From cb46b0b62bb53e8119aaa51e55b12fa0c76fe2c7 Mon Sep 17 00:00:00 2001 From: Larry Masinter Date: Sat, 29 Aug 2020 18:35:53 -0700 Subject: [PATCH] initial checkin for library --- library/BIGBITMAPS | 1645 ++++++ library/BINARYFILES | 1 + library/BROWSER | 491 ++ library/CASH-FILE | 1 + library/CHARCODETABLES | 1 + library/CHARDEVICE | 1 + library/CHAT | 1 + library/CHATDECLS | 1 + library/CHATSERVER-EMACS | Bin 0 -> 5231 bytes library/CHATTERMINAL | 1 + library/CLIPBOARD | 1 + library/COLOR | 1 + library/COPYFILES | 1 + library/DANDELIONKEYBOARDS | 1 + library/DATABASEFNS | 1 + library/DEDIT | 1 + library/DEDITPP | 1 + library/DES | 1 + library/DMCHAT | 1 + library/DORADOKEYBOARDS | 1 + library/DOSPRINT | 53 + library/DOVEKEYBOARDS | 1 + library/DOVERS232C | 1 + library/EDITBITMAP | 1 + library/ETHERRECORDS | 1 + library/EXPORTS.ALL | 1 + library/FILE-UPDATE | 1 + library/FILEBROWSER | 226 + library/FONTSAMPLE | 1 + library/FOREIGN-FUNCTIONS | 921 ++++ library/FX-80DRIVER | 1 + library/GCHAX | 387 ++ library/GRAPHER | 3199 ++++++++++++ library/GRAPHZOOM | 1 + library/HASH | 1 + library/HASH-FILE | 1 + library/HRULE | 1 + library/IMAGEOBJ | 542 ++ library/INIT.MAIKO | 1 + library/INIT.NONET | 1 + library/INIT.SAMPLE | 1 + library/KEYBOARDCONFIGS | 1 + library/KEYBOARDEDITOR | 438 ++ library/LLCOLOR | 1 + library/MAIKOCOLOR | 1 + library/MAIKOKEYBOARDS | 1 + library/MASTERSCOPE | 1 + library/MATCH | 1 + library/MATMULT | 1 + library/MINISERVE | 1 + library/MSANALYZE | 1 + library/MSCOMMON | 1 + library/MSPARSE | 1 + library/NSCHAT | 1 + library/NSMAINTAIN | 366 ++ library/PCTREE | 251 + library/POSTSCRIPTSTREAM | 2523 ++++++++++ library/POSTSCRIPTSTREAM.DATABASE | 1 + library/RDSYS | 321 ++ library/READNUMBER | 1 + library/READSYS | 1 + library/REMOTEVMEM | 1 + library/SAMEDIR | 1 + library/SCALEBITMAP | 1 + library/SEDIT-COMMONLISP | 1 + library/SKETCH | 1 + library/SKETCHBMELT | 1 + library/SKETCHEDIT | 1 + library/SKETCHELEMENTS | 7756 +++++++++++++++++++++++++++++ library/SKETCHOBJ | 1 + library/SKETCHOPS | 1 + library/SKETCHSTREAM | 1 + library/SPY | 943 ++++ library/SYSEDIT | 1 + library/TABLEBROWSER | 1 + library/TABLEBROWSERDECLS | 1 + library/TBDECLS | 150 + library/TEDIT | 1655 ++++++ library/TEDIT.DATABASE | 12 + library/TEDITABBREV | 46 + library/TEDITCHAT | 439 ++ library/TEDITCOMMAND | 1 + library/TEDITDCL | 493 ++ library/TEDITFILE | 1636 ++++++ library/TEDITFIND | 493 ++ library/TEDITFNKEYS | 1 + library/TEDITHCPY | 1569 ++++++ library/TEDITHISTORY | 1 + library/TEDITLOOKS | 2014 ++++++++ library/TEDITMENU | 4539 +++++++++++++++++ library/TEDITPAGE | 1839 +++++++ library/TEDITSCREEN | 2961 +++++++++++ library/TEDITSELECTION | 2277 +++++++++ library/TEDITWINDOW | 2398 +++++++++ library/TELERAID | 1 + library/TEXEC | 1 + library/TEXTMODULES | 1 + library/TEXTOFD | 1623 ++++++ library/TEXTOFD.DATABASE | 1 + library/TFBRAVO | 1 + library/TTYCHAT | 1 + library/UNICODE | 1 + library/UNICODE.TXT | 96 + library/UNIXCHAT | 1 + library/UNIXCOMM | 1 + library/UNIXPRINT | 1 + library/UNIXPRINTCOMMAND | 78 + library/VIRTUALKEYBOARDS | 1489 ++++++ library/VMEM | 1 + library/VT100KP | 1 + library/VTCHAT | 1 + library/WHERE-IS | 1 + library/XCCS | 1 + 113 files changed, 45947 insertions(+) create mode 100644 library/BIGBITMAPS create mode 100644 library/BINARYFILES create mode 100644 library/BROWSER create mode 100644 library/CASH-FILE create mode 100644 library/CHARCODETABLES create mode 100644 library/CHARDEVICE create mode 100644 library/CHAT create mode 100644 library/CHATDECLS create mode 100644 library/CHATSERVER-EMACS create mode 100644 library/CHATTERMINAL create mode 100644 library/CLIPBOARD create mode 100644 library/COLOR create mode 100644 library/COPYFILES create mode 100644 library/DANDELIONKEYBOARDS create mode 100644 library/DATABASEFNS create mode 100644 library/DEDIT create mode 100644 library/DEDITPP create mode 100644 library/DES create mode 100644 library/DMCHAT create mode 100644 library/DORADOKEYBOARDS create mode 100644 library/DOSPRINT create mode 100644 library/DOVEKEYBOARDS create mode 100644 library/DOVERS232C create mode 100644 library/EDITBITMAP create mode 100644 library/ETHERRECORDS create mode 100644 library/EXPORTS.ALL create mode 100644 library/FILE-UPDATE create mode 100644 library/FILEBROWSER create mode 100644 library/FONTSAMPLE create mode 100644 library/FOREIGN-FUNCTIONS create mode 100644 library/FX-80DRIVER create mode 100644 library/GCHAX create mode 100644 library/GRAPHER create mode 100644 library/GRAPHZOOM create mode 100644 library/HASH create mode 100644 library/HASH-FILE create mode 100644 library/HRULE create mode 100644 library/IMAGEOBJ create mode 100644 library/INIT.MAIKO create mode 100644 library/INIT.NONET create mode 100644 library/INIT.SAMPLE create mode 100644 library/KEYBOARDCONFIGS create mode 100644 library/KEYBOARDEDITOR create mode 100644 library/LLCOLOR create mode 100644 library/MAIKOCOLOR create mode 100644 library/MAIKOKEYBOARDS create mode 100644 library/MASTERSCOPE create mode 100644 library/MATCH create mode 100644 library/MATMULT create mode 100644 library/MINISERVE create mode 100644 library/MSANALYZE create mode 100644 library/MSCOMMON create mode 100644 library/MSPARSE create mode 100644 library/NSCHAT create mode 100644 library/NSMAINTAIN create mode 100644 library/PCTREE create mode 100644 library/POSTSCRIPTSTREAM create mode 100644 library/POSTSCRIPTSTREAM.DATABASE create mode 100644 library/RDSYS create mode 100644 library/READNUMBER create mode 100644 library/READSYS create mode 100644 library/REMOTEVMEM create mode 100644 library/SAMEDIR create mode 100644 library/SCALEBITMAP create mode 100644 library/SEDIT-COMMONLISP create mode 100644 library/SKETCH create mode 100644 library/SKETCHBMELT create mode 100644 library/SKETCHEDIT create mode 100644 library/SKETCHELEMENTS create mode 100644 library/SKETCHOBJ create mode 100644 library/SKETCHOPS create mode 100644 library/SKETCHSTREAM create mode 100644 library/SPY create mode 100644 library/SYSEDIT create mode 100644 library/TABLEBROWSER create mode 100644 library/TABLEBROWSERDECLS create mode 100644 library/TBDECLS create mode 100644 library/TEDIT create mode 100644 library/TEDIT.DATABASE create mode 100644 library/TEDITABBREV create mode 100644 library/TEDITCHAT create mode 100644 library/TEDITCOMMAND create mode 100644 library/TEDITDCL create mode 100644 library/TEDITFILE create mode 100644 library/TEDITFIND create mode 100644 library/TEDITFNKEYS create mode 100644 library/TEDITHCPY create mode 100644 library/TEDITHISTORY create mode 100644 library/TEDITLOOKS create mode 100644 library/TEDITMENU create mode 100644 library/TEDITPAGE create mode 100644 library/TEDITSCREEN create mode 100644 library/TEDITSELECTION create mode 100644 library/TEDITWINDOW create mode 100644 library/TELERAID create mode 100644 library/TEXEC create mode 100644 library/TEXTMODULES create mode 100644 library/TEXTOFD create mode 100644 library/TEXTOFD.DATABASE create mode 100644 library/TFBRAVO create mode 100644 library/TTYCHAT create mode 100644 library/UNICODE create mode 100644 library/UNICODE.TXT create mode 100644 library/UNIXCHAT create mode 100644 library/UNIXCOMM create mode 100644 library/UNIXPRINT create mode 100644 library/UNIXPRINTCOMMAND create mode 100644 library/VIRTUALKEYBOARDS create mode 100644 library/VMEM create mode 100644 library/VT100KP create mode 100644 library/VTCHAT create mode 100644 library/WHERE-IS create mode 100644 library/XCCS diff --git a/library/BIGBITMAPS b/library/BIGBITMAPS new file mode 100644 index 00000000..b2d1ec8c --- /dev/null +++ b/library/BIGBITMAPS @@ -0,0 +1,1645 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) +(FILECREATED "13-Jul-94 15:32:54" |{DSK}export>lispcore>library>BIGBITMAPS.;2| 105325 + + |changes| |to:| (VARS BIGBITMAPSCOMS) + + |previous| |date:| "20-Jan-93 13:40:44" |{PELE:MV:ENVOS}LIBRARY>BIGBITMAPS.;10|) + + +; Copyright (c) 1991, 1993, 1994 by Venue. All rights reserved. + +(PRETTYCOMPRINT BIGBITMAPSCOMS) + +(RPAQQ BIGBITMAPSCOMS + ((DECLARE\: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY (RECORDS BIGBM) + (CONSTANTS (|\\MaxBitMapHeight| 65535) + (|\\MaxBitMapWidth| 65535) + (|\\MaxBitMapWords| 131066)) + (MACROS |GetNewFragment|) + (MACROS |\\SFInvert|)) + (INITRECORDS BIGBM) + (FNS BITBLT.BIGBM BITMAPCREATE.BIGBM BITMAPCREATE BITMAPCOPY BLTSHADE.BIGBM BITBLT + \\ORG.BITBLT \\BLTSHADE.DISPLAY \\RESHOWBORDER1) + (FNS \\DRAWCIRCLE.BIGBM \\FILLCIRCLE.BIGBM \\DRAWELLIPSE.BIGBM \\DRAWCURVE.BIGBM) + (FNS DSPCREATE DSPDESTINATION |\\SFFixY| |\\SFFixDestination| |\\SFFixClippingRegion|) + (FNS \\SW2BM BITMAPHEIGHT BITMAPWIDTH |\\SFFixFont| BITSPERPIXEL) + (FNS COLORIZEBITMAP \\BWTOCOLORBLT UNCOLORIZEBITMAP) + (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD '\\ORG.BITBLT 'ORG.BITBLT) + (MOVD? 'BLTSHADE 'ORG.BLTSHADE) + (MOVD 'BLTSHADE.BIGBM 'BLTSHADE) + (MOVD 'BITBLT 'BKBITBLT))))) +(DECLARE\: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY +(DECLARE\: EVAL@COMPILE + +(DATATYPE BIGBM (BIGBMWIDTH BIGBMHEIGHT BIGBMLIST)) +) + +(/DECLAREDATATYPE 'BIGBM '(POINTER POINTER POINTER) + '((BIGBM 0 POINTER) + (BIGBM 2 POINTER) + (BIGBM 4 POINTER)) + '6) + +(DECLARE\: EVAL@COMPILE + +(RPAQQ |\\MaxBitMapHeight| 65535) + +(RPAQQ |\\MaxBitMapWidth| 65535) + +(RPAQQ |\\MaxBitMapWords| 131066) + + +(CONSTANTS (|\\MaxBitMapHeight| 65535) + (|\\MaxBitMapWidth| 65535) + (|\\MaxBitMapWords| 131066)) +) + +(DECLARE\: EVAL@COMPILE + +(PUTPROPS |GetNewFragment| MACRO ((LIST) + (PROG1 (CAR LIST) + (SETQ LIST (CDR LIST))))) +) + +(DECLARE\: EVAL@COMPILE + +(PUTPROPS |\\SFInvert| MACRO ((|BitMap| \y) + + (* |corrects| |for| |the| |fact| |that| |alto| |bitmaps| |are| |stored| |with| + 0\,0 |as| |upper| |left| |while| |lisp| |bitmaps| |have| 0\,0 |as| |lower| + |left.| |The| |correction| |is| |actually| |off| |by| |one| + (|greater|) |because| \a |majority| |of| |the| |places| |that| |it| |is| + |called| |actually| |need| |one| |more| |than| |corrected| Y |value.|) + + (IDIFFERENCE (|fetch| (BITMAP BITMAPHEIGHT) |of| + |BitMap|) + \y))) +) +) + +(/DECLAREDATATYPE 'BIGBM '(POINTER POINTER POINTER) + '((BIGBM 0 POINTER) + (BIGBM 2 POINTER) + (BIGBM 4 POINTER)) + '6) +(DEFINEQ + +(BITBLT.BIGBM + (LAMBDA (SRCE SRCELEFT SRCEBOTTOM DEST DESTLEFT DESTBOTTOM WIDTH HEIGHT SRCETYPE OPERATION TEXTURE + CLIPPINGREGION) (* \; "Edited 24-Jan-91 11:19 by matsuda") + (PROG (SRCEBMLIST DESTBMLIST SRCEBIGBMHEIGHT DESTBIGBMHEIGHT SRCETOP DESTTOP SRCEFRAG DESTFRAG + SRCEFRAGTOP DESTFRAGTOP SRCEFRAGBOTTOM DESTFRAGBOTTOM SRCE-H DEST-H H NEXT-S-TOP + NEXT-D-TOP SBOTTOM DBOTTOM) + (SETQ SRCETOP (IPLUS (OR SRCEBOTTOM (SETQ SRCEBOTTOM 0)) + (OR HEIGHT (SETQ HEIGHT (BITMAPHEIGHT SRCE))))) + (SETQ DESTTOP (IPLUS (OR DESTBOTTOM (SETQ DESTBOTTOM 0)) + HEIGHT)) + (COND + ((< DESTBOTTOM 0) + (SETQ HEIGHT (+ HEIGHT DESTBOTTOM)) + (SETQ SRCEBOTTOM (- SRCEBOTTOM DESTBOTTOM)) + (SETQ DESTBOTTOM 0) + (SETQ DESTTOP HEIGHT))) + (COND + ((|type?| BIGBM SRCE) + (SETQ SRCEBMLIST (|fetch| (BIGBM BIGBMLIST) |of| SRCE)) + (SETQ SRCEBIGBMHEIGHT (|fetch| (BIGBM BIGBMHEIGHT) |of| SRCE)) + (SETQ SRCEFRAG (|GetNewFragment| SRCEBMLIST)) + (SETQ SRCEFRAGTOP SRCEBIGBMHEIGHT) + (SETQ SRCEFRAGBOTTOM (- SRCEFRAGTOP (BITMAPHEIGHT SRCEFRAG))) + (|until| (< SRCEFRAGBOTTOM SRCETOP) |do| + + (* |;;| + "Search the first fragment of SRCE bitmaps") + + (SETQ SRCEFRAG (|GetNewFragment| + SRCEBMLIST)) + (SETQ SRCEFRAGTOP SRCEFRAGBOTTOM) + (SETQ SRCEFRAGBOTTOM (- SRCEFRAGTOP + (BITMAPHEIGHT + SRCEFRAG)))) + (COND + ((|type?| BIGBM DEST) + (PROG NIL + + (* |;;| "BIGBM to BIGBM case") + + (SETQ DESTBMLIST (|fetch| (BIGBM BIGBMLIST) |of| DEST)) + (SETQ DESTBIGBMHEIGHT (|fetch| (BIGBM BIGBMHEIGHT) |of| DEST)) + (SETQ DESTFRAG (|GetNewFragment| DESTBMLIST)) + (SETQ DESTFRAGTOP DESTBIGBMHEIGHT) + (SETQ DESTFRAGBOTTOM (- DESTFRAGTOP (BITMAPHEIGHT DESTFRAG))) + LOOP + (|until| (<= DESTFRAGBOTTOM DESTTOP) |do| + + (* |;;| + "Serch the first fragment of DEST bitmaps") + + (SETQ DESTFRAG ( + |GetNewFragment| + DESTBMLIST)) + (SETQ DESTFRAGTOP + DESTFRAGBOTTOM) + (SETQ DESTFRAGBOTTOM + (- DESTFRAGTOP ( + BITMAPHEIGHT + DESTFRAG)))) + (COND + ((<= SRCEFRAGBOTTOM SRCEBOTTOM) + (SETQ SRCE-H (- SRCETOP SRCEBOTTOM))) + (T (SETQ SRCE-H (- SRCETOP SRCEFRAGBOTTOM)))) + (COND + ((<= DESTFRAGBOTTOM DESTBOTTOM) + (SETQ DEST-H (- DESTTOP DESTBOTTOM))) + (T (SETQ DEST-H (- DESTTOP DESTFRAGBOTTOM)))) + (SETQ H (MIN DEST-H SRCE-H)) (* \; " Decriments Height") + (SETQ NEXT-S-TOP (- SRCETOP H)) + (SETQ NEXT-D-TOP (- DESTTOP H)) + (SETQ SBOTTOM (- NEXT-S-TOP SRCEFRAGBOTTOM)) + (SETQ DBOTTOM (- NEXT-D-TOP DESTFRAGBOTTOM)) + (ORG.BITBLT SRCEFRAG SRCELEFT SBOTTOM DESTFRAG DESTLEFT DBOTTOM WIDTH H + SRCETYPE OPERATION TEXTURE CLIPPINGREGION) + (COND + ((> (SETQ HEIGHT (- HEIGHT H)) + 0) + (SETQ SRCETOP NEXT-S-TOP) + (SETQ DESTTOP NEXT-D-TOP) + (COND + ((<= NEXT-S-TOP SRCEFRAGBOTTOM) + (SETQ SRCEFRAG (|GetNewFragment| SRCEBMLIST)) + (SETQ SRCEFRAGTOP SRCEFRAGBOTTOM) + (SETQ SRCEFRAGBOTTOM (- SRCEFRAGTOP (BITMAPHEIGHT SRCEFRAG))))) + (COND + ((<= NEXT-D-TOP DESTFRAGBOTTOM) + (SETQ DESTFRAG (|GetNewFragment| DESTBMLIST)) + (COND + ((NOT DESTFRAG) + (RETURN))) + (SETQ DESTFRAGTOP DESTFRAGBOTTOM) + (SETQ DESTFRAGBOTTOM (- DESTFRAGTOP (BITMAPHEIGHT DESTFRAG))))) + (GO LOOP) + + (* |;;| "I hate goto, but this is temporary one") + + )))) + (T (PROG NIL + LOOP2 + (COND + ((<= SRCEFRAGBOTTOM SRCEBOTTOM) + + (* |;;| " bottom edge") + + (SETQ SRCE-H (- SRCETOP SRCEBOTTOM)) + + (* |;;| "BIGBM to BITMAP case") + + ) + (T (SETQ SRCE-H (- SRCETOP SRCEFRAGBOTTOM)))) + (SETQ H (MIN HEIGHT SRCE-H)) + (SETQ NEXT-S-TOP (- SRCETOP H)) + (SETQ NEXT-D-TOP (- DESTTOP H)) + (SETQ SBOTTOM (- NEXT-S-TOP SRCEFRAGBOTTOM)) + (ORG.BITBLT SRCEFRAG SRCELEFT SBOTTOM DEST DESTLEFT NEXT-D-TOP WIDTH H + SRCETYPE OPERATION TEXTURE CLIPPINGREGION) + (COND + ((> (SETQ HEIGHT (- HEIGHT H)) + 0) + (SETQ SRCETOP NEXT-S-TOP) + (SETQ DESTTOP NEXT-D-TOP) + (COND + ((<= NEXT-S-TOP SRCEFRAGBOTTOM) + (SETQ SRCEFRAG (|GetNewFragment| SRCEBMLIST)) + + (* |;;| "Get next SRCE fragment") + + (SETQ SRCEFRAGTOP SRCEFRAGBOTTOM) + (SETQ SRCEFRAGBOTTOM (- SRCEFRAGTOP (BITMAPHEIGHT SRCEFRAG))))) + (GO LOOP2) + + (* |;;| "I hate goto, but this is temporary one") + + )))))) + ((OR (|type?| BIGBM DEST)) + (PROG NIL + (SETQ DESTBMLIST (|fetch| (BIGBM BIGBMLIST) |of| DEST)) + (SETQ DESTBIGBMHEIGHT (|fetch| (BIGBM BIGBMHEIGHT) |of| DEST)) + (SETQ DESTFRAG (|GetNewFragment| DESTBMLIST)) + (SETQ DESTFRAGTOP DESTBIGBMHEIGHT) + (SETQ DESTFRAGBOTTOM (- DESTFRAGTOP (BITMAPHEIGHT DESTFRAG))) + (|until| (< DESTFRAGBOTTOM DESTTOP) |do| + + (* |;;| + "Serch the first fragment of DEST bitmaps") + + (SETQ DESTFRAG (|GetNewFragment| + DESTBMLIST)) + (SETQ DESTFRAGTOP DESTFRAGBOTTOM) + (SETQ DESTFRAGBOTTOM + (- DESTFRAGTOP (BITMAPHEIGHT + DESTFRAG)))) + (COND + ((<= DESTFRAGBOTTOM DESTBOTTOM) + + (* |;;| " bottom edge") + + (SETQ DEST-H (- DESTTOP DESTBOTTOM))) + (T (SETQ DEST-H (- DESTTOP DESTFRAGBOTTOM)))) + LOOP3 + (COND + ((<= DESTFRAGBOTTOM DESTBOTTOM) + (SETQ DEST-H (- DESTTOP DESTBOTTOM))) + (T (SETQ DEST-H (- DESTTOP DESTFRAGBOTTOM)))) + (SETQ H (MIN DEST-H HEIGHT)) + (SETQ NEXT-S-TOP (- SRCETOP H)) + (SETQ NEXT-D-TOP (- DESTTOP H)) + (SETQ DBOTTOM (- NEXT-D-TOP DESTFRAGBOTTOM)) + (ORG.BITBLT SRCE SRCELEFT NEXT-S-TOP DESTFRAG DESTLEFT DBOTTOM WIDTH H SRCETYPE + OPERATION TEXTURE CLIPPINGREGION) + (COND + ((> (SETQ HEIGHT (- HEIGHT H)) + 0) + (SETQ DESTTOP NEXT-D-TOP) + (SETQ SRCETOP NEXT-S-TOP) + (COND + ((<= NEXT-D-TOP DESTFRAGBOTTOM) + (SETQ DESTFRAG (|GetNewFragment| DESTBMLIST)) + (SETQ DESTFRAGTOP DESTFRAGBOTTOM) + (SETQ DESTFRAGBOTTOM (- DESTFRAGTOP (BITMAPHEIGHT DESTFRAG))))) + (GO LOOP3) + + (* |;;| "I hate goto, but this is temporary one") + + )))) + (T + (* |;;| "Normal case, use BITBLT") + + (ORG.BITBLT SRCE SRCELEFT SRCEBOTTOM DEST DESTLEFT DESTBOTTOM WIDTH HEIGHT SRCETYPE + OPERATION TEXTURE CLIPPINGREGION)))))) + +(BITMAPCREATE.BIGBM + (LAMBDA (WIDTH HEIGHT BITSPERPIXEL) (* \; "Edited 7-Sep-89 18:14 by takeshi") + (LET (H HLEFT BM BIGBM) + (SETQ H (FLOOR (IQUOTIENT |\\MaxBitMapWords| WIDTH) + BITSPERWORD)) (* \; + "slice should be a multiple of 16 so that textures tesselate nicely.") + (SETQ HLEFT HEIGHT) + (SETQ BIGBM (|create| BIGBM)) + (|freplace| (BIGBM BIGBMWIDTH) OF BIGBM WITH WIDTH) + (|freplace| (BIGBM BIGBMHEIGHT) OF BIGBM WITH HEIGHT) + (|freplace| (BIGBM BIGBMLIST) OF BIGBM WITH (|while| (IGREATERP HLEFT 0) + |collect| + (SETQ BM (BITMAPCREATE + WIDTH + (MIN H HLEFT) + BITSPERPIXEL)) + (SETQ HLEFT (- HLEFT H)) + BM)) + BIGBM))) + +(BITMAPCREATE + (LAMBDA (WIDTH HEIGHT BITSPERPIXEL) (* \; "Edited 1-Nov-91 15:47 by jds") + (* \; + "creates a bitmap & bigbm data structure.") + (PROG (RW) + (OR (AND (IGEQ WIDTH 0) + (ILEQ WIDTH |\\MaxBitMapWidth|)) + (\\ILLEGAL.ARG WIDTH)) + (OR (AND (IGEQ HEIGHT 0) + (ILEQ HEIGHT |\\MaxBitMapHeight|)) + (\\ILLEGAL.ARG HEIGHT)) + + (* |;;| "WIDTH & HEIGHT are now known to be OK.") + + (SETQ BITSPERPIXEL (\\INSUREBITSPERPIXEL BITSPERPIXEL)) + (SETQ RW (FOLDHI (ITIMES WIDTH BITSPERPIXEL) + BITSPERWORD)) + (RETURN (COND + ((NOT (IGREATERP (ITIMES RW HEIGHT) + |\\MaxBitMapWords|)) + (|create| BITMAP + BITMAPRASTERWIDTH _ RW + BITMAPWIDTH _ WIDTH + BITMAPHEIGHT _ HEIGHT + BITMAPBITSPERPIXEL _ BITSPERPIXEL + BITMAPBASE _ (\\ALLOCBLOCK (FOLDHI (ITIMES RW HEIGHT) + WORDSPERCELL) + NIL + (AND (NULL WINDFLG) + 0)))) + (T (BITMAPCREATE.BIGBM WIDTH HEIGHT BITSPERPIXEL))))))) + +(BITMAPCOPY + (LAMBDA (BITMAP) (* \; "Edited 1-Nov-91 15:49 by jds") + + (* |;;| "makes a copy of an existing BitMap") + + (PROG (NEWBITMAP) + (BITBLT BITMAP 0 0 (SETQ NEWBITMAP (BITMAPCREATE (BITMAPWIDTH BITMAP) + (BITMAPHEIGHT BITMAP) + (BITSPERPIXEL BITMAP))) + 0 0 NIL NIL 'INPUT 'REPLACE 0) + (RETURN NEWBITMAP)))) + +(BLTSHADE.BIGBM + (LAMBDA (TEXTURE DESTINATION DESTLEFT DESTBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) + (* \; "Edited 17-Oct-89 19:01 by takeshi") + (LET (H SLITHEIGHT) + + (* |;;| "Clippingregion is handled incorrectly (at least in the Y direction).") + + (COND + ((NOT (|type?| BIGBM DESTINATION)) + (ORG.BLTSHADE TEXTURE DESTINATION DESTLEFT DESTBOTTOM WIDTH HEIGHT OPERATION + CLIPPINGREGION)) + (T (PROG (DESTTOP DESTBMLIST DESTBIGBMHEIGHT DESTFRAG DESTFRAGTOP DESTFRAGBOTTOM DEST-H + NEXT-D-TOP DBOTTOM) + (SETQ DESTTOP (IPLUS DESTBOTTOM HEIGHT)) + (SETQ DESTBMLIST (|fetch| (BIGBM BIGBMLIST) |of| DESTINATION)) + (SETQ DESTBIGBMHEIGHT (|fetch| (BIGBM BIGBMHEIGHT) |of| DESTINATION)) + (SETQ DESTFRAG (|GetNewFragment| DESTBMLIST)) + (SETQ DESTFRAGTOP DESTBIGBMHEIGHT) + (SETQ DESTFRAGBOTTOM (- DESTFRAGTOP (BITMAPHEIGHT DESTFRAG))) + LOOP + (|until| (<= DESTFRAGBOTTOM DESTTOP) |do| + + (* |;;| + "Serch the first fragment of DEST bitmaps") + + (SETQ DESTFRAG (|GetNewFragment| + DESTBMLIST)) + (SETQ DESTFRAGTOP DESTFRAGBOTTOM) + (SETQ DESTFRAGBOTTOM + (- DESTFRAGTOP (BITMAPHEIGHT + DESTFRAG)))) + (COND + ((<= DESTFRAGBOTTOM DESTBOTTOM) + (SETQ DEST-H (- DESTTOP DESTBOTTOM))) + (T (SETQ DEST-H (- DESTTOP DESTFRAGBOTTOM)))) + (SETQ NEXT-D-TOP (- DESTTOP DEST-H)) + (SETQ DBOTTOM (- NEXT-D-TOP DESTFRAGBOTTOM)) + (ORG.BLTSHADE TEXTURE DESTFRAG DESTLEFT DBOTTOM WIDTH DEST-H OPERATION + CLIPPINGREGION) + (COND + ((> (SETQ HEIGHT (- HEIGHT DEST-H)) + 0) + (SETQ DESTTOP NEXT-D-TOP) + (COND + ((<= NEXT-D-TOP DESTFRAGBOTTOM) + (SETQ DESTFRAG (|GetNewFragment| DESTBMLIST)) + (SETQ DESTFRAGTOP DESTFRAGBOTTOM) + (SETQ DESTFRAGBOTTOM (- DESTFRAGTOP (BITMAPHEIGHT DESTFRAG))))) + (GO LOOP) + + (* |;;| "I hate goto, but this is temporary one") + + )))))))) + +(BITBLT + (LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT + SOURCETYPE OPERATION TEXTURE CLIPPINGREGION) + (* \; "Edited 29-Jun-90 10:43 by matsuda") + (DECLARE (LOCALVARS . T)) + + (* |;;| "IRM defined defaults") + + (OR DESTINATIONLEFT (SETQ DESTINATIONLEFT 0)) + (OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM 0)) + (COND + ((EQ SOURCETYPE 'TEXTURE) + (COND + ((|type?| BITMAP DESTINATION) + (\\BLTSHADE.BITMAP TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT + OPERATION CLIPPINGREGION)) + ((|type?| BIGBM DESTINATION) + (BLTSHADE.BIGBM TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT + OPERATION CLIPPINGREGION)) + (T (PROG ((STREAM (\\OUTSTREAMARG DESTINATION))) + (RETURN (IMAGEOP 'IMBLTSHADE STREAM TEXTURE STREAM DESTINATIONLEFT + DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)))))) + (T (COND + ((OR (|type?| BIGBM SOURCE) + (|type?| BIGBM DESTINATION)) + (BITBLT.BIGBM SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT + DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION)) + (T (ORG.BITBLT SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT + DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION)))) + ))) + +(\\ORG.BITBLT + (LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT + SOURCETYPE OPERATION TEXTURE CLIPPINGREGION) + (DECLARE (LOCALVARS . T)) (* \; "Edited 24-Jul-90 16:34 by matsuda") + + (* |;;| "IRM defined defaults") + + (OR DESTINATIONLEFT (SETQ DESTINATIONLEFT 0)) + (OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM 0)) + (COND + ((EQ SOURCETYPE 'TEXTURE) + (COND + ((|type?| BITMAP DESTINATION) + (\\BLTSHADE.BITMAP TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT + OPERATION CLIPPINGREGION)) + ((|type?| BIGBM DESTINATION) + (BLTSHADE.BIGBM TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT + OPERATION CLIPPINGREGION)) + (T (PROG ((STREAM (\\OUTSTREAMARG DESTINATION))) + (RETURN (IMAGEOP 'IMBLTSHADE STREAM TEXTURE STREAM DESTINATIONLEFT + DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)))))) + (T (PROG (SOURCEDD SOURCEBM CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) + (COND + ((|type?| BITMAP SOURCE) + (OR SOURCELEFT (SETQ SOURCELEFT 0)) + (OR SOURCEBOTTOM (SETQ SOURCEBOTTOM 0)) + (SETQ SOURCEBM SOURCE) + (SETQ CLIPPEDSOURCELEFT SOURCELEFT) + (SETQ CLIPPEDSOURCEBOTTOM SOURCEBOTTOM) (* \; + "limit the WIDTH and HEIGHT to the source size.") + (SETQ WIDTH (COND + (WIDTH (IMIN WIDTH (IDIFFERENCE (|fetch| (BITMAP BITMAPWIDTH) + |of| SOURCE) + SOURCELEFT))) + (T (|fetch| (BITMAP BITMAPWIDTH) |of| SOURCE)))) + (SETQ HEIGHT (COND + (HEIGHT (IMIN HEIGHT (IDIFFERENCE (|fetch| (BITMAP + BITMAPHEIGHT + ) + |of| SOURCE) + SOURCEBOTTOM))) + (T (|fetch| (BITMAP BITMAPHEIGHT) |of| SOURCE))))) + ((SETQ SOURCEDD (\\GETDISPLAYDATA SOURCE)) + (OR SOURCELEFT (SETQ SOURCELEFT (|fetch| (REGION LEFT) + |of| (|ffetch| (\\DISPLAYDATA + |DDClippingRegion| + ) |of| + SOURCEDD)))) + (OR SOURCEBOTTOM (SETQ SOURCEBOTTOM (|fetch| (REGION BOTTOM) + |of| (|ffetch| (\\DISPLAYDATA + |DDClippingRegion| + ) |of| + SOURCEDD)) + )) (* \; + "do transformations coming out of source") + (SETQ SOURCEBM (|fetch| (\\DISPLAYDATA |DDDestination|) |of| SOURCEDD)) + (SETQ CLIPPEDSOURCELEFT (IMAX (SETQ SOURCELEFT (\\DSPTRANSFORMX SOURCELEFT + SOURCEDD)) + (|fetch| (\\DISPLAYDATA |DDClippingLeft|) + |of| SOURCEDD))) + (SETQ CLIPPEDSOURCEBOTTOM (IMAX (SETQ SOURCEBOTTOM (\\DSPTRANSFORMY SOURCEBOTTOM + SOURCEDD)) + (|fetch| (\\DISPLAYDATA |DDClippingBottom|) + |of| SOURCEDD))) + (* \; + "limit the WIDTH and HEIGHT by the source dimensions.") + (SETQ WIDTH (COND + (WIDTH (IMIN WIDTH (IDIFFERENCE (|fetch| (\\DISPLAYDATA + |DDClippingRight| + ) |of| + SOURCEDD) + CLIPPEDSOURCELEFT))) + (T (IDIFFERENCE (|fetch| (\\DISPLAYDATA |DDClippingRight|) + |of| SOURCEDD) + CLIPPEDSOURCELEFT)))) + (SETQ HEIGHT (COND + (HEIGHT (IMIN HEIGHT (IDIFFERENCE (|fetch| (\\DISPLAYDATA + |DDClippingTop|) + |of| SOURCEDD) + CLIPPEDSOURCEBOTTOM))) + (T (IDIFFERENCE (|fetch| (\\DISPLAYDATA |DDClippingTop|) + |of| SOURCEDD) + CLIPPEDSOURCEBOTTOM)))) + (* \; + "if texture is not given, use the display stream's.") + (OR TEXTURE (SETQ TEXTURE (|ffetch| (\\DISPLAYDATA |DDTexture|) |of| + SOURCEDD))))) + (COND + ((OR (IGEQ 0 WIDTH) + (IGEQ 0 HEIGHT)) (* \; + "if either width or height is 0, don't do anything.") + (RETURN))) + (RETURN (COND + ((|type?| BITMAP DESTINATION) + (COND + ((WINDOWP SOURCE) + + (* |;;| "bring source window to the top. Note: this doesn't work if the user passes in a display stream onto the screen instead of a window.") + + (.WHILE.TOP.DS. (\\OUTSTREAMARG SOURCE) + (\\BITBLT.BITMAP SOURCEBM SOURCELEFT SOURCEBOTTOM DESTINATION + DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT + SOURCETYPE OPERATION TEXTURE CLIPPINGREGION + CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM))) + (T (PROG ((DESTNBITS (BITSPERPIXEL DESTINATION)) + (SRCNBITS (BITSPERPIXEL SOURCEBM))) + (COND + ((NOT (EQ SRCNBITS DESTNBITS)) + (COND + ((EQ DESTNBITS 1) + (SETQ SOURCEBM (UNCOLORIZEBITMAP SOURCEBM + (COLORMAP SRCNBITS)))))))) + (\\BITBLT.BITMAP SOURCEBM SOURCELEFT SOURCEBOTTOM DESTINATION + DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE + OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT + CLIPPEDSOURCEBOTTOM)))) + (T (PROG (STREAM) + (SETQ STREAM (\\OUTSTREAMARG DESTINATION)) + (COND + ((AND (NEQ SOURCE DESTINATION) + (WINDOWP SOURCE)) + + (* |;;| "both source and destination are windows, see if they overlap and use an intermediate bitmap. Note: this doesn't work if the user passes in a display stream onto the screen instead of a window.") + + (COND + ((WINDOWP DESTINATION) + (COND + ((WOVERLAPP SOURCE DESTINATION) + (RETURN (PROG (SCRATCHBM) + (.WHILE.TOP.DS. + (\\OUTSTREAMARG SOURCE) + (BITBLT SOURCEBM SOURCELEFT + SOURCEBOTTOM + (SETQ SCRATCHBM + (BITMAPCREATE WIDTH HEIGHT + (BITSPERPIXEL + SOURCEBM))) + 0 0 WIDTH HEIGHT 'INPUT + 'REPLACE)) + (RETURN (BITBLT SCRATCHBM 0 0 + STREAM DESTINATIONLEFT + DESTINATIONBOTTOM WIDTH + HEIGHT SOURCETYPE + OPERATION TEXTURE + CLIPPINGREGION)))))))) + (* \; + "bring the source to the top. this should be done uninterruptably but is better than nothing.") + (TOTOPW SOURCE))) + (IMAGEOP 'IMBITBLT STREAM SOURCEBM SOURCELEFT SOURCEBOTTOM STREAM + DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE + OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT + CLIPPEDSOURCEBOTTOM)))))))))) + +(\\BLTSHADE.DISPLAY + (LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) + (* \; "Edited 21-Dec-90 10:41 by matsuda") + (* \; "BLTSHADE to a display stream") + (DECLARE (LOCALVARS . T)) + (PROG (|left| |top| |bottom| |right| DESTINATIONBITMAP DESTDD DESTINATIONNBITS) + (SETQ DESTDD (|fetch| (STREAM IMAGEDATA) |of| STREAM)) + (SETQ DESTINATIONBITMAP (|fetch| (\\DISPLAYDATA |DDDestination|) |of| DESTDD)) + + (* |;;| "bring it to top so that its TOTOPFNs will get called before the destination information is cached in case one of them moves, reshapes, etc. the window") + + (* |;;| "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.") + + (\\INSURETOPWDS STREAM) + (SETQ DESTINATIONLEFT (\\DSPTRANSFORMX DESTINATIONLEFT DESTDD)) + (SETQ DESTINATIONBOTTOM (\\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD)) + (PROGN (* \; + "compute limits based on clipping regions.") + (SETQ |left| (|fetch| (\\DISPLAYDATA |DDClippingLeft|) |of| DESTDD)) + (SETQ |bottom| (|fetch| (\\DISPLAYDATA |DDClippingBottom|) |of| DESTDD)) + (SETQ |right| (|fetch| (\\DISPLAYDATA |DDClippingRight|) |of| DESTDD)) + (SETQ |top| (|fetch| (\\DISPLAYDATA |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 (\\DSPTRANSFORMX + (|fetch| (REGION LEFT) + |of| CLIPPINGREGION) + DESTDD)))) + (SETQ |bottom| (IMAX |bottom| (SETQ CRBOTTOM + (\\DSPTRANSFORMY (|fetch| + (REGION BOTTOM) + |of| + CLIPPINGREGION + ) + DESTDD)))) + (SETQ |right| (IMIN |right| (IPLUS CRLEFT (|fetch| (REGION + WIDTH) + |of| CLIPPINGREGION + )))) + (SETQ |top| (IMIN |top| (IPLUS CRBOTTOM (|fetch| (REGION HEIGHT) + |of| CLIPPINGREGION)) + )))))) + (SETQ DESTINATIONNBITS (BITSPERPIXEL DESTINATIONBITMAP)) + + (* |;;| "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 (SELECTQ (TYPENAME TEXTURE) + (LITATOM (COND + ((NULL TEXTURE) (* \; + "NIL case. default texture to background texture.") + (|ffetch| (\\DISPLAYDATA |DDTexture|) |of| DESTDD)) + ((NOT (EQ DESTINATIONNBITS 1)) + (* \; "should be a color name") + (OR (COLORNUMBERP TEXTURE DESTINATIONNBITS T) + (\\ILLEGAL.ARG TEXTURE))) + (T (\\ILLEGAL.ARG TEXTURE)))) + ((SMALLP FIXP) + (LOGAND TEXTURE (MAXIMUMSHADE DESTINATIONNBITS))) + (BITMAP TEXTURE) + (LISTP (* \; + "should be a list of levels rgb or hls.") + (OR (AND (NOT (EQ DESTINATIONNBITS 1)) + (COLORNUMBERP TEXTURE DESTINATIONNBITS)) + (\\ILLEGAL.ARG TEXTURE))) + (\\ILLEGAL.ARG TEXTURE))) + (COND + ((NOT (EQ DESTINATIONNBITS 1)) + (COND + ((NOT (|type?| BIGBM DESTINATIONBITMAP)) + (SETQ |left| (ITIMES DESTINATIONNBITS |left|)) + (SETQ |right| (ITIMES DESTINATIONNBITS |right|)))) + (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) + (.WHILE.TOP.DS. STREAM (COND + ((NOT (|type?| BIGBM DESTINATIONBITMAP)) + (PROG (HEIGHT) + (SETQ HEIGHT (IDIFFERENCE |top| |bottom|)) + (|replace| (PILOTBBT PBTWIDTH) |of| \\SYSPILOTBBT + |with| (IDIFFERENCE |right| |left|)) + (|replace| (PILOTBBT PBTHEIGHT) |of| \\SYSPILOTBBT + |with| HEIGHT) + (\\BITBLTSUB \\SYSPILOTBBT NIL |left| NIL + DESTINATIONBITMAP |left| (|\\SFInvert| + DESTINATIONBITMAP + |top|) + HEIGHT + 'TEXTURE + (OR OPERATION (|ffetch| (\\DISPLAYDATA + DDOPERATION) + |of| DESTDD)) + TEXTURE + (ITIMES DESTINATIONNBITS (|fetch| ( + \\DISPLAYDATA + DDXOFFSET) + |of| DESTDD)) + (|fetch| (\\DISPLAYDATA DDYOFFSET) |of| + DESTDD)))) + (T (PROG (HEIGHT) + (SETQ HEIGHT (IDIFFERENCE |top| |bottom|)) + (BLTSHADE.BIGBM TEXTURE DESTINATIONBITMAP |left| + |bottom| (IDIFFERENCE |right| |left|) + (IDIFFERENCE |top| |bottom|) + (OR OPERATION (|ffetch| (\\DISPLAYDATA + DDOPERATION) + |of| DESTDD)) + CLIPPINGREGION))))) + (RETURN T)))) + +(\\RESHOWBORDER1 + (LAMBDA (NEWBORDER OLDBORDER WINDOW) (* \; "Edited 26-Jul-90 12:52 by matsuda") + + (* |;;| "redisplays the border of a window. Is called by RESHOWBORDER and RESHOWTITLE. It doesn't check for equality between the new and old borders because it is also used when a title is added or deleted.") + + (PROG ((REGION (|fetch| (WINDOW REG) |of| WINDOW)) + (OLDSAVE (|fetch| (WINDOW SAVE) |of| WINDOW)) + NUSAV DELTA NUWIDTH NUHEIGHT) + (SETQ DELTA (IDIFFERENCE NEWBORDER OLDBORDER)) + (SETQ NUWIDTH (IPLUS (|fetch| (REGION WIDTH) |of| REGION) + (ITIMES DELTA 2))) + (SETQ NUHEIGHT (IDIFFERENCE (IPLUS (|fetch| (REGION HEIGHT) + |of| (DSPCLIPPINGREGION NIL (|fetch| + (WINDOW DSP) + |of| WINDOW))) + (ITIMES NEWBORDER 2)) + (COND + ((|fetch| (WINDOW WTITLE) |of| WINDOW) + (DSPLINEFEED NIL (|fetch| (SCREEN SCTITLEDS) + |of| (|fetch| (WINDOW SCREEN) + |of| WINDOW)))) + (T 0)))) + (SETQ NUSAV (BITMAPCREATE NUWIDTH NUHEIGHT (BITSPERPIXEL OLDSAVE))) + (.WHILE.TOP.DS. WINDOW (* \; "Save window image") + (\\SW2BM (|fetch| (SCREEN SCDESTINATION) |of| (|fetch| (WINDOW + SCREEN) + |of| WINDOW)) + REGION + (|fetch| (WINDOW SAVE) |of| WINDOW) + NIL) (* \; "put new save image into window") + (|replace| (WINDOW SAVE) |of| WINDOW |with| NUSAV) + (|replace| (WINDOW WBORDER) |of| WINDOW |with| NEWBORDER) + (* \; + "create a region that coresponds to the old region with the new border.") + (|replace| (WINDOW REG) |of| WINDOW + |with| (|create| REGION + LEFT _ (IDIFFERENCE (|fetch| (REGION LEFT) |of| REGION) + DELTA) + BOTTOM _ (IDIFFERENCE (|fetch| (REGION BOTTOM) |of| + REGION) + DELTA) + WIDTH _ NUWIDTH + HEIGHT _ NUHEIGHT)) + (UPDATE/SCROLL/REG WINDOW) (* \; "draw border in the new image.") + (SHOWWFRAME WINDOW) (* \; + "copy the visible part from the old image into the new one.") + (BITBLT OLDSAVE OLDBORDER OLDBORDER NUSAV NEWBORDER NEWBORDER + (IDIFFERENCE (BITMAPWIDTH OLDSAVE) + (ITIMES 2 OLDBORDER)) + (|fetch| (REGION HEIGHT) |of| (DSPCLIPPINGREGION NIL + (|fetch| (WINDOW DSP) + |of| WINDOW))) + 'INPUT + 'REPLACE) (* \; + "put the new image up on the screen.") + (\\SW2BM (|fetch| (SCREEN SCDESTINATION) |of| (|fetch| (WINDOW + SCREEN) + |of| WINDOW)) + (|fetch| (WINDOW REG) |of| WINDOW) + (|fetch| (WINDOW SAVE) |of| WINDOW) + NIL))))) +) +(DEFINEQ + +(\\DRAWCIRCLE.BIGBM + (LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS BRUSH DASHING) + (* \; "Edited 29-Jan-91 16:25 by matsuda") + (DECLARE (LOCALVARS . T)) + (PROG ((DD (|fetch| IMAGEDATA |of| DISPLAYSTREAM)) + BITMAP) + (SETQ BITMAP (|fetch| (\\DISPLAYDATA |DDDestination|) |of| DD)) + (COND + ((|type?| BIGBM BITMAP) + (PROG (BIGBMLIST HEIGHT BOTTOM BM |ClippingTop| |ClippingBottom| |CTop| |CBottom|) + (SETQ BIGBMLIST (|fetch| (BIGBM BIGBMLIST) |of| BITMAP)) + (SETQ HEIGHT (BITMAPHEIGHT BITMAP)) + (SETQ |ClippingTop| (|ffetch| (\\DISPLAYDATA |DDClippingTop|) |of| DD)) + (SETQ |ClippingBottom| (|ffetch| (\\DISPLAYDATA |DDClippingBottom|) + |of| DD)) + (SETQ BM (|GetNewFragment| BIGBMLIST)) + (|while| (AND BM (IGREATERP HEIGHT |ClippingBottom|)) + |do| (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM))) + (SETQ |CTop| (COND + ((IGREATERP |ClippingTop| HEIGHT) + (IDIFFERENCE HEIGHT BOTTOM)) + (T (IDIFFERENCE |ClippingTop| BOTTOM)))) + (COND + ((IGEQ |CTop| 0) + (SETQ |CBottom| (COND + ((ILESSP |ClippingBottom| BOTTOM) + 0) + (T (IDIFFERENCE |ClippingBottom| BOTTOM)))) + (|replace| (\\DISPLAYDATA |DDDestination|) |of| DD + |with| BM) + (|replace| (\\DISPLAYDATA |DDClippingTop|) |of| DD + |with| |CTop|) + (|replace| (\\DISPLAYDATA |DDClippingBottom|) |of| DD + |with| |CBottom|) + (\\DRAWCIRCLE.DISPLAY DISPLAYSTREAM CENTERX (IDIFFERENCE CENTERY + BOTTOM) + RADIUS BRUSH DASHING) + (SETQ BM (|GetNewFragment| BIGBMLIST)) + (SETQ HEIGHT BOTTOM)))) + (|replace| (\\DISPLAYDATA |DDDestination|) |of| DD |with| BITMAP) + (|replace| (\\DISPLAYDATA |DDClippingTop|) |of| DD |with| + |ClippingTop|) + (|replace| (\\DISPLAYDATA |DDClippingBottom|) |of| DD |with| + |ClippingBottom| + ) + (MOVETO CENTERX CENTERY DISPLAYSTREAM) + (RETURN NIL))) + (T (\\DRAWCIRCLE.DISPLAY DISPLAYSTREAM CENTERX CENTERY RADIUS BRUSH DASHING)))))) + +(\\FILLCIRCLE.BIGBM + (LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS TEXTURE) + (DECLARE (LOCALVARS . T)) (* \; "Edited 29-Jan-91 16:21 by matsuda") + (COND + ((OR (NOT (NUMBERP RADIUS)) + (ILESSP (SETQ RADIUS (FIXR RADIUS)) + 0)) + (\\ILLEGAL.ARG RADIUS)) + (T (PROG ((DD (|fetch| IMAGEDATA |of| DISPLAYSTREAM)) + BITMAP) + (SETQ BITMAP (|fetch| (\\DISPLAYDATA |DDDestination|) |of| DD)) + (COND + ((|type?| BIGBM BITMAP) + (PROG (BIGBMLIST HEIGHT BOTTOM BM |ClippingTop| |ClippingBottom| |CTop| |CBottom| + ) + (SETQ BIGBMLIST (|fetch| (BIGBM BIGBMLIST) |of| BITMAP)) + (SETQ HEIGHT (BITMAPHEIGHT BITMAP)) + (SETQ |ClippingTop| (|ffetch| (\\DISPLAYDATA |DDClippingTop|) + |of| DD)) + (SETQ |ClippingBottom| (|ffetch| (\\DISPLAYDATA |DDClippingBottom|) + |of| DD)) + (SETQ BM (|GetNewFragment| BIGBMLIST)) + (|while| (AND BM (IGREATERP HEIGHT |ClippingBottom|)) + |do| (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM))) + (SETQ |CTop| (COND + ((IGREATERP |ClippingTop| HEIGHT) + (IDIFFERENCE HEIGHT BOTTOM)) + (T (IDIFFERENCE |ClippingTop| BOTTOM)))) + (COND + ((IGEQ |CTop| 0) + (SETQ |CBottom| (COND + ((ILESSP |ClippingBottom| BOTTOM) + 0) + (T (IDIFFERENCE |ClippingBottom| BOTTOM)))) + (|replace| (\\DISPLAYDATA |DDDestination|) |of| DD + |with| BM) + (|replace| (\\DISPLAYDATA |DDClippingTop|) |of| DD + |with| |CTop|) + (|replace| (\\DISPLAYDATA |DDClippingBottom|) |of| + DD + |with| |CBottom|) + (\\FILLCIRCLE.DISPLAY DISPLAYSTREAM CENTERX (IDIFFERENCE + CENTERY BOTTOM) + RADIUS TEXTURE) + (SETQ BM (|GetNewFragment| BIGBMLIST)) + (SETQ HEIGHT BOTTOM)))) + (|replace| (\\DISPLAYDATA |DDDestination|) |of| DD |with| + BITMAP) + (|replace| (\\DISPLAYDATA |DDClippingTop|) |of| DD |with| + |ClippingTop|) + (|replace| (\\DISPLAYDATA |DDClippingBottom|) |of| DD |with| + + |ClippingBottom| + ) + (MOVETO CENTERX CENTERY DISPLAYSTREAM) + (RETURN NIL))) + (T (\\FILLCIRCLE.DISPLAY DISPLAYSTREAM CENTERX CENTERY RADIUS TEXTURE)))))))) + +(\\DRAWELLIPSE.BIGBM + (LAMBDA (DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) + (DECLARE (LOCALVARS . T)) (* \; "Edited 29-Jan-91 12:52 by matsuda") + (PROG ((DD (|fetch| IMAGEDATA |of| DISPLAYSTREAM) + BITMAP)) + (SETQ BITMAP (|fetch| (\\DISPLAYDATA |DDDestination|) |of| DD)) + (COND + ((|type?| BIGBM BITMAP) + (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))) + (PROG (BIGBMLIST HEIGHT BOTTOM BM YY1 YY2 |ClippingTop| |ClippingBottom| |CTop| + |CBottom|) + (SETQ BIGBMLIST (|fetch| (BIGBM BIGBMLIST) |of| BITMAP)) + (SETQ HEIGHT (BITMAPHEIGHT BITMAP)) + (SETQ |ClippingTop| (|ffetch| (\\DISPLAYDATA |DDClippingTop|) + |of| DD)) + (SETQ |ClippingBottom| (|ffetch| (\\DISPLAYDATA |DDClippingBottom|) + |of| DD)) + (SETQ BM (|GetNewFragment| BIGBMLIST)) + (|while| (AND BM (IGREATERP HEIGHT |ClippingBottom|)) + |do| (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM))) + (SETQ |CTop| (COND + ((IGREATERP |ClippingTop| HEIGHT) + (IDIFFERENCE HEIGHT BOTTOM)) + (T (IDIFFERENCE |ClippingTop| BOTTOM)))) + (COND + ((IGEQ |CTop| 0) + (SETQ |CBottom| (COND + ((ILESSP |ClippingBottom| BOTTOM) + 0) + (T (IDIFFERENCE |ClippingBottom| BOTTOM)))) + (|replace| (\\DISPLAYDATA |DDDestination|) |of| DD + |with| BM) + (|replace| (\\DISPLAYDATA |DDClippingTop|) |of| DD + |with| |CTop|) + (|replace| (\\DISPLAYDATA |DDClippingBottom|) |of| + DD + |with| |CBottom|) + (\\DRAWELLIPSE.DISPLAY DISPLAYSTREAM CENTERX (IDIFFERENCE + CENTERY BOTTOM) + SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH + DASHING) + (SETQ BM (|GetNewFragment| BIGBMLIST)) + (SETQ HEIGHT BOTTOM)))) + (|replace| (\\DISPLAYDATA |DDDestination|) |of| DD |with| + BITMAP) + (|replace| (\\DISPLAYDATA |DDClippingTop|) |of| DD |with| + |ClippingTop|) + (|replace| (\\DISPLAYDATA |DDClippingBottom|) |of| DD |with| + + |ClippingBottom| + ) + (MOVETO CENTERX CENTERY DISPLAYSTREAM) + (RETURN NIL)))) + (T (\\DRAWELLIPSE.DISPLAY DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS + ORIENTATION BRUSH DASHING)))))) + +(\\DRAWCURVE.BIGBM + (LAMBDA (DISPLAYSTREAM KNOTS CLOSED BRUSH DASHING) + (DECLARE (LOCALVARS . T)) (* \; "Edited 29-Jan-91 17:48 by matsuda") + (PROG ((DD (|fetch| (STREAM IMAGEDATA) |of| DISPLAYSTREAM)) + BITMAP) + (SETQ BITMAP (|fetch| (\\DISPLAYDATA |DDDestination|) |of| DD)) + (COND + ((|type?| BIGBM BITMAP) + (PROG (BIGBMLIST HEIGHT BOTTOM BM |ClippingTop| |ClippingBottom| |CTop| |CBottom| + POINTS) + (|for| KNOT |in| KNOTS |do| (OR (|type?| POSITION KNOT) + (ERROR "bad knot" KNOT))) + (SETQ BIGBMLIST (|fetch| (BIGBM BIGBMLIST) |of| BITMAP)) + (SETQ HEIGHT (BITMAPHEIGHT BITMAP)) + (SETQ |ClippingTop| (|ffetch| (\\DISPLAYDATA |DDClippingTop|) |of| DD)) + (SETQ |ClippingBottom| (|ffetch| (\\DISPLAYDATA |DDClippingBottom|) + |of| DD)) + (SETQ BM (|GetNewFragment| BIGBMLIST)) + (|while| (AND BM (IGREATERP HEIGHT |ClippingBottom|)) + |do| (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM))) + (SETQ |CTop| (COND + ((IGREATERP |ClippingTop| HEIGHT) + (IDIFFERENCE HEIGHT BOTTOM)) + (T (IDIFFERENCE |ClippingTop| BOTTOM)))) + (COND + ((IGEQ |CTop| 0) + (SETQ |CBottom| (COND + ((ILESSP |ClippingBottom| BOTTOM) + 0) + (T (IDIFFERENCE |ClippingBottom| BOTTOM)))) + (|replace| (\\DISPLAYDATA |DDDestination|) |of| DD + |with| BM) + (|replace| (\\DISPLAYDATA |DDClippingTop|) |of| DD + |with| |CTop|) + (|replace| (\\DISPLAYDATA |DDClippingBottom|) |of| DD + |with| |CBottom|) + (SETQ POINTS (|for| KNOT |in| KNOTS + |collect| (|create| POSITION + XCOORD _ (CAR KNOT) + YCOORD _ (DIFFERENCE + (CDR KNOT) + BOTTOM)))) + (\\DRAWCURVE.DISPLAY DISPLAYSTREAM POINTS CLOSED BRUSH DASHING) + (SETQ BM (|GetNewFragment| BIGBMLIST)) + (SETQ HEIGHT BOTTOM)))) + (|replace| (\\DISPLAYDATA |DDDestination|) |of| DD |with| BITMAP) + (|replace| (\\DISPLAYDATA |DDClippingTop|) |of| DD |with| + |ClippingTop|) + (|replace| (\\DISPLAYDATA |DDClippingBottom|) |of| DD |with| + |ClippingBottom| + ) + (RETURN DISPLAYSTREAM))) + (T (\\DRAWCURVE.DISPLAY DISPLAYSTREAM KNOTS CLOSED BRUSH DASHING)))))) +) +(DEFINEQ + +(DSPCREATE + (LAMBDA (DESTINATION) (* \; "Edited 20-Jul-90 19:11 by matsuda") + + (* |;;| "Creates a stream-of-type-display on the DESTINATION bitmap or display device") + + (LET (DSTRM) + (COND + ((NULL DESTINATION) + (SETQ DESTINATION |ScreenBitMap|)) + (T (* \; "DESTINATION is accepted BITMAP or BIGBM.\\DTEST causes error when object to be tested is not BITMAP.") + (\\DTEST (COND + ((|type?| BIGBM DESTINATION) + (CAR (|fetch| (BIGBM BIGBMLIST) OF DESTINATION))) + (T DESTINATION)) + 'BITMAP))) + (SETQ DSTRM (|create| STREAM + USERCLOSEABLE _ NIL + OUTCHARFN _ (FUNCTION \\DSPPRINTCHAR) + IMAGEDATA _ (|create| \\DISPLAYDATA) + IMAGEOPS _ \\DISPLAYIMAGEOPS + DEVICE _ |DisplayFDEV| + ACCESS _ 'OUTPUT)) (* \; + "initial x and y positions are 0 when the data is created.") + (DSPFONT DEFAULTFONT DSTRM) (* \; + "dspfont can win since the (default) display imageops are filled in the stream") + (DSPDESTINATION DESTINATION DSTRM) (* \; + "dspdestination calls \\SFFixFont, which presumes there is a font present.") + (DSPFONT DEFAULTFONT DSTRM) + + (* |;;| "the reference to SCREENWIDTH here is for historic reasons: until 3-feb-86 the default right margin was always SCREENWIDTH. It should be the width of the destination and for any destination larger than the screen this is a serious bug and was fixed. The MAX of the right value and SCREENWIDTH was left in because existing code might be assumine a large right margin for small bitmaps and auto-CR in without it. rrb") + + (DSPRIGHTMARGIN (MAX SCREENWIDTH (BITMAPWIDTH DESTINATION)) + DSTRM) + (DSPSOURCETYPE 'INPUT DSTRM) + (DSPOPERATION 'REPLACE DSTRM) (* \; + "called to cause the updating of the bitblt table from the fields initialized earlier.") + DSTRM))) + +(DSPDESTINATION + (LAMBDA (DESTINATION DISPLAYSTREAM) (* \; "Edited 22-Sep-89 13:53 by takeshi") + (DECLARE (GLOBALVARS \\DISPLAYIMAGEOPS \\4DISPLAYIMAGEOPS \\8DISPLAYIMAGEOPS + \\24DISPLAYIMAGEOPS)) + (PROG (DD) + (SETQ DD (\\GETDISPLAYDATA DISPLAYSTREAM DISPLAYSTREAM)) + (RETURN (PROG1 (|ffetch| (\\DISPLAYDATA |DDDestination|) |of| DD) + (COND + (DESTINATION (* \; + "(SETQ DESTINATION (OR (\\\\DTEST DESTINATION 'BITMAP) (\\\\DTEST DESTINATION 'BIGBM)))") + (COND + ((|type?| BITMAP DESTINATION) + (UNINTERRUPTABLY + (|replace| (STREAM DEVICE) |of| DISPLAYSTREAM + |with| (SELECTQ (|fetch| (BITMAP + BITMAPBITSPERPIXEL + ) |of| + DESTINATION + ) + (1 |DisplayFDEV|) + (4 \\4DISPLAYFDEV) + (8 \\8DISPLAYFDEV) + (24 \\24DISPLAYFDEV) + (SHOULDNT))) + (|replace| (STREAM IMAGEOPS) |of| DISPLAYSTREAM + |with| (SELECTQ (|fetch| (BITMAP + BITMAPBITSPERPIXEL + ) |of| + DESTINATION + ) + (1 \\DISPLAYIMAGEOPS) + (4 \\4DISPLAYIMAGEOPS) + (8 \\8DISPLAYIMAGEOPS) + (24 \\24DISPLAYIMAGEOPS) + (SHOULDNT))) + (|freplace| (\\DISPLAYDATA |DDDestination|) |of| + DD + |with| DESTINATION) + (|\\SFFixDestination| DD DISPLAYSTREAM))) + ((|type?| BIGBM DESTINATION) + (UNINTERRUPTABLY + (|replace| (STREAM DEVICE) |of| DISPLAYSTREAM + |with| \\8DISPLAYFDEV) + + (* |;;| "I'll add the bpp slot in BIGBM") + + (|replace| (STREAM IMAGEOPS) |of| DISPLAYSTREAM + |with| \\8DISPLAYIMAGEOPS) + (|freplace| (\\DISPLAYDATA |DDDestination|) |of| + DD + |with| DESTINATION) + (|\\SFFixDestination| DD DISPLAYSTREAM))))))))))) + +(|\\SFFixY| + (LAMBDA (DISPLAYDATA CSINFO) (* \; "Edited 6-Jul-90 10:13 by matsuda") + + (* |;;| "makes that part of the bitblt table of a display stream which deals with the Y information consistent. This is called from \\BLTCHAR whenever a character is being printed and the charset/y-position caches are invalid") + (* \; + "assumes DISPLAYDATA has already been type checked.") + (PROG ((PBT (|ffetch| DDPILOTBBT |of| DISPLAYDATA)) + (Y (\\DSPTRANSFORMY (|ffetch| DDYPOSITION |of| DISPLAYDATA) + DISPLAYDATA)) + TOP CHARTOP BM) + (SETQ CHARTOP (IPLUS Y (|freplace| DDCHARSETASCENT |of| DISPLAYDATA + |with| (|ffetch| CHARSETASCENT |of| CSINFO)))) + (SETQ BM (|ffetch| |DDDestination| |of| DISPLAYDATA)) + (COND + ((|type?| BIGBM BM) + (SETQ TOP (IMAX (IMIN (|ffetch| |DDClippingTop| |of| DISPLAYDATA) + CHARTOP) + 0)) + (|freplace| PBTDEST |of| PBT |with| NIL) + (|freplace| PBTSOURCE |of| PBT + |with| (\\ADDBASE (|ffetch| BITMAPBASE |of| (SETQ BM (|ffetch| + (CHARSETINFO + CHARSETBITMAP) + |of| CSINFO) + )) + (ITIMES (|ffetch| BITMAPRASTERWIDTH |of| BM) + (|freplace| DDCHARHEIGHTDELTA |of| DISPLAYDATA + |with| (IMIN (IMAX (IDIFFERENCE CHARTOP TOP) + 0) + MAX.SMALL.INTEGER))))) + (|freplace| PBTHEIGHT |of| PBT + |with| (IMAX (IDIFFERENCE TOP (IMAX (IDIFFERENCE Y (|freplace| + DDCHARSETDESCENT + |of| DISPLAYDATA + |with| (|ffetch| + CHARSETDESCENT + |of| + CSINFO))) + (|ffetch| |DDClippingBottom| + |of| DISPLAYDATA))) + 0))) + (T (|freplace| PBTDEST |of| PBT + |with| (\\ADDBASE (|fetch| BITMAPBASE |of| BM) + (ITIMES (|ffetch| BITMAPRASTERWIDTH |of| BM) + (|\\SFInvert| BM (SETQ TOP + (IMAX (IMIN (|ffetch| + |DDClippingTop| + |of| DISPLAYDATA) + CHARTOP) + 0)))))) + (|freplace| PBTSOURCE |of| PBT + |with| (\\ADDBASE (|ffetch| BITMAPBASE |of| (SETQ BM + (|ffetch| + (CHARSETINFO + CHARSETBITMAP) + |of| CSINFO))) + (ITIMES (|ffetch| BITMAPRASTERWIDTH |of| BM) + (|freplace| DDCHARHEIGHTDELTA |of| DISPLAYDATA + |with| (IMIN (IMAX (IDIFFERENCE CHARTOP TOP) + 0) + MAX.SMALL.INTEGER))))) + (|freplace| PBTHEIGHT |of| PBT + |with| (IMAX (IDIFFERENCE TOP (IMAX (IDIFFERENCE Y + (|freplace| DDCHARSETDESCENT + |of| DISPLAYDATA + |with| (|ffetch| + CHARSETDESCENT + |of| CSINFO))) + (|ffetch| |DDClippingBottom| + |of| DISPLAYDATA))) + 0))))))) + +(|\\SFFixDestination| + (LAMBDA (DISPLAYDATA DISPLAYSTREAM) (* \; "Edited 6-Jul-90 13:55 by matsuda") + + (* |;;| "fixes up those parts of the bitblt array which are dependent upon the destination") + + (PROG ((PBT (|ffetch| (\\DISPLAYDATA DDPILOTBBT) |of| DISPLAYDATA)) + (BM (|ffetch| (\\DISPLAYDATA |DDDestination|) |of| DISPLAYDATA))) + (|replace| (PILOTBBT PBTDESTBPL) |of| PBT + |with| (UNFOLD (COND + ((|type?| BITMAP BM) + (|ffetch| (BITMAP BITMAPRASTERWIDTH) |of| BM)) + (T (|ffetch| (BITMAP BITMAPRASTERWIDTH) + |of| (CAR (|fetch| (BIGBM BIGBMLIST) OF BM))))) + BITSPERWORD)) (* \; + "line width information will be updated by \\SFFixFont") + (|\\SFFixClippingRegion| DISPLAYDATA) + (\\INVALIDATEDISPLAYCACHE DISPLAYDATA) + (|\\SFFixFont| DISPLAYSTREAM DISPLAYDATA) + (RETURN)))) + +(|\\SFFixClippingRegion| + (LAMBDA (DISPLAYDATA) (* \; "Edited 6-Jul-90 13:55 by matsuda") + + (* |;;| "compute the top, bottom, left and right edges of the clipping region in destination coordinates to save computation every BltChar and coordinate transformation taking into account the size of the bit map as well as the clipping region.") + + (PROG ((CLIPREG (|ffetch| (\\DISPLAYDATA |DDClippingRegion|) |of| DISPLAYDATA)) + (BM (|ffetch| (\\DISPLAYDATA |DDDestination|) |of| DISPLAYDATA))) + (|freplace| (\\DISPLAYDATA |DDClippingRight|) |of| DISPLAYDATA + |with| (IMAX 0 (IMIN (\\DSPTRANSFORMX (IPLUS (|ffetch| (REGION LEFT) + |of| CLIPREG) + (|ffetch| (REGION WIDTH) + |of| CLIPREG)) + DISPLAYDATA) + (BITMAPWIDTH BM)))) + (|freplace| (\\DISPLAYDATA |DDClippingLeft|) |of| DISPLAYDATA + |with| (IMIN (IMAX (\\DSPTRANSFORMX (|ffetch| (REGION LEFT) |of| CLIPREG) + DISPLAYDATA) + 0) + MAX.SMALL.INTEGER)) + (|freplace| (\\DISPLAYDATA |DDClippingTop|) |of| DISPLAYDATA + |with| (IMAX 0 (IMIN (\\DSPTRANSFORMY (IPLUS (|ffetch| (REGION BOTTOM) + |of| CLIPREG) + (|ffetch| (REGION HEIGHT) + |of| CLIPREG)) + DISPLAYDATA) + (BITMAPHEIGHT BM)))) + (|freplace| (\\DISPLAYDATA |DDClippingBottom|) |of| DISPLAYDATA + |with| (IMIN (IMAX (\\DSPTRANSFORMY (|ffetch| (REGION BOTTOM) |of| CLIPREG) + DISPLAYDATA) + 0) + MAX.SMALL.INTEGER))))) +) +(DEFINEQ + +(\\SW2BM + (LAMBDA (P PR Q QR) (* \; "Edited 8-Sep-89 16:14 by takeshi") + + (* |Switches| |the| |areas| |of| P |and| Q |defined| |by| |the| |regions| PR + |and| QR |respectively|) + + (PROG (PL PH PW PB QL QH QW QB) + (COND + (PR (SETQ PL (|fetch| (REGION LEFT) |of| PR)) + (SETQ PB (|fetch| (REGION BOTTOM) |of| PR)) + (SETQ PH (|fetch| (REGION HEIGHT) |of| PR)) + (SETQ PW (|fetch| (REGION WIDTH) |of| PR))) + (T (SETQ PL (SETQ PB 0)) + (COND + ((|type?| BITMAP P) + (SETQ PW (|ffetch| (BITMAP BITMAPWIDTH) |of| P)) + (SETQ PH (|ffetch| (BITMAP BITMAPHEIGHT) |of| P))) + (T (SETQ PW (|fetch| (BIGBM BIGBMWIDTH) |of| P)) + (SETQ PH (|fetch| (BIGBM BIGBMHEIGHT) |of| P)))))) + (COND + (QR (SETQ QL (|fetch| (REGION LEFT) |of| QR)) + (SETQ QB (|fetch| (REGION BOTTOM) |of| QR)) + (SETQ QW (|fetch| (REGION WIDTH) |of| QR)) + (SETQ QH (|fetch| (REGION HEIGHT) |of| QR))) + (T (SETQ QL (SETQ QB 0)) + (COND + ((|type?| BITMAP Q) + (SETQ QW (|ffetch| (BITMAP BITMAPWIDTH) |of| Q)) + (SETQ QH (|ffetch| (BITMAP BITMAPHEIGHT) |of| Q))) + (T (SETQ QW (|fetch| (BIGBM BIGBMWIDTH) |of| Q)) + (SETQ QH (|fetch| (BIGBM BIGBMHEIGHT) |of| Q)))))) + (PROG ((CL (IMAX (IMINUS PL) + (IMINUS QL) + 0)) + (CB (IMAX (IMINUS PB) + (IMINUS QB) + 0))) + (PROG ((XP (IPLUS CL PL)) + (YP (IPLUS CB PB)) + (XQ (IPLUS CL QL)) + (YQ (IPLUS CB QB)) + CW CH) + (SETQ CW (IMIN (COND + ((|type?| BITMAP P) + (IDIFFERENCE (IMIN (|ffetch| (BITMAP BITMAPWIDTH) + |of| P) + (IPLUS PL PW)) + XP)) + (T (IDIFFERENCE (IMIN (|fetch| (BIGBM BIGBMWIDTH) + |of| P) + (IPLUS PL PW)) + XP))) + (COND + ((|type?| BITMAP Q) + (IDIFFERENCE (IMIN (|ffetch| (BITMAP BITMAPWIDTH) + |of| Q) + (IPLUS QL QW)) + XQ)) + (T (IDIFFERENCE (IMIN (|fetch| (BIGBM BIGBMWIDTH) + |of| Q) + (IPLUS QL QW)) + XQ))))) + (SETQ CH (IMIN (IDIFFERENCE (IMIN (COND + ((|type?| BITMAP P) + (|fetch| (BITMAP BITMAPHEIGHT) + |of| P)) + (T (|fetch| (BIGBM BIGBMHEIGHT) + |of| P))) + (IPLUS PB PH)) + YP) + (IDIFFERENCE (IMIN (COND + ((|type?| BITMAP Q) + (|fetch| (BITMAP BITMAPHEIGHT) + |of| Q)) + (T (|fetch| (BIGBM BIGBMHEIGHT) + |of| Q))) + (IPLUS QB QH)) + YQ))) + (UNINTERRUPTABLY + (BITBLT P XP YP Q XQ YQ CW CH 'INPUT 'INVERT) + (BITBLT Q XQ YQ P XP YP CW CH 'INPUT 'INVERT) + (BITBLT P XP YP Q XQ YQ CW CH 'INPUT 'INVERT))))))) + +(BITMAPHEIGHT + (LAMBDA (BITMAP) (* \; "Edited 22-Sep-89 14:05 by takeshi") + + (* |;;| "returns the height in pixels of a bitmap.") + + (COND + ((|type?| BITMAP BITMAP) + (|ffetch| (BITMAP BITMAPHEIGHT) |of| BITMAP)) + ((|type?| WINDOW BITMAP) + (WINDOWPROP BITMAP 'HEIGHT)) + ((|type?| BIGBM BITMAP) + (|ffetch| (BIGBM BIGBMHEIGHT) |of| BITMAP)) + (T (\\ILLEGAL.ARG BITMAP))))) + +(BITMAPWIDTH + (LAMBDA (BITMAP) (* \; "Edited 22-Sep-89 14:07 by takeshi") + + (* |;;| "returns the width of a bitmap in pixels") + + (COND + ((|type?| BITMAP BITMAP) + (|ffetch| (BITMAP BITMAPWIDTH) |of| BITMAP)) + ((|type?| WINDOW BITMAP) + (WINDOWPROP BITMAP 'WIDTH)) + ((|type?| BIGBM BITMAP) + (|ffetch| (BIGBM BIGBMWIDTH) |of| BITMAP)) + (T (\\ILLEGAL.ARG BITMAP))))) + +(|\\SFFixFont| + (LAMBDA (DISPLAYSTREAM DISPLAYDATA) (* \; "Edited 6-Jul-90 10:11 by matsuda") + + (* |;;| "used to fix up those parts of the bitblt table which depend upon the FONT. DISPLAYDATA is the IMAGEDATA for DISPLAYSTREAM, for convenience.") + + (PROG ((PILOTBBT (|ffetch| (\\DISPLAYDATA DDPILOTBBT) |of| DISPLAYDATA)) + (FONT (|ffetch| (\\DISPLAYDATA DDFONT) |of| DISPLAYDATA)) + (BITSPERPIXEL (BITSPERPIXEL (|ffetch| (\\DISPLAYDATA |DDDestination|) + |of| DISPLAYDATA)))) + (|freplace| (\\DISPLAYDATA |DDSlowPrintingCase|) |of| DISPLAYDATA + |with| (OR (NOT (EQ BITSPERPIXEL 1)) + (NOT (EQ (|ffetch| (FONTDESCRIPTOR ROTATION) |of| FONT) + 0))))) + (\\INVALIDATEDISPLAYCACHE DISPLAYDATA) + (\\SFFIXLINELENGTH DISPLAYSTREAM))) + +(BITSPERPIXEL + (LAMBDA (BITMAP) (* \; "Edited 29-Jun-90 10:15 by matsuda") + + (* |;;| "returns the height in pixels of a bitmap.") + + (COND + ((|type?| BITMAP BITMAP) + (|fetch| (BITMAP BITMAPBITSPERPIXEL) |of| BITMAP)) + ((|type?| BIGBM BITMAP) + (|fetch| (BITMAP BITMAPBITSPERPIXEL) |of| (CAR (|fetch| (BIGBM BIGBMLIST) + |of| BITMAP)))) + ((|type?| SCREEN BITMAP) + (BITSPERPIXEL (|fetch| (SCREEN SCDESTINATION) |of| BITMAP))) + ((|type?| WINDOW BITMAP) + (BITSPERPIXEL (|fetch| (WINDOW SCREEN) |of| BITMAP))) + ((ARRAYP BITMAP) (* \; + "Consider array to be a colormap.") + (SELECTQ (ARRAYSIZE BITMAP) + (256 8) + (16 4) + (LISPERROR "ILLEGAL ARG" BITMAP))) + (T (LISPERROR "ILLEGAL ARG" BITMAP))))) +) +(DEFINEQ + +(COLORIZEBITMAP + (LAMBDA (BITMAP 0COLOR 1COLOR BITSPERPIXEL) (* \; "Edited 13-Jul-90 14:42 by matsuda") + + (* |creates| \a |copy| |of| BITMAP |that| |is| |in| |color| |form| |allowing| + BITSPERPIXEL |per| |pixel.| 0COLOR |and| 1COLOR |are| |the| |color| |numbers| + |that| |get| |translated| |from| 0 |and| 1 |respectively.|) + + (PROG (COLORBITMAP) + (SETQ COLORBITMAP (BITMAPCREATE (|fetch| (BITMAP BITMAPWIDTH) |of| BITMAP) + (|fetch| (BITMAP BITMAPHEIGHT) |of| BITMAP) + BITSPERPIXEL)) + (COND + ((NOT (|type?| BIGBM COLORBITMAP)) + (\\BWTOCOLORBLT BITMAP 0 0 COLORBITMAP 0 0 (|fetch| (BITMAP BITMAPWIDTH) + |of| BITMAP) + (|fetch| (BITMAP BITMAPHEIGHT) |of| BITMAP) + (COLORNUMBERP 0COLOR BITSPERPIXEL) + (COLORNUMBERP 1COLOR BITSPERPIXEL) + BITSPERPIXEL)) + (T (PROG (DESTBMLIST DESTBITMAP SOURCEBOOTTOM) + (SETQ DESTBMLIST (|fetch| (BIGBM BIGBMLIST) |of| COLORBITMAP)) + (SETQ DESTBM (|GetNewFragment| DESTBMLIST)) + (SETQ SOURCEBOOTTOM (|fetch| (BITMAP BITMAPHEIGHT) |of| BITMAP)) + (|while| DESTBM |do| (SETQ DESTBMHEIGHT (|fetch| (BITMAP + BITMAPHEIGHT + ) + |of| DESTBM)) + (SETQ SOURCEBOOTTOM (- SOURCEBOOTTOM DESTBMHEIGHT)) + (\\BWTOCOLORBLT BITMAP 0 SOURCEBOOTTOM DESTBM 0 0 + (|fetch| (BITMAP BITMAPWIDTH) |of| + BITMAP) + DESTBMHEIGHT + (COLORNUMBERP 0COLOR BITSPERPIXEL) + (COLORNUMBERP 1COLOR BITSPERPIXEL) + BITSPERPIXEL) + (SETQ DESTBM (|GetNewFragment| DESTBMLIST)))))) + (RETURN COLORBITMAP)))) + +(\\BWTOCOLORBLT + (LAMBDA (SOURCEBWBM SLEFT SBOTTOM DESTCOLORBM DLEFT DBOTTOM WIDTH HEIGHT 0COLOR 1COLOR DESTNBITS) + (* \; "Edited 13-Jul-90 14:11 by matsuda") + + (* |blits| |from| \a |black| |and| |white| |bitmap| |into| \a |color| |bitmap| + |which| |has| DESTNBITS |bits| |per| |pixel.| + DESTCOLORBM |is| \a |pointer| |to| |the| |color| |bitmap.|) + (* |assumes| |all| |datatypes| |and| + |bounds| |have| |been| |checked|) + (SELECTQ DESTNBITS + (4 (PROG (MAP SRCBASE SRCHEIGHT SRCRW SRCWRD SRCOFFSET DESBASE DESHEIGHT DESRW DESWRD DESOFF + NBITS DESALIGNLEFT SCR) + (SETQ MAP (|fetch| (ARRAYP BASE) |of| (\\MAP4 0COLOR 1COLOR))) + (SETQ SRCBASE (|fetch| (BITMAP BITMAPBASE) |of| SOURCEBWBM)) + (SETQ SRCHEIGHT (|fetch| (BITMAP BITMAPHEIGHT) |of| SOURCEBWBM)) + (SETQ SRCRW (|fetch| (BITMAP BITMAPRASTERWIDTH) |of| SOURCEBWBM)) + (SETQ SRCWRD (FOLDLO SLEFT BITSPERWORD)) + (SETQ SRCOFFSET (MOD SLEFT BITSPERWORD)) + (SETQ DESBASE (|fetch| (BITMAP BITMAPBASE) |of| DESTCOLORBM)) + (SETQ DESHEIGHT (|fetch| (BITMAP BITMAPHEIGHT) |of| DESTCOLORBM)) + (SETQ DESRW (|fetch| (BITMAP BITMAPRASTERWIDTH) |of| DESTCOLORBM)) + (SETQ DESWRD (FOLDLO DLEFT 4)) + (SETQ DESOFF (MOD DLEFT 4)) + (SETQ NBITS 4) (* DESTCOLORBM |is| |used| |to| + |allow| |one| |bit| |per| |pixel| + |bitblt| |operations| |on| |the| + |bitmap.|) + (COND + ((NOT (EQ 0 DESOFF)) (* |save| |the| |left| |bits| |of| + |the| |destination| |bitmap| |so| + |it| |can| |be| |word| |aligned.|) + (SETQ SCR (BITMAPCREATE 4 HEIGHT 4)) + (BITBLT DESTCOLORBM (SETQ DESALIGNLEFT (LLSH DESWRD 2)) + DBOTTOM SCR 0 0 DESOFF HEIGHT 'INPUT 'REPLACE))) + (|for| LINECOUNTER |from| 1 |to| HEIGHT + |do| + + (* |linecounter| |goes| |from| 1 |to| |height| |because| |bitmaps| |are| + |stored| |internally| |with| |top| |first| |so| |subtracting| |height| |is| + |necessary| |to| |get| |offset| |of| |line| |and| |the| 1 |corrects| |for| + |height| |difference.|) + + (\\4BITLINEBLT (\\ADDBASE SRCBASE (IPLUS (ITIMES (IDIFFERENCE SRCHEIGHT + (IPLUS LINECOUNTER + SBOTTOM)) + SRCRW) + SRCWRD)) + SRCOFFSET + (\\ADDBASE DESBASE (IPLUS (ITIMES (IDIFFERENCE DESHEIGHT + (IPLUS LINECOUNTER DBOTTOM) + ) + DESRW) + DESWRD)) + WIDTH MAP 0COLOR 1COLOR)) + (COND + (DESALIGNLEFT (* |move| |the| |color| |bits| |to| + |the| |right| |and| |restore| |the| + |saved| |color| |bits.|) + (BITBLT DESTCOLORBM DESALIGNLEFT DBOTTOM DESTCOLORBM (IPLUS + DESALIGNLEFT + DESOFF) + DBOTTOM WIDTH HEIGHT 'INPUT 'REPLACE) + (BITBLT SCR 0 0 DESTCOLORBM DESALIGNLEFT DBOTTOM DESOFF HEIGHT + 'INPUT + 'REPLACE))))) + (8 ((OPCODES SUBRCALL 142 11) + SOURCEBWBM SLEFT SBOTTOM DESTCOLORBM DLEFT DBOTTOM WIDTH HEIGHT 0COLOR 1COLOR DESTNBITS) + + (* PROG (MAP SRCBASE SRCHEIGHT SRCRW SRCWRD SRCOFFSET DESBASE DESHEIGHT DESRW + DESWRD DESOFF) (SETQ MAP (|fetch| (ARRAYP BASE) |of| + (\\MAP8 0COLOR 1COLOR))) (SETQ SRCBASE (|fetch| + (BITMAP BITMAPBASE) |of| SOURCEBWBM)) (SETQ SRCHEIGHT + (|fetch| (BITMAP BITMAPHEIGHT) |of| SOURCEBWBM)) + (SETQ SRCRW (|fetch| (BITMAP BITMAPRASTERWIDTH) |of| SOURCEBWBM)) + (SETQ SRCWRD (FOLDLO SLEFT BITSPERWORD)) + (SETQ SRCOFFSET (MOD SLEFT BITSPERWORD)) + (SETQ DESBASE (|fetch| (BITMAP BITMAPBASE) |of| DESTCOLORBM)) + (SETQ DESHEIGHT (|fetch| (BITMAP BITMAPHEIGHT) |of| DESTCOLORBM)) + (SETQ DESRW (|fetch| (BITMAP BITMAPRASTERWIDTH) |of| DESTCOLORBM)) + (SETQ DESWRD (FOLDLO DLEFT 2)) (SETQ DESOFF + (MOD DLEFT 2)) (|for| LINECOUNTER |from| 1 |to| HEIGHT |do| + (* |linecounter| |goes| |from| 1 |to| |height| |because| |bitmaps| |are| + |stored| |internally| |with| |top| |first| |so| |subtracting| |height| |is| + |necessary| |to| |get| |offset| |of| |line| |and| |the| 1 |corrects| |for| + |height| |difference.|) (\\8BITLINEBLT (\\ADDBASE SRCBASE + (IPLUS (ITIMES (IDIFFERENCE SRCHEIGHT (IPLUS LINECOUNTER SBOTTOM)) SRCRW) + SRCWRD)) SRCOFFSET (\\ADDBASE DESBASE (IPLUS + (ITIMES (IDIFFERENCE DESHEIGHT (IPLUS LINECOUNTER DBOTTOM)) DESRW) DESWRD)) + DESOFF WIDTH MAP 0COLOR 1COLOR)) *) + + ) + (24 (PROG (SRCBASE SRCHEIGHT SRCRW DESBASE DESHEIGHT DESRW) + (SETQ SRCBASE (|fetch| (BITMAP BITMAPBASE) |of| SOURCEBWBM)) + (SETQ SRCHEIGHT (|fetch| (BITMAP BITMAPHEIGHT) |of| SOURCEBWBM)) + (SETQ SRCRW (|fetch| (BITMAP BITMAPRASTERWIDTH) |of| SOURCEBWBM)) + (SETQ DESBASE (|fetch| (BITMAP BITMAPBASE) |of| DESTCOLORBM)) + (SETQ DESHEIGHT (|fetch| (BITMAP BITMAPHEIGHT) |of| DESTCOLORBM)) + (SETQ DESRW (|fetch| (BITMAP BITMAPRASTERWIDTH) |of| DESTCOLORBM)) + (|for| LINECOUNTER |from| 1 |to| HEIGHT + |do| + + (* |linecounter| |goes| |from| 1 |to| |height| |because| |bitmaps| |are| + |stored| |internally| |with| |top| |first| |so| |subtracting| |height| |is| + |necessary| |to| |get| |offset| |of| |line| |and| |the| 1 |corrects| |for| + |height| |difference.|) + + (\\24BITLINEBLT (\\ADDBASE SRCBASE (ITIMES (IDIFFERENCE SRCHEIGHT + (IPLUS LINECOUNTER + SBOTTOM)) + SRCRW)) + SLEFT + (\\ADDBASE DESBASE (ITIMES (IDIFFERENCE DESHEIGHT (IPLUS + LINECOUNTER + DBOTTOM)) + DESRW)) + DLEFT WIDTH 0COLOR 1COLOR)))) + (SHOULDNT)))) + +(UNCOLORIZEBITMAP + (LAMBDA (BITMAP COLORMAP) (* \; "Edited 13-Jul-90 16:54 by matsuda") + (PROG (BITSPERPIXEL MAXCOLOR MAXX MAXY BWBITMAP TABLE RGB R G B BIT BASE BWBASE RASTERWIDTH + BWRASTERWIDTH WORD) + (SETQ MAXX (SUB1 (BITMAPWIDTH BITMAP))) + (SETQ MAXY (SUB1 (BITMAPHEIGHT BITMAP))) + (SETQ BITSPERPIXEL (BITSPERPIXEL BITMAP)) + (SETQ COLORMAP (OR COLORMAP (COLORMAP BITSPERPIXEL))) + (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) + (SETQ BWBITMAP (BITMAPCREATE (ADD1 MAXX) + (ADD1 MAXY) + 1)) + (SETQ TABLE (\\ALLOCBLOCK (FOLDHI (ADD1 MAXCOLOR) + 2))) + (|for| I |from| 0 |to| MAXCOLOR + |do| (SETQ RGB (ELT COLORMAP I)) + (SETQ R (|fetch| (RGB RED) |of| RGB)) + (SETQ G (|fetch| (RGB GREEN) |of| RGB)) + (SETQ B (|fetch| (RGB BLUE) |of| RGB)) + (SETQ BIT (IDIFFERENCE 1 (IQUOTIENT (IPLUS R G B) + 384))) + (\\PUTBASE TABLE I BIT)) + (COND + ((|type?| BITMAP BITMAP) + (SETQ BASE (|fetch| (BITMAP BITMAPBASE) |of| BITMAP)) + (SETQ BWBASE (|fetch| (BITMAP BITMAPBASE) |of| BWBITMAP)) + (SETQ RASTERWIDTH (|fetch| (BITMAP BITMAPRASTERWIDTH) |of| BITMAP)) + (SETQ BWRASTERWIDTH (|fetch| (BITMAP BITMAPRASTERWIDTH) |of| BWBITMAP)))) + (SELECTQ BITSPERPIXEL + (4 (|for| Y |from| 0 |to| MAXY + |do| (SETQ WORD 0) + (|for| X |from| 0 |to| MAXX + |do| (SETQ WORD (LOGOR (LLSH WORD 1) + (\\GETBASE TABLE (\\GETBASENYBBLE BASE X)))) + (COND + ((EQ (LOGAND X 15) + 15) + (\\PUTBASE BWBASE (FOLDLO X 16) + WORD) + (SETQ WORD 0)))) + (COND + ((NOT (EQ (LOGAND MAXX 15) + 15)) + (SETQ WORD (LLSH WORD (IDIFFERENCE 15 (LOGAND MAXX 15)))) + (\\PUTBASE BWBASE (FOLDLO MAXX 16) + WORD))) + (COND + ((NOT (EQ Y MAXY)) + (SETQ BASE (\\ADDBASE BASE RASTERWIDTH)) + (SETQ BWBASE (\\ADDBASE BWBASE BWRASTERWIDTH)))))) + (8 (COND + ((NOT (|type?| BIGBM BITMAP)) + ((OPCODES SUBRCALL 141 3) + BITMAP BWBITMAP TABLE)) + (T (PROG ((SRCBIGBMLIST (|fetch| (BIGBM BIGBMLIST) |of| BITMAP)) + SRCBITMAP + (WIDTH (ADD1 MAXX)) + HEIGHT + (DESTBOTTOM (ADD1 MAXY)) + (TEMPBM (BITMAPCREATE (ADD1 MAXX) + (ADD1 MAXY) + 1))) + (SETQ SRCBITMAP (|GetNewFragment| SRCBIGBMLIST)) + (|while| SRCBITMAP |do| (SETQ DESTBOTTOM + (IDIFFERENCE DESTBOTTOM + (SETQ HEIGHT (|fetch| + (BITMAP + BITMAPHEIGHT + ) + |of| + SRCBITMAP) + ))) + ((OPCODES SUBRCALL 141 3) + SRCBITMAP TEMPBM TABLE) + (BITBLT TEMPBM 0 (IDIFFERENCE + (ADD1 MAXY) + HEIGHT) + BWBITMAP 0 DESTBOTTOM WIDTH HEIGHT + 'INPUT + 'REPLACE) + (SETQ SRCBITMAP (|GetNewFragment| + SRCBIGBMLIST)))))) + (* |for| Y |from| 0 |to| MAXY |do| + (SETQ WORD 0) (|for| X |from| 0 |to| + MAXX |do| (SETQ WORD + (LOGOR (LLSH WORD 1) + (\\GETBASE TABLE (\\GETBASEBYTE BASE + X)))) (COND ((EQ (LOGAND X 15) 15) + (\\PUTBASE BWBASE (FOLDLO X 16) WORD) + (SETQ WORD 0)))) (COND + ((NOT (EQ (LOGAND MAXX 15) 15)) + (SETQ WORD (LLSH WORD + (IDIFFERENCE 15 (LOGAND MAXX 15)))) + (\\PUTBASE BWBASE (FOLDLO MAXX 16) + WORD))) (COND ((NOT + (EQ Y MAXY)) (SETQ BASE + (\\ADDBASE BASE RASTERWIDTH)) + (SETQ BWBASE (\\ADDBASE BWBASE + BWRASTERWIDTH)))) *) + ) + NIL) + (RETURN BWBITMAP)))) +) +(DECLARE\: DONTEVAL@LOAD DOCOPY + +(MOVD '\\ORG.BITBLT 'ORG.BITBLT) + +(MOVD? 'BLTSHADE 'ORG.BLTSHADE) + +(MOVD 'BLTSHADE.BIGBM 'BLTSHADE) + +(MOVD 'BITBLT 'BKBITBLT) +) +(PUTPROPS BIGBITMAPS COPYRIGHT ("Venue" 1991 1993 1994)) +(DECLARE\: DONTCOPY + (FILEMAP (NIL (3181 47731 (BITBLT.BIGBM 3191 . 14014) (BITMAPCREATE.BIGBM 14016 . 15358) (BITMAPCREATE + 15360 . 16962) (BITMAPCOPY 16964 . 17499) (BLTSHADE.BIGBM 17501 . 20637) (BITBLT 20639 . 22287) ( +\\ORG.BITBLT 22289 . 33858) (\\BLTSHADE.DISPLAY 33860 . 43098) (\\RESHOWBORDER1 43100 . 47729)) (47732 + 63529 (\\DRAWCIRCLE.BIGBM 47742 . 51105) (\\FILLCIRCLE.BIGBM 51107 . 55153) (\\DRAWELLIPSE.BIGBM +55155 . 59675) (\\DRAWCURVE.BIGBM 59677 . 63527)) (63530 79105 (DSPCREATE 63540 . 65970) ( +DSPDESTINATION 65972 . 69870) (|\\SFFixY| 69872 . 75594) (|\\SFFixDestination| 75596 . 76779) ( +|\\SFFixClippingRegion| 76781 . 79103)) (79106 87192 (\\SW2BM 79116 . 84140) (BITMAPHEIGHT 84142 . +84640) (BITMAPWIDTH 84642 . 85134) (|\\SFFixFont| 85136 . 86108) (BITSPERPIXEL 86110 . 87190)) (87193 +105083 (COLORIZEBITMAP 87203 . 89840) (\\BWTOCOLORBLT 89842 . 98124) (UNCOLORIZEBITMAP 98126 . 105081) +)))) +STOP diff --git a/library/BINARYFILES b/library/BINARYFILES new file mode 100644 index 00000000..96667896 --- /dev/null +++ b/library/BINARYFILES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "28-Apr-2018 16:02:04"  {DSK}kaplan>Local>medley3.5>lispcore>library>BINARYFILES.;1 53324 changes to%: (FNS FILETOBYTEBLOCK) previous date%: "22-Sep-99 09:38:17" {DSK}kaplan>Local>dict>code>BINARYFILES.;1) (* ; " Copyright (c) 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1999, 2018 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT BINARYFILESCOMS) (RPAQQ BINARYFILESCOMS [ (* ;  "Generic for binary files with standard prefix") (COMS (MACROS BYTES2 BYTES3 GETBYTE PUTBYTE PUTBYTES2 PUTBYTES3) (MACROS BIN2 BIN3) (MACROS BOUT2 BOUT3 BOUT4) (MACROS TABLEBASE)) (RECORDS BYTEBLOCKHEADER STANDARDHEADER) (FNS BINARYFILETYPE BYTEBLOCK COPYBINARYFILEHEADER FILETOBYTEBLOCK WORDBLOCK SIZECOPYRIGHTANDDATESTRINGS NCOPYRIGHTSTRINGCHARS WRITECOPYRIGHTANDDATESTRINGS PUTCOPYRIGHTSTRING) (FNS COERCEUTOITIME ITOUTIME UTOITIME) (COMS (FNS BINARYFILETYPETOCODE CODETOBINARYFILETYPE) (VARS BINARYFILETYPES)) (FNS GETCOPYRIGHTSTRING) (FNS EVENBYTE EVENNUMBER QUADBYTE QUADNUMBER OPENBINARYFILESTREAM OPENDATEDSTREAM MAKE-STANDARDHEADER READBINARYFILEHEADER) (MACROS BOUTBITS BOUTBITSCONTEXT) (COMS (FNS BITBLOCK) (MACROS SETBIT GETBIT)) (COMS (* ; "For debugging") (MACROS BB.DB BBC.DB)) (COMS (* ; "For commented files") (FNS COLLAPSECOMMENTS READCOMMENTEDFILE WRITECOMMENTEDFILE WRITECOMMENTEDFILE.ADDHISTORY WRITECOMMENT) (FNS STRIPCOMMENTS) (VARS (PHONRDTBL (COPYREADTABLE FILERDTBL))) (P (SETSYNTAX (CHARCODE ;) '[MACRO (LAMBDA (FILE) (LIST COMMENTFLG (COND [(EQ (PEEKCCODE FILE) (CHARCODE ;)) (READCCODE FILE) (COND ((EQ (PEEKCCODE FILE) (CHARCODE ;)) (READCCODE FILE) ';;;) (T ';;] (T ';)) (DREADLINE FILE] PHONRDTBL]) (* ; "Generic for binary files with standard prefix") (DECLARE%: EVAL@COMPILE (PUTPROPS BYTES2 MACRO [OPENLAMBDA (BASE BYTEOFFSET EVENFLAG) (* ; "Gets a two-byte number.") (COND (EVENFLAG (* ;; "If calling form has EVENFLAG, BYTEOFFSET is asserted to be even and Lisp or other implementations that have an even 2-byte fetch (\GETBASE) can optimize optimize") (\GETBASE BASE (LRSH BYTEOFFSET 1))) (T (LOGOR (LLSH (GETBYTE BASE BYTEOFFSET) 8) (GETBYTE BASE (ADD1 BYTEOFFSET]) (PUTPROPS BYTES3 MACRO [OPENLAMBDA (BASE BYTEOFFSET) (* ; "Gets a three-byte number.") (LOGOR (LLSH (GETBYTE BASE BYTEOFFSET) 16) (LLSH (GETBYTE BASE (ADD1 BYTEOFFSET)) 8) (GETBYTE BASE (IPLUS BYTEOFFSET 2]) (PUTPROPS GETBYTE MACRO ((BASE OFFSET) (* ;  "Gets the byte stored at offset from base") (\GETBASEBYTE BASE OFFSET))) (PUTPROPS PUTBYTE MACRO (OPENLAMBDA (BASE BYTEOFFSET VALUE) (* ;  "Adjust base/offset cause \PUTBASEBYTE fails for offsets greater than 65535") (\PUTBASEBYTE (\ADDBASE BASE (LRSH BYTEOFFSET 1)) (LOGAND BYTEOFFSET 1) VALUE))) (PUTPROPS PUTBYTES2 MACRO [OPENLAMBDA (BASE BYTEOFFSET VALUE) (LET ((B (\ADDBASE BASE (LRSH BYTEOFFSET 1))) (OFF (LOGAND BYTEOFFSET 1))) (* ;  "Adjust base/offset cause \PUTBASEBYTE fails for offsets greater than 65535") (\PUTBASEBYTE B OFF (LRSH VALUE 8)) (\PUTBASEBYTE B (ADD1 OFF) (LOGAND VALUE 255]) (PUTPROPS PUTBYTES3 MACRO [OPENLAMBDA (BASE BYTEOFFSET VALUE) (LET ((B (\ADDBASE BASE (LRSH BYTEOFFSET 1))) (OFF (LOGAND BYTEOFFSET 1))) (* ;  "Adjust base/offset cause \PUTBASEBYTE fails for offsets greater than 65535") (\PUTBASEBYTE B OFF (LRSH VALUE 16)) (\PUTBASEBYTE B (ADD1 OFF) (LOGAND (LRSH VALUE 8) 255)) (\PUTBASEBYTE B (IPLUS OFF 2) (LOGAND VALUE 255]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS BIN2 MACRO (OPENLAMBDA (F) (LOGOR (LLSH (\BIN F) 8) (\BIN F)))) (PUTPROPS BIN3 MACRO (OPENLAMBDA (F) (LOGOR (LLSH (\BIN F) 16) (LLSH (\BIN F) 8) (\BIN F)))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS BOUT2 MACRO (OPENLAMBDA (F V) (BOUT F (LRSH V 8)) (BOUT F (LOGAND V 255)))) (PUTPROPS BOUT3 MACRO (OPENLAMBDA (F V) (BOUT F (LRSH V 16)) (BOUT2 F (LOGAND V 65535)))) (PUTPROPS BOUT4 MACRO (OPENLAMBDA (F V) (* ; "Store 32-bit signed integer V.") (BOUT2 F (LRSH V 16)) (BOUT2 F (LOGAND V 65535)))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS TABLEBASE MACRO ((BASE BYTELOC) (* ;  "Maps a byte location into a pointer to a table beginning at that offset from base") (\ADDBASE BASE (LRSH BYTELOC 1)))) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS BYTEBLOCKHEADER [(blockLength (LOGOR (LLSH (\GETBASEBYTE DATUM 0) 16) (LLSH (\GETBASEBYTE DATUM 1) 8) (\GETBASEBYTE DATUM 2)) (PROGN (\PUTBASEBYTE DATUM 0 (LRSH NEWVALUE 16)) (\PUTBASEBYTE DATUM 1 (LOGAND (LRSH NEWVALUE 8) 255)) (\PUTBASEBYTE DATUM 2 (LOGAND NEWVALUE 255] (SYSTEM)) (BLOCKRECORD STANDARDHEADER ((NIL 3 BYTE (* ; "Bytes 0-2: file length")) (STOREDHEADERLENGTH BYTE (* ;; "Byte 3: Header length explicitly stored in header block, as opposed to depending on constant value in code. Includes all fixed-length information for this type") ) (BINARYFILETYPE BYTE (* ;  "Byte 4: Type of this binary file, from CONSTANTPROPS") ) (VERSION BYTE (* ;  "Byte 5: Version number for this implementation") ) (COPYRIGHTLOC BYTE (* ;  "Byte 6: Location of copyright string, zero if none") ) (LANGUAGECODE BYTE (* ;  "Byte 7: Code from CONSTANTPROPS")) (UINTEGERDATE1 WORD (* ;; "Bytes 8-11: unique birthdate identifier, stored in commonlisp universal time as 32bit unsigned number") ) (UINTEGERDATE2 WORD)) (CREATE (BYTEBLOCK (FETCH (STANDARDHEADER STANDARDHEADERLENGTH) OF NIL))) [ACCESSFNS STANDARDHEADER ((STANDARDHEADERLENGTH (PROGN 12)) [UINTEGERDATE (CL:LOGIOR (CL:ASH (FETCH (STANDARDHEADER UINTEGERDATE1) OF DATUM) 16) (FETCH UINTEGERDATE2 OF DATUM)) (PROGN (REPLACE (STANDARDHEADER UINTEGERDATE1) OF DATUM WITH (CL:ASH NEWVALUE -16)) (REPLACE (STANDARDHEADER UINTEGERDATE2) OF DATUM WITH (LOGAND NEWVALUE 65535 ] (STRINGDATE (GDATE (FETCH ( STANDARDHEADER INTEGERDATE ) OF DATUM) (DATEFORMAT TIME.ZONE)) (REPLACE (STANDARDHEADER INTEGERDATE) OF DATUM WITH (IDATE NEWVALUE))) (FILELENGTH (FETCH (BYTEBLOCKHEADER blockLength) OF DATUM) (REPLACE (BYTEBLOCKHEADER blockLength) OF DATUM WITH NEWVALUE)) (BINARYFILETYPESYMBOL (CODETOBINARYFILETYPE (FETCH (STANDARDHEADER BINARYFILETYPE) OF DATUM) T)) (INTEGERDATE (COERCEUTOITIME (FETCH UINTEGERDATE OF DATUM)) (REPLACE UINTEGERDATE OF DATUM WITH (ITOUTIME NEWVALUE] (SYSTEM)) ) (DEFINEQ (BINARYFILETYPE [LAMBDA (FILE LEAVEOPEN UNKNOWNOK) (* ; "Edited 18-Jul-97 12:42 by rmk:") (* ;; "Returns the binaryfiletype symbol for FILE, causing an error if it is not of a recognized type. File is left open if LEAVEOPEN, position is set to 0. ") (RESETLST (LET [(STRM (OPENSTREAM FILE 'INPUT] [RESETSAVE NIL (IF LEAVEOPEN THEN `(SETFILEPTR ,STRM 0) ELSE `(CLOSEF? ,STRM] (CL:WHEN (IGEQ (GETEOFPTR STRM) 12) (SETFILEPTR STRM 4) (* ; "Move to the type byte") (CODETOBINARYFILETYPE (BIN STRM) UNKNOWNOK))))]) (BYTEBLOCK [LAMBDA (NBYTES) (* rmk%: "22-Dec-85 15:15") (* Returns a block of NBYTES bytes) (* Coerce from bytes to cells;  should really have FOLDHI) (\ALLOCBLOCK (LRSH (IPLUS 3 NBYTES) 2]) (COPYBINARYFILEHEADER [LAMBDA (HEADER) (* ; "Edited 3-Mar-92 11:21 by rmk:") (LET [(BLOCK (BYTEBLOCK (FETCH STOREDHEADERLENGTH OF HEADER] (\MOVEBYTES HEADER 0 BLOCK 0 (FETCH STOREDHEADERLENGTH OF HEADER)) BLOCK]) (FILETOBYTEBLOCK [LAMBDA (FILE LENGTH START) (* ; "Edited 28-Apr-2018 11:15 by rmk:") (* rmk%: "20-Dec-87 10:08") (* ;; "Returns a (system-internal) arrayblock holding the contents of FILE.") (* ;; "") (* ;; "If LENGTH is not given, it is read from first 3 bytes of the file, to avoid depending on file server capabilities. If FILE is already open, then just reads from current position. This means that byteblock files (with 3 byte length-leaders) can simply be appended together.") (* ;; "") (* ;; "If LENGTH is T, then the filelength of the file is used. Otherwise, LENGTH is the number of bytes to read.") (* ;; "") (* ;; "If START is not given, then reading begins after the 3-byte LENGTH") (RESETLST (LET (BLOCK STREAM) [IF (AND (STREAMP FILE) (SETQ STREAM (GETSTREAM FILE 'INPUT T))) THEN (SETQ START (GETFILEPTR STREAM)) ELSE (RESETSAVE [SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD '((SEQUENTIAL T) (TYPE BINARY] '(PROGN (CLOSEF? OLDVALUE] [IF (NULL LENGTH) THEN (SETQ START 3) (SETQ LENGTH (BIN3 STREAM)) ELSE (SETQ START 0) (IF (EQ LENGTH T) THEN (SETQ LENGTH (GETEOFPTR STREAM] (SETQ BLOCK (BYTEBLOCK LENGTH)) (REPLACE FILELENGTH OF BLOCK WITH LENGTH) (\BINS STREAM BLOCK START (IDIFFERENCE LENGTH 3)) BLOCK))]) (WORDBLOCK [LAMBDA (NWORDS) (* rmk%: " 9-Feb-87 18:42") (* Returns a block of NWORDS words) (* Coerce from words to cells;  should really have FOLDHI) (\ALLOCBLOCK (LRSH (ADD1 NWORDS) 1]) (SIZECOPYRIGHTANDDATESTRINGS [LAMBDA (COPYRIGHTSTRING HEADER VERSIONSTRING) (* ; "Edited 9-Jul-94 11:20 by rmk:") (* ;; "Add 1 for string length, 2->0 for CRLF before copyright string, 2 for CRLF separator before date, 2 for CRLF, 4->0 2 CRLF's before version string, and 2 for final CRLF's. Also, add 2 for every CR, LF, or CRLF in the middle of the copyright string. We don't actually know the date yet, but assume that all dates are the same size. If HEADER, then assumes it is a standard header block, that copyright is to be written by WRITECOPYRIGHTANDDATESTRINGS immediately after the header on the file. Block is marked accordingly and return is the byte location just after the copyright and date. If no HEADER, then return is simply length of copyright and date.") (LET [CLOC (LEN (IPLUS [IF (EQ COPYRIGHTSTRING 'NODATE) THEN 0 ELSE (IPLUS (IF COPYRIGHTSTRING THEN (IPLUS 1 (NCOPYRIGHTSTRINGCHARS COPYRIGHTSTRING)) ELSE 0) 2 (NCHARS (DATE (DATEFORMAT TIME.ZONE] (IF VERSIONSTRING THEN (IPLUS 4 (NCOPYRIGHTSTRINGCHARS VERSIONSTRING)) ELSE 0] (CL:UNLESS (EQ LEN 0) (* ; "Add for closing CRLF") (ADD LEN 2)) (IF HEADER THEN (SETQ CLOC (EVENNUMBER (FETCH STOREDHEADERLENGTH OF HEADER))) (IF COPYRIGHTSTRING THEN (REPLACE COPYRIGHTLOC OF HEADER WITH CLOC)) (* ;;  "Another EVENNUMBER because WRITECOPYRIGHTANDDATESTRINGS leaves file at even position ") (EVENNUMBER (IPLUS CLOC LEN)) ELSE LEN]) (NCOPYRIGHTSTRINGCHARS [LAMBDA (COPYRIGHTSTRING) (* ; "Edited 23-Apr-94 16:57 by rmk:") (* ;;  "Computes number of bytes to be occupied by copyrightstring, counting 2 for each CR, LF, or CRLF.") (FOR I (NC _ 0) FROM 1 DO (SELCHARQ (NTHCHARCODE COPYRIGHTSTRING I) (NIL (RETURN NC)) (CR (CL:WHEN (EQ (CHARCODE LF) (NTHCHARCODE COPYRIGHTSTRING (ADD1 I))) (* ;;  "Bump I to skip an actually occuring LF, since we're doing it here.") (ADD I 1)) (ADD NC 2)) (LF (ADD NC 2)) (ADD NC 1]) (WRITECOPYRIGHTANDDATESTRINGS [LAMBDA (COPYRIGHTSTRING STREAM DATE VERSIONSTRING) (* ; "Edited 9-Jul-94 11:04 by rmk:") (EVENBYTE STREAM) (CL:UNLESS (EQ COPYRIGHTSTRING 'NODATE) (IF COPYRIGHTSTRING THEN (* ;; "Copyright string assumed to be 8-bit ascii") (BOUT STREAM (IPLUS 2 (NCOPYRIGHTSTRINGCHARS COPYRIGHTSTRING))) (* ;; "Output copyright string, including length byte to facilitate future access and CRLF to make for better viewing. Convert all internal CR, LF, or CRLF to CRLF. This should provide reasonable formatting on all platforms.") (AND NIL (BOUT STREAM (CHARCODE CR)) (BOUT STREAM (CHARCODE LF))) (PUTCOPYRIGHTSTRING COPYRIGHTSTRING STREAM) (* ;;  "Put both CR and LF, since we don't know what kind of system it will be viewed on") (BOUT STREAM (CHARCODE CR)) (BOUT STREAM (CHARCODE LF))) (PRIN3 (IF (STRINGP DATE) ELSEIF (FIXP DATE) THEN (GDATE DATE (DATEFORMAT TIME.ZONE)) ELSEIF (NULL DATE) THEN (DATE (DATEFORMAT TIME.ZONE)) ELSE (* ;; "DATE is assumed to be a standard header") (FETCH STRINGDATE OF DATE)) STREAM)) (IF VERSIONSTRING THEN (BOUT STREAM (CHARCODE CR)) (* ; "2 CRLF separators") (BOUT STREAM (CHARCODE LF)) (BOUT STREAM (CHARCODE CR)) (BOUT STREAM (CHARCODE LF)) (PUTCOPYRIGHTSTRING VERSIONSTRING STREAM)) (CL:WHEN (OR (NEQ COPYRIGHTSTRING 'NODATE) VERSIONSTRING) (* ;  "Closing CRLF only if something was put out") (BOUT STREAM (CHARCODE CR)) (BOUT STREAM (CHARCODE LF))) (EVENBYTE STREAM]) (PUTCOPYRIGHTSTRING [LAMBDA (STRING STREAM) (* ; "Edited 9-Jul-94 10:57 by rmk:") (* ;; "Puts STRING on STREAM, make sure that each CR or LF sequence is expanded to a CRLF.") (FOR I C FROM 1 DO (BOUT STREAM (SELCHARQ (SETQ C (NTHCHARCODE STRING I)) (NIL (RETURN)) (CR (CL:WHEN (EQ (CHARCODE LF) (NTHCHARCODE STRING (ADD1 I))) (* ;;  "Bump I to skip an actually occuring LF, since we're doing it here.") (ADD I 1)) (BOUT STREAM (CHARCODE CR)) (CHARCODE LF)) (LF (BOUT STREAM (CHARCODE CR)) (CHARCODE LF)) C]) ) (DEFINEQ (COERCEUTOITIME [LAMBDA (UTIME?) (* ; "Edited 10-Oct-93 15:53 by rmk:") (* ;; "Returns Interlisp IDATE time corresponding to UTIME?. UTIME? might actually be in IDATE format already (backward compatibility issues), in which case nothing needs to be done.") (CL:MULTIPLE-VALUE-BIND (SECOND MINUTE HOUR DATE MONTH YEAR) (CL:DECODE-UNIVERSAL-TIME UTIME?) (CL:IF (ILESSP YEAR 1970) UTIME? (UTOITIME UTIME?))]) (ITOUTIME [LAMBDA (ITIME) (* ; "Edited 10-Oct-93 16:05 by rmk:") (* ;; "Converts Interlisp IDATE time to commonlisp universal time") (+ ITIME (CONSTANT (+ (CL:* 365 24 60 60) MAX.FIXP 1]) (UTOITIME [LAMBDA (UTIME) (* ; "Edited 10-Oct-93 16:04 by rmk:") (* ;; "Converts commonlisp universal time to Interlisp IDATE") (- UTIME (CONSTANT (+ (CL:* 365 24 60 60) MAX.FIXP 1]) ) (DEFINEQ (BINARYFILETYPETOCODE [LAMBDA (FILETYPE) (* ; "Edited 17-Jun-95 09:41 by rmk:") (SETQ FILETYPE (U-CASE FILETYPE)) (OR [CADR (FIND L IN BINARYFILETYPES SUCHTHAT (EQMEMB FILETYPE (CAR L] (HELP "UNKNOWN FILETYPE" FILETYPE]) (CODETOBINARYFILETYPE [LAMBDA (CODE UNKNOWNOK) (* ; "Edited 2-May-99 13:35 by rmk:") (* ; "Edited 17-Jun-95 09:41 by rmk:") (* ;; "Return CADDR, which means that a code can map to a different symbol-type than the symol-type will map to. E.g. 8 can map to FSMFILE, but OLDFSMFILE maps to 8 while FSMFILE maps to 19. This allows upgrading of a generic type.") (FOR L IN BINARYFILETYPES WHEN (EQ CODE (CADR L)) DO [RETURN (CL:IF (CADDR L) (CAR (MKLIST (CADDR L))) (CAR (MKLIST (CAR L))))] FINALLY (IF UNKNOWNOK THEN 'UNKNOWN ELSE (HELP "UNKNOWN BINARYFILETYPE CODE" CODE]) ) (RPAQQ BINARYFILETYPES ((FSMINDEX 1) (* ; "counting and noncounting") (SYNONYMTABLE 2) (CACHEBLOCK 3) (* ; "For number mapping") (ACCESSTABLE 4) (* ; "Linear approximation") (DEFSFILE 5) (VARIABLEWIDTHDATA 6) (* ; "Nerd data") (TRANSLATIONTABLES 7) (OLDFSMFILE 8 FSMFILE) (* ;  "Superceded by type 19, but generic code gets FSMFILE as a return.") (* ;; "Avoid 9, 10, 13 which are likely to appear in text files.") (SORTFILE 11) (CATEGORYFILE 12) (HMMFILE 14) (HMMTRAINERMODEL 15) (BITLOCATORFILE 16) (LOCTABLE 17) (VLDEFSFILE 18) (FSMFILE 19) (* ; "Supercedes type 8, 5/1/1999.") (SIMPLECOMPACTFSM 101 (* ;;  "Lauri's compaction schems. Can't really be used to discriminate text from binary file") ))) (DEFINEQ (GETCOPYRIGHTSTRING [LAMBDA (BASE OFFSET NOVALUE) (* ; "Edited 13-Oct-90 13:02 by rmk:") (* ;; "Returns copyright string stored at byte OFFSET from base, where byte at that location is the length. OFFSET=NOVALUE or 0 => no such string. Thus, NOVALUE=T if caller has already checked. If OFFSET is NIL, then the COPYRIGHTLOC of assumed STANDARDHEADER base is used") (IF [NEQ (OR NOVALUE 0) (OR OFFSET (SETQ OFFSET (FETCH (STANDARDHEADER COPYRIGHTLOC) OF BASE] THEN (LET ((LEN (GETBYTE BASE OFFSET)) (START 1)) (* ; "Skip leading CR, LF, SPACE, TAB") (FOR I FROM 1 TO LEN WHILE (SELCHARQ (GETBYTE BASE (IPLUS I OFFSET)) ((CR LF SPACE TAB) (ADD START 1)) NIL)) (FOR I (STRPOS _ 0) [STR _ (ALLOCSTRING (- LEN (- START 1] FROM START TO LEN DO (RPLCHARCODE STR (ADD STRPOS 1) (GETBYTE BASE (IPLUS I OFFSET))) FINALLY (RETURN STR]) ) (DEFINEQ (EVENBYTE [LAMBDA (STREAM) (* ; "Edited 17-Dec-89 14:51 by rmk:") (* ;  "Outputs a zero padding byte if stream is not positioned at an even byte") (OR (EVENP (GETFILEPTR STREAM)) (BOUT STREAM 0]) (EVENNUMBER [LAMBDA (N) (* ; "Edited 17-Dec-89 14:52 by rmk:") (* ; "Bumps n by one if it isn't even") (IF (EVENP N) THEN N ELSE (ADD1 N]) (QUADBYTE [LAMBDA (STREAM) (* ; "Edited 22-Sep-99 09:33 by rmk:") (* ;; "Outputs zero padding bytes to insure that stream is positioned at a 4-byte boundary") (SELECTQ (LOGAND (GETFILEPTR STREAM) 3) (3 (BOUT STREAM 0)) (2 (BOUT STREAM 0) (BOUT STREAM 0)) (1 (BOUT STREAM 0) (BOUT STREAM 0) (BOUT STREAM 0)) NIL]) (QUADNUMBER [LAMBDA (N) (* ; "Edited 22-Sep-99 09:36 by rmk:") (* ;; "Bumps N to bring it up to the next multiple of 4") (IPLUS N (SELECTQ (LOGAND N 3) (3 1) (2 2) (1 3) 0]) (OPENBINARYFILESTREAM [LAMBDA (FILENAME HEADER COPYRIGHTSTRING VERSIONSTRING)(* ; "Edited 9-Jul-94 10:44 by rmk:") (* ;; "Opens a binary stream, stores its date in the standard header HEADER, and then writes HEADER at the beginning of the stream, followed by COPYRIGHT, if given, and clear-text date (unless COPYRIGHTSTRING is NODATE), and VERSIONSTRING (if given) separated by 2 CRLF sequences. Checks for file-length consistency upon normal closing. This check is tricky because not all servers accurately maintain the length--we assume that if the file is open it is positioned at the end--and we make that be the EOF. If it has already been closed, we don't check.") (LET (STREAM) (* ;  "Don't do sequential, cause NS servers flush the file if you end up over allocation") [RESETSAVE [SETQ STREAM (OPENDATEDSTREAM FILENAME 'OUTPUT 'NEW `((TYPE BINARY) (LENGTH ,(FETCH FILELENGTH OF HEADER] `(PROGN (COND (RESETSTATE (CLOSEF? OLDVALUE) (DELFILE OLDVALUE)) ((GETSTREAM OLDVALUE 'OUTPUT T) (LET ((LEN (GETFILEPTR OLDVALUE))) (CLOSEF OLDVALUE) (COND ((IEQP LEN ,(FETCH FILELENGTH OF HEADER)) (SETFILEINFO (FULLNAME OLDVALUE) 'LENGTH LEN)) (T (HELP "BINARYFILE LENGTH MISMATCH" (LIST (FULLNAME OLDVALUE) ,(FETCH FILELENGTH OF HEADER) LEN] (REPLACE INTEGERDATE OF HEADER WITH (GETFILEINFO STREAM 'ICREATIONDATE)) (PRINTOUT T "Output file = " (FULLNAME STREAM) (CONCAT " [" (FETCH STRINGDATE OF HEADER) "]") T 3 "Length = " (FETCH FILELENGTH OF HEADER) " bytes" T) (\BOUTS STREAM HEADER 0 (FETCH STOREDHEADERLENGTH OF HEADER)) (WRITECOPYRIGHTANDDATESTRINGS COPYRIGHTSTRING STREAM HEADER VERSIONSTRING) STREAM]) (OPENDATEDSTREAM [LAMBDA (FILE ACCESS RECOG PARAMETERS) (* ; "Edited 15-Apr-89 21:12 by rmk:") (* ;  "Version of OPENSTREAM that tries to guarantee a meaningful creationdate") (LET ((STREAM (OPENSTREAM FILE ACCESS RECOG PARAMETERS))) (if (NULL (GETFILEINFO STREAM 'ICREATIONDATE)) then (SETQ STREAM (OPENSTREAM (CLOSEF STREAM) ACCESS 'OLD PARAMETERS)) (OR (GETFILEINFO STREAM 'ICREATIONDATE) (HELP "COULDN'T OPEN DATED STREAM" STREAM))) STREAM]) (MAKE-STANDARDHEADER [LAMBDA (HEADERLENGTH TYPE VERSION FILELENGTH IDATE BLOCK LANGUAGE) (* ; "Edited 18-Nov-93 18:21 by rmk:") (CL:UNLESS BLOCK (SETQ BLOCK (BYTEBLOCK (MAX 12 HEADERLENGTH)))) (CL:WHEN FILELENGTH (REPLACE FILELENGTH OF BLOCK WITH FILELENGTH)) (REPLACE STOREDHEADERLENGTH OF BLOCK WITH HEADERLENGTH) (CL:WHEN TYPE (REPLACE BINARYFILETYPE OF BLOCK WITH (BINARYFILETYPETOCODE TYPE))) (CL:WHEN VERSION (REPLACE (STANDARDHEADER VERSION) OF BLOCK WITH VERSION)) (CL:WHEN LANGUAGE [REPLACE LANGUAGECODE OF BLOCK WITH (CAR (MKLIST (LANGUAGECODE LANGUAGE]) (REPLACE INTEGERDATE OF BLOCK WITH (OR IDATE (IDATE))) BLOCK]) (READBINARYFILEHEADER [LAMBDA (FILE TYPE VERSIONS LEAVEOPEN WHOLEFILE MINHEADERLENGTH) (* ; "Edited 6-Dec-97 12:28 by rmk:") (* ;; "Returns a (system-internal) arrayblock holding the header at the beginning of FILE, provided that it is of type TYPE and has one of the allowable VERSIONS. Length is read from first 3 bytes of the file, to avoid depending on file server capabilities. The header length is the next byte after this. If FILE is already open, then just reads from current position. If file is opened, it is left open if LEAVEOPEN. Returns 2 values--header block plus stream or closed filename. If WHOLEFILE, returns a single block containing the whole file. IF MINHEADERLENGTH is given, then block returned will be maximum of its stored length and MINHEADERLENGTH. This allows for future upgrades.") (LET (FILELENGTH BLOCK HEADERLENGTH STREAM) [IF [AND (STREAMP FILE) (SETQ STREAM (GETSTREAM FILE 'INPUT] THEN (SETQ LEAVEOPEN T) ELSE [SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD `((TYPE BINARY) (SEQUENTIAL ,WHOLEFILE] (CL:UNLESS LEAVEOPEN [RESETSAVE NIL `(CLOSEF? ,STREAM])] (SETQ FILELENGTH (BIN3 STREAM)) (SETQ HEADERLENGTH (BIN STREAM)) (CL:WHEN MINHEADERLENGTH (SETQ HEADERLENGTH (MAX HEADERLENGTH MINHEADERLENGTH))) [SETQ BLOCK (MAKE-STANDARDHEADER HEADERLENGTH NIL NIL FILELENGTH NIL (CL:WHEN WHOLEFILE (BYTEBLOCK FILELENGTH] (\BINS STREAM BLOCK 4 (- (CL:IF WHOLEFILE FILELENGTH HEADERLENGTH) 4)) (CL:UNLESS (OR (NULL TYPE) (EQ (FETCH BINARYFILETYPE OF BLOCK) (BINARYFILETYPETOCODE TYPE))) (ERROR "Incorrect binary file type" (LIST TYPE (CODETOBINARYFILETYPE (FETCH BINARYFILETYPE OF BLOCK) T)))) (CL:UNLESS (OR (NULL VERSIONS) (EQMEMB (FETCH VERSION OF BLOCK) VERSIONS)) (ERROR (CONCAT "Unacceptable " TYPE " version") (FETCH VERSION OF BLOCK))) (CL:VALUES BLOCK (IF LEAVEOPEN THEN STREAM ELSE (CLOSEF STREAM]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS BOUTBITS MACRO (OPENLAMBDA (STREAM BITS NBITS) (BIND (BITSREMAINING _ BITS) (NBITSREMAINING _ NBITS) DO (COND ((IGREATERP NEMPTYBITSINBYTE NBITSREMAINING) (* ; "BITSREMAINING is less than 256") (SETQ NEMPTYBITSINBYTE (IDIFFERENCE NEMPTYBITSINBYTE NBITSREMAINING)) (SETQ BITSINBYTE (CL:LOGIOR BITSINBYTE (CL:ASH BITSREMAINING NEMPTYBITSINBYTE))) (RETURN))) (* ; "BITSREMAINING may be a bignum") [BOUT STREAM (CL:LOGIOR BITSINBYTE (CL:ASH BITSREMAINING (IMINUS (SETQ NBITSREMAINING (IDIFFERENCE NBITSREMAINING NEMPTYBITSINBYTE ] (SETQ BITSREMAINING (LOGAND BITSREMAINING (- (CL:ASH 1 NBITSREMAINING) 1))) (SETQ BITSINBYTE 0) (SETQ NEMPTYBITSINBYTE 8)) BITS)) (PUTPROPS BOUTBITSCONTEXT MACRO ((STREAM . FORMS) (* ;  "Open STREAM needed so can cleanup the last byte") (LET ((NEMPTYBITSINBYTE 8) (BITSINBYTE 0)) (DECLARE (SPECVARS NEMPTYBITSINBYTE BITSINBYTE)) (PROGN . FORMS) (OR (EQ NEMPTYBITSINBYTE 8) (BOUT STREAM BITSINBYTE)) STREAM))) ) (DEFINEQ (BITBLOCK [LAMBDA (NBITS) (* rmk%: "22-Dec-85 15:19") (* Returns a block of NBITS bytes) (* Coerce from bits to cells;  should really have FOLDHI) (\ALLOCBLOCK (LRSH (IPLUS 31 NBITS) 5]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS SETBIT MACRO [OPENLAMBDA (BASE BITNUM VALUE) (\PUTBASEBYTE BASE (LRSH BITNUM 3) (IF (EQ VALUE 1) THEN (LOGOR (LLSH 1 (IDIFFERENCE 7 (LOGAND BITNUM 7))) (\GETBASEBYTE BASE (LRSH BITNUM 3))) ELSE (LOGAND [LOGXOR 255 (LLSH 1 (IDIFFERENCE 7 (LOGAND BITNUM 7] (\GETBASEBYTE BASE (LRSH BITNUM 3]) (PUTPROPS GETBIT MACRO [OPENLAMBDA (BASE BITNUM) (LOGAND 1 (LRSH (\GETBASEBYTE BASE (LRSH BITNUM 3)) (IDIFFERENCE 7 (LOGAND BITNUM 7]) ) (* ; "For debugging") (DECLARE%: EVAL@COMPILE (PUTPROPS BB.DB MACRO (OPENLAMBDA (STREAM BITS NBITS) (bind (BITSREMAINING _ BITS) (NBITSREMAINING _ NBITS) do (COND ((IGREATERP NEMPTYBITSINBYTE NBITSREMAINING) (SETQ NEMPTYBITSINBYTE (IDIFFERENCE NEMPTYBITSINBYTE NBITSREMAINING)) (SETQ BITSINBYTE (LOGOR BITSINBYTE (LLSH BITSREMAINING NEMPTYBITSINBYTE ))) (RETURN))) (printout STREAM .I8.2.T [LOGOR BITSINBYTE (LRSH BITSREMAINING (SETQ NBITSREMAINING (IDIFFERENCE NBITSREMAINING NEMPTYBITSINBYTE ] T) [SETQ BITSREMAINING (LOGAND BITSREMAINING (SUB1 (LLSH 1 NBITSREMAINING] (SETQ BITSINBYTE 0) (SETQ NEMPTYBITSINBYTE 8)) BITS)) (PUTPROPS BBC.DB MACRO ((STREAM . FORMS) (* Open STREAM needed so can cleanup  the last byte) (LET ((NEMPTYBITSINBYTE 8) (BITSINBYTE 0)) (DECLARE (SPECVARS NEMPTYBITSINBYTE BITSINBYTE)) (PROGN . FORMS) (OR (EQ NEMPTYBITSINBYTE 8) (printout STREAM .I8.2.T BITSINBYTE T)) STREAM))) ) (* ; "For commented files") (DEFINEQ (COLLAPSECOMMENTS [LAMBDA (L) (* ; "Edited 6-Oct-92 16:29 by rmk:") (* ;  "Collapses adjacent semi-coloned comments together") [IF (LISTP L) THEN (BIND (TAIL _ L) WHILE TAIL DO (IF (NLISTP TAIL) THEN (RETURN) ELSEIF [AND (EQ COMMENTFLG (CAR (CAR TAIL))) (EQ COMMENTFLG (CAR (CADR TAIL))) (MEMB (CADR (CAR TAIL)) '(; ;; ;;;)) (EQ (CADR (CAR TAIL)) (CADR (CADR TAIL))) (STRINGP (CADDR (CAR TAIL))) (STRINGP (CADDR (CADR TAIL] THEN [RPLACA (CDDR (CAR TAIL)) (CONCAT (CADDR (CAR TAIL)) " " (CADDR (CADR TAIL] (RPLACD TAIL (CDDR TAIL)) ELSE (COLLAPSECOMMENTS (CAR TAIL)) (POP TAIL] L]) (READCOMMENTEDFILE [LAMBDA (FILE MSG) (* ; "Edited 27-Sep-92 14:33 by rmk:") (LET ((FILENAME (INFILEP FILE)) DATE) (OR FILENAME (ERROR "CAN'T FIND" FILE)) (SETQ DATE (GETFILEINFO FILENAME 'CREATIONDATE)) (IF MSG THEN (PRINTOUT T MSG " from " FILENAME (CONCAT " [" DATE "]") T)) (CL:VALUES (COLLAPSECOMMENTS (RESETLST (READFILE (LET (STRM TSTRM) [RESETSAVE (SETQ STRM (OPENSTREAM FILENAME 'INPUT)) '(PROGN (CLOSEF? OLDVALUE] (SETQ TSTRM (OPENTEXTSTREAM STRM)) (CL:IF (TEDIT.FORMATTEDFILEP TSTRM) TSTRM (CLOSEF STRM))) PHONRDTBL))) DATE FILENAME]) (WRITECOMMENTEDFILE [LAMBDA (EXPR FILE HISTORYFLAG) (* ; "Edited 2-Nov-92 09:20 by rmk:") (* ;; "Writes EXPR (or value of atomic EXPR) on file, not enclosed in parens, with comments indicated by semi-coloned strings for ordinary text editting. File should be read with READCOMMENTEDFILE.") (* ;; "If HISTORYFLAG, wites out a (modified) HISTORY property to include the filename, date, and username of this writing. If history begins with a comment, that comment will be embedded in the new written history entry. Does not modify the in-memory EXPR, since future writings of subsequent changes shouldn't reflect intermediate edits. History stuff is inside this function because the filename and creationdate are not known on the outside. If FILE is an open stream, then EXPR is written to it and it is left open.") (RESETLST (LET* (STREAM LEAVEOPEN (LISTEXPR (OR (LISTP EXPR) (AND (LITATOM EXPR) (LISTP (EVALV EXPR))) EXPR))) [IF (AND (STREAMP FILE) (OPENP FILE 'OUTPUT)) THEN (SETQ STREAM FILE) (SETQ LEAVEOPEN T) ELSE (RESETSAVE (SETQ STREAM (OPENDATEDSTREAM FILE 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE) (AND RESETSTATE (DELFILE OLDVALUE] (IF HISTORYFLAG THEN (SETQ LISTEXPR (WRITECOMMENTEDFILE.ADDHISTORY LISTEXPR STREAM))) (RESETSAVE (SETREADTABLE PHONRDTBL)) (RESETSAVE PRETTYPRINTMACROS (CONS ' (* . WRITECOMMENT) PRETTYPRINTMACROS)) (RESETSAVE COMMENTFLG NIL) (PRINTOUT STREAM .PPVTL LISTEXPR T) (CL:WHEN (AND (LITATOM EXPR) (LISTP (EVALV EXPR))) (UNMARKASCHANGED EXPR 'VARS)) (IF LEAVEOPEN THEN STREAM ELSE (CLOSEF STREAM))))]) (WRITECOMMENTEDFILE.ADDHISTORY [LAMBDA (EXPR STREAM) (* ; "Edited 27-May-90 12:58 by rmk:") (IF (LISTP (CAR (LISTP EXPR))) THEN (LET* [(OLDHIST (ASSOC 'HISTORY EXPR)) (NEWHIST (IF OLDHIST THEN (APPEND OLDHIST) ELSE (LIST 'HISTORY] [IF (AND OLDHIST (EQ (CAR (LISTP (CADR OLDHIST))) COMMENTFLG)) THEN (RPLACA (CDR NEWHIST) (LIST (FULLNAME STREAM) (GETFILEINFO STREAM 'CREATIONDATE) (USERNAME NIL T) (CADR NEWHIST))) ELSE (PUSH (CDR NEWHIST) (LIST (FULLNAME STREAM) (GETFILEINFO STREAM 'CREATIONDATE) (USERNAME NIL T] (IF OLDHIST THEN (SUBST NEWHIST OLDHIST EXPR) ELSE (CONS NEWHIST EXPR))) ELSE EXPR]) (WRITECOMMENT [LAMBDA (FORM STREAM) (* ; "Edited 10-May-89 10:06 by rmk:") (* ;  " Prints comments between columns 30 and 80") (bind W NEXTSPACEPOS (LEFTCOL _ 30) (RIGHTCOL _ 80) (COMMSTRING _ (CADDR FORM)) (LASTSPACEPOS _ 0) (MARK _ (CADR FORM)) first (PRINTOUT STREAM .TAB LEFTCOL MARK " ") do (SETQ NEXTSPACEPOS (STRPOS " " COMMSTRING (ADD1 LASTSPACEPOS))) (if (IGREATERP (IPLUS (POSITION STREAM) (IDIFFERENCE (OR NEXTSPACEPOS (ADD1 (NCHARS COMMSTRING))) LASTSPACEPOS)) RIGHTCOL) then (PRINTOUT STREAM .TAB LEFTCOL MARK " ")) [PRINTOUT STREAM (SUBSTRING COMMSTRING (ADD1 LASTSPACEPOS) NEXTSPACEPOS (CONSTANT (CONCAT] (if NEXTSPACEPOS then (SETQ LASTSPACEPOS NEXTSPACEPOS) else (TERPRI STREAM) (RETURN]) ) (DEFINEQ (STRIPCOMMENTS [LAMBDA (L) (* ; "Edited 31-Mar-90 17:22 by rmk:") (* ;  "Returns a copy of L with recognized comments removed") (IF (NLISTP L) THEN L ELSEIF (AND (EQ (CAAR L) COMMENTFLG) (MEMB (CADAR L) '(; ;; ;;;)) (STRINGP (CADDAR L))) THEN (STRIPCOMMENTS (CDR L)) ELSE (CONS (STRIPCOMMENTS (CAR L)) (STRIPCOMMENTS (CDR L]) ) (RPAQ PHONRDTBL (COPYREADTABLE FILERDTBL)) (SETSYNTAX (CHARCODE ;) '[MACRO (LAMBDA (FILE) (LIST COMMENTFLG (COND [(EQ (PEEKCCODE FILE) (CHARCODE ;)) (READCCODE FILE) (COND ((EQ (PEEKCCODE FILE) (CHARCODE ;)) (READCCODE FILE) ';;;) (T ';;] (T ';)) (DREADLINE FILE] PHONRDTBL) (PUTPROPS BINARYFILES COPYRIGHT ("Xerox Corporation" 1989 1990 1991 1992 1993 1994 1995 1997 1999 2018 )) (DECLARE%: DONTCOPY (FILEMAP (NIL (13332 23812 (BINARYFILETYPE 13342 . 14126) (BYTEBLOCK 14128 . 14589) ( COPYBINARYFILEHEADER 14591 . 14898) (FILETOBYTEBLOCK 14900 . 16702) (WORDBLOCK 16704 . 17162) ( SIZECOPYRIGHTANDDATESTRINGS 17164 . 19300) (NCOPYRIGHTSTRINGCHARS 19302 . 20396) ( WRITECOPYRIGHTANDDATESTRINGS 20398 . 22532) (PUTCOPYRIGHTSTRING 22534 . 23810)) (23813 24912 ( COERCEUTOITIME 23823 . 24351) (ITOUTIME 24353 . 24633) (UTOITIME 24635 . 24910)) (24913 26296 ( BINARYFILETYPETOCODE 24923 . 25221) (CODETOBINARYFILETYPE 25223 . 26294)) (27624 29089 ( GETCOPYRIGHTSTRING 27634 . 29087)) (29090 37741 (EVENBYTE 29100 . 29454) (EVENNUMBER 29456 . 29746) ( QUADBYTE 29748 . 30211) (QUADNUMBER 30213 . 30525) (OPENBINARYFILESTREAM 30527 . 33006) ( OPENDATEDSTREAM 33008 . 33747) (MAKE-STANDARDHEADER 33749 . 34595) (READBINARYFILEHEADER 34597 . 37739 )) (40292 40762 (BITBLOCK 40302 . 40760)) (44069 51764 (COLLAPSECOMMENTS 44079 . 45590) ( READCOMMENTEDFILE 45592 . 46940) (WRITECOMMENTEDFILE 46942 . 49164) (WRITECOMMENTEDFILE.ADDHISTORY 49166 . 50501) (WRITECOMMENT 50503 . 51762)) (51765 52456 (STRIPCOMMENTS 51775 . 52454))))) STOP \ No newline at end of file diff --git a/library/BROWSER b/library/BROWSER new file mode 100644 index 00000000..c941717d --- /dev/null +++ b/library/BROWSER @@ -0,0 +1,491 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "25-Mar-94 13:43:20" |{PELE:MV:ENVOS}LIBRARY>BROWSER.;4| 26296 + + changes to%: (FNS BROWSER.MIDDLEFN) + + previous date%: "20-Jan-93 16:00:51" |{PELE:MV:ENVOS}LIBRARY>BROWSER.;3|) + + +(* ; " +Copyright (c) 1983, 1984, 1987, 1988, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT BROWSERCOMS) + +(RPAQQ BROWSERCOMS + [(FILES MASTERSCOPE GRAPHER) + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) + GRAPHER) + (CONSTANTS (CHANGEDSHADE 8840))) + (FNS NUMSPATHS BROWSER BROWSER.WHENFNSCHANGED BRPATHS1 BROWSER.LEFTFN GET.BROWSE.PP.WINDOW + GET.BROWSE.DESCRIBE.WINDOW BROWSEPP PPREPAINTFN PPRESHAPEFN DESCRIBEREPAINTFN + BROWSERDESCRIBE BROWSER.MIDDLEFN DEDITPROCESSRUNNINGP REDRAWBROWSEGRAPH STBROWSER) + (GLOBALRESOURCES BROWSEHASH) + (DECLARE%: DONTCOPY (RECORDS BROWSEWIN PATHSARGS)) + [VARS (BROWSERBOXING) + (BROWSERFORMAT) + (BROWSERWINDOWS) + (NODESELECTIONWINDOW) + (PFWINDOW) + (BROWSER.DESCRIBE.WINDOW) + (BrowserPPWindowWidth 750) + (BROWSERFONT '(GACHA 8] + [P (MOVD? 'MSPATHS 'OLDMSPATHS) + (PROG [(WC (FILEPKGTYPE 'FNS 'WHENCHANGED] + (OR (MEMB 'BROWSER.WHENFNSCHANGED WC) + (FILEPKGTYPE 'FNS 'WHENCHANGED (CONS 'BROWSER.WHENFNSCHANGED WC] + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (SELECTQ (SYSTEMTYPE) + (D (BROWSER T)) + NIL]) + +(FILESLOAD MASTERSCOPE GRAPHER) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (LOADCOMP) + GRAPHER) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ CHANGEDSHADE 8840) + + +(CONSTANTS (CHANGEDSHADE 8840)) +) +) +(DEFINEQ + +(NUMSPATHS + [LAMBDA (FROM TO INVERTED AVOIDING SEPARATE NOTRACE MARKING) + (* ; "Edited 11-Apr-88 11:08 by jrb:") + (COND + [(AND (WINDOWWORLD) + (EQ (OUTPUT) + T)) + [OR AVOIDING (SETQ AVOIDING '(NIL (NIL NIL . FNS) + APPLY LAMBDA (X) + (GETPROP X 'AVOID] + (RESETVARS ((MSPRINTFLG)) + (AND INVERTED (UPDATECHANGED)) + (STBROWSER + [GLOBALRESOURCE + BROWSEHASH + (PROG [X NAMED TEM (UNDONE (MSLISTSET FROM T)) + ROOTS GRAPHNODE.LIST (SEEN BROWSEHASH) + (CALLRELATION (PARSERELATION 'CALL] + (DECLARE (SPECVARS SEEN UNDONE)) + (CLRHASH SEEN) + (for X in UNDONE do (PUTHASH X (COND + ((AND NOTRACE + (MSMEMBSET X NOTRACE)) + -1) + (T 0)) + SEEN) + (OR INVERTED (UPDATEFN X NIL 0))) + [do (COND + (NAMED (PUTHASH (CAR NAMED) + 0 SEEN) + [push ROOTS (fetch (GRAPHNODE NODEID) + of (BRPATHS1 (CAR NAMED] + (SETQ NAMED (CDR NAMED))) + (UNDONE [COND + ([OR (NULL (SETQ TEM (GETHASH (CAR UNDONE) + SEEN))) + (EQ TEM 0) + (AND (LISTP TEM) + (NULL (CAR TEM] + (PUTHASH (CAR UNDONE) + (LIST NIL) + SEEN) + (SETQ NAMED (LIST (CAR UNDONE] + (SETQ UNDONE (CDR UNDONE))) + (T (RETURN] + (RETURN (LAYOUTFOREST GRAPHNODE.LIST ROOTS BROWSERFORMAT BROWSERBOXING] + (PROG1 (LIST FROM TO INVERTED AVOIDING SEPARATE NOTRACE) + (* ; + "this LIST is actually an 'instance' of PATHSARGS") + ] + (T (OLDMSPATHS FROM TO INVERTED AVOIDING SEPARATE NOTRACE MARKING]) + +(BROWSER + [LAMBDA (DISPLAYFLG) (* rmk%: "16-Dec-83 15:39") + (COND + (DISPLAYFLG (SETQ BROWSERFONT (FONTCREATE BROWSERFONT)) + (MOVD 'NUMSPATHS 'MSPATHS)) + (T (MOVD 'OLDMSPATHS 'MSPATHS]) + +(BROWSER.WHENFNSCHANGED + [LAMBDA (FNNAME TYPE REASON) (* DECLARATIONS%: (RECORDS BROWSEWIN)) + (* ; "Edited 31-Mar-87 11:22 by jop") + + (* ;; "called by system when FNNAME has changed If FNNAME is in a browser window, it reprints and redescribes it.") + + (COND + ((AND (ACTIVEWP PFWINDOW) + (EQ (WINDOWPROP PFWINDOW 'FNBROWSED) + FNNAME)) + (BROWSEPP FNNAME PFWINDOW))) + (COND + ((AND (ACTIVEWP BROWSER.DESCRIBE.WINDOW) + (EQ (WINDOWPROP BROWSER.DESCRIBE.WINDOW 'FNBROWSED) + FNNAME)) + (BROWSERDESCRIBE FNNAME BROWSER.DESCRIBE.WINDOW))) + (for X in BROWSERWINDOWS do (COND + ((find GRAPHNODE + in (fetch (GRAPH GRAPHNODES) + of (fetch (BROWSEWIN GRAPH) + of X)) + suchthat (EQ (fetch (GRAPHNODE NODELABEL) + of GRAPHNODE) + FNNAME)) + (COND + ((fetch (BROWSEWIN GRAPH) of X) + (DSPFILL NIL CHANGEDSHADE 'PAINT + (fetch (BROWSEWIN WINDOW) of + X)) + (WINDOWPROP (fetch (BROWSEWIN WINDOW) + of X) + 'BUTTONEVENTFN + (FUNCTION REDRAWBROWSEGRAPH)) + (replace (BROWSEWIN GRAPH) of X + with NIL]) + +(BRPATHS1 + [LAMBDA (FROM) (* ; "Edited 11-Apr-88 11:27 by jrb:") + (DECLARE (GLOBALVARS BROWSERFONT)) + (PROG (TEM) + (MSPATHS2 FROM) + (COND + ((EQ (SETQ TEM (GETHASH FROM SEEN)) + -1) (* ; + "on NOPATHS list - create a node for it with no subs") + (SETQ TEM (create GRAPHNODE + NODEID _ FROM + NODELABEL _ FROM + NODEFONT _ BROWSERFONT + TONODES _ NIL)) + (push GRAPHNODE.LIST TEM) + (PUTHASH FROM TEM SEEN) + (RETURN TEM)) + ((NEQ TEM 0) (* ; "already expanded into a list") + (RETURN TEM)) + (T (RETURN (PROG ((ENTRY (create GRAPHNODE + NODEID _ FROM + NODELABEL _ FROM + NODEFONT _ BROWSERFONT))) + (push GRAPHNODE.LIST ENTRY) + (PUTHASH FROM ENTRY SEEN) + (replace (GRAPHNODE TONODES) of ENTRY + with (for X + in (for Y + in (COND + ((NOT INVERTED) + (GETRELATION FROM CALLRELATION)) + (T (GETRELATION FROM CALLRELATION T) + )) when (MSPATHS2 Y) + collect Y) when (SETQ X (BRPATHS1 + X)) + collect (fetch (GRAPHNODE NODEID) of X))) + (RETURN ENTRY]) + +(BROWSER.LEFTFN + [LAMBDA (NODE NWINDOW) (* ; "Edited 31-Mar-87 11:16 by jop") + (* ; + "function that is applied upon selection of a node.") + (COND + ((NULL NODE)) + ((EQ (fetch NODELABEL of NODE) + (WINDOWPROP (GET.BROWSE.PP.WINDOW) + 'FNBROWSED)) + (BROWSERDESCRIBE (fetch NODELABEL of NODE) + (GET.BROWSE.DESCRIBE.WINDOW))) + (T (* ; + "if first time touched, pretty print it.") + (BROWSEPP (fetch NODELABEL of NODE) + (GET.BROWSE.PP.WINDOW]) + +(GET.BROWSE.PP.WINDOW + [LAMBDA NIL (* ; "Edited 31-Mar-87 11:23 by jop") + (* ; + "returns the window for pretty printing from the browser.") + (COND + ((WINDOWP PFWINDOW) + PFWINDOW) + (T (SETQ PFWINDOW (CREATEW NIL "Browser print out window")) + (WINDOWPROP PFWINDOW 'REPAINTFN 'PPREPAINTFN) + (WINDOWPROP PFWINDOW 'REPAINTFN 'PPREPAINTFN) + (WINDOWPROP PFWINDOW 'RESHAPEFN 'PPRESHAPEFN) + (WINDOWPROP PFWINDOW 'SCROLLFN 'SCROLLBYREPAINTFN) + PFWINDOW]) + +(GET.BROWSE.DESCRIBE.WINDOW + [LAMBDA NIL (* ; "Edited 31-Mar-87 11:23 by jop") + (* ; + "returns the window for describe action from the browser.") + (COND + ((WINDOWP BROWSER.DESCRIBE.WINDOW) + BROWSER.DESCRIBE.WINDOW) + (T (SETQ BROWSER.DESCRIBE.WINDOW (CREATEW NIL "Browser describe window")) + (WINDOWPROP BROWSER.DESCRIBE.WINDOW 'REPAINTFN 'DESCRIBEREPAINTFN) + (WINDOWPROP BROWSER.DESCRIBE.WINDOW 'RESHAPEFN 'DESCRIBEREPAINTFN) + (WINDOWPROP BROWSER.DESCRIBE.WINDOW 'SCROLLFN 'SCROLLBYREPAINTFN) + BROWSER.DESCRIBE.WINDOW]) + +(BROWSEPP + [LAMBDA (FN WINDOW) (* ; "Edited 31-Mar-87 11:16 by jop") + (DECLARE (GLOBALVARS BrowserPPWindowWidth)) + (PROG (WIDTH BOTTOM) + (WINDOWPROP WINDOW 'FNBROWSED FN) + (CLEARW WINDOW) + (MOVETOUPPERLEFT WINDOW) + (WINDOWPROP WINDOW 'EXTENT NIL) + (SETQ WIDTH (PPREPAINTFN WINDOW)) (* ; "set the extent of the window.") + (WINDOWPROP WINDOW 'EXTENT (create REGION + LEFT _ 0 + BOTTOM _ (SETQ BOTTOM (DSPYPOSITION NIL WINDOW)) + WIDTH _ WIDTH + HEIGHT _ (IDIFFERENCE (WINDOWPROP WINDOW 'HEIGHT) + BOTTOM]) + +(PPREPAINTFN + [LAMBDA (WINDOW REGION RESHAPE) (* ; "Edited 11-Jun-90 14:11 by mitani") + + (* ;; "repaints the browser pp window WINDOW. Returns the width of the image so that caller can set the EXTENT.") + + (PROG ((FN (WINDOWPROP WINDOW 'FNBROWSED)) + (EXTENT (WINDOWPROP WINDOW 'EXTENT)) + DEF FNTYPE) + (RETURN (COND + (FN (printout WINDOW .FONT LAMBDAFONT) + (MOVETOUPPERLEFT WINDOW EXTENT) + (printout WINDOW .FONT DEFAULTFONT) + (COND + ((for FPTYPE in MSFNTYPES + when (SETQ DEF (GETDEF FN (ffetch (MSANALYZABLE FILEPKGNAME) + of FPTYPE) + NIL + 'NOERROR)) + do (SETQ FNTYPE (ffetch (MSANALYZABLE FILEPKGNAME) + of FPTYPE)) + (RETURN DEF) finally NIL) + (* ; + "set up linelength characteristics.") + (RESETLST + (RESETSAVE (OUTPUT WINDOW)) + (RESETSAVE (SETREADTABLE T)) + (RESETSAVE **COMMENT**FLG) + (if (EQ FNTYPE 'FNS) + then (printout WINDOW "(" .FONT LAMBDAFONT |.P2| FN .FONT + DEFAULTFONT T)) + (DSPRIGHTMARGIN (fetch (REGION RIGHT) of (DSPCLIPPINGREGION + NIL WINDOW)) + WINDOW) + (PRINTDEF DEF (AND (EQ FNTYPE 'FNS) + 2) + 'FNS) + (if (EQ FNTYPE 'FNS) + then (PRIN1 ")" WINDOW))) + (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL WINDOW))) + (T (* ; + "set right margin out so wouldn't clip.") + (DSPRIGHTMARGIN 5000 WINDOW) + (APPLY* (FUNCTION PF*) + FN NIL (GETSTREAM WINDOW)) + (DSPRIGHTMARGIN (fetch (REGION RIGHT) of (DSPCLIPPINGREGION + NIL WINDOW)) + WINDOW) + BrowserPPWindowWidth))) + (T 0]) + +(PPRESHAPEFN + [LAMBDA (WINDOW) (* lmm "20-Jul-84 15:48") + (BROWSEPP (WINDOWPROP WINDOW 'FNBROWSED) + WINDOW]) + +(DESCRIBEREPAINTFN + [LAMBDA (WIN REG) (* ; "Edited 31-Mar-87 11:24 by jop") + (* ; + "reprints the contents of a describe window.") + (PROG [(FN (WINDOWPROP WIN 'FNBROWSED)) + (EXTENT (WINDOWPROP WIN 'EXTENT] + (COND + (FN (RESETLST (RESETSAVE MSPRINTFLG NIL) + (RESETSAVE (OUTPUT WIN)) + (DSPSCROLL 'OFF WIN) + (COND + (EXTENT (MOVETOUPPERLEFT WIN EXTENT))) + (MSDESCRIBE FN]) + +(BROWSERDESCRIBE + [LAMBDA (FN WIN) (* ; "Edited 31-Mar-87 11:15 by jop") + + (* ;; "puts the masterscope DESCRIBE information in the window DS. Keeps tracks of which fn so if it changes the window can be updated.") + + (WINDOWPROP WIN 'FNBROWSED FN) + (CLEARW WIN) + (DESCRIBEREPAINTFN WIN) + (WINDOWPROP WIN 'EXTENT (create REGION + LEFT _ 0 + BOTTOM _ (DSPYPOSITION NIL WIN) + WIDTH _ (WINDOWPROP WIN 'WIDTH) + HEIGHT _ (IDIFFERENCE (WINDOWPROP WIN 'HEIGHT) + (DSPYPOSITION NIL WIN]) + +(BROWSER.MIDDLEFN + [LAMBDA (NODE NWINDOW) (* ; "Edited 25-Mar-94 13:25 by jds") + (* ; + "called when yellow selection from browser. Call display editor on the function.") + (COND + ((NULL NODE)) + [(THIS.PROCESS) (* ; "processes are running.") + (SELECTQ (EDITMODE) + (DEDIT [COND + ((DEDITPROCESSRUNNINGP) + (printout PROMPTWINDOW T T "Dedit can't run in two processes at once, yet." T + "You can call Dedit in the same process by typing " + (fetch NODELABEL of NODE) + " " "into the Dedit " "window then selecting 'Edit'.")) + (T (ADD.PROCESS `(ED ',(fetch NODELABEL of NODE]) + ((SEDIT SEDIT:SEDIT) (* ; + "SEdit doesn't have to worry about this stuff") + (ED (fetch NODELABEL of NODE) + ':DONTWAIT)) + (ED (fetch NODELABEL of NODE] + (T (ED (fetch NODELABEL of NODE]) + +(DEDITPROCESSRUNNINGP + [LAMBDA NIL (* ; "Edited 31-Mar-87 11:27 by jop") + + (* ;; "is there a dedit process running?") + + (AND (EQ (EDITMODE) + 'DEDIT) + \DEDITWINDOWS]) + +(REDRAWBROWSEGRAPH + [LAMBDA (WINDOW) (* DECLARATIONS%: (RECORDS BROWSEWIN)) + (* ; "Edited 31-Mar-87 11:24 by jop") + (PROG [(WN (find X in BROWSERWINDOWS suchthat (EQ (fetch (BROWSEWIN WINDOW) + of X) + WINDOW] + (AND WN (APPLY 'NUMSPATHS (fetch (BROWSEWIN ARGS) of WN))) + (* ; "(OR WN (SHOULDNT))") + (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION APPLYTOSELECTEDNODE)) + (APPLYTOSELECTEDNODE WINDOW]) + +(STBROWSER + [LAMBDA (GRAPH ARGS) (* DECLARATIONS%: (RECORDS BROWSEWIN)) + (* ; "Edited 31-Mar-87 11:18 by jop") + + (* ;; "puts a browser graph for the args FROMFN in a window. If a similar graph is already a window, that window is reused; otherwise a new window is created.") + + (WINDOWADDPROP (bind TMP for W in BROWSERWINDOWS + when (EQUAL (fetch (PATHSARGS DISCRIMINANT) of ARGS) + (fetch (PATHSARGS DISCRIMINANT) of (fetch + (BROWSEWIN ARGS) + of W))) + do (replace (BROWSEWIN ARGS) of W with ARGS) + (replace (BROWSEWIN GRAPH) of W with GRAPH) + (SHOWGRAPH GRAPH (SETQ W (fetch (BROWSEWIN WINDOW) of W)) + (FUNCTION BROWSER.LEFTFN) + (FUNCTION BROWSER.MIDDLEFN)) + (RETURN W) + finally (SETQ W (SHOWGRAPH GRAPH (CONCAT "PATHS" + (COND + ((SETQ TMP (fetch + (PATHSARGS FROM) + of ARGS)) + (* ; + "CADDDR here gets the thing that looks like it might be a function name.") + (CONCAT (COND + ((CADR (CADR TMP)) + " FROM ") + (T " TO ")) + (CADDDR TMP))) + (T "")) + (COND + ((SETQ TMP (fetch + (PATHSARGS TO) + of ARGS)) + (* ; + "CADDDR here gets the thing that looks like it might be a function name.") + (CONCAT (COND + ((CADR (CADR TMP)) + " FROM ") + (T " TO ")) + (CADDDR TMP))) + (T ""))) + (FUNCTION BROWSER.LEFTFN) + (FUNCTION BROWSER.MIDDLEFN))) + (push BROWSERWINDOWS + (create BROWSEWIN + ARGS _ ARGS + GRAPH _ GRAPH + WINDOW _ W)) + (RETURN W)) + 'CLOSEFN + (FUNCTION (LAMBDA (WINDOW) (* ; + "The closing function for browser windows. removes it from BROWSERWINDOWS") + (SETQ BROWSERWINDOWS (DREMOVE (for X in BROWSERWINDOWS + when (EQ (fetch (BROWSEWIN WINDOW) + of X) + WINDOW) + do (RETURN X)) + BROWSERWINDOWS]) +) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +[PUTDEF 'BROWSEHASH 'RESOURCES '(NEW (LIST (HARRAY 30] +) +) + +(/SETTOPVAL '\BROWSEHASH.GLOBALRESOURCE NIL) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RECORD BROWSEWIN (ARGS GRAPH WINDOW)) + +(RECORD PATHSARGS (FROM TO . ETC) + [ACCESSFNS PATHSARGS ((DISCRIMINANT (CONS (fetch (PATHSARGS FROM) + of DATUM) + (fetch (PATHSARGS TO) + of DATUM]) +) +) + +(RPAQQ BROWSERBOXING NIL) + +(RPAQQ BROWSERFORMAT NIL) + +(RPAQQ BROWSERWINDOWS NIL) + +(RPAQQ NODESELECTIONWINDOW NIL) + +(RPAQQ PFWINDOW NIL) + +(RPAQQ BROWSER.DESCRIBE.WINDOW NIL) + +(RPAQQ BrowserPPWindowWidth 750) + +(RPAQQ BROWSERFONT (GACHA 8)) + +(MOVD? 'MSPATHS 'OLDMSPATHS) + +[PROG [(WC (FILEPKGTYPE 'FNS 'WHENCHANGED] + (OR (MEMB 'BROWSER.WHENFNSCHANGED WC) + (FILEPKGTYPE 'FNS 'WHENCHANGED (CONS 'BROWSER.WHENFNSCHANGED WC] +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(SELECTQ (SYSTEMTYPE) + (D (BROWSER T)) + NIL) +) +(PUTPROPS BROWSER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1987 1988 1990 1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (1952 24987 (NUMSPATHS 1962 . 5228) (BROWSER 5230 . 5493) (BROWSER.WHENFNSCHANGED 5495 + . 7794) (BRPATHS1 7796 . 10062) (BROWSER.LEFTFN 10064 . 10922) (GET.BROWSE.PP.WINDOW 10924 . 11606) ( +GET.BROWSE.DESCRIBE.WINDOW 11608 . 12356) (BROWSEPP 12358 . 13232) (PPREPAINTFN 13234 . 16368) ( +PPRESHAPEFN 16370 . 16550) (DESCRIBEREPAINTFN 16552 . 17248) (BROWSERDESCRIBE 17250 . 18008) ( +BROWSER.MIDDLEFN 18010 . 19317) (DEDITPROCESSRUNNINGP 19319 . 19590) (REDRAWBROWSEGRAPH 19592 . 20355) + (STBROWSER 20357 . 24985))))) +STOP diff --git a/library/CASH-FILE b/library/CASH-FILE new file mode 100644 index 00000000..112acd17 --- /dev/null +++ b/library/CASH-FILE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "CASH-FILE" (USE "LISP" "XCL"))) (IL:FILECREATED "11-Jun-90 14:33:44" IL:|{DSK}local>lde>lispcore>library>CASH-FILE.;2| 6688 IL:|changes| IL:|to:| (IL:VARS IL:CASH-FILECOMS) IL:|previous| IL:|date:| " 9-Oct-87 11:22:19" IL:|{DSK}local>lde>lispcore>library>CASH-FILE.;1|) ; Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CASH-FILECOMS) (IL:RPAQQ IL:CASH-FILECOMS ((IL:P (PROVIDE "CASH-FILE") (EXPORT '(MAKE-CASH-FILE OPEN-CASH-FILE GET-CASH-FILE REM-CASH-FILE CASH-FILE CASH-FILE-P CASH-FILE-HASH-FILE) "CASH-FILE") (REQUIRE "HASH-FILE" "HASH-FILE.DFASL") (USE-PACKAGE "HASH-FILE" "CASH-FILE")) (IL:STRUCTURES CASH-FILE) (IL:FUNCTIONS %PRINT-CASH-FILE) (IL:VARIABLES NOT-IN-HASH-FILE) (IL:FUNCTIONS MAKE-CASH-FILE OPEN-CASH-FILE GET-CASH-FILE PUT-CASH-FILE REM-CASH-FILE) (IL:SETFS GET-CASH-FILE) (IL:FUNCTIONS MOVE-TO-HEAD-OF-QUEUE ADD-TO-CACHE DEL-FROM-CACHE) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:CASH-FILE))) (PROVIDE "CASH-FILE") (EXPORT '(MAKE-CASH-FILE OPEN-CASH-FILE GET-CASH-FILE REM-CASH-FILE CASH-FILE CASH-FILE-P CASH-FILE-HASH-FILE) "CASH-FILE") (REQUIRE "HASH-FILE" "HASH-FILE.DFASL") (USE-PACKAGE "HASH-FILE" "CASH-FILE") (DEFSTRUCT (CASH-FILE (:CONSTRUCTOR MAKE-CASH-FILE-INTERNAL) (:PRINT-FUNCTION %PRINT-CASH-FILE)) (CACHE NIL :TYPE HASH-TABLE :READ-ONLY T) (CACHE-SIZE NIL :TYPE INTEGER :READ-ONLY T) (QUEUE NIL :TYPE LIST) (HASH-FILE NIL :TYPE HASH-FILE :READ-ONLY T)) (DEFUN %PRINT-CASH-FILE (CASH-FILE STREAM DEPTH) (FORMAT STREAM "#" (LET* ((STREAM (HASH-FILE::HASH-FILE-STREAM ( CASH-FILE-HASH-FILE CASH-FILE))) (NAMESTRING (NAMESTRING (PATHNAME STREAM)))) (IF NAMESTRING NAMESTRING STREAM)))) (DEFCONSTANT NOT-IN-HASH-FILE '(NOT-IN-HASH-FILE)) (DEFUN MAKE-CASH-FILE (FILE-NAME SIZE CACHE-SIZE) (MAKE-CASH-FILE-INTERNAL :HASH-FILE (MAKE-HASH-FILE FILE-NAME SIZE) :CACHE (MAKE-HASH-TABLE :SIZE CACHE-SIZE :TEST 'EQUAL) :CACHE-SIZE CACHE-SIZE)) (DEFUN OPEN-CASH-FILE (FILE-NAME CACHE-SIZE &KEY (DIRECTION :INPUT)) (MAKE-CASH-FILE-INTERNAL :HASH-FILE (OPEN-HASH-FILE FILE-NAME :DIRECTION DIRECTION) :CACHE (MAKE-HASH-TABLE :SIZE CACHE-SIZE :TEST 'EQUAL) :CACHE-SIZE CACHE-SIZE)) (DEFUN GET-CASH-FILE (KEY CASH-FILE &OPTIONAL DEFAULT) (MULTIPLE-VALUE-BIND (VALUE FOUND?) (GETHASH KEY (CASH-FILE-CACHE CASH-FILE)) (COND (FOUND? (IL:* IL:|;;| "cache hit ") (MOVE-TO-HEAD-OF-QUEUE KEY CASH-FILE) (IF (EQ VALUE NOT-IN-HASH-FILE) (IL:* IL:|;;| "it was a cached miss") (VALUES DEFAULT NIL) (IL:* IL:|;;| "it was a cached hit") (VALUES (IL:* IL:|;;|  "return a copy to be compatable with GET-HASH-FILE which always hands you new structure") (COPY-TREE VALUE) T))) (T (IL:* IL:|;;| "try the HASH-FILE") (MULTIPLE-VALUE-SETQ (VALUE FOUND?) (GET-HASH-FILE KEY (CASH-FILE-HASH-FILE CASH-FILE))) (IL:* IL:|;;| "cache what we found") (ADD-TO-CACHE KEY (IF FOUND? (IL:* IL:|;;| "cache the VALUE") VALUE (IL:* IL:|;;| "cache the miss") NOT-IN-HASH-FILE) CASH-FILE) (IL:* IL:|;;| "return VALUE or DEFAULT") (IF FOUND? (VALUES VALUE T) (VALUES DEFAULT NIL)))))) (DEFUN PUT-CASH-FILE (KEY CASH-FILE VALUE) (IL:* IL:|;;| "add it to the hash file") (SETF (GET-HASH-FILE KEY (CASH-FILE-HASH-FILE CASH-FILE)) VALUE) (IL:* IL:|;;| "add it to the cache") (ADD-TO-CACHE KEY VALUE CASH-FILE) VALUE) (DEFUN REM-CASH-FILE (KEY CASH-FILE) (LET ((FOUND? (REM-HASH-FILE KEY (CASH-FILE-HASH-FILE CASH-FILE)))) (WHEN FOUND? (DEL-FROM-CACHE KEY CASH-FILE)) FOUND?)) (DEFSETF GET-CASH-FILE PUT-CASH-FILE) (DEFUN MOVE-TO-HEAD-OF-QUEUE (KEY CASH-FILE) (SETF (CASH-FILE-QUEUE CASH-FILE) (DELETE KEY (CASH-FILE-QUEUE CASH-FILE) :TEST 'EQUAL :COUNT 1)) (PUSH KEY (CASH-FILE-QUEUE CASH-FILE))) (DEFUN ADD-TO-CACHE (KEY VALUE CASH-FILE) (LET ((CACHE (CASH-FILE-CACHE CASH-FILE))) (IF (>= (HASH-TABLE-COUNT CACHE) (CASH-FILE-CACHE-SIZE CASH-FILE)) (IL:* IL:|;;| "cache is full -- throw out last entry") (DEL-FROM-CACHE (CAR (LAST (CASH-FILE-QUEUE CASH-FILE))) CASH-FILE)) (IL:* IL:|;;| "store VALUE in the cache") (SETF (GETHASH KEY CACHE) VALUE) (IL:* IL:|;;| "put the KEY at the head of the QUEUE") (PUSH KEY (CASH-FILE-QUEUE CASH-FILE)) VALUE)) (DEFUN DEL-FROM-CACHE (KEY CASH-FILE) (IL:* IL:|;;| "delete it from the queue") (SETF (CASH-FILE-QUEUE CASH-FILE) (DELETE KEY (CASH-FILE-QUEUE CASH-FILE) :TEST 'EQUAL :COUNT 1)) (IL:* IL:|;;| "delete it from the cache") (REMHASH KEY (CASH-FILE-CACHE CASH-FILE))) (IL:PUTPROPS IL:CASH-FILE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "CASH-FILE" (:USE "LISP" "XCL")))) (IL:PUTPROPS IL:CASH-FILE IL:FILETYPE :XCL-COMPILE-FILE) (IL:PUTPROPS IL:CASH-FILE IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/library/CHARCODETABLES b/library/CHARCODETABLES new file mode 100644 index 00000000..fbae1511 --- /dev/null +++ b/library/CHARCODETABLES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 4-Feb-93 19:47:50" |{PELE:MV:ENVOS}LIBRARY>CHARCODETABLES.;5| 11685 changes to%: (FNS SHOWCSETLIST) previous date%: "25-Aug-92 16:59:31" |{PELE:MV:ENVOS}LIBRARY>CHARCODETABLES.;4|) (* ; " Copyright (c) 1985, 1986, 1990, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CHARCODETABLESCOMS) (RPAQQ CHARCODETABLESCOMS ( (* ;; "User-level entries:") (FNS SHOWCOMMONCSETS SHOWCSET SHOWCSETLIST SHOWCSETRANGE) (* ;; "Main printing functions:") (FNS CENTERPRINT CODETABLE))) (* ;; "User-level entries:") (DEFINEQ (SHOWCOMMONCSETS [LAMBDA (FONT) (* ; "Edited 25-Aug-92 16:55 by jds") (* ;; "Create character-code charts for all the common character sets in existence, namely 0, 41-50, and 356-361 (all octal, of course!) This explicitly excludes the Japanese and Chinese character ranges, which mostly don't exist.") (SHOWCSETRANGE 0 0 FONT) (SHOWCSETLIST (CHARCODE (0,41 0,42 0,44 0,45 0,46 0,47 0,50)) FONT) (SHOWCSETRANGE 238 241 FONT) (PRINTOUT T "Done." T]) (SHOWCSET [LAMBDA (FONT) (* ; "Edited 25-Aug-92 16:55 by jds") (* ;; "Create character-code charts for ALL the character sets in existence, as of Xerox Character Code Standard XC1-2-2-0") (SHOWCSETRANGE 0 0 FONT) (SHOWCSETLIST (CHARCODE (0,41 0,42 0,43 0,44 0,45 0,46 0,47 0,50)) FONT) (SHOWCSETRANGE 48 115 FONT) (SHOWCSETLIST (CHARCODE 0,164 0,165 0,166 0,167 0,170 0,171 0,172)) (SHOWCSETRANGE 161 212 FONT) (SHOWCSETLIST (CHARCODE 0,340 0,341 0,342 0,343 0,356 0,357 0,360 0,361 0,365 0,375 0,376)) (PRINTOUT T "Done." T]) (SHOWCSETLIST [LAMBDA (CSETS FONT) (* ; "Edited 4-Feb-93 19:35 by jds") (* ;; "Produce character-code charts for the character sets in the list CSETS. The charts appear two-up, landscape.") (PROG (IPSTREAM (COUNT 0) (XOFFSET 0) HALFPAGE) [for CHARSET in CSETS do (* ;; "Print each code chart") [COND ((NOT IPSTREAM) (* ;; "W're sure to need an open file. Open one, if there isn't one already. Doing it here assures that we'll never create an empty one at the end.") [SETQ IPSTREAM (OPENIMAGESTREAM '{LPT} NIL '(LANDSCAPE T] (SETQ HALFPAGE (FIXR (FTIMES 5.5 72 (DSPSCALE NIL IPSTREAM] (RESETLST (RESETSAVE (RADIX 8))) (* ;  "Everything's in octal on these charts.") (PRINTOUT T "Listing Character set " CHARSET "." T) (CODETABLE IPSTREAM [OR FONT '(CLASSIC 12 (MEDIUM REGULAR REGULAR] CHARSET XOFFSET) (* ; "Produce the code table.") (DSPFONT '(CLASSIC 12 (MEDIUM REGULAR REGULAR)) IPSTREAM) (* ;;; "Move to the other half of the page, or to the next page, depending.") (COND ((ZEROP XOFFSET) (* ;  "This is the first one on the page. Move over for the next chart.") (SETQ XOFFSET HALFPAGE)) (T (* ;  "That was the second chart on this page. Go to a new page for the next one.") (SETQ XOFFSET 0) (COND ((IGEQ (SETQ COUNT (ADD1 COUNT)) 5) (* ;  "But every 5 pages, start a new file, to prevent overflow on the print server.") (CLOSEF IPSTREAM) (SETQ IPSTREAM NIL) (SETQ COUNT 0)) (T (DSPNEWPAGE IPSTREAM] (AND IPSTREAM (CLOSEF IPSTREAM]) (SHOWCSETRANGE [LAMBDA (FirstCSet LastCSet FONT) (* ; "Edited 25-Aug-92 16:55 by jds") (* ;; "Produce character-code charts for a given range of character sets, from FirstCSet to LastCSet. They appear two-up, landscape.") (SHOWCSETLIST (for CHARSET from FirstCSet to LastCSet collect CHARSET) FONT]) ) (* ;; "Main printing functions:") (DEFINEQ (CENTERPRINT [LAMBDA (TEXT FONT X Y STREAM) (* ; "Edited 25-Aug-92 16:56 by jds") (* ;;; "Print TEXT onto STREAM in FONT, centered horizontally at X, with its baseline at Y") (LET* [(WIDTH (STRINGWIDTH TEXT FONT)) (XLOC (DIFFERENCE X (FTIMES WIDTH 0.5] (MOVETO (FIXR XLOC) Y STREAM) (DSPFONT FONT STREAM) (PRIN1 TEXT STREAM]) (CODETABLE [LAMBDA (STREAM FONT CHARSET XOFFSET) (* ; "Edited 25-Aug-92 16:57 by jds") (* ;; "Generates a font table for character set CHARSET of font FONT. The table is printed on image stream STREAM, at horizontal offset XOFFSET. The characters are printed using PRIN1.") (LET* ((TitleFont (FONTCREATE 'MODERN 10 'BOLD NIL STREAM)) (NUMBERFONT (FONTCREATE 'MODERN 8 'BOLD NIL STREAM)) (SCALE (DSPSCALE NIL STREAM)) (InchesToPrinterUnits (FTIMES 72.0 SCALE)) (DDev (IMAGESTREAMTYPE STREAM)) (CHARSETNAME (OCTALSTRING CHARSET)) TITLE) (SETQ FONT (FONTCREATE FONT NIL NIL NIL STREAM)) (* ;  "Get the interpress version of the FONT we're making the table for.") (* ;;; "Print the title over the table, showing font name, size, etc.") (DSPFONT TitleFont STREAM) (SETQ TITLE (CONCAT (FONTPROP FONT 'FAMILY) " " (FONTPROP FONT 'SIZE) " " (FONTPROP FONT 'WEIGHT) "-" (FONTPROP FONT 'SLOPE) " Character Set " CHARSETNAME)) (CENTERPRINT TITLE TitleFont (PLUS XOFFSET (TIMES 2.75 InchesToPrinterUnits)) (FTIMES 7.5 InchesToPrinterUnits) STREAM) (* ;;; "Print out the lines for the table, and the character-code guide numbers along the top and left edge.") (DSPFONT NUMBERFONT STREAM) [for X from (IPLUS XOFFSET InchesToPrinterUnits) by (FIXR (FTIMES SCALE 18)) as I from 0 to 16 bind (Y0 _ (FIXR (FTIMES SCALE 72))) (YSPAN _ (FIXR (FTIMES SCALE 24 16))) do (* ;;; "Draw thr vertical lines between the boxes in the code chart.") (DRAWLINE X Y0 X (IPLUS Y0 YSPAN) 35 'PAINT STREAM) (COND ((ILEQ I 15) (* ;; "And if it's not the rightmost line, print a number across the top as well, for the high-order 4 bits of the character code.") (CENTERPRINT (OCTALSTRING (ITIMES I 16)) NUMBERFONT (IPLUS X (FIXR (FTIMES SCALE 9))) (IPLUS Y0 YSPAN 35) STREAM] [for Y from (FIXR (FTIMES SCALE 72)) by (FIXR (FTIMES SCALE 24)) as I from 0 to 16 bind [X0 _ (IPLUS XOFFSET (FIXR (FTIMES SCALE 72] (XSPAN _ (FIXR (FTIMES SCALE 18 16))) do (* ;;; "Now print the horizontal lines between boxes in the code chart.") (DRAWLINE X0 Y (IPLUS X0 XSPAN) Y 35 'PAINT STREAM) (COND ((ILEQ I 15) (* ; "And if it isn't the bottommost line, print the low-order 4 bits of character code along the left.") (CENTERPRINT (OCTALSTRING (IDIFFERENCE 15 I)) NUMBERFONT (IPLUS X0 (FIXR (FTIMES SCALE -9))) (IPLUS Y (FIXR (FTIMES 6 SCALE))) STREAM] (* ;;; "Now go really print the characters in the table.") (DSPFONT FONT STREAM) (for YPosition from [FIXR (FTIMES SCALE (IPLUS 72 6 (ITIMES 15 24] by (FIXR (FTIMES SCALE -24)) as LOWBITS from 0 to 15 bind CharacterCode do (* ;;; "Run down each column -- i.e., varying the low bits fastest -- printing the characters.") [for XPosition from (IPLUS XOFFSET (FIXR (FTIMES SCALE 75))) by (FIXR (FTIMES 18 SCALE)) as HIBITS from 0 to 15 do (SETQ CharacterCode (IPLUS (LLSH CHARSET 8) (LLSH HIBITS 4) LOWBITS)) (MOVETO XPosition YPosition STREAM) (COND ((IEQP (LOGAND CharacterCode 255) 255) (* ;  "Can't print the charset-change character!") ) ((NEQ CharacterCode (CHARCODE FF)) (COND ((EQ DDev 'DISPLAY) (BLTCHAR CharacterCode STREAM)) (T (\OUTCHAR STREAM CharacterCode] (printout T ".")) (printout T " done." T]) ) (PUTPROPS CHARCODETABLES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990 1992 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (842 5920 (SHOWCOMMONCSETS 852 . 1403) (SHOWCSET 1405 . 2058) (SHOWCSETLIST 2060 . 5536) (SHOWCSETRANGE 5538 . 5918)) (5963 11571 (CENTERPRINT 5973 . 6404) (CODETABLE 6406 . 11569))))) STOP \ No newline at end of file diff --git a/library/CHARDEVICE b/library/CHARDEVICE new file mode 100644 index 00000000..e8c11522 --- /dev/null +++ b/library/CHARDEVICE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "20-Jan-93 13:45:35" {DSK}lde>lispcore>library>CHARDEVICE.;2 24926 changes to%: (VARS CHARDEVICECOMS) (RECORDS SGTTY MODEM-LINES) previous date%: " 1-May-92 15:09:57" {DSK}lde>lispcore>library>CHARDEVICE.;1) (PRETTYCOMPRINT CHARDEVICECOMS) (RPAQQ CHARDEVICECOMS ((FNS \CHAR-DEVICE-INIT \CHAR-DEV-EVENTFN \CHAR-ERROR) (P (\CHAR-DEVICE-INIT)) (COMS (* ;; "File manipulation (Open, close, etc)") (FNS \CHAR-DEV-OPENFILE \CHAR-DEV-CLOSEFILE)) (COMS (* ;; "UNBUFFERED Stream methods (BIN, BOUT, etc)") (FNS \CHAR-DEV-BIN \CHAR-DEV-BOUT \CHAR-BINS \CHAR-BOUTS \CHAR-DEV-PEEKBIN \CHAR-DEV-READP)) (COMS (* ;; "BUFFERED Stream methods (BINS, BOUTS, GETNEXTBUFFER, etc.)") (FNS \CHAR-FILLBUFFER)) (COMS (* ;; "Structures for using IOCTL with various character devices:") (FNS IOCTL) (* ;; "TTY (and TERMIO??) device:") (COMS (RECORDS SGTTY) (CONSTANTS (TIOCGETP (\MAKENUMBER 16390 29704)) (TIOCSETP (\MAKENUMBER 32774 29705)) (TIOCSETN (\MAKENUMBER 32774 29706)) (TIOCEXCL (\MAKENUMBER 8192 29709)) (TIOCNXCL (\MAKENUMBER 8192 29710)) (TIOCHPCL (\MAKENUMBER 8192 29698)) (TIOCGETD (\MAKENUMBER 16388 29696)) (TIOCSETD (\MAKENUMBER 32772 29697)) (TIOCFLUSH (\MAKENUMBER 32772 29712)) (TIOCSTI (\MAKENUMBER 32769 29810)) (TIOCSBRK (\MAKENUMBER 8192 29819)) (TIOCCBRK (\MAKENUMBER 8192 29818)) (TIOCOUTQ (\MAKENUMBER 16388 29811)) (FIONREAD (\MAKENUMBER 16388 26239)) (TIOCMODG (\MAKENUMBER 16388 29699)) (TIOCMODS (\MAKENUMBER 32772 29700)) (TIOCSETC (\MAKENUMBER 32774 29713)) (TIOCGETC (\MAKENUMBER 16390 29714)) (TCXONC (\MAKENUMBER 8192 21510)) (TCFLSH (\MAKENUMBER 8192 21511)) (TCGETS (\MAKENUMBER 16418 21512)) (TCSETS (\MAKENUMBER 32802 21513)) (TCSETSW (\MAKENUMBER 32802 21514)) (TCSETSF (\MAKENUMBER 32802 21515)) (TCSNDBRK (\MAKENUMBER 8192 21516)) (TCDRAIN (\MAKENUMBER 8192 21517)) (TIOCGWINSZ (\MAKENUMBER 16392 29800)) (TIOCSWINSZ (\MAKENUMBER 32776 29799)) (TIOCSSIZE (\MAKENUMBER 32776 29733)) (TIOCGSIZE (\MAKENUMBER 16392 29734)) (TIOCMBIS (\MAKENUMBER 32772 29804)) (TIOCMBIC (\MAKENUMBER 32772 29803)) (TIOCGSOFTCAR (\MAKENUMBER 16388 29796)) (TIOCPKT (\MAKENUMBER 32772 29808)) (TIOCREMOTE (\MAKENUMBER 32772 29801)) (TIOCOUTQ (\MAKENUMBER 16388 29811)) (TIOCMGET (\MAKENUMBER 16388 29802)) (TIOCMSET (\MAKENUMBER 32772 29805)) (TIOCUCNTL (\MAKENUMBER 32772 29798)) (TIOCSSOFTCAR (\MAKENUMBER 32772 29797))) (CONSTANTS (B0 0) (B50 1) (B75 2) (B110 3) (B134 4) (B150 5) (B200 6) (B300 7) (B600 8) (B1200 9) (B1800 10) (B2400 11) (B4800 12) (B9600 13) (B19200 14)) (CONSTANTS (FREAD 1) (FWRITE 2)) (CONSTANTS (TIOCPKT_DATA 0) (TIOCPKT_FLUSHREAD 1) (TIOCPKT_FLUSHWRITE 2) (TIOCPKT_STOP 4) (TIOCPKT_START 8) (TIOCPKT_NOSTOP 16) (TIOCPKT_DOSTOP 32) (TIOCPKT_IOCTL 64) (TIOCM_LE 1) (TIOCM_DTR 2) (TIOCM_RTS 4) (TIOCM_ST 8) (TIOCM_SR 16) (TIOCM_CTS 32) (TIOCM_CAR 64) (TIOCM_RI 128) (TIOCM_DSR 256)) (RECORDS MODEM-LINES)) (INITRECORDS SGTTY)) [COMS (* ;; "Changes to \INITSUBRS to support the character deice:") (ADDVARS (\INITSUBRS (CHAR-OPENFILE 200) (CHAR-BIN 201) (CHAR-BOUT 202) (CHAR-IOCTL 203) (CHAR-CLOSEFILE 204) (CHAR-EOFP 205) (CHAR-READP 206) (CHAR-BINS 207) (CHAR-BOUTS 208) (CHAR-FILLBUFFER 209] (COMS (* ;; "DSEBUGGING FNS") (FNS RP BAUD-RATE CHARS-AVAILABLE BINS-BAUD)))) (DEFINEQ (\CHAR-DEVICE-INIT (LAMBDA NIL (* ; "Edited 12-Sep-89 16:09 by jds") (SETQ \CHAR-DEVICE-FDEV (create FDEV BIN _ (FUNCTION \CHAR-DEV-BIN) BOUT _ (FUNCTION \CHAR-DEV-BOUT) OPENFILE _ (FUNCTION \CHAR-DEV-OPENFILE) EVENTFN _ (FUNCTION \CHAR-DEV-EVENTFN) REOPENFILE _ (FUNCTION \CHAR-DEV-OPENFILE) CLOSEFILE _ (FUNCTION \CHAR-DEV-CLOSEFILE) BLOCKIN _ (FUNCTION \CHAR-BINS) BLOCKOUT _ (FUNCTION \CHAR-BOUTS) READP _ (FUNCTION \CHAR-DEV-READP) PEEKBIN _ (FUNCTION \CHAR-DEV-PEEKBIN))) (\DEFINEDEVICE (QUOTE CHAR) \CHAR-DEVICE-FDEV)) ) (\CHAR-DEV-EVENTFN (LAMBDA (FDEV EVENT) NIL)) (\CHAR-ERROR (LAMBDA (ERRNO STREAM) (SELECTQ ERRNO (1 (ERROR "Not Owner: " STREAM)) (2 (\LISPERROR "FILE NOT FOUND" STREAM)) (9 (ERROR "Bad file number: " (FETCH (STREAM F1) of STREAM))) (ERROR "Unix error number: " ERRNO))) ) ) (\CHAR-DEVICE-INIT) (* ;; "File manipulation (Open, close, etc)") (DEFINEQ (\CHAR-DEV-OPENFILE [LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV) (* ; "Edited 4-Aug-89 13:49 by jds") (LET ([UNIX-NAME (SUBSTRING NAME (ADD1 (STRPOS "}" NAME] (ERRNO (CREATECELL \FIXP)) IODESCRIPTOR ACCESS-VALUE STREAM) (SETQ STREAM (create STREAM BINABLE _ NIL BOUTABLE _ NIL DEVICE _ FDEV FULLFILENAME _ NAME USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC F1 _ IODESCRIPTOR)) (SELECTQ ACCESS (INPUT (replace (STREAM STRMBINFN) of STREAM with (FUNCTION \CHAR-DEV-BIN)) (SETQ ACCESS-VALUE 0)) (OUTPUT (replace (STREAM STRMBOUTFN) of STREAM with (FUNCTION \CHAR-DEV-BOUT )) (SETQ ACCESS-VALUE 1)) (BOTH (replace (STREAM STRMBINFN) of STREAM with (FUNCTION \CHAR-DEV-BIN)) (replace (STREAM STRMBOUTFN) of STREAM with (FUNCTION \CHAR-DEV-BOUT)) (SETQ ACCESS-VALUE 2)) (APPEND (\ILLEGAL.ARG ACCESS)) (\ILLEGAL.ARG ACCESS)) (COND ((SETQ IODESCRIPTOR (SUBRCALL CHAR-OPENFILE UNIX-NAME ACCESS-VALUE ERRNO)) (* ;; "Open happened, so put things together.") (replace (STREAM F1) of STREAM with IODESCRIPTOR)) (T (\CHAR-ERROR ERRNO NAME))) STREAM]) (\CHAR-DEV-CLOSEFILE [LAMBDA (STREAM) (* ; "Edited 2-Aug-89 15:49 by jds") (LET ((ERRNO (CREATECELL \FIXP)) IODESCRIPTOR ACCESS-VALUE) (COND ((SUBRCALL CHAR-CLOSEFILE (fetch (STREAM F1) of STREAM) ERRNO) (* ;; "Close happened, so put things together.") ) (T (CL:ERROR "Char-device close failed with error number ~d.~%%" ERRNO))) STREAM]) ) (* ;; "UNBUFFERED Stream methods (BIN, BOUT, etc)") (DEFINEQ (\CHAR-DEV-BIN (LAMBDA (STREAM) (* ; "Edited 12-Sep-89 16:08 by jds") (COND ((fetch F3 of STREAM) (PROG1 (fetch F3 of STREAM) (replace F3 of STREAM with NIL))) (T (LET ((ERRNO (CREATECELL \FIXP)) CH) (while (NOT (SETQ CH (SUBRCALL CHAR-BIN (fetch (STREAM F1) of STREAM) ERRNO))) do (COND ((IEQP ERRNO 35) (* ; "EWOULDBLOCK -- need to wait a bit, as there's nothing waiting to come.") (BLOCK)) (T (\CHAR-ERROR ERRNO STREAM)))) CH)))) ) (\CHAR-DEV-BOUT [LAMBDA (STREAM CCODE) (* ; "Edited 2-Aug-89 15:48 by jds") [LET ((ERRNO (CREATECELL \FIXP))) (WHILE (NOT (SUBRCALL CHAR-BOUT (FETCH (STREAM F1) OF STREAM) CCODE ERRNO)) DO (COND ((IEQP ERRNO 35) (* ; "EWOULDBLOCK") (BLOCK)) (T (\CHAR-ERROR ERRNO STREAM] CCODE]) (\CHAR-BINS [LAMBDA (STREAM BASE OFFSET NBYTES) (* ; "Edited 3-Aug-89 13:42 by jds") (LET ((ERRNO (\CREATECELL \FIXP)) (CHARS-READ 0) (BYTES-TO-READ NBYTES) THIS-READ) [WHILE (< CHARS-READ NBYTES) DO (COND ((SETQ THIS-READ (SUBRCALL CHAR-BINS (FETCH (STREAM F1) OF STREAM) BASE OFFSET BYTES-TO-READ ERRNO)) (AND (ILESSP (SETQ CHARS-READ (+ CHARS-READ THIS-READ)) NBYTES) (BLOCK)) (SETQ BYTES-TO-READ (- BYTES-TO-READ THIS-READ)) (SETQ OFFSET (+ OFFSET THIS-READ))) ((IEQP ERRNO 35) (BLOCK)) (T (\CHAR-ERROR ERRNO STREAM] NBYTES]) (\CHAR-BOUTS [LAMBDA (STREAM BASE OFFSET NBYTES) (* ; "Edited 3-Aug-89 13:43 by jds") (LET ((ERRNO (\CREATECELL \FIXP)) (CHARS-WRITTEN 0) (BYTES-TO-WRITE NBYTES) THIS-WRITE) [WHILE (< CHARS-WRITTEN NBYTES) DO (COND ((SETQ THIS-WRITE (SUBRCALL CHAR-BOUTS (FETCH (STREAM F1) OF STREAM) BASE OFFSET BYTES-TO-WRITE ERRNO)) (SETQ CHARS-WRITTEN (+ CHARS-WRITTEN THIS-WRITE)) (SETQ BYTES-TO-WRITE (- BYTES-TO-WRITE THIS-WRITE)) (SETQ OFFSET (+ OFFSET THIS-WRITE)) (BLOCK)) ((IEQP ERRNO 35) (BLOCK)) (T (\CHAR-ERROR ERRNO STREAM] NBYTES]) (\CHAR-DEV-PEEKBIN (LAMBDA (STREAM NOERRORFLG) (* ; "Edited 12-Sep-89 16:09 by jds") (COND ((fetch F3 of STREAM)) (T (replace F3 of STREAM with (\BIN STREAM))))) ) (\CHAR-DEV-READP (LAMBDA (STREAM) (* ; "Edited 12-Sep-89 15:32 by jds") (* ;; "READP method for CHAR streams. T if there's an input char available.") (LET ((RESULT (\CREATECELL \FIXP))) (IOCTL STREAM FIONREAD RESULT) (ILESSP 0 RESULT))) ) ) (* ;; "BUFFERED Stream methods (BINS, BOUTS, GETNEXTBUFFER, etc.)") (DEFINEQ (\CHAR-FILLBUFFER [LAMBDA (STREAM BUFFER) (* ; "Edited 3-Aug-89 11:43 by jds") (LET ((ERRNO (\CREATECELL \FIXP)) CHARS-READ) [CL:TAGBODY READ-LOOP (COND ((SETQ CHARS-READ (SUBRCALL CHAR-BINS (FETCH (STREAM F1) OF STREAM) BUFFER 0 512)) ASDF) ((IEQP ERRNO 35) (BLOCK) (GO READ-LOOP)) ((\CHAR-ERROR ERRNO STREAM] CHARS-READ]) ) (* ;; "Structures for using IOCTL with various character devices:") (DEFINEQ (IOCTL [LAMBDA (STREAM REQUEST DATA) (* ; "Edited 2-Aug-89 15:49 by jds") (LET ((ERRNO (CREATECELL \FIXP))) (OR (SUBRCALL CHAR-IOCTL (fetch (STREAM F1) of STREAM) REQUEST DATA ERRNO) ERRNO]) ) (* ;; "TTY (and TERMIO??) device:") (DECLARE%: EVAL@COMPILE (DATATYPE SGTTY ((INPUT-SPEED BYTE) (OUTPUT-SPEED BYTE) (ERASE-CHAR BYTE) (KILL-CHAR BYTE) (FLAGS WORD))) ) (/DECLAREDATATYPE 'SGTTY '(BYTE BYTE BYTE BYTE WORD) '((SGTTY 0 (BITS . 7)) (SGTTY 0 (BITS . 135)) (SGTTY 1 (BITS . 7)) (SGTTY 1 (BITS . 135)) (SGTTY 2 (BITS . 15))) '4) (DECLARE%: EVAL@COMPILE (RPAQ TIOCGETP (\MAKENUMBER 16390 29704)) (RPAQ TIOCSETP (\MAKENUMBER 32774 29705)) (RPAQ TIOCSETN (\MAKENUMBER 32774 29706)) (RPAQ TIOCEXCL (\MAKENUMBER 8192 29709)) (RPAQ TIOCNXCL (\MAKENUMBER 8192 29710)) (RPAQ TIOCHPCL (\MAKENUMBER 8192 29698)) (RPAQ TIOCGETD (\MAKENUMBER 16388 29696)) (RPAQ TIOCSETD (\MAKENUMBER 32772 29697)) (RPAQ TIOCFLUSH (\MAKENUMBER 32772 29712)) (RPAQ TIOCSTI (\MAKENUMBER 32769 29810)) (RPAQ TIOCSBRK (\MAKENUMBER 8192 29819)) (RPAQ TIOCCBRK (\MAKENUMBER 8192 29818)) (RPAQ TIOCOUTQ (\MAKENUMBER 16388 29811)) (RPAQ FIONREAD (\MAKENUMBER 16388 26239)) (RPAQ TIOCMODG (\MAKENUMBER 16388 29699)) (RPAQ TIOCMODS (\MAKENUMBER 32772 29700)) (RPAQ TIOCSETC (\MAKENUMBER 32774 29713)) (RPAQ TIOCGETC (\MAKENUMBER 16390 29714)) (RPAQ TCXONC (\MAKENUMBER 8192 21510)) (RPAQ TCFLSH (\MAKENUMBER 8192 21511)) (RPAQ TCGETS (\MAKENUMBER 16418 21512)) (RPAQ TCSETS (\MAKENUMBER 32802 21513)) (RPAQ TCSETSW (\MAKENUMBER 32802 21514)) (RPAQ TCSETSF (\MAKENUMBER 32802 21515)) (RPAQ TCSNDBRK (\MAKENUMBER 8192 21516)) (RPAQ TCDRAIN (\MAKENUMBER 8192 21517)) (RPAQ TIOCGWINSZ (\MAKENUMBER 16392 29800)) (RPAQ TIOCSWINSZ (\MAKENUMBER 32776 29799)) (RPAQ TIOCSSIZE (\MAKENUMBER 32776 29733)) (RPAQ TIOCGSIZE (\MAKENUMBER 16392 29734)) (RPAQ TIOCMBIS (\MAKENUMBER 32772 29804)) (RPAQ TIOCMBIC (\MAKENUMBER 32772 29803)) (RPAQ TIOCGSOFTCAR (\MAKENUMBER 16388 29796)) (RPAQ TIOCPKT (\MAKENUMBER 32772 29808)) (RPAQ TIOCREMOTE (\MAKENUMBER 32772 29801)) (RPAQ TIOCOUTQ (\MAKENUMBER 16388 29811)) (RPAQ TIOCMGET (\MAKENUMBER 16388 29802)) (RPAQ TIOCMSET (\MAKENUMBER 32772 29805)) (RPAQ TIOCUCNTL (\MAKENUMBER 32772 29798)) (RPAQ TIOCSSOFTCAR (\MAKENUMBER 32772 29797)) (CONSTANTS (TIOCGETP (\MAKENUMBER 16390 29704)) (TIOCSETP (\MAKENUMBER 32774 29705)) (TIOCSETN (\MAKENUMBER 32774 29706)) (TIOCEXCL (\MAKENUMBER 8192 29709)) (TIOCNXCL (\MAKENUMBER 8192 29710)) (TIOCHPCL (\MAKENUMBER 8192 29698)) (TIOCGETD (\MAKENUMBER 16388 29696)) (TIOCSETD (\MAKENUMBER 32772 29697)) (TIOCFLUSH (\MAKENUMBER 32772 29712)) (TIOCSTI (\MAKENUMBER 32769 29810)) (TIOCSBRK (\MAKENUMBER 8192 29819)) (TIOCCBRK (\MAKENUMBER 8192 29818)) (TIOCOUTQ (\MAKENUMBER 16388 29811)) (FIONREAD (\MAKENUMBER 16388 26239)) (TIOCMODG (\MAKENUMBER 16388 29699)) (TIOCMODS (\MAKENUMBER 32772 29700)) (TIOCSETC (\MAKENUMBER 32774 29713)) (TIOCGETC (\MAKENUMBER 16390 29714)) (TCXONC (\MAKENUMBER 8192 21510)) (TCFLSH (\MAKENUMBER 8192 21511)) (TCGETS (\MAKENUMBER 16418 21512)) (TCSETS (\MAKENUMBER 32802 21513)) (TCSETSW (\MAKENUMBER 32802 21514)) (TCSETSF (\MAKENUMBER 32802 21515)) (TCSNDBRK (\MAKENUMBER 8192 21516)) (TCDRAIN (\MAKENUMBER 8192 21517)) (TIOCGWINSZ (\MAKENUMBER 16392 29800)) (TIOCSWINSZ (\MAKENUMBER 32776 29799)) (TIOCSSIZE (\MAKENUMBER 32776 29733)) (TIOCGSIZE (\MAKENUMBER 16392 29734)) (TIOCMBIS (\MAKENUMBER 32772 29804)) (TIOCMBIC (\MAKENUMBER 32772 29803)) (TIOCGSOFTCAR (\MAKENUMBER 16388 29796)) (TIOCPKT (\MAKENUMBER 32772 29808)) (TIOCREMOTE (\MAKENUMBER 32772 29801)) (TIOCOUTQ (\MAKENUMBER 16388 29811)) (TIOCMGET (\MAKENUMBER 16388 29802)) (TIOCMSET (\MAKENUMBER 32772 29805)) (TIOCUCNTL (\MAKENUMBER 32772 29798)) (TIOCSSOFTCAR (\MAKENUMBER 32772 29797))) ) (DECLARE%: EVAL@COMPILE (RPAQQ B0 0) (RPAQQ B50 1) (RPAQQ B75 2) (RPAQQ B110 3) (RPAQQ B134 4) (RPAQQ B150 5) (RPAQQ B200 6) (RPAQQ B300 7) (RPAQQ B600 8) (RPAQQ B1200 9) (RPAQQ B1800 10) (RPAQQ B2400 11) (RPAQQ B4800 12) (RPAQQ B9600 13) (RPAQQ B19200 14) (CONSTANTS (B0 0) (B50 1) (B75 2) (B110 3) (B134 4) (B150 5) (B200 6) (B300 7) (B600 8) (B1200 9) (B1800 10) (B2400 11) (B4800 12) (B9600 13) (B19200 14)) ) (DECLARE%: EVAL@COMPILE (RPAQQ FREAD 1) (RPAQQ FWRITE 2) (CONSTANTS (FREAD 1) (FWRITE 2)) ) (DECLARE%: EVAL@COMPILE (RPAQQ TIOCPKT_DATA 0) (RPAQQ TIOCPKT_FLUSHREAD 1) (RPAQQ TIOCPKT_FLUSHWRITE 2) (RPAQQ TIOCPKT_STOP 4) (RPAQQ TIOCPKT_START 8) (RPAQQ TIOCPKT_NOSTOP 16) (RPAQQ TIOCPKT_DOSTOP 32) (RPAQQ TIOCPKT_IOCTL 64) (RPAQQ TIOCM_LE 1) (RPAQQ TIOCM_DTR 2) (RPAQQ TIOCM_RTS 4) (RPAQQ TIOCM_ST 8) (RPAQQ TIOCM_SR 16) (RPAQQ TIOCM_CTS 32) (RPAQQ TIOCM_CAR 64) (RPAQQ TIOCM_RI 128) (RPAQQ TIOCM_DSR 256) (CONSTANTS (TIOCPKT_DATA 0) (TIOCPKT_FLUSHREAD 1) (TIOCPKT_FLUSHWRITE 2) (TIOCPKT_STOP 4) (TIOCPKT_START 8) (TIOCPKT_NOSTOP 16) (TIOCPKT_DOSTOP 32) (TIOCPKT_IOCTL 64) (TIOCM_LE 1) (TIOCM_DTR 2) (TIOCM_RTS 4) (TIOCM_ST 8) (TIOCM_SR 16) (TIOCM_CTS 32) (TIOCM_CAR 64) (TIOCM_RI 128) (TIOCM_DSR 256)) ) (DECLARE%: EVAL@COMPILE (BLOCKRECORD MODEM-LINES ((NIL WORD) (NIL BITS 7) (DSR FLAG) (RI FLAG) (CAR FLAG) (CTS FLAG) (SR FLAG) (ST FLAG) (RTS FLAG) (DTR FLAG) (LE FLAG))) ) (/DECLAREDATATYPE 'SGTTY '(BYTE BYTE BYTE BYTE WORD) '((SGTTY 0 (BITS . 7)) (SGTTY 0 (BITS . 135)) (SGTTY 1 (BITS . 7)) (SGTTY 1 (BITS . 135)) (SGTTY 2 (BITS . 15))) '4) (* ;; "Changes to \INITSUBRS to support the character deice:") (ADDTOVAR \INITSUBRS (CHAR-OPENFILE 200) (CHAR-BIN 201) (CHAR-BOUT 202) (CHAR-IOCTL 203) (CHAR-CLOSEFILE 204) (CHAR-EOFP 205) (CHAR-READP 206) (CHAR-BINS 207) (CHAR-BOUTS 208) (CHAR-FILLBUFFER 209)) (* ;; "DSEBUGGING FNS") (DEFINEQ (RP [LAMBDA (X BASE) (LET ((*PRINT-BASE* BASE)) (PRINT X]) (BAUD-RATE [LAMBDA (FF) (LET ((CHARS 0) (STARTTIME (IDATE)) ENDTIME) (for I from 1 to 10000 do (BIN FF)) (SETQ ENDTIME (IDATE)) (- ENDTIME STARTTIME]) (CHARS-AVAILABLE [LAMBDA (STREAM) (LET ((RESULT (\CREATECELL \FIXP))) (IOCTL STREAM FIONREAD RESULT) RESULT]) (BINS-BAUD [LAMBDA (FF) (* ; "Edited 3-Aug-89 14:19 by jds") (LET ((CHARS 0) (RESULT NIL) COUNT TC) (while (< CHARS 10000) do (SETQ TC (\BINS FF SB 0 512)) (add CHARS TC]) ) (PUTPROPS CHARDEVICE COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7990 8819 (\CHAR-DEVICE-INIT 8000 . 8531) (\CHAR-DEV-EVENTFN 8533 . 8582) (\CHAR-ERROR 8584 . 8817)) (8899 11044 (\CHAR-DEV-OPENFILE 8909 . 10534) (\CHAR-DEV-CLOSEFILE 10536 . 11042)) ( 11105 15738 (\CHAR-DEV-BIN 11115 . 11553) (\CHAR-DEV-BOUT 11555 . 12183) (\CHAR-BINS 12185 . 13705) ( \CHAR-BOUTS 13707 . 15322) (\CHAR-DEV-PEEKBIN 15324 . 15491) (\CHAR-DEV-READP 15493 . 15736)) (15815 16581 (\CHAR-FILLBUFFER 15825 . 16579)) (16658 16954 (IOCTL 16668 . 16952)) (24090 24864 (RP 24100 . 24177) (BAUD-RATE 24179 . 24402) (CHARS-AVAILABLE 24404 . 24545) (BINS-BAUD 24547 . 24862))))) STOP \ No newline at end of file diff --git a/library/CHAT b/library/CHAT new file mode 100644 index 00000000..3815447d --- /dev/null +++ b/library/CHAT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "20-Jan-93 13:46:52" {DSK}lde>lispcore>library>CHAT.;3 54346 changes to%: (RECORDS EMACSCOMMANDS) previous date%: "21-Dec-92 10:50:12" {DSK}lde>lispcore>library>CHAT.;2) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CHATCOMS) (RPAQQ CHATCOMS [(COMS (* ; "CHAT typein") (FNS CHAT CHAT.STARTUP CHAT.PROMPT.FOR.INPUT CHAT.CHOOSE.EMULATOR CHAT.SET.EMULATOR CHAT.INIT FIND.CHAT.PROTOCOL CHAT.TYPEIN CHAT.BIN CHAT.CLOSE CHAT.DEACTIVATE.WINDOW CHAT.CLOSEFN CHAT.CLOSE.CONNECTION CHAT.LOGIN) (VARIABLES CHAT.TTY.PROCESS CHAT.HOST.TO.PROTOCOL CHAT.HOSTINFO CHAT.OSTYPES CHAT.PROTOCOL.ABBREVS CHAT.ALLHOSTS CHAT.DISPLAYTYPES CHAT.FONT CHAT.IN.EMACS? CHAT.INTERRUPTS CHAT.KEYACTIONS CHAT.PROTOCOLTYPES CHAT.WAIT.TIME CHAT.WINDOW.REGION CHAT.WINDOW.SIZE CHATWINDOW CLOSECHATWINDOWFLG DEFAULTCHATHOST NETWORKLOGINFO) (PROP (VARTYPE) CHAT.OSTYPES CHAT.HOSTINFO NETWORKLOGINFO CHAT.PROTOCOL.ABBREVS CHAT.PROTOCOLTYPES)) (COMS (* ; "CHAT streams") (FNS ADD.CHAT.MESSAGE CHAT.LOGINFO CHAT.SENDSCREENPARAMS CHAT.SETDISPLAYTYPE CHAT.FLUSH&WAIT CHAT.ENDOFSTREAMOP CHAT.OPTIONMENU)) (COMS (* ; "CHAT typeout") (FNS CHAT.TYPEOUT CHAT.TYPEOUT.CLOSE CHAT.DID.RESHAPE CHAT.SCREENPARAMS)) (COMS (* ; "window stuff") (FNS GETCHATWINDOW CHAT.BUTTONFN CHAT.HOLD CHAT.MENU CHAT.CLEAR.FROM.MENU CHAT.TAKE.INPUT CHAT.TAKE.INPUT1 DO.CHAT.OPTION CHAT.RECONNECT CHAT.RECONNECT.OFF CHAT.RESHAPEWINDOW CHAT.TTYENTRYFN CHAT.TTYEXITFN CHAT.TYPESCRIPT CHAT.TYPESCRIPT1 )) [COMS (* ; "for dialouts") (FNS CHAT.CHOOSE.PHONE.NUMBER) (INITVARS (CHAT.PHONE.NUMBER.MENU) (CHAT.PHONE.NUMBERS '(Other] (COMS (* ; "for EMACS") (FNS CHAT.EMACS.MOVE CHAT.SWITCH.EMACS) (VARIABLES CHAT.EMACSCOMMANDS)) (COMS (FNS CHAT.ICONFN) (BITMAPS TTYKBD TTYKBDMASK) (VARS TTYKBDICONSPECREGION) (INITVARS (TTYKBDICONSPEC))) (ADDVARS (CHATMENUITEMS)) (INITVARS (CHATMENU) (* ; "Cached menu variables") (CHAT.REOPENMENU) (CHAT.HOSTMENU) (CHATWINDOWLST) (CHAT.DRIVERTYPES) (CHATDEBUGFLG)) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T) (FILES (SOURCE) CHATDECLS) (RECORDS EMACSCOMMANDS) (GLOBALVARS CHATMENUITEMS)) (INITVARS (INVERTWINDOWFN 'INVERTW)) (COMS (FNS \SPAWN.CHAT) (DECLARE%: DONTEVAL@LOAD DOCOPY [ADDVARS (BackgroundMenuCommands ("Chat" '(\SPAWN.CHAT) "Runs a new CHAT process; prompts for host" (SUBITEMS ("No Login" '(\SPAWN.CHAT 'NONE) "Runs CHAT without doing automatic login" ] (P (SETQ BackgroundMenu)) (FILES DMCHAT) (* ;  "need DMCHAT since it's the default emulator") (INITRECORDS CHAT.STATE]) (* ; "CHAT typein") (DEFINEQ (CHAT (LAMBDA (HOST LOGOPTION INITSTREAM WINDOW FROMMENU) (* ; "Edited 15-Feb-90 11:34 by bvm") (LET (SUCCESS RESULT PROC) (if (AND (OR HOST (SETQ HOST (COND ((AND FROMMENU (OR CHAT.HOSTMENU (LET ((HOSTS CHAT.ALLHOSTS)) (if (AND DEFAULTCHATHOST (NOT (CL:MEMBER DEFAULTCHATHOST CHAT.ALLHOSTS :TEST (QUOTE STRING-EQUAL)))) then (SETQ HOSTS (SORT (CONS DEFAULTCHATHOST HOSTS) (FUNCTION UALPHORDER)))) (if HOSTS then (SETQ CHAT.HOSTMENU (create MENU ITEMS _ (APPEND HOSTS (QUOTE (Other))) TITLE _ "Host")))))) (* ; "From background menu, and there are some hosts to choose from, so offer menu") (MENU CHAT.HOSTMENU)) (DEFAULTCHATHOST) (T (* ; "No hosts, no default--fall thru and prompt user") (QUOTE Other))))) (OR (NEQ HOST (QUOTE Other)) (SETQ HOST (if FROMMENU then (* ; "Doing a mouse interaction") (CHAT.PROMPT.FOR.INPUT "Chat to host: " (AND WINDOW (GETPROMPTWINDOW WINDOW))) else (PROMPTFORWORD " Host: " NIL "Enter name of host to chat to, or to abort" NIL NIL (QUOTE TTY) (CHARCODE (CR))))))) then (* ; "Have a host--get the process started. Want to get this proc going as soon as possible so we can give it the tty") (SETQ PROC (ADD.PROCESS (BQUOTE (CHAT.STARTUP (QUOTE (\, HOST)) (QUOTE (\, LOGOPTION)) (QUOTE (\, INITSTREAM)) (QUOTE (\, WINDOW)) (QUOTE (\, FROMMENU)))) (QUOTE RESTARTABLE) (QUOTE NO))) (do (* ; "Wait for it to open or fail") (if (NOT (PROCESSP PROC)) then (RETURN (SETQ RESULT (PROCESS.RESULT PROC))) elseif (PROCESSPROP PROC (QUOTE CHAT.STARTUP)) then (RETURN (SETQ RESULT (SETQ SUCCESS HOST))) else (BLOCK 1000)))) (COND ((AND (NOT SUCCESS) WINDOW (WINDOWPROP WINDOW (QUOTE CHATHOST))) (* ; "Window not useable, let it reconnect") (WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN) (FUNCTION CHAT.RECONNECT)) (REMOVEPROMPTWINDOW WINDOW))) RESULT)) ) (CHAT.STARTUP [LAMBDA (HOST LOGOPTION INITSTREAM WINDOW FROMMENU) (* ; "Edited 9-Dec-92 12:30 by jds") (PROG (STREAMS RESULT OPENFN DISPLAYTYPE SLASH PROTOCOL) [COND ((OR FROMMENU CHAT.TTY.PROCESS) (* ;  "Grab tty right away, not when we finally get connected.") (TTY.PROCESS (THIS.PROCESS] [COND [[AND (SETQ SLASH (STRPOS "/" HOST)) (SETQ PROTOCOL (CDR (CL:ASSOC (SUBSTRING HOST (ADD1 SLASH)) CHAT.PROTOCOL.ABBREVS :TEST 'STRING-EQUAL] (* ;  "Caller explicitly specified protocol to use") (COND ([NOT (SETQ OPENFN (CDR (ASSOC PROTOCOL CHAT.PROTOCOLTYPES] (SETQ RESULT (CONCAT "The " PROTOCOL " Chat protocol is not loaded.")) (GO FAIL)) (T (SETQ HOST (SUBSTRING HOST 1 (SUB1 SLASH))) (SETQ OPENFN (CL:FUNCALL OPENFN HOST PROTOCOL)) (COND ((NOT OPENFN) (SETQ RESULT (CONCAT HOST " is not a recognized " PROTOCOL " host.")) (GO FAIL] ((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 PROTOCOL))) (* ; "use protocol that worked the last time. Clear PROTOCOL to skip the test below for remembering it") (SETQ PROTOCOL NIL)) (T (* ; "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 OPENFN] (COND ((NOT OPENFN) (* ;  "Don't know how to talk to this host") (SETQ RESULT (CONCAT "Unknown Chat host: " HOST)) (GO FAIL))) (SETQ HOST (CAR OPENFN)) (COND ((NOT (CL:MEMBER HOST CHAT.ALLHOSTS :TEST 'STRING-EQUAL)) (SETQ CHAT.ALLHOSTS (SORT (CONS HOST CHAT.ALLHOSTS) (FUNCTION UALPHORDER))) (SETQ CHAT.HOSTMENU))) (SETQ DISPLAYTYPE (CHAT.CHOOSE.EMULATOR HOST)) (* ;  "Do this first so openfn can see the terminal type") (COND ((NOT (SETQ STREAMS (CL:FUNCALL (CADR OPENFN) HOST (fetch (CHATDISPLAYTYPE DPYNAME) of DISPLAYTYPE) LOGOPTION))) (RETURN "Failed"))) [COND (PROTOCOL (* ;  "Remember protcol that worked for next time") (LET [(TEM (CL:ASSOC HOST CHAT.HOST.TO.PROTOCOL :TEST 'STRING-EQUAL] (COND (TEM (RPLACD TEM PROTOCOL)) (T (push CHAT.HOST.TO.PROTOCOL (CONS HOST PROTOCOL] (SETQ WINDOW (GETCHATWINDOW HOST WINDOW (fetch (CHATDISPLAYTYPE DPYNAME) of DISPLAYTYPE))) [COND ((LISTP (CDR STREAMS)) (* ; "(instream outstream . props)") [for TAIL on (CDDR STREAMS) by (CDDR TAIL) do (* ;  "Handle props. Only 1 interesting one right now.") (CASE (CAR TAIL) (LOGOPTION (SETQ LOGOPTION (CADR TAIL))))] (SETQ STREAMS (CONS (CAR STREAMS) (CADR STREAMS] (CHAT.INIT STREAMS WINDOW HOST DISPLAYTYPE) (LET [(PROC (THIS.PROCESS)) (STATE (WINDOWPROP WINDOW 'CHATSTATE] (PROCESSPROP PROC 'KEYACTION (SETQ \CURRENTKEYACTION (LET [(KEY (KEYACTIONTABLE \CURRENTKEYACTION)) (OSINFO (CDR (ASSOC (GETHOSTINFO HOST 'OSTYPE) CHAT.OSTYPES))) (HOSTINFO (CDR (CL:ASSOC HOST CHAT.HOSTINFO :TEST 'STRING-EQUAL] (for PAIR in (CURRENTINTERRUPTS KEY) when (<= (CAR PAIR) 255) do (INTCHAR (CAR PAIR) NIL NIL KEY)) (* ;  " turn off all interrupts in charset 0") (for INTERRUPTS in (LIST CHAT.INTERRUPTS (LISTGET OSINFO :INTERRUPTS) (LISTGET HOSTINFO :INTERRUPTS)) do (for PAIR in INTERRUPTS do (INTCHAR (CAR PAIR) NIL NIL KEY))) (for KEYACTIONS in (LIST CHAT.KEYACTIONS (LISTGET OSINFO :KEYACTIONS) (LISTGET HOSTINFO :KEYACTIONS)) do (for PAIR in KEYACTIONS do (KEYACTION (CAR PAIR) (CDR PAIR) KEY))) KEY))) (PROCESSPROP PROC 'NAME (CONCAT "CHAT#" HOST)) (PROCESSPROP PROC 'CHAT.STARTUP T) (* ;  "Signal success to CHAT, who's waiting for us to get going.") (PROCESSPROP PROC 'TTYENTRYFN (FUNCTION CHAT.TTYENTRYFN)) (PROCESSPROP PROC 'WINDOW WINDOW) (CLEARW WINDOW) (WINDOWPROP WINDOW 'PROCESS PROC) (WINDOWPROP WINDOW 'CHATHOST (CONS HOST LOGOPTION)) [PROCESSPROP PROC 'RESTARTFORM `(CHAT.TYPEIN ',HOST ',WINDOW 'HARDRESET] (* ; "In case of hard reset") (PROCESSPROP PROC 'RESTARTABLE 'HARDRESET) (* ; "We are now restartable") ) (RETURN (CHAT.TYPEIN HOST WINDOW LOGOPTION INITSTREAM)) FAIL (* ;; "Come here with RESULT set to description of failure") (COND (FROMMENU (printout (COND (WINDOW (GETPROMPTWINDOW WINDOW)) (T PROMPTWINDOW)) T RESULT))) (RETURN RESULT]) (CHAT.PROMPT.FOR.INPUT (LAMBDA (PROMPT WINDOW MINLENGTH) (* ; "Edited 15-Feb-90 14:51 by bvm") (* ;; "Prompt in WINDOW for a string. If WINDOW is NIL, pop up a one-line window, allowing at least space for MINLENGTH characters of input.") (RESETLST (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (RESETSAVE NIL (LIST (if WINDOW then (* ; "Just clear it now and when we're done") (CLEARW WINDOW) (FUNCTION CLEARW) else (* ; "Make our own and close it on way out") (SETQ WINDOW (LET ((FONT (DEFAULTFONT (QUOTE DISPLAY)))) (CREATEW (MAKEWITHINREGION (create REGION LEFT _ LASTMOUSEX BOTTOM _ LASTMOUSEY WIDTH _ (WIDTHIFWINDOW (+ (STRINGWIDTH PROMPT FONT) (TIMES (OR MINLENGTH 40) (CHARWIDTH (CHARCODE A) FONT)))) HEIGHT _ (HEIGHTIFWINDOW (FONTPROP FONT (QUOTE HEIGHT)))))))) (WINDOWPROP WINDOW (QUOTE PAGEFULLFN) (FUNCTION NILL)) (FUNCTION CLOSEW)) WINDOW)) (TTYINPROMPTFORWORD PROMPT NIL NIL WINDOW NIL NIL (CHARCODE (CR))))) ) (CHAT.CHOOSE.EMULATOR (LAMBDA (HOST) (* ; "Edited 25-Oct-89 17:42 by bvm") (* ;; "Returns a record of type CHATDISPLAYTYPE to be used for this session") (COND ((FIXP CHAT.DISPLAYTYPES) (COND (CHAT.EMULATORTYPE (create CHATDISPLAYTYPE HOST _ NIL DPYNAME _ CHAT.EMULATORTYPE DPYCODE _ CHAT.DISPLAYTYPES)))) ((LISTP CHAT.DISPLAYTYPES) (OR (CL:ASSOC HOST CHAT.DISPLAYTYPES :TEST (QUOTE STRING-EQUAL)) (FASSOC NIL CHAT.DISPLAYTYPES))) (T (ERROR "Please set CHAT.DISPLAYTYPES to be a list of (HOST TTY-TYPE-# EMULATORTYPE)") NIL))) ) (CHAT.SET.EMULATOR (LAMBDA (CHAT.STATE WINDOW NEWEMULATOR) (* ; "Edited 20-Mar-90 15:49 by bvm") (LET ((TYPEOUTPROC (fetch (CHAT.STATE TYPEOUTPROC) of CHAT.STATE)) INSTREAM) (COND (NEWEMULATOR (DEL.PROCESS TYPEOUTPROC) (CLEARW WINDOW) (replace (CHAT.STATE TERM.STATE) of CHAT.STATE with NIL) (LET ((OLDTITLE (WINDOWPROP WINDOW (QUOTE TITLE)))) (WINDOWPROP WINDOW (QUOTE TITLE) (CONCAT NEWEMULATOR (SUBSTRING OLDTITLE (STRPOS " " OLDTITLE))))) (replace (CHAT.STATE TYPEOUTPROC) of CHAT.STATE with (ADD.PROCESS (BQUOTE (CHAT.TYPEOUT (\, WINDOW) (QUOTE (\, NEWEMULATOR)) (QUOTE (\, CHAT.STATE)))))) (if (SETQ INSTREAM (fetch (CHAT.STATE INSTREAM) of CHAT.STATE)) then (* ; "Inform the host.") (CHAT.SETDISPLAYTYPE INSTREAM (for TRIPLE in CHAT.DISPLAYTYPES when (EQ (CADDR TRIPLE) NEWEMULATOR) do (* ; "This is kind of crufty, since we don't know in general what the right code is, so we just guess by taking a sample entry from here") (RETURN (CADR TRIPLE))) NEWEMULATOR)))))) ) (CHAT.INIT [LAMBDA (STREAMS WINDOW HOST DISPLAYTYPE) (* ; "Edited 11-Jun-90 14:37 by mitani") (LET* [(INSTREAM (CAR STREAMS)) (OUTSTREAM (CDR STREAMS)) (DPYNAME (fetch (CHATDISPLAYTYPE DPYNAME) of DISPLAYTYPE)) (STATE (create CHAT.STATE RUNNING? _ T CHATINEMACS _ CHAT.IN.EMACS? INSTREAM _ INSTREAM OUTSTREAM _ OUTSTREAM WINDOW _ WINDOW DSP _ (WINDOWPROP WINDOW 'DSP] (WINDOWPROP WINDOW 'CHATSTATE STATE) (COND [(EQ DPYNAME 'TEDIT) (replace (CHAT.STATE TEXTSTREAM) of STATE with (TEDITSTREAM.INIT WINDOW (FUNCTION TEDITCHAT.MENUFN] (T (WINDOWPROP WINDOW 'CURSORMOVEDFN NIL) (WINDOWPROP WINDOW 'RESHAPEFN (FUNCTION CHAT.RESHAPEWINDOW)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION CHAT.BUTTONFN)) (WINDOWPROP WINDOW 'REPAINTFN NIL) (WINDOWPROP WINDOW 'NEWREGIONFN NIL) (WINDOWPROP WINDOW 'WINDOWENTRYFN 'GIVE.TTY.PROCESS) (WINDOWPROP WINDOW 'RIGHTBUTTONFN NIL) (WINDOWPROP WINDOW 'CURSOROUTFN NIL) (WINDOWPROP WINDOW 'SCROLLFN NIL))) (WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION CHAT.CLOSEFN)) (WINDOWPROP WINDOW 'ICONWINDOW NIL) (WINDOWPROP WINDOW 'ICONFN (FUNCTION CHAT.ICONFN)) (STREAMPROP INSTREAM 'OLDEOSOP (fetch (STREAM ENDOFSTREAMOP) of INSTREAM)) (STREAMPROP INSTREAM 'DISPLAYTYPE DISPLAYTYPE) (replace (STREAM ENDOFSTREAMOP) of INSTREAM with (FUNCTION CHAT.ENDOFSTREAMOP]) (FIND.CHAT.PROTOCOL (LAMBDA (NAME) (* ; "Edited 15-Feb-90 15:00 by bvm") (* ;;; "Find a protocol for use by CHAT by calling the filter fns on CHAT.PROTOCOLS. The fns should return a CHAT.PROTOCOL that can be used to contact NAME or NIL.") (for PAIR in CHAT.PROTOCOLTYPES bind RESULT when (SETQ RESULT (CL:FUNCALL (CDR PAIR) NAME)) do (RETURN RESULT))) ) (CHAT.TYPEIN (LAMBDA (HOST WINDOW LOGOPTION INITSTREAM) (* ; "Edited 15-Feb-90 12:18 by bvm") (DECLARE (SPECVARS STREAM)) (* ; "so that menu can change it") (PROG* ((THISPROC (THIS.PROCESS)) (DEFAULTSTREAM T) (STATE (WINDOWPROP WINDOW (QUOTE CHATSTATE))) (CHATSTREAM (fetch (CHAT.STATE OUTSTREAM) of STATE)) (INSTREAM (fetch (CHAT.STATE INSTREAM) of STATE)) STREAM CH CHATPROMPTWINDOW LOCALECHOSTREAM) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (WINDOW) (AND RESETSTATE (NEQ RESETSTATE (QUOTE HARDRESET)) (CHAT.CLOSE WINDOW T)))) WINDOW)) (* ; "If an error occurs, or process is killed, this will flush the connection etc") (IF (NEQ LOGOPTION (QUOTE HARDRESET)) THEN (* ; "Only do this the first time") (LET ((DISPLAYTYPE (STREAMPROP INSTREAM (QUOTE DISPLAYTYPE))) DISPLAYNAME) (COND (DISPLAYTYPE (CHAT.SETDISPLAYTYPE INSTREAM (fetch (CHATDISPLAYTYPE DPYCODE) of DISPLAYTYPE) (SETQ DISPLAYNAME (fetch (CHATDISPLAYTYPE DPYNAME) of DISPLAYTYPE))))) (CHAT.SCREENPARAMS STATE INSTREAM WINDOW) (replace (CHAT.STATE TYPEOUTPROC) of STATE with (ADD.PROCESS (BQUOTE (CHAT.TYPEOUT (\, WINDOW) (QUOTE (\, DISPLAYNAME)) (QUOTE (\, STATE)))) (QUOTE NAME) (QUOTE CHAT.TYPEOUT) (QUOTE RESTARTABLE) (QUOTE HARDRESET))) (AND (NEQ LOGOPTION (QUOTE NONE)) (CHAT.LOGIN HOST LOGOPTION WINDOW STATE)) (COND (INITSTREAM (NLSETQ (SETQ STREAM (COND ((STRINGP INITSTREAM) (OPENSTRINGSTREAM INITSTREAM)) (T (OPENSTREAM INITSTREAM (QUOTE INPUT)))))))))) (TTYDISPLAYSTREAM WINDOW) (* ; "So that \TTYBACKGROUND flashes the caret where we expect") (bind OUTPUTSTREAM while (EQ (fetch (CHAT.STATE RUNNING?) of STATE) T) do (COND ((NULL STREAM) (SETQ STREAM DEFAULTSTREAM))) (SETQ OUTPUTSTREAM (if (fetch (CHAT.STATE LOCALECHO) of STATE) then (OR LOCALECHOSTREAM (SETQ LOCALECHOSTREAM (CL:MAKE-BROADCAST-STREAM CHATSTREAM (GETSTREAM WINDOW (QUOTE OUTPUT))))) else CHATSTREAM)) (COND ((EQ STREAM T) (* ;; "Handle terminal specially") (OR (TTY.PROCESSP) (\WAIT.FOR.TTY)) (COND ((\SYSBUFP) (do (SETQ CH (\GETKEY)) (COND ((<= CH \MAXTHINCHAR) (BOUT OUTPUTSTREAM CH)) ((EQ (LRSH CH 8) 1) (* ; "META char set => ascii meta") (BOUT OUTPUTSTREAM (LOGOR 128 (LOGAND CH 127)))) (T (* ; "Not in charset zero, not a meta. Most hosts don't understand.(PRINTCCODE CH CHATSTREAM) (CHARSET CHATSTREAM 0)") (FLASHWINDOW WINDOW))) repeatwhile (\SYSBUFP)) (FORCEOUTPUT CHATSTREAM)))) (T (until (EOFP STREAM) do (BOUT OUTPUTSTREAM (\BIN STREAM))) (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.BIN (LAMBDA (OUTSTREAM STATE) (* rda%: "20-Aug-84 23:09") (until (\SYSBUFP) bind (FIRSTTIME _ T) do (COND (FIRSTTIME (FORCEOUTPUT OUTSTREAM) (SETQ FIRSTTIME NIL))) (\TTYBACKGROUND)) (\GETKEY)) ) (CHAT.CLOSE (LAMBDA (WINDOW ABORTED CLOSING) (* lmm "24-Oct-86 16:39") (* ;; "Close chat connection that is using WINDOW. Also serves as the CLOSEFN of this window, when CLOSING is NIL") (DECLARE (GLOBALVARS HIGHLIGHTSHADE)) (PROG ((CHATSTATE (WINDOWPROP WINDOW (QUOTE CHATSTATE))) (ACTIVE? (OPENWP WINDOW)) ICON PROC FILE KEEP) (DETACHALLWINDOWS WINDOW) (* ; "Restore REPLACE mode for BITBLT") (DSPOPERATION (QUOTE REPLACE) WINDOW) (* ; "Turn scrolling back on") (DSPSCROLL (QUOTE ON) WINDOW) (COND (CHATSTATE (DEL.PROCESS (fetch (CHAT.STATE TYPEOUTPROC) of CHATSTATE)) (COND ((SETQ FILE (fetch (CHAT.STATE TYPESCRIPTSTREAM) of CHATSTATE)) (COND (ACTIVE? (TERPRI WINDOW) (PRIN1 "Closing " WINDOW) (PRINT (CLOSEF FILE) WINDOW)) (T (CLOSEF FILE))))) (AND ACTIVE? (\CHECKCARET WINDOW)) (replace (CHAT.STATE RUNNING?) of (WINDOWPROP WINDOW (QUOTE CHATSTATE) NIL) with NIL) (OR ABORTED (PROGN (ALLOW.BUTTON.EVENTS) (CHAT.CLOSE.CONNECTION (fetch (CHAT.STATE INSTREAM) of CHATSTATE) (fetch (CHAT.STATE OUTSTREAM) of CHATSTATE))))) (T (RETURN))) (SETQ CHATWINDOWLST (DREMOVE WINDOW CHATWINDOWLST)) (SETQ PROC (WINDOWPROP WINDOW (QUOTE PROCESS) NIL)) (* ;; "Save the process running, if any; don't do anything with it until after we close the window, if we're going to, so that windows don't flip around excessively") (WINDOWPROP WINDOW (QUOTE CLOSEFN) NIL) (* ; "Clear all CLOSE functions so that next time this chatwindow is reused it will be clean") (COND (ACTIVE? (* ; "Change title to indicate closure") (CHAT.DEACTIVATE.WINDOW WINDOW) (COND ((AND (NOT (SETQ KEEP (WINDOWPROP WINDOW (QUOTE KEEPCHAT) NIL))) (NOT CLOSING) (OR CLOSECHATWINDOWFLG (NEQ WINDOW CHATWINDOW))) (CLOSEW WINDOW))) (COND ((EQ KEEP (QUOTE NEW)) (* ; "Invoked via the New command -- start up a new connection in this window") (ADD.PROCESS (LIST (FUNCTION CHAT) NIL NIL NIL WINDOW T)))) (COND (PROC (* ; "Do this last, because if we are PROC, DEL.PROCESS won't return") (DEL.PROCESS PROC)))) ((AND (SETQ ICON (WINDOWPROP WINDOW (QUOTE ICONWINDOW))) (OPENWP ICON)) (* ; "Shade the icon if the chat window is currently closed") (ICONW.SHADE ICON HIGHLIGHTSHADE) (* ; "And arrange for middle-button to offer Reconnect option") (WINDOWPROP ICON (QUOTE OLDBUTTONEVENTFN) (WINDOWPROP ICON (QUOTE BUTTONEVENTFN) (FUNCTION CHAT.RECONNECT))))))) ) (CHAT.DEACTIVATE.WINDOW (LAMBDA (WINDOW) (* bvm%: " 4-Sep-85 19:41") (LET ((TITLE (WINDOWPROP WINDOW (QUOTE TITLE)))) (WINDOWPROP WINDOW (QUOTE TITLE) (CONCAT (SUBSTRING TITLE 1 (IPLUS (OR (STRPOS ", height" TITLE) 0) -1)) ", closed")) (WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN) (FUNCTION CHAT.RECONNECT)) (WINDOWPROP WINDOW (QUOTE EXPANDFN) NIL))) ) (CHAT.CLOSEFN (LAMBDA (WINDOW) (* lmm "24-Oct-86 16:39") (* ;; "Close this chat connection making sure that the window gets closed. Used as CLOSEFN of the chat window.") (CHAT.CLOSE WINDOW NIL T)) ) (CHAT.CLOSE.CONNECTION (LAMBDA (INSTREAM OUTSTREAM) (* rda%: "23-Aug-84 15:25") (* ;;; "Close the streams for a connection if they are open.") (COND ((OPENP INSTREAM) (CLOSEF INSTREAM))) (COND ((OPENP OUTSTREAM) (CLOSEF OUTSTREAM)))) ) (CHAT.LOGIN (LAMBDA (HOST OPTION WINDOW CHATSTATE) (* ; "Edited 9-Nov-89 14:02 by bvm") (* ;; "Login to HOST. If a job already exists on HOST, Attach to it unless OPTION overrides.") (PROG ((OSTYPE (GETOSTYPE HOST)) (LOGINFO (GETHOSTINFO HOST (QUOTE LOGINFO))) (STATE (WINDOWPROP WINDOW (QUOTE CHATSTATE))) NAME/PASS COM INSTREAM OUTSTREAM) (OR LOGINFO (RETURN)) (SETQ INSTREAM (fetch (CHAT.STATE INSTREAM) of STATE)) (SETQ COM (COND (OPTION) ((ASSOC (QUOTE ATTACH) LOGINFO) (OR (CHAT.LOGINFO INSTREAM HOST (CAR (SETQ NAME/PASS (\INTERNAL/GETPASSWORD HOST NIL NIL NIL NIL OSTYPE)))) (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 (SETQ OUTSTREAM (fetch (CHAT.STATE OUTSTREAM) of STATE)) (if (AND (SETQ LOGINFO (CDR LOGINFO)) (NULL NAME/PASS) (OR (FMEMB (QUOTE USERNAME) LOGINFO) (FMEMB (QUOTE PASSWORD) LOGINFO))) then (* ; "Don't ask for password until we know we need it") (SETQ NAME/PASS (\INTERNAL/GETPASSWORD HOST NIL NIL NIL NIL OSTYPE))) (for X in 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))))) ) ) (DEFGLOBALVAR CHAT.TTY.PROCESS T "If true, Chat always grabs the tty when it starts; if NIL, Chat only grabs tty when invoked by mouse command." ) (DEFGLOBALVAR CHAT.HOST.TO.PROTOCOL NIL "A-list of (host . protocol), giving preferred transport protocol (key in CHAT.PROTOCOLTYPES)") (DEFGLOBALVAR CHAT.HOSTINFO NIL "A-list of (host . proplist) for Chat. Only recognized prop for now is :KEYACTIONS.") (DEFGLOBALVAR CHAT.OSTYPES '([UNIX :KEYACTIONS ((BS (127 127] (* ;  "make the BS key send DEL when talking to UNIX hosts") ) "A-list of (host . proplist). Only recognized prop is :KEYACTIONS.") (DEFGLOBALVAR CHAT.PROTOCOL.ABBREVS NIL "A-list of (abbrev . protocol) for use in the host/x syntax.") (DEFGLOBALVAR CHAT.ALLHOSTS NIL "List of hosts to Chat to (clear CHAT.HOSTMENU if you change this).") (CL:DEFVAR CHAT.DISPLAYTYPES '((NIL 10 DM2500)) "List of triples (host code driver) telling the preferred driver (a symbol) for host. Code is numeric value for use with PupChat. Host = NIL gives default preference." ) (DEFGLOBALVAR CHAT.FONT NIL "Font to use in a Chat window (fixed-width is required for accurate terminal emulation)") (CL:DEFVAR CHAT.IN.EMACS? NIL "Initial state of Emacs feature on opening a connection.") (DEFGLOBALVAR CHAT.INTERRUPTS NIL "List of (charcode interrupt)'s of Lisp interrupts to leave enabled during Chat.") (DEFGLOBALVAR CHAT.KEYACTIONS NIL "List of (keyname . actions) to set during a chat connection (see also :KEYACTION property in CHAT.OSTYPES, CHAT.HOSTINFO)" ) (DEFGLOBALVAR CHAT.PROTOCOLTYPES NIL "List of (protocol . filterfn) describing possible Chat transport protocols.") (DEFGLOBALVAR CHAT.WAIT.TIME 2000 "Msecs to wait during the 'WAIT' part of a login") (DEFGLOBALVAR CHAT.WINDOW.REGION NIL "A Lisp region in which to create the first Chat window.") (DEFGLOBALVAR CHAT.WINDOW.SIZE NIL "A size (width . height) in pixels to use in prompting for Chat windows.") (DEFGLOBALVAR CHATWINDOW NIL "The default window to use for Chat connection") (DEFGLOBALVAR CLOSECHATWINDOWFLG NIL "If true, ALL chat windows, including the initial one, are closed on exit.") (DEFGLOBALVAR DEFAULTCHATHOST NIL "Where (CHAT) with no arguments chats to.") (DEFGLOBALVAR NETWORKLOGINFO [LIST '(TENEX (LOGIN "LOGIN " USERNAME " " PASSWORD " ") (ATTACH "ATTACH " USERNAME " " PASSWORD " ") (WHERE "WHERE " USERNAME CR "ATTACH " USERNAME " " PASSWORD CR)) (LIST 'TOPS20 '(LOGIN "LOGIN " USERNAME CR PASSWORD CR) (LIST 'ATTACH "ATTACH " 'USERNAME (MKSTRING #\Escape) 'CR 'PASSWORD 'CR) '(WHERE "LOGIN " USERNAME CR PASSWORD CR)) (* ;; "use LF when logging in to unix, as SUN OS 3.X telnet servers will only accept this (4.0 accepts either).") '(UNIX (LOGIN WAIT LF WAIT USERNAME LF WAIT PASSWORD LF)) '(IFS (LOGIN "Login " USERNAME " " PASSWORD CR) (ATTACH)) '(NS (LOGIN "Logon" CR USERNAME CR PASSWORD CR)) '(VMS (LOGIN USERNAME CR PASSWORD CR] "A-list of (ostype . loginfo), where loginfo is a plist specifying what to send for different logging commands: LOGIN, ATTACH, or WHERE. Each property value is a list of strings mixed with the symbols USERNAME, PASSWORD, WAIT, CR, LF." ) (PUTPROPS CHAT.OSTYPES VARTYPE ALIST) (PUTPROPS CHAT.HOSTINFO VARTYPE ALIST) (PUTPROPS NETWORKLOGINFO VARTYPE ALIST) (PUTPROPS CHAT.PROTOCOL.ABBREVS VARTYPE ALIST) (PUTPROPS CHAT.PROTOCOLTYPES VARTYPE ALIST) (* ; "CHAT streams") (DEFINEQ (ADD.CHAT.MESSAGE (LAMBDA (STREAM MSG) (* rda%: "22-Aug-84 18:07") (STREAMPROP STREAM (QUOTE MESSAGE) (CONCAT (OR (STREAMPROP STREAM (QUOTE MESSAGE)) "") MSG))) ) (CHAT.LOGINFO (LAMBDA (INSTREAM HOST NAME) (* ; "Edited 15-Feb-90 15:00 by bvm") (* ;;; "Invoke the LOGINFO method for INSTREAM, if any.") (LET ((FN (STREAMPROP INSTREAM (QUOTE LOGINFO)))) (COND (FN (CL:FUNCALL FN HOST NAME))))) ) (CHAT.SENDSCREENPARAMS (LAMBDA (INSTREAM HEIGHT WIDTH) (* ; "Edited 15-Feb-90 15:01 by bvm") (* ;;; "Invoke the SENDSCREENPARAMS method for INSTREAM, if any.") (LET ((FN (STREAMPROP INSTREAM (QUOTE SENDSCREENPARAMS)))) (AND FN (CL:FUNCALL FN INSTREAM HEIGHT WIDTH)))) ) (CHAT.SETDISPLAYTYPE (LAMBDA (INSTREAM CODE NAME) (* ; "Edited 14-Feb-90 14:49 by bvm") (* ;;; "Invoke the SETDISPLAYTYPE method for INSTREAM. CODE is a numeric code from CHAT.DISPLAYTYPES, NAME is the driver name") (LET ((FN (STREAMPROP INSTREAM (QUOTE SETDISPLAYTYPE)))) (AND FN (CL:FUNCALL FN INSTREAM CODE NAME)))) ) (CHAT.FLUSH&WAIT (LAMBDA (INSTREAM) (* ; "Edited 15-Feb-90 15:02 by bvm") (* ;;; "Invoke the FLUSH&WAIT method for INSTREAM") (LET ((FN (STREAMPROP INSTREAM (QUOTE FLUSH&WAIT)))) (AND FN (CL:FUNCALL FN INSTREAM)))) ) (CHAT.ENDOFSTREAMOP [LAMBDA (STREAM) (* ; "Edited 11-Jun-90 14:37 by mitani") (* ;;; "Return -1 to indicate EOS to CHAT, and restore the streams EOS op incase it's needed for other things.") (replace (STREAM ENDOFSTREAMOP) of STREAM with (OR (STREAMPROP STREAM 'EOSOP) (FUNCTION \EOSERROR))) -1]) (CHAT.OPTIONMENU (LAMBDA (INSTREAM) (* ejs%: "23-Jun-85 17:04") (* ;;; "Apply the menu-building method for INSTREAM, if any.") (LET* ((FN (STREAMPROP INSTREAM (QUOTE OPTIONMENU))) (MENU (COND ((FNTYP FN) (APPLY* FN INSTREAM)) ((type? MENU FN) FN)))) (AND MENU (fetch (MENU ITEMS) MENU)))) ) ) (* ; "CHAT typeout") (DEFINEQ (CHAT.TYPEOUT (LAMBDA (WINDOW DPYNAME CHAT.STATE) (* ; "Edited 12-Aug-88 10:35 by drc:") (bind (CNT _ 1) (HANDLECHARFN _ (CADR (FASSOC DPYNAME CHAT.DRIVERTYPES))) (INSTREAM _ (fetch (CHAT.STATE INSTREAM) of CHAT.STATE)) (TERM.STATE _ (FETCH (CHAT.STATE TERM.STATE) of CHAT.STATE)) (TYPEIN.PROCESS _ (WINDOWPROP WINDOW (QUOTE PROCESS))) (OUTSTREAM _ (COND ((EQ DPYNAME (QUOTE TEDIT)) (WINDOWPROP WINDOW (QUOTE TEXTSTREAM))) (T (WINDOWPROP WINDOW (QUOTE DSP))))) TYPESCRIPTSTREAM CRPENDING MSG CH first (IF (NOT TERM.STATE) THEN (* ; "First time, ask terminal to get itself set up") (replace (CHAT.STATE TERM.STATE) of CHAT.STATE with (SETQ TERM.STATE (CL:FUNCALL (CADDR (FASSOC DPYNAME CHAT.DRIVERTYPES)) CHAT.STATE)))) (* ; "TERM.HOME CHAT.STATE") while (IGEQ (SETQ CH (BIN INSTREAM)) 0) do (while (fetch (CHAT.STATE HELD) of CHAT.STATE) do (BLOCK)) (\CHECKCARET OUTSTREAM) (COND ((SETQ MSG (GETSTREAMPROP INSTREAM (QUOTE MESSAGE))) (PRIN1 MSG OUTSTREAM) (PUTSTREAMPROP INSTREAM (QUOTE MESSAGE) NIL))) (* ; "Print any protocol related msgs that might have come along while we where asleep") (SPREADAPPLY* HANDLECHARFN (SETQ CH (LOGAND CH (MASK.1'S 0 7))) 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 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))))) (COND ((AND (TTY.PROCESSP TYPEIN.PROCESS) (OR \LONGSYSBUF (NEQ 0 (fetch (RING READ) of \SYSBUFFER)))) (* ;; "block if there's any type ahead to make sure we see keyboard input in case the output stream never blocks.") (BLOCK))) finally (SELECTQ CH (-1 (CHAT.TYPEOUT.CLOSE WINDOW OUTSTREAM CHAT.STATE (QUOTE CLOSE) "closed")) (-2 (CHAT.TYPEOUT.CLOSE WINDOW OUTSTREAM CHAT.STATE (QUOTE ABORT) "aborted")) (CHAT.TYPEOUT.CLOSE WINDOW OUTSTREAM CHAT.STATE (QUOTE CLOSE) "closed somehow")) (COND ((NOT (OPENWP WINDOW)) (DEL.PROCESS (WINDOWPROP WINDOW (QUOTE PROCESS))))))) ) (CHAT.TYPEOUT.CLOSE (LAMBDA (WINDOW OUTSTREAM CHAT.STATE NEWSTATE MSG) (* ; "Edited 9-Nov-89 14:55 by bvm") (COND ((OPENWP WINDOW) (printout OUTSTREAM T "[Connection " MSG " by remote host]" T))) (replace (CHAT.STATE RUNNING?) of CHAT.STATE with NEWSTATE) (LET ((CHATPROC (WINDOWPROP WINDOW (QUOTE PROCESS)))) (if (AND CHATPROC (NOT (TTY.PROCESSP CHATPROC))) then (* ;; "Ordinarily, typein process notices that we've closed and will gracefully clean up, but currently it's hung waiting for tty. I could give it the tty explicitly, but that might disrupt the user's typing to some other process right now, especially if (tty.process t) chooses not to give it back to the same place. So we'll just explicitly kill it (it does have a cleanup form to handle closing the window, etc).") (DEL.PROCESS CHATPROC)))) ) (CHAT.DID.RESHAPE (LAMBDA (CHAT.STATE) (DECLARE (USEDFREE INSTREAM DSP)) (* ejs%: "12-May-85 15:23") (* ;; "Invoked in the type-out process when window is reshaped") (with CHAT.STATE CHAT.STATE (CHAT.SCREENPARAMS CHAT.STATE INSTREAM DSP) (TERM.RESET.DISPLAY.PARMS CHAT.STATE))) ) (CHAT.SCREENPARAMS (LAMBDA (CHAT.STATE INSTREAM WINDOW) (* ejs%: "12-May-85 15:51") (* ;;; "Sends screen width, height to partner and updates title. If INSTREAM is NIL then only update title.") (PROG ((HEIGHT (IMIN (IQUOTIENT (WINDOWPROP WINDOW (QUOTE HEIGHT)) (IABS (DSPLINEFEED NIL (WINDOWPROP WINDOW (QUOTE DSP))))) 127)) (WIDTH (IMIN (LINELENGTH NIL WINDOW) 127)) (TITLE (WINDOWPROP WINDOW (QUOTE TITLE))) EMACSMODE TITLEMIDDLE) (COND (INSTREAM (CHAT.SENDSCREENPARAMS INSTREAM HEIGHT WIDTH))) (WINDOWPROP WINDOW (QUOTE 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 "")))))) ) ) (* ; "window stuff") (DEFINEQ (GETCHATWINDOW (LAMBDA (HOST WINDOW DPYTYPE) (* bvm%: " 5-Sep-85 12:04") (* ;; "Return a window, possibly new, to run a chat connection to HOST. Uses WINDOW if possible") (PROG ((TITLE (CONCAT (L-CASE DPYTYPE T) " Chat connection to " HOST)) DSP STATE) (COND ((AND (OR (WINDOWP WINDOW) (WINDOWP (SETQ WINDOW CHATWINDOW))) (OR (NOT (SETQ STATE (WINDOWPROP WINDOW (QUOTE CHATSTATE)))) (COND ((NOT (fetch (CHAT.STATE RUNNING?) of STATE)) (* ; "Connection in CHATWINDOW is dead") (CHAT.CLOSE WINDOW NIL T) T)))) (* ; "Old window not in use. This shouldn't happen, but...") (WINDOWPROP WINDOW (QUOTE TITLE) TITLE) (SETQ DSP (WINDOWPROP WINDOW (QUOTE DSP)))) (T (SETQ DSP (WINDOWPROP (SETQ WINDOW (LET ((SIZE (LISTP CHAT.WINDOW.SIZE))) (DECODE.WINDOW.ARG (AND (NULL CHATWINDOWLST) CHAT.WINDOW.REGION) (CAR SIZE) (CDR SIZE) TITLE))) (QUOTE DSP))) (DSPSCROLL T DSP) (OR CHATWINDOW (SETQ CHATWINDOW WINDOW)))) (push CHATWINDOWLST WINDOW) (RETURN WINDOW))) ) (CHAT.BUTTONFN (LAMBDA (WINDOW) (* ejs%: "12-May-85 17:59") (COND ((LASTMOUSESTATE LEFT) (PROG (CHAT.STATE CHAT.PROC) (COND ((AND (SETQ CHAT.STATE (WINDOWPROP WINDOW (QUOTE CHATSTATE))) (fetch (CHAT.STATE CHATINEMACS) of CHAT.STATE) (SETQ CHAT.PROC (fetch (CHAT.STATE TYPEOUTPROC) of CHAT.STATE))) (PROCESS.APPLY CHAT.PROC (FUNCTION CHAT.EMACS.MOVE) (LIST CHAT.STATE))) (T (CHAT.HOLD WINDOW))))) ((LASTMOUSESTATE MIDDLE) (CHAT.MENU WINDOW)))) ) (CHAT.HOLD (LAMBDA (WINDOW) (* ejs%: "12-May-85 16:33") (* ;;; "Toggle HOLD while button is down") (PROG ((STATE (WINDOWPROP WINDOW (QUOTE CHATSTATE)))) (TOTOPW WINDOW) (OR STATE (RETURN)) (COND ((NOT (fetch (CHAT.STATE HELD) of STATE)) (replace (CHAT.STATE HELD) of STATE with T) (UNINTERRUPTABLY (UNTILMOUSESTATE UP)))) (replace (CHAT.STATE HELD) of STATE with NIL))) ) (CHAT.MENU (LAMBDA (WINDOW) (* lmm "20-Oct-86 18:03") (DECLARE (GLOBALVARS CHATMENU CHAT.REOPENMENU) (SPECVARS WINDOW STATE)) (* ; "Called by MIDDLE") (PROG ((STATE (WINDOWPROP WINDOW (QUOTE 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 (create MENU ITEMS _ (APPEND CHATMENUITEMS (AND (CDR CHAT.DRIVERTYPES) (for X in CHAT.DRIVERTYPES collect (BQUOTE ((\, (CONCAT (CAR X) " Mode")) (QUOTE (LAMBDA (STATE WINDOW) (CHAT.SET.EMULATOR STATE WINDOW (QUOTE (\, (CAR X)))))))))) (STREAMPROP (fetch (CHAT.STATE INSTREAM) of STATE) (QUOTE OPTIONS)) (if (fetch (CHAT.STATE LOCALECHO) of STATE) then (QUOTE (("Local Echo OFF" (QUOTE ECHO) "Turn off local echoing"))) else (QUOTE (("Local Echo ON" (QUOTE ECHO) "Turn on local echoing")))) (QUOTE ((Close (QUOTE Close) "Closes the connection and returns") (Suspend (QUOTE Suspend) "Closes the connection but leaves window up") (New (QUOTE New) "Closes this connection and prompts for a new host") (Freeze (QUOTE Freeze) "Holds typeout in this window until you bug it again") (Clear (FUNCTION CHAT.CLEAR.FROM.MENU) "Clears window, sets roll mode") ("Dribble" (FUNCTION CHAT.TYPESCRIPT) "Starts a typescript of window typeout") ("Input" (FUNCTION CHAT.TAKE.INPUT) "Allows input from a file") ("Emacs" (FUNCTION CHAT.SWITCH.EMACS) "Toggle EMACS positioning"))))))) (ECHO (replace (CHAT.STATE LOCALECHO) of STATE with (NOT (fetch (CHAT.STATE LOCALECHO) of STATE)))) (Close (replace (CHAT.STATE RUNNING?) of STATE with (QUOTE CLOSE)) (* ; "Ask CHAT.TYPEIN to shut things down.")) (New (replace (CHAT.STATE RUNNING?) of STATE with (QUOTE CLOSE)) (WINDOWPROP WINDOW (QUOTE KEEPCHAT) (QUOTE NEW))) (Suspend (replace (CHAT.STATE RUNNING?) of STATE with (QUOTE CLOSE)) (WINDOWPROP WINDOW (QUOTE KEEPCHAT) T)) (Freeze (* ; "Leave in HELD state") (RETURN)) (NIL) (APPLY* COMMAND STATE WINDOW)) (replace (CHAT.STATE HELD) of STATE with NIL))) ) (CHAT.CLEAR.FROM.MENU (LAMBDA (STATE WINDOW) (* ; "Edited 15-Feb-90 18:43 by bvm") (CLEARW WINDOW) (TERM.RESET.DISPLAY.PARMS STATE) (TERM.HOME STATE)) ) (CHAT.TAKE.INPUT (LAMBDA (STATE WINDOW) (* bvm%: " 1-Jun-84 17:43") (PROCESS.APPLY (WINDOWPROP WINDOW (QUOTE PROCESS)) (FUNCTION CHAT.TAKE.INPUT1) (LIST WINDOW))) ) (CHAT.TAKE.INPUT1 (LAMBDA (WINDOW) (* ; "Edited 4-Dec-86 22:53 by lmm") (DECLARE (USEDFREE STREAM)) (* ; "In CHAT.TYPEIN") (PROG ((PWINDOW (GETPROMPTWINDOW WINDOW)) FILE) (CLEARW PWINDOW) (COND ((AND STREAM (NEQ STREAM T)) (printout PWINDOW "Can't, still reading " (FULLNAME STREAM))) (T (SETQ FILE (PROMPTFORWORD "Take input from file (cr to return): " NIL NIL PWINDOW)) (LET ((*LAST-CONDITION* NIL)) (COND ((NULL FILE) (CLEARW)) ((NLSETQ (SETQ FILE (OPENSTREAM FILE (QUOTE INPUT)))) (CLEARW PWINDOW) (printout PWINDOW "Reading " (FULLNAME (SETQ STREAM FILE)))) (T (CLEARW PWINDOW) (PRIN1 *LAST-CONDITION* PWINDOW)))))))) ) (DO.CHAT.OPTION (LAMBDA (CHAT.STATE WINDOW) (* ejs%: "12-May-85 15:52") (* ;;; "Pop up a menu of protocol specific options.") (PROG ((MENU (CHAT.OPTIONMENU (fetch (CHAT.STATE INSTREAM) of CHAT.STATE)))) (COND (MENU (MENU MENU)) (T (printout PROMPTWINDOW "This protocol has no options."))))) ) (CHAT.RECONNECT (LAMBDA (WINDOW) (* bvm%: " 4-Sep-85 19:52") (LET* ((MAINW (OR (WINDOWPROP WINDOW (QUOTE ICONFOR)) WINDOW)) (STATE (WINDOWPROP MAINW (QUOTE CHATHOST))) FN) (COND ((NULL STATE) (APPLY* (CHAT.RECONNECT.OFF WINDOW) WINDOW)) ((NOT (LASTMOUSESTATE MIDDLE)) (APPLY* (OR (WINDOWPROP WINDOW (QUOTE OLDBUTTONEVENTFN)) (FUNCTION TOTOPW)) WINDOW)) ((MENU (OR CHAT.REOPENMENU (SETQ CHAT.REOPENMENU (create MENU ITEMS _ (QUOTE ((ReConnect T "Will reestablish this Chat connection"))))))) (CHAT.RECONNECT.OFF WINDOW) (* ; "Don't let this command get issued twice") (TTY.PROCESS (ADD.PROCESS (LIST (QUOTE CHAT) (KWOTE (CAR STATE)) (KWOTE (CDR STATE)) NIL MAINW T))))))) ) (CHAT.RECONNECT.OFF (LAMBDA (WINDOW) (* bvm%: " 4-Sep-85 19:51") (* ;;; "Removes CHAT.RECONNECT as the buttonfn for WINDOW and returns new buttonfn") (LET ((FN (OR (WINDOWPROP WINDOW (QUOTE OLDBUTTONEVENTFN) NIL) (FUNCTION TOTOPW)))) (WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN) FN) FN)) ) (CHAT.RESHAPEWINDOW (LAMBDA (WINDOW OLDIMAGE IMAGEREGION OLDSCREENREGION) (* ejs%: "14-Jun-85 15:08") (* ;; "RESHAPEFN for the chat window") (RESHAPEBYREPAINTFN WINDOW OLDIMAGE IMAGEREGION) (* ;; "Note: Don't pass OLDSCREENREGION to RESHAPEBYREPAINTFN or it may try to leave the image fixed and move the coordinate system. Our code assumes that the bottom of the window is zero. If someone gets ambitious, can figure out how to change the rest of Chat code so it does not make that assumption") (LET* ((CHAT.STATE (WINDOWPROP WINDOW (QUOTE CHATSTATE))) (CHAT.PROC (AND CHAT.STATE (fetch (CHAT.STATE TYPEOUTPROC) of CHAT.STATE)))) (COND ((AND (PROCESSP CHAT.PROC) (NOT (RELPROCESSP CHAT.PROC))) (PROCESS.APPLY CHAT.PROC (FUNCTION CHAT.DID.RESHAPE) (LIST CHAT.STATE)))))) ) (CHAT.TTYENTRYFN (LAMBDA (PROCESS) (* lmm "14-Oct-86 11:28") (PROG ((WINDOW (PROCESSPROP PROCESS (QUOTE WINDOW))) STATE) (COND ((AND WINDOW (SETQ STATE (WINDOWPROP WINDOW (QUOTE CHATSTATE)))) (replace (CHAT.STATE HELD) of STATE with NIL))))) ) (CHAT.TTYEXITFN (LAMBDA (PROCESS NEWPROCESS) (* lmm "14-Oct-86 11:26") NIL)) (CHAT.TYPESCRIPT (LAMBDA (STATE) (* ejs%: "12-May-85 16:08") (PROG ((PROC (fetch (CHAT.STATE TYPEOUTPROC) of STATE))) (COND (PROC (PROCESS.APPLY PROC (FUNCTION CHAT.TYPESCRIPT1) (LIST STATE)))))) ) (CHAT.TYPESCRIPT1 (LAMBDA (CHAT.STATE) (* ; "Edited 15-Feb-90 14:51 by bvm") (* ;; "Called in context of type-out proc to change the dribble file") (with CHAT.STATE CHAT.STATE (LET ((PWINDOW (GETPROMPTWINDOW WINDOW)) FILE OLDFILE) (if (NOT (STRING-EQUAL (SETQ FILE (CHAT.PROMPT.FOR.INPUT "Typescript to file (cr to close): " PWINDOW)) T)) then (COND ((OR (NULL FILE) (NLSETQ (SETQ FILE (OPENSTREAM FILE (QUOTE OUTPUT) (QUOTE NEW))))) (COND (TYPESCRIPTSTREAM (printout PWINDOW (CLOSEF TYPESCRIPTSTREAM) " closed. "))) (replace TYPESCRIPTSTREAM of CHAT.STATE with (SETQ TYPESCRIPTSTREAM FILE)) (AND FILE (printout PWINDOW "Opened " (FULLNAME FILE)))) (T (printout PWINDOW "Could not open " FILE))))))) ) ) (* ; "for dialouts") (DEFINEQ (CHAT.CHOOSE.PHONE.NUMBER (LAMBDA NIL (* ; "Edited 15-Feb-90 14:58 by bvm") (* ;; "Prompt user for phone number") (DECLARE (GLOBALVARS CHAT.PHONE.NUMBER.MENU CHAT.PHONE.NUMBERS)) (LET ((NUMBER (COND ((CDR CHAT.PHONE.NUMBERS) (MENU (OR CHAT.PHONE.NUMBER.MENU (SETQ CHAT.PHONE.NUMBER.MENU (create MENU ITEMS _ CHAT.PHONE.NUMBERS TITLE _ "Phone Number "))))) (T (QUOTE Other)))) NEWNUMBER) (COND ((NEQ NUMBER (QUOTE Other)) NUMBER) ((SETQ NUMBER (CHAT.PROMPT.FOR.INPUT "Please enter a phone number in the form (800)555-1212: " 16)) (push CHAT.PHONE.NUMBERS (LIST NUMBER (SETQ NEWNUMBER (CONCATCODES (for CHAR in (CHCON NUMBER) collect CHAR when (AND (IGEQ CHAR (CHARCODE 0)) (ILEQ CHAR (CHARCODE 9)))))))) (SETQ CHAT.PHONE.NUMBER.MENU NIL) NEWNUMBER)))) ) ) (RPAQ? CHAT.PHONE.NUMBER.MENU ) (RPAQ? CHAT.PHONE.NUMBERS '(Other)) (* ; "for EMACS") (DEFINEQ (CHAT.EMACS.MOVE (LAMBDA (CHAT.STATE) (* ejs%: "12-May-85 15:44") (* ;;; "This function is invoked in the context of the typeout process, so that we can easily see where we are on the display, and so that we don't hang up the mouse if connection gets in trouble") (with CHAT.STATE CHAT.STATE (PROG ((CLOC (CURSORPOSITION NIL WINDOW)) DROW CCOLUMN) (* ;; "The characters are FONTHEIGHT high by FONTWIDTH wide") (COND ((IGEQ XPOS FONTWIDTH) (* ; "Go back to column 0") (BOUT OUTSTREAM (fetch EMCOL0 of CHAT.EMACSCOMMANDS)))) (SETQ DROW (IDIFFERENCE (IQUOTIENT YPOS FONTHEIGHT) (IQUOTIENT (fetch YCOORD of CLOC) FONTHEIGHT))) (* ;; "Positive DROW means go DOWN") (COND ((ILESSP DROW 0) (* ; "Go up DROW rows") (COND ((NEQ DROW -1) (BOUT OUTSTREAM (fetch EMARG of CHAT.EMACSCOMMANDS)) (PRIN3 (MKSTRING (IMINUS DROW)) OUTSTREAM))) (BOUT OUTSTREAM (fetch EMUP of CHAT.EMACSCOMMANDS))) ((IGREATERP DROW 0) (* ; "Go down DROW rows") (COND ((NEQ DROW 1) (BOUT OUTSTREAM (fetch EMARG of CHAT.EMACSCOMMANDS)) (PRIN3 (MKSTRING DROW) OUTSTREAM))) (BOUT OUTSTREAM (fetch EMDOWN of CHAT.EMACSCOMMANDS)))) (SETQ CCOLUMN (IQUOTIENT (fetch XCOORD of CLOC) FONTWIDTH)) (COND ((IGREATERP CCOLUMN 0) (* ; "Now go to the correct column") (COND ((NEQ CCOLUMN 1) (BOUT OUTSTREAM (fetch EMARG of CHAT.EMACSCOMMANDS)) (PRIN3 (MKSTRING CCOLUMN) OUTSTREAM))) (BOUT OUTSTREAM (fetch EMFORWARD of CHAT.EMACSCOMMANDS)))) (FORCEOUTPUT OUTSTREAM)))) ) (CHAT.SWITCH.EMACS (LAMBDA (CHATSTATE WINDOW) (* ejs%: "12-May-85 17:05") (* ;;; "Toggles the value of CHAT.IN.EMACS?") (replace (CHAT.STATE CHATINEMACS) of CHATSTATE with (NOT (fetch (CHAT.STATE CHATINEMACS) of CHATSTATE))) (* ; "Now update title to show Emacs state") (CHAT.SCREENPARAMS CHATSTATE NIL WINDOW)) ) ) (DEFGLOBALVAR CHAT.EMACSCOMMANDS '(21 16 14 6 1) "List of 5 character codes that perform Emacs functions Arg, Up 1 Line, Down 1 Line, Forward Character, Beginning of Line" ) (DEFINEQ (CHAT.ICONFN (LAMBDA (WINDOW OLDICON) (* bvm%: " 4-Sep-85 19:23") (DECLARE (GLOBALVARS TTYKBDICONSPEC TTYKBD TTYKBDMASK TTYKBDICONSPECREGION)) (COND ((TTY.PROCESSP (WINDOWPROP WINDOW (QUOTE PROCESS))) (TTY.PROCESS T))) (COND ((FNTYP (QUOTE TITLEDICONW)) (OR OLDICON (TITLEDICONW (OR TTYKBDICONSPEC (SETQ TTYKBDICONSPEC (create TITLEDICON ICON _ TTYKBD MASK _ TTYKBDMASK TITLEREG _ TTYKBDICONSPECREGION))) (CAR (WINDOWPROP WINDOW (QUOTE CHATHOST))) (FONTCREATE (QUOTE HELVETICA) 8)))))) ) ) (RPAQQ TTYKBD #*(64 64)@@@OOOOOOOOOO@@@@@AOOOOOOOOOOH@@@@COOOOOOOOOOL@@@@CH@@@@@@@@CL@@@@CH@@@@@@@@AL@@@@CHOOOOOOOOAL@@@@CIOOOOOOOOIL@@@@CIH@@@@@@AIL@@@@CIH@@@@@@AIL@@@@CIH@@@@@@AIL@@@@CIH@@@@@@AIL@@@@CIHAIBBGLAIL@@@@CIHBEBEA@AIL@@@@CIHBABEA@AIL@@@@CIHBANGA@AIL@@@@CIHBABHI@AIL@@@@CIHBEBHI@AIL@@@@CIHAIBHI@AIL@@@@CIH@@@@@@AIL@@@@CIH@@@@@@AIL@@@@CIH@@@@@@AIL@@@@CIH@@@@@@AIL@@@@CIH@@@@@@AIL@@@@CIH@@@@@@AIL@@@@CIOOOOOOOOIL@@@@CHOOOOOOOOAL@@@@OH@@@@@@@@AO@@@AOH@@@@@@@@AOH@@CL@@@@@@@@@@CL@@GHGCILNGCILNAN@@O@@@@@@@@@@@@O@ANALNGCILNGCILGHCL@@@@@@@@@@@@CLGHFGCILNGCILNGANO@@@@@@@@@@@@@@ON@@@@@@@@@@@@@@GN@@@@@@@@@@@@@@GOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOLGOOOOOOOOOOOOOONOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@ON@@@@@@@@@@@@@@GN@@@@@@@@@@@@@@GN@@@@@@@@@@@@@@GN@@@@@@@@@@@@@@GN@@@@@@@@@@@@@@GN@@@@@@@@@@@@@@GN@@@@@@@@@@@@@@GN@@@@@@@@@@@@@@GN@@@@@@@@@@@@@@GN@@@@@@@@@@@@@@GN@@@@@@@@@@@@@@GN@@@@@@@@@@@@@@GO@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOGOOOOOOOOOOOOOONCOOOOOOOOOOOOOOL ) (RPAQQ TTYKBDMASK #*(64 64)@@@OOOOOOOOOO@@@@@AOOOOOOOOOOH@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@COOOOOOOOOOL@@@@OOOOOOOOOOOO@@@AOOOOOOOOOOOOH@@COOOOOOOOOOOOL@@GOOOOOOOOOOOON@@OOOOOOOOOOOOOO@AOOOOOOOOOOOOOOHCOOOOOOOOOOOOOOLGOOOOOOOOOOOOOONOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOLGOOOOOOOOOOOOOONOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOGOOOOOOOOOOOOOONCOOOOOOOOOOOOOOL ) (RPAQQ TTYKBDICONSPECREGION (4 3 56 14)) (RPAQ? TTYKBDICONSPEC ) (ADDTOVAR CHATMENUITEMS ) (RPAQ? CHATMENU ) (RPAQ? CHAT.REOPENMENU ) (RPAQ? CHAT.HOSTMENU ) (RPAQ? CHATWINDOWLST ) (RPAQ? CHAT.DRIVERTYPES ) (RPAQ? CHATDEBUGFLG ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (FILESLOAD (SOURCE) CHATDECLS) (DECLARE%: EVAL@COMPILE (RECORD EMACSCOMMANDS (EMARG EMUP EMDOWN EMFORWARD EMCOL0)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CHATMENUITEMS) ) ) (RPAQ? INVERTWINDOWFN 'INVERTW) (DEFINEQ (\SPAWN.CHAT (LAMBDA (LOGOPTION) (* ; "Edited 25-May-88 16:20 by bvm") (* ;; "From the Background Menu, runs CHAT as a process") (ADD.PROCESS (BQUOTE (CHAT NIL (QUOTE (\, LOGOPTION)) NIL NIL T)))) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDTOVAR BackgroundMenuCommands ("Chat" '(\SPAWN.CHAT) "Runs a new CHAT process; prompts for host" (SUBITEMS ("No Login" '(\SPAWN.CHAT 'NONE) "Runs CHAT without doing automatic login" )))) (SETQ BackgroundMenu) (FILESLOAD DMCHAT) (/DECLAREDATATYPE 'CHAT.STATE '(FLAG FLAG FLAG FLAG FLAG FLAG (BITS 1) POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((CHAT.STATE 0 (FLAGBITS . 0)) (CHAT.STATE 0 (FLAGBITS . 16)) (CHAT.STATE 0 (FLAGBITS . 32)) (CHAT.STATE 0 (FLAGBITS . 48)) (CHAT.STATE 0 (FLAGBITS . 64)) (CHAT.STATE 0 (FLAGBITS . 80)) (CHAT.STATE 0 (BITS . 96)) (CHAT.STATE 2 POINTER) (CHAT.STATE 4 POINTER) (CHAT.STATE 6 POINTER) (CHAT.STATE 8 POINTER) (CHAT.STATE 10 POINTER) (CHAT.STATE 12 POINTER) (CHAT.STATE 1 (BITS . 15)) (CHAT.STATE 14 (BITS . 15)) (CHAT.STATE 15 (BITS . 15)) (CHAT.STATE 16 (BITS . 15)) (CHAT.STATE 17 (BITS . 15)) (CHAT.STATE 18 (BITS . 15)) (CHAT.STATE 19 (BITS . 15)) (CHAT.STATE 20 (BITS . 15)) (CHAT.STATE 21 (BITS . 15)) (CHAT.STATE 22 POINTER) (CHAT.STATE 24 POINTER) (CHAT.STATE 26 POINTER) (CHAT.STATE 28 POINTER) (CHAT.STATE 30 POINTER) (CHAT.STATE 32 POINTER) (CHAT.STATE 34 POINTER) (CHAT.STATE 36 POINTER) (CHAT.STATE 38 POINTER) (CHAT.STATE 40 POINTER) (CHAT.STATE 42 POINTER) (CHAT.STATE 44 POINTER)) '46) ) (PUTPROPS CHAT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1989 1990 1992 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4424 27453 (CHAT 4434 . 6212) (CHAT.STARTUP 6214 . 14801) (CHAT.PROMPT.FOR.INPUT 14803 . 15726) (CHAT.CHOOSE.EMULATOR 15728 . 16259) (CHAT.SET.EMULATOR 16261 . 17240) (CHAT.INIT 17242 . 19217) (FIND.CHAT.PROTOCOL 19219 . 19577) (CHAT.TYPEIN 19579 . 22480) (CHAT.BIN 22482 . 22686) ( CHAT.CLOSE 22688 . 24999) (CHAT.DEACTIVATE.WINDOW 25001 . 25353) (CHAT.CLOSEFN 25355 . 25558) ( CHAT.CLOSE.CONNECTION 25560 . 25799) (CHAT.LOGIN 25801 . 27451)) (31396 33372 (ADD.CHAT.MESSAGE 31406 . 31572) (CHAT.LOGINFO 31574 . 31808) (CHAT.SENDSCREENPARAMS 31810 . 32083) (CHAT.SETDISPLAYTYPE 32085 . 32410) (CHAT.FLUSH&WAIT 32412 . 32632) (CHAT.ENDOFSTREAMOP 32634 . 33074) (CHAT.OPTIONMENU 33076 . 33370)) (33402 37669 (CHAT.TYPEOUT 33412 . 35706) (CHAT.TYPEOUT.CLOSE 35708 . 36524) ( CHAT.DID.RESHAPE 36526 . 36809) (CHAT.SCREENPARAMS 36811 . 37667)) (37699 45838 (GETCHATWINDOW 37709 . 38663) (CHAT.BUTTONFN 38665 . 39113) (CHAT.HOLD 39115 . 39490) (CHAT.MENU 39492 . 41589) ( CHAT.CLEAR.FROM.MENU 41591 . 41747) (CHAT.TAKE.INPUT 41749 . 41917) (CHAT.TAKE.INPUT1 41919 . 42548) ( DO.CHAT.OPTION 42550 . 42846) (CHAT.RECONNECT 42848 . 43524) (CHAT.RECONNECT.OFF 43526 . 43815) ( CHAT.RESHAPEWINDOW 43817 . 44594) (CHAT.TTYENTRYFN 44596 . 44843) (CHAT.TTYEXITFN 44845 . 44925) ( CHAT.TYPESCRIPT 44927 . 45128) (CHAT.TYPESCRIPT1 45130 . 45836)) (45868 46637 ( CHAT.CHOOSE.PHONE.NUMBER 45878 . 46635)) (46742 48495 (CHAT.EMACS.MOVE 46752 . 48174) ( CHAT.SWITCH.EMACS 48176 . 48493)) (48712 49215 (CHAT.ICONFN 48722 . 49213)) (51928 52142 (\SPAWN.CHAT 51938 . 52140))))) STOP \ No newline at end of file diff --git a/library/CHATDECLS b/library/CHATDECLS new file mode 100644 index 00000000..8d517e4f --- /dev/null +++ b/library/CHATDECLS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "20-Jan-93 13:47:40" {DSK}lde>lispcore>library>CHATDECLS.;2 3757 changes to%: (RECORDS CHAT.STATE CHATDISPLAYTYPE CHATUSERSTATE) previous date%: "11-Jun-90 14:39:02" {DSK}lde>lispcore>library>CHATDECLS.;1) (* ; " Copyright (c) 1985, 1986, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CHATDECLSCOMS) (RPAQQ CHATDECLSCOMS ((* Declarations used by various CHAT files) (RECORDS CHAT.STATE CHATDISPLAYTYPE CHATUSERSTATE))) (* Declarations used by various CHAT files) (DECLARE%: EVAL@COMPILE (DATATYPE CHAT.STATE ((HELD FLAG) (CHATINEMACS FLAG) (UNDERLINEMODE FLAG) (ROLLMODE FLAG) (WRAPMODE FLAG) (LOCALECHO FLAG) (NIL BITS 1) (RUNNING? POINTER) (WINDOW POINTER) (DSP POINTER) (OUTSTREAM POINTER) (INSTREAM POINTER) (TEXTSTREAM POINTER) (TTYWIDTH WORD) (TTYHEIGHT WORD) (XPOS WORD) (YPOS WORD) (FONTWIDTH WORD) (FONTHEIGHT WORD) (FONTDESCENT WORD) (TOPMARGIN WORD) (BOTTOMMARGIN WORD) CLEARMODEFN TYPEOUTPROC TERM.TAB.STOPS TERM.IDENTITY.STRING TERM.NORMAL.FONT ITALICFONT TERM.STATE FONT PLAINFONT CHATBOLDFONT HOMEPOS TYPESCRIPTSTREAM) XPOS _ 0 YPOS _ 0 BOTTOMMARGIN _ 0 ROLLMODE _ T) (RECORD CHATDISPLAYTYPE (HOST DPYCODE DPYNAME)) (RECORD CHATUSERSTATE (HELD RUNNING? INSTREAM OUTSTREAM CARETSTATE TYPESCRIPTOFD TYPEOUTPROC CHATINEMACS)) ) (/DECLAREDATATYPE 'CHAT.STATE '(FLAG FLAG FLAG FLAG FLAG FLAG (BITS 1) POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((CHAT.STATE 0 (FLAGBITS . 0)) (CHAT.STATE 0 (FLAGBITS . 16)) (CHAT.STATE 0 (FLAGBITS . 32)) (CHAT.STATE 0 (FLAGBITS . 48)) (CHAT.STATE 0 (FLAGBITS . 64)) (CHAT.STATE 0 (FLAGBITS . 80)) (CHAT.STATE 0 (BITS . 96)) (CHAT.STATE 2 POINTER) (CHAT.STATE 4 POINTER) (CHAT.STATE 6 POINTER) (CHAT.STATE 8 POINTER) (CHAT.STATE 10 POINTER) (CHAT.STATE 12 POINTER) (CHAT.STATE 1 (BITS . 15)) (CHAT.STATE 14 (BITS . 15)) (CHAT.STATE 15 (BITS . 15)) (CHAT.STATE 16 (BITS . 15)) (CHAT.STATE 17 (BITS . 15)) (CHAT.STATE 18 (BITS . 15)) (CHAT.STATE 19 (BITS . 15)) (CHAT.STATE 20 (BITS . 15)) (CHAT.STATE 21 (BITS . 15)) (CHAT.STATE 22 POINTER) (CHAT.STATE 24 POINTER) (CHAT.STATE 26 POINTER) (CHAT.STATE 28 POINTER) (CHAT.STATE 30 POINTER) (CHAT.STATE 32 POINTER) (CHAT.STATE 34 POINTER) (CHAT.STATE 36 POINTER) (CHAT.STATE 38 POINTER) (CHAT.STATE 40 POINTER) (CHAT.STATE 42 POINTER) (CHAT.STATE 44 POINTER)) '46) (PUTPROPS CHATDECLS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/library/CHATSERVER-EMACS b/library/CHATSERVER-EMACS new file mode 100644 index 0000000000000000000000000000000000000000..4d8a6277ccc81f1dbaf8cc382fd0305d8244ef22 GIT binary patch literal 5231 zcmc&&OK;oC6}EvOiwkJiMOPOG+FZ(r6xp#8N4^M3lOvlAUnXfgL0uHGM8|4mQV^+Y zq*eRF`s@0g8Hx|d36k4Ivv9Nb%@jk+72Tm_i>~DkJ^DEix*6%GwxIS0 z!*0{hzHYqN&+uuvkqB%n^xK`*^IeT)46KfXNo_jl{&_j;zU|Zg(O|znI67|A^JlAn zn&JC@{kqH+?`}s){Emg+8RvQwir`8FUE%0P*gJW(dcI3X{WtqW)N0`m{;kIMqvTVZ zt!R~}gB6i>r3WEx3LBmic1oG~BK~cfE?Hh=&EV)@aP+E8-)Yvt3YuFd zWTf*ii|MEPoV0O=_TR$E+b?t_+)L3T(q}W0vl%VoEMEK;PkODE<_98*KEgadK-|7& zw-)&N#l@4eq-jGpBpIU0YtI+%(4|Y)`cMtZ&mMpG5aCF;BIp$H;)QA^^o;i+!njXb zD5488kqle^h@3h@`;1)6#^fH|oKRbCN|Q9sl3#NAv`9ab=^PyO`xIy6(LB!DSSpn$ z^TH@PwMjEPU#e5^(Jn5%NRSs;XPwT5>c>%%XOyHAkMGlI@`*;tgzO>ZDLuraghu0W zJkM#G%$IqwSNPG5^bgqNTn`M-6j%ubkkHnTw8Z^sN?@RcKrEtzTkhS)55-7Y!^Vs z^Jh=y_4#f~GwcBrotiq5@m_p9_4L5(h7k(Q*(2{VQa`a>k*diwk0-Rx^_LX&*FRu@ z{(W&f;Mnca>f{8KV5F0nvOJx|3EeHyhZ^b%RB;j>mZ-W3Witl+>D^tth!db+ zZB2-_;km$nWO;7q1;zQe*WsOD`lWkqxn|c7ka{Bm*aGj&MQGr+E!?x{oR0eqFMPC? zb77sGM|5!5m{Geyflu3kC=##wNDqq)5r!}!I=8~|6W`yXL?5CC4BHC@1QejE+PXd$ zuADQ6E~B`nuuR5U>PM{E68<485PuU5Vs(eu->*m;n&OI1FNZ@B2(v@0^bUjNY>_vt zu?+YqXUqLnX)1`M%Nzwq(~L%RyOepK&;&ho91kd)j~uygy-rdYyK5nQUdi^L#5U(Os9G9oZOB<}Ay!+-3!*?bM5%RaAE_JxaM&!x8JcIfd3rV& z?3r-t>#;K0F4Bua(0ZS%QSA$)O^IjfMp)U+ew+Tmv<41g0dDk_E zY0FAX*4(PimtHqr__ooUhjWD6hChHAH*v7+fdYCLKx?(Sd>YqkmwAPx1Kji>ZVfT% z2`;-eVq*F!Nf&XOn{Y3oc#Pa?j9DaAe|MQ1n?%^^q<+)m3J% z;iOg++p#OE>#Jd(DkW8GTRq-SXE^QFo2@1(+VrW7{b;}6??Z{Q#ue9V19ZaxVR+Jj z(o6*-MSxs@mr8kPL@f=yz|o^-fwy&ap-2<@cSf@`%jtGBnSD8_#LF?O_CSk0+Zq(TF`8o<#7@(m<|pjt&p^5$VPkZZgCzft?04#{TKM8T8y zxC)ZhFK%1~sbIPk1R$`ulPxEF#ZKqAlx6AobDR_2Jtngl_>*_OvgEkyaogB z#mN!~;HM__ZculC7vhmjzP~v-UUTGecYOSo4v${F2DCV#RrMBk`{TE7sYkC4ULT?{ zF?y;MJo=g^50BqqvQ=TLY>Aj+acpoXaoh?c&u{JUzh^tUJAd5yDY6_9f>Y`4&QEe& T{`tc@{%?0@2S0ZI@t^+!%|DaO literal 0 HcmV?d00001 diff --git a/library/CHATTERMINAL b/library/CHATTERMINAL new file mode 100644 index 00000000..a67c9fd5 --- /dev/null +++ b/library/CHATTERMINAL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 4-Jul-90 02:21:01" |{PELE:MV:ENVOS}LIBRARY>CHATTERMINAL.;3| 20832 changes to%: (VARS CHATTERMINALCOMS) previous date%: "14-Jun-90 15:57:05" {DSK}sybalsky>bane>chatterminal.;1) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1990 by VENUE & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CHATTERMINALCOMS) (RPAQQ CHATTERMINALCOMS ((FNS TERM.ADDCHAR TERM.ADDLINE TERM.CLEAR.TAB TERM.DELCHAR TERM.DELETELINE TERM.DOWN TERM.ERASE.IN.DISPLAY TERM.ERASE.IN.LINE TERM.ERASE.TO.EOL TERM.ERASEBITS TERM.GODOWN TERM.HOME TERM.IDENTIFY.SELF TERM.LEFT TERM.MODIFY.ATTRIBUTES TERM.MOVETO TERM.NEWLINE TERM.PRINTCHAR TERM.RESET.DISPLAY.PARMS TERM.RIGHT TERM.SCROLLDOWN TERM.SET.TAB TERM.SETMARGINS TERM.SMOOTHSCROLL TERM.TAB TERM.UP) (VARIABLES CHAT.UNDERLINE.DESCENT CHAT.UNDERLINE.METHOD) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) CHATDECLS) (LOCALVARS . T)))) (DEFINEQ (TERM.ADDCHAR (LAMBDA (CHAT.STATE) (* ejs%: "12-May-85 14:43") (* ; "Insert a space at cursor position, pushing rest of line to right") (LET ((DSP (ffetch (CHAT.STATE DSP) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (XPOS (ffetch (CHAT.STATE XPOS) of CHAT.STATE)) (Y (- (ffetch (CHAT.STATE YPOS) of CHAT.STATE) (ffetch (CHAT.STATE FONTDESCENT) of CHAT.STATE))) (FONTWIDTH (ffetch (CHAT.STATE FONTWIDTH) of CHAT.STATE)) (FONTHEIGHT (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE))) (BITBLT DSP XPOS Y DSP (+ XPOS FONTWIDTH) Y (+ (- (ffetch (CHAT.STATE TTYWIDTH) of CHAT.STATE) XPOS) FONTWIDTH) FONTHEIGHT (QUOTE INPUT) (QUOTE REPLACE)) (* ; "Blt remainder of line to the right by FONTWIDTH, then erase the character under the cursor") (TERM.ERASEBITS CHAT.STATE XPOS Y FONTWIDTH FONTHEIGHT))) ) (TERM.ADDLINE (LAMBDA (CHAT.STATE ATYPOS) (* ejs%: "12-May-85 14:44") (LET ((DSP (ffetch (CHAT.STATE DSP) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (TTYWIDTH (ffetch (CHAT.STATE TTYWIDTH) of CHAT.STATE)) (FONTHEIGHT (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE)) (Y (- (OR ATYPOS (ffetch (CHAT.STATE YPOS) of CHAT.STATE)) (ffetch (CHAT.STATE FONTDESCENT) of CHAT.STATE)))) (* ;; "To insert line at y, we blt everything below it down one, then clear the line at y") (BITBLT DSP 0 FONTHEIGHT DSP 0 0 TTYWIDTH Y (QUOTE INPUT) (QUOTE REPLACE)) (TERM.ERASEBITS CHAT.STATE 0 Y TTYWIDTH FONTHEIGHT))) ) (TERM.CLEAR.TAB (LAMBDA (CHAT.STATE TERMINAL.X) (* ejs%: "12-May-85 14:45") (* ;;; "Clear a tab stop") (freplace (CHAT.STATE TERM.TAB.STOPS) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)) with (DREMOVE TERMINAL.X (ffetch (CHAT.STATE TERM.TAB.STOPS) of)))) ) (TERM.DELCHAR (LAMBDA (CHAT.STATE) (* ejs%: "12-May-85 14:46") (* ;; "Delete character under cursor, moving rest of line to left") (LET ((DSP (ffetch (CHAT.STATE DSP) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (TTYWIDTH (ffetch (CHAT.STATE TTYWIDTH) of CHAT.STATE)) (XPOS (ffetch (CHAT.STATE XPOS) of CHAT.STATE)) (FONTWIDTH (ffetch (CHAT.STATE FONTWIDTH) of CHAT.STATE)) (FONTHEIGHT (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE)) (Y (- (ffetch (CHAT.STATE YPOS) of CHAT.STATE) (ffetch (CHAT.STATE FONTDESCENT) of CHAT.STATE)))) (BITBLT DSP (+ XPOS FONTWIDTH) Y DSP XPOS Y (+ (- TTYWIDTH XPOS) FONTWIDTH) FONTHEIGHT (QUOTE INPUT) (QUOTE REPLACE)) (* ; "Blt remainder of line to the left by FONTWIDTH, then erase the rightmost character position") (TERM.ERASEBITS CHAT.STATE (- TTYWIDTH FONTWIDTH) Y FONTWIDTH FONTHEIGHT))) ) (TERM.DELETELINE (LAMBDA (CHAT.STATE ATYPOS) (* ejs%: "12-May-85 19:08") (LET ((DSP (ffetch (CHAT.STATE DSP) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (TTYWIDTH (ffetch (CHAT.STATE TTYWIDTH) of CHAT.STATE)) (FONTHEIGHT (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE)) (BOTTOMMARGIN (ffetch (CHAT.STATE BOTTOMMARGIN) of CHAT.STATE))) (* ; "To delete line at ATYPOS, we blt everything below it up one, then clear the bottom line") (BITBLT DSP 0 BOTTOMMARGIN DSP 0 (+ FONTHEIGHT BOTTOMMARGIN) TTYWIDTH (- (OR ATYPOS (ffetch (CHAT.STATE YPOS) of CHAT.STATE)) (ffetch (CHAT.STATE FONTDESCENT) of CHAT.STATE) BOTTOMMARGIN) (QUOTE INPUT) (QUOTE REPLACE)) (TERM.ERASEBITS CHAT.STATE 0 BOTTOMMARGIN TTYWIDTH FONTHEIGHT))) ) (TERM.DOWN (LAMBDA (CHAT.STATE NLINES) (* ejs%: "12-May-85 19:06") (* ;;; "Move down NLINES (default = 1), pegging at bottom if NLINES not 1, else wrap or roll") (LET ((DSP (ffetch (CHAT.STATE DSP) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (XPOS (ffetch (CHAT.STATE XPOS) of CHAT.STATE)) (YPOS (ffetch (CHAT.STATE YPOS) of CHAT.STATE)) (FONTHEIGHT (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE)) (BOTTOM (+ (ffetch (CHAT.STATE BOTTOMMARGIN) of CHAT.STATE) (ffetch (CHAT.STATE FONTDESCENT) of CHAT.STATE)))) (COND ((> YPOS BOTTOM) (MOVETO XPOS (freplace (CHAT.STATE YPOS) of CHAT.STATE with (IMAX BOTTOM (- YPOS (ITIMES FONTHEIGHT (OR NLINES 1))))) DSP)) ((NULL (ffetch (CHAT.STATE ROLLMODE) of CHAT.STATE)) (* ; "Wraparound to top") (MOVETO XPOS (freplace (CHAT.STATE YPOS) of CHAT.STATE with (ffetch (CHAT.STATE HOMEPOS) of CHAT.STATE)) DSP)) (T (* ; "On bottom line in rollmode, scroll screen up one. Ypos does not change") (TERM.DELETELINE CHAT.STATE (- (ffetch (CHAT.STATE TOPMARGIN) of CHAT.STATE) FONTHEIGHT)))))) ) (TERM.ERASE.IN.DISPLAY (LAMBDA (CHAT.STATE PARAM) (* ejs%: "12-May-85 14:48") (* ; "Misc erasing functions") (\DTEST CHAT.STATE (QUOTE CHAT.STATE)) (LET ((TTYWIDTH (ffetch (CHAT.STATE TTYWIDTH) of CHAT.STATE)) (XPOS (ffetch (CHAT.STATE XPOS) of CHAT.STATE)) (YPOS (ffetch (CHAT.STATE YPOS) of CHAT.STATE)) (FONTHEIGHT (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE)) (FONTDESCENT (ffetch (CHAT.STATE FONTDESCENT) of CHAT.STATE))) (SELECTQ PARAM (0 (* ; "Erase to end of screen") (TERM.ERASE.TO.EOL CHAT.STATE) (TERM.ERASEBITS CHAT.STATE 0 0 TTYWIDTH (- YPOS FONTDESCENT))) (1 (* ; "Erase from HOME to current position") (TERM.ERASEBITS CHAT.STATE 0 (+ YPOS FONTHEIGHT) TTYWIDTH (- (ffetch (CHAT.STATE HOMEPOS) of CHAT.STATE) (+ YPOS FONTHEIGHT))) (TERM.ERASEBITS CHAT.STATE 0 (- YPOS FONTDESCENT) XPOS FONTHEIGHT)) (2 (* ; "Erase screen") (CLEARW (ffetch (CHAT.STATE WINDOW) of CHAT.STATE)) (MOVETO XPOS YPOS (ffetch (CHAT.STATE DSP) of CHAT.STATE))) NIL))) ) (TERM.ERASE.IN.LINE (LAMBDA (CHAT.STATE PARAM) (* ejs%: "12-May-85 14:48") (* ; "Do line-oriented erasing") (CASE PARAM (0 (* ; "Erase to end-of-line") (TERM.ERASE.TO.EOL CHAT.STATE)) ((1 2) (* ; "Erase from beginning of line to current pos, or entire line") (TERM.ERASEBITS CHAT.STATE 0 (- (ffetch (CHAT.STATE YPOS) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE))) (ffetch (CHAT.STATE FONTDESCENT) of CHAT.STATE)) (if (EQ PARAM 1) then (ffetch (CHAT.STATE XPOS) of CHAT.STATE) else (ffetch (CHAT.STATE TTYWIDTH) of CHAT.STATE)) (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE))))) ) (TERM.ERASE.TO.EOL (LAMBDA (CHAT.STATE) (* ejs%: "12-May-85 16:18") (LET ((XPOS (ffetch (CHAT.STATE XPOS) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE))))) (TERM.ERASEBITS CHAT.STATE XPOS (- (ffetch (CHAT.STATE YPOS) of CHAT.STATE) (ffetch (CHAT.STATE FONTDESCENT) of CHAT.STATE)) (- (ffetch (CHAT.STATE TTYWIDTH) of CHAT.STATE) XPOS) (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE)))) ) (TERM.ERASEBITS (LAMBDA (CHAT.STATE LEFT BOTTOM WIDTH HEIGHT) (* ; "Edited 8-Dec-87 14:03 by jrb:") (LET ((DSP (fetch (CHAT.STATE DSP) of CHAT.STATE))) (BITBLT NIL NIL NIL DSP LEFT BOTTOM WIDTH HEIGHT (QUOTE TEXTURE) (QUOTE REPLACE) (DSPTEXTURE NIL DSP)))) ) (TERM.GODOWN (LAMBDA (CHAT.STATE NLINES) (* ejs%: "12-May-85 14:49") (* ;;; "Move down NLINES, pegging at the bottom of the window") (LET ((YPOS (ffetch (CHAT.STATE YPOS) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (BOTTOM (+ (ffetch (CHAT.STATE BOTTOMMARGIN) of CHAT.STATE) (ffetch (CHAT.STATE FONTDESCENT) of CHAT.STATE)))) (COND ((> YPOS BOTTOM) (MOVETO (ffetch (CHAT.STATE XPOS) of CHAT.STATE) (freplace (CHAT.STATE YPOS) of CHAT.STATE with (IMAX BOTTOM (- YPOS (ITIMES (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE) (OR NLINES 1))))) (ffetch (CHAT.STATE DSP) of CHAT.STATE)))))) ) (TERM.HOME (LAMBDA (CHAT.STATE) (* ejs%: "12-May-85 16:59") (\DTEST CHAT.STATE (QUOTE CHAT.STATE)) (MOVETO (freplace (CHAT.STATE XPOS) of CHAT.STATE with 0) (freplace (CHAT.STATE YPOS) of CHAT.STATE with (ffetch (CHAT.STATE HOMEPOS) of CHAT.STATE)) (ffetch (CHAT.STATE DSP) of CHAT.STATE))) ) (TERM.IDENTIFY.SELF (LAMBDA (CHAT.STATE) (* ejs%: "12-May-85 20:22") (* ;;; "Identify self to the host operating system") (with CHAT.STATE CHAT.STATE (PRIN3 TERM.IDENTITY.STRING OUTSTREAM) (FORCEOUTPUT OUTSTREAM))) ) (TERM.LEFT (LAMBDA (CHAT.STATE NCHARS) (* ejs%: "12-May-85 14:50") (* ;;; "Move the cursor NCHARS (default = 1), pegging at the left margin") (LET ((XPOS (ffetch (CHAT.STATE XPOS) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE))))) (COND ((> XPOS 0) (MOVETO (freplace (CHAT.STATE XPOS) of CHAT.STATE with (IMAX 0 (- XPOS (ITIMES (ffetch (CHAT.STATE FONTWIDTH) of CHAT.STATE) (OR NCHARS 1))))) (ffetch (CHAT.STATE YPOS) of CHAT.STATE) (ffetch (CHAT.STATE DSP) of CHAT.STATE)))))) ) (TERM.MODIFY.ATTRIBUTES (LAMBDA (CHAT.STATE ATTRIBUTES INVERTFLG) (* ejs%: "18-Mar-86 16:40") (* ;;; "Function to do character attribute setting. Attributes is a list of attribute modifying commands") (LET ((DSP (ffetch (CHAT.STATE DSP) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (PLAINFONT (ffetch (CHAT.STATE PLAINFONT) of CHAT.STATE))) (for A inside ATTRIBUTES do (PROG NIL RETRY (CASE A (NORMAL (* ; "What does inverting normal mean?") (DSPFONT PLAINFONT DSP) (DSPSOURCETYPE (QUOTE INPUT) DSP) (freplace (CHAT.STATE UNDERLINEMODE) of CHAT.STATE with NIL)) (BRIGHT (* ; "Implement 'BRIGHT' by using a bold font") (DSPFONT (if INVERTFLG then PLAINFONT else (OR (ffetch (CHAT.STATE CHATBOLDFONT) of CHAT.STATE) (freplace (CHAT.STATE CHATBOLDFONT) of CHAT.STATE with (FONTCOPY PLAINFONT (QUOTE WEIGHT) (QUOTE BOLD))))) DSP)) (ITALIC (DSPFONT (if INVERTFLG then PLAINFONT else (OR (ffetch (CHAT.STATE ITALICFONT) of CHAT.STATE) (freplace (CHAT.STATE ITALICFONT) of CHAT.STATE with (FONTCOPY PLAINFONT (QUOTE SLOPE) (QUOTE ITALIC))))) DSP)) ((BLINK UNDERLINE) (* ; "Implement 'BLINK' with underline, for now. Blinking characters are probably a bit too expensive") (CASE CHAT.UNDERLINE.METHOD ((BOLD BRIGHT) (SETQ A (QUOTE BRIGHT)) (GO RETRY)) ((INVERSE INVERT) (SETQ A (QUOTE INVERSE)) (GO RETRY)) (ITALIC (SETQ A (QUOTE ITALIC)) (GO RETRY)) (T (* ; "The default: underline") (freplace (CHAT.STATE UNDERLINEMODE) of CHAT.STATE with (NOT INVERTFLG))))) (INVERSE (* ; "Inverse video we can do directly") (DSPSOURCETYPE (if INVERTFLG then (* ; "Inverse of inverse is normal") (QUOTE INPUT) else (QUOTE INVERT)) DSP))))))) ) (TERM.MOVETO (LAMBDA (CHAT.STATE CX CY) (* ejs%: "12-May-85 14:53") (* ;;; "Set our cursor position") (LET ((FONTWIDTH (ffetch (CHAT.STATE FONTWIDTH) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE))))) (MOVETO (freplace (CHAT.STATE XPOS) of CHAT.STATE with (IMIN (ITIMES CX FONTWIDTH) (- (ffetch (CHAT.STATE TTYWIDTH) of CHAT.STATE) FONTWIDTH))) (freplace (CHAT.STATE YPOS) of CHAT.STATE with (IMAX (ffetch (CHAT.STATE FONTDESCENT) of CHAT.STATE) (- (ffetch (CHAT.STATE HOMEPOS) of CHAT.STATE) (ITIMES CY (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE))))) (ffetch (CHAT.STATE DSP) of CHAT.STATE)))) ) (TERM.NEWLINE (LAMBDA (CHAT.STATE) (* ejs%: "12-May-85 14:54") (* ; "Do a CRLF.") (TERM.DOWN (\DTEST CHAT.STATE (QUOTE CHAT.STATE))) (MOVETO (freplace (CHAT.STATE XPOS) of CHAT.STATE with 0) (ffetch (CHAT.STATE YPOS) of CHAT.STATE) (ffetch (CHAT.STATE DSP) of CHAT.STATE))) ) (TERM.PRINTCHAR (LAMBDA (CHAT.STATE CHAR WRAPFN) (* ; "Edited 2-Sep-88 10:35 by jds") (* ;;; "Print a character. If this char fills the last position on the line, then the next action is determined by WRAPFN: if it is given, we call it with CHAT.STATE as arg. Otherwise, if WRAPMODE is on in the state, we perform an explict newline, else we peg at the right margin.") (LET* ((DSP (ffetch (CHAT.STATE DSP) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (DISPLAYDATA (fetch (STREAM IMAGEDATA) of DSP)) (XPOS (ffetch (CHAT.STATE XPOS) of CHAT.STATE)) IMAGEWIDTH CHARWIDTH) (if (NEQ (ffetch (\DISPLAYDATA DDCHARSET) of DISPLAYDATA) (\CHARSET CHAR)) then (* ;; "The display stream's caches are invalid. Fix them up for the new character set (this also cleans up after font changes, etc, and at initial window opening)") (\CHANGECHARSET.DISPLAY DISPLAYDATA (\CHARSET CHAR))) (* ;; "These two SETQs can't be in the LET* because the charset change may need to happen first:") (SETQ IMAGEWIDTH (\DSPGETCHARIMAGEWIDTH CHAR DISPLAYDATA)) (SETQ CHARWIDTH (\DSPGETCHARWIDTH CHAR DISPLAYDATA)) (if (NEQ IMAGEWIDTH CHARWIDTH) then (* ;; "Take care of the case where the character's image isn't the same as its escapement, by filling in the background properly for the intervening space. We wouldn't have to worry about this nonsense if ns fonts did their character bitmaps properly.") (\BLTSHADE.DISPLAY (CASE (fetch DDSOURCETYPE of DISPLAYDATA) (INVERT BLACKSHADE) (T WHITESHADE)) DSP (+ XPOS IMAGEWIDTH) (- (ffetch (CHAT.STATE YPOS) of CHAT.STATE) (ffetch (CHAT.STATE FONTDESCENT) of CHAT.STATE)) (- CHARWIDTH IMAGEWIDTH) (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE))) (\BLTCHAR CHAR DSP DISPLAYDATA) (if (ffetch (CHAT.STATE UNDERLINEMODE) of CHAT.STATE) then (* ; "Underline what we just drew") (\BLTSHADE.DISPLAY BLACKSHADE DSP XPOS (- (ffetch (CHAT.STATE YPOS) of CHAT.STATE) CHAT.UNDERLINE.DESCENT) CHARWIDTH 1 (QUOTE INVERT))) (if (>= (freplace (CHAT.STATE XPOS) of CHAT.STATE with (+ XPOS (ffetch (CHAT.STATE FONTWIDTH) of CHAT.STATE))) (ffetch (CHAT.STATE TTYWIDTH) of CHAT.STATE)) then (* ; "Have reached right margin, so wrap around") (if WRAPFN then (* ; "Terminal-specific wrap handler") (CL:FUNCALL WRAPFN CHAT.STATE) elseif (ffetch (CHAT.STATE WRAPMODE) of CHAT.STATE) then (TERM.NEWLINE CHAT.STATE) else (* ; "No, don't wrap--stay on the last character") (MOVETO (freplace (CHAT.STATE XPOS) of CHAT.STATE with XPOS) (ffetch (CHAT.STATE YPOS) of CHAT.STATE) DSP))))) ) (TERM.RESET.DISPLAY.PARMS (LAMBDA (CHAT.STATE) (* ; "Edited 21-May-90 00:00 by jrb:") (* ;; "Reset state, assuming window coords are as if CLEARW was just called.") (LET* ((WINDOW (ffetch (CHAT.STATE WINDOW) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (DSP (ffetch (CHAT.STATE DSP) of CHAT.STATE)) (FONT (PROGN (DSPFONT (OR CHAT.FONT (DEFAULTFONT (QUOTE DISPLAY))) DSP) (* ; "Reset default font, and read it back after display has coerced it as necessary") (DSPFONT NIL DSP))) (FONTDESCENT (FONTPROP FONT (QUOTE DESCENT))) (FONTWIDTH (CHARWIDTH (CHARCODE A) FONT)) (FONTHEIGHT (FONTPROP FONT (QUOTE HEIGHT))) (CLEARMODEFN (ffetch (CHAT.STATE CLEARMODEFN) of CHAT.STATE)) TERM.STATE) (freplace (CHAT.STATE PLAINFONT) of CHAT.STATE with (freplace (CHAT.STATE FONT) of CHAT.STATE with FONT)) (freplace (CHAT.STATE CHATBOLDFONT) of CHAT.STATE with (freplace (CHAT.STATE ITALICFONT) of CHAT.STATE with NIL)) (freplace (CHAT.STATE FONTHEIGHT) of CHAT.STATE with FONTHEIGHT) (freplace (CHAT.STATE FONTWIDTH) of CHAT.STATE with FONTWIDTH) (freplace (CHAT.STATE FONTDESCENT) of CHAT.STATE with FONTDESCENT) (* ;; "We use just the part of window that is even multiple of the font width and height") (LET ((TTYHEIGHT (+ (ITIMES (IQUOTIENT (WINDOWPROP WINDOW (QUOTE HEIGHT)) FONTHEIGHT) FONTHEIGHT) FONTDESCENT))) (freplace (CHAT.STATE TTYHEIGHT) of CHAT.STATE with (freplace (CHAT.STATE TOPMARGIN) of CHAT.STATE with TTYHEIGHT)) (* ;; "JRB Just guessing that nobody sets BOTTOMMARGIN, or that somebody is clobbering it...") (freplace (CHAT.STATE BOTTOMMARGIN) of CHAT.STATE with 0) (freplace (CHAT.STATE HOMEPOS) of CHAT.STATE with (- TTYHEIGHT FONTHEIGHT)) (freplace (CHAT.STATE TTYWIDTH) of CHAT.STATE with (ITIMES (IQUOTIENT (WINDOWPROP WINDOW (QUOTE WIDTH)) FONTWIDTH) FONTWIDTH))) (if (AND CLEARMODEFN (SETQ TERM.STATE (ffetch (CHAT.STATE TERM.STATE) of CHAT.STATE))) then (* ;; "Clear any funny mode the terminal might have gotten into. Test for TERM.STATE is because when we are called at startup, TERM.STATE might not be filled in yet (what a crock).") (CL:FUNCALL CLEARMODEFN CHAT.STATE TERM.STATE)))) ) (TERM.RIGHT (LAMBDA (CHAT.STATE NCHARS) (* ejs%: "12-May-85 15:33") (* ;;; "Move the cursor NCHARS to the right, pegging at the right margin") (LET ((TTYWIDTH (ffetch (CHAT.STATE TTYWIDTH) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (XPOS (ffetch (CHAT.STATE XPOS) of CHAT.STATE)) (FONTWIDTH (ffetch (CHAT.STATE FONTWIDTH) of CHAT.STATE))) (COND ((< (+ XPOS FONTWIDTH) TTYWIDTH) (MOVETO (freplace (CHAT.STATE XPOS) of CHAT.STATE with (IMIN TTYWIDTH (+ XPOS (ITIMES FONTWIDTH (OR NCHARS 1))))) (ffetch (CHAT.STATE YPOS) of CHAT.STATE) (ffetch (CHAT.STATE DSP) of CHAT.STATE)))))) ) (TERM.SCROLLDOWN (LAMBDA (CHAT.STATE TOP) (* ejs%: "12-May-85 14:56") (* ;;; "Scroll down a line, from the line at TOP") (LET* ((DSP (ffetch (CHAT.STATE DSP) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (TTYWIDTH (ffetch (CHAT.STATE TTYWIDTH) of CHAT.STATE)) (FONTHEIGHT (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE)) (BOTTOMMARGIN (ffetch (CHAT.STATE BOTTOMMARGIN) of CHAT.STATE)) (NEARBOTTOM (+ BOTTOMMARGIN FONTHEIGHT))) (* ;; "Move most of window down one line, then erase the top line") (BITBLT DSP 0 NEARBOTTOM DSP 0 BOTTOMMARGIN TTYWIDTH (- TOP NEARBOTTOM) (QUOTE INPUT) (QUOTE REPLACE)) (TERM.ERASEBITS CHAT.STATE 0 (- TOP FONTHEIGHT (ffetch (CHAT.STATE FONTDESCENT) of CHAT.STATE)) TTYWIDTH FONTHEIGHT))) ) (TERM.SET.TAB (LAMBDA (CHAT.STATE TERMINAL.X) (* ejs%: "26-Aug-85 12:28") (* ;;; "Set a new tab stop for the terminal") (LET ((TERM.TAB.STOPS (ffetch (CHAT.STATE TERM.TAB.STOPS) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE))))) (freplace (CHAT.STATE TERM.TAB.STOPS) of CHAT.STATE with (COND ((NULL TERM.TAB.STOPS) (LIST TERMINAL.X)) (T (SORT (CONS TERMINAL.X TERM.TAB.STOPS))))))) ) (TERM.SETMARGINS (LAMBDA (CHAT.STATE TOP BOTTOM) (* ejs%: "12-May-85 14:58") (* ;;; "Function to set top and bottom margins, for terminals that implement a programmable scrolling region") (LET ((FONTHEIGHT (ffetch (CHAT.STATE FONTHEIGHT) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (HOMEPOS (ffetch (CHAT.STATE HOMEPOS) of CHAT.STATE))) (freplace (CHAT.STATE TOPMARGIN) of CHAT.STATE with (- HOMEPOS (ITIMES (- TOP 2) FONTHEIGHT))) (freplace (CHAT.STATE BOTTOMMARGIN) of CHAT.STATE with (- HOMEPOS (ITIMES (SUB1 BOTTOM) FONTHEIGHT) (ffetch (CHAT.STATE FONTDESCENT) of CHAT.STATE))))) ) (TERM.SMOOTHSCROLL (LAMBDA (CHAT.STATE) (* ejs%: "12-May-85 14:58") (* ;;; "For those of you who can stand smooth scrolling, this will scroll in the normal direction, one (pixel) line at a time") (LET ((DSP (ffetch (CHAT.STATE DSP) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (TTYWIDTH (ffetch (CHAT.STATE TTYWIDTH) of CHAT.STATE)) (TTYHEIGHT (ffetch (CHAT.STATE TTYHEIGHT) of CHAT.STATE)) (FONTHEIGHT (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE))) (for I from 1 to FONTHEIGHT do (BITBLT DSP 0 0 DSP 0 1 TTYWIDTH TTYHEIGHT (QUOTE INPUT) (QUOTE REPLACE))) (TERM.ERASEBITS CHAT.STATE 0 0 TTYWIDTH FONTHEIGHT))) ) (TERM.TAB (LAMBDA (CHAT.STATE) (* edited%: "26-Mar-86 11:06") (* ;; "Advance x to next tab stop on the line, if there is one.") (LET* ((XPOS (ffetch (CHAT.STATE XPOS) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (FONTWIDTH (ffetch (CHAT.STATE FONTWIDTH) of CHAT.STATE)) (CURSORX (ADD1 (IQUOTIENT XPOS FONTWIDTH))) NEXT.STOP) (COND ((SETQ NEXT.STOP (for CX in (ffetch (CHAT.STATE TERM.TAB.STOPS) of CHAT.STATE) thereis (IGEQ CX CURSORX))) (MOVETO (freplace (CHAT.STATE XPOS) of CHAT.STATE with (ITIMES NEXT.STOP FONTWIDTH)) (ffetch (CHAT.STATE YPOS) of CHAT.STATE) (ffetch (CHAT.STATE DSP) of CHAT.STATE)))))) ) (TERM.UP (LAMBDA (CHAT.STATE NLINES) (* ejs%: "12-May-85 14:59") (* ;;; "Go up NLINES (default = 1), pegging at top") (LET ((YPOS (ffetch (CHAT.STATE YPOS) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (HOMEPOS (ffetch (CHAT.STATE HOMEPOS) of CHAT.STATE))) (COND ((< YPOS HOMEPOS) (MOVETO (ffetch (CHAT.STATE XPOS) of CHAT.STATE) (freplace (CHAT.STATE YPOS) of CHAT.STATE with (IMIN HOMEPOS (+ YPOS (ITIMES (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE) (OR NLINES 1))))) (ffetch (CHAT.STATE DSP) of CHAT.STATE)))))) ) ) (DEFGLOBALVAR CHAT.UNDERLINE.DESCENT 3 "Number of pixels below baseline to draw character underline") (DEFGLOBALVAR CHAT.UNDERLINE.METHOD 'UNDERLINE "How to handle terminal 'underline' or 'blink' attributes: one of UNDERLINE, INVERT, BOLD") (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) CHATDECLS) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS CHATTERMINAL COPYRIGHT ("VENUE & Xerox Corporation" 1984 1985 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1149 20319 (TERM.ADDCHAR 1159 . 1955) (TERM.ADDLINE 1957 . 2559) (TERM.CLEAR.TAB 2561 . 2817) (TERM.DELCHAR 2819 . 3649) (TERM.DELETELINE 3651 . 4370) (TERM.DOWN 4372 . 5400) ( TERM.ERASE.IN.DISPLAY 5402 . 6364) (TERM.ERASE.IN.LINE 6366 . 6945) (TERM.ERASE.TO.EOL 6947 . 7332) ( TERM.ERASEBITS 7334 . 7597) (TERM.GODOWN 7599 . 8188) (TERM.HOME 8190 . 8486) (TERM.IDENTIFY.SELF 8488 . 8708) (TERM.LEFT 8710 . 9187) (TERM.MODIFY.ATTRIBUTES 9189 . 10814) (TERM.MOVETO 10816 . 11413) ( TERM.NEWLINE 11415 . 11694) (TERM.PRINTCHAR 11696 . 14173) (TERM.RESET.DISPLAY.PARMS 14175 . 16281) ( TERM.RIGHT 16283 . 16867) (TERM.SCROLLDOWN 16869 . 17588) (TERM.SET.TAB 17590 . 17971) ( TERM.SETMARGINS 17973 . 18562) (TERM.SMOOTHSCROLL 18564 . 19180) (TERM.TAB 19182 . 19795) (TERM.UP 19797 . 20317))))) STOP \ No newline at end of file diff --git a/library/CLIPBOARD b/library/CLIPBOARD new file mode 100644 index 00000000..df4a12fb --- /dev/null +++ b/library/CLIPBOARD @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 8-Aug-2020 15:48:08"  {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;53 7823 changes to%: (VARS CLIPBOARDCOMS) previous date%: " 8-Aug-2020 15:25:18" {DSK}kaplan>Local>medley3.5>lispcore>library>CLIPBOARD.;52) (PRETTYCOMPRINT CLIPBOARDCOMS) (RPAQQ CLIPBOARDCOMS [ (* ; "Enable copy and paste") (FNS INSTALL-CLIPBOARD GETCLIPBOARD PUTCLIPBOARD PASTEFROMCLIPBOARD LISPINTERRUPTS.PASTE) (FNS TEDIT.COPYTOCLIPBOARD TEDIT.EXTRACTTOCLIPBOARD) (FNS SEDIT.COPYTOCLIPBOARD) (INITVARS (CLIPBOARD-FORMAT :UTF8)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD) UNIXCOMM UNICODE) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "Enable copy and paste") (DEFINEQ (INSTALL-CLIPBOARD [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:59 by rmk:") (* ; "Edited 19-Apr-2020 12:15 by rmk:") (* ; "Edited 18-Apr-2018 23:00 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.PASTE) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.ORIG) (MOVD 'LISPINTERRUPTS.PASTE 'LISPINTERRUPTS)) (INTERRUPTCHAR (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (INTERRUPTCHAR (CHARCODE "1,V") '(PASTEFROMCLIPBOARD)) (CL:WHEN (BOUNDP 'TEDIT.READTABLE) (* ; "TEDIT") (* ;; "Paste") (TEDIT.SETFUNCTION (CHARCODE "1,v") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,V") (FUNCTION PASTEFROMCLIPBOARD) TEDIT.READTABLE) (* ;; "Copy") (TEDIT.SETFUNCTION (CHARCODE "1,c") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,C") (FUNCTION TEDIT.COPYTOCLIPBOARD) TEDIT.READTABLE) (* ;; "Extract") (TEDIT.SETFUNCTION (CHARCODE "1,X") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE) (TEDIT.SETFUNCTION (CHARCODE "1,x") (FUNCTION TEDIT.EXTRACTTOCLIPBOARD) TEDIT.READTABLE)) (CL:WHEN (GETP 'SEDIT 'FILEDATES) (* ; "SEDIT copy: INTERRUPTCHAR does paste") (SEDIT:ADD-COMMAND "1,c" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:ADD-COMMAND "1,C" 'SEDIT.COPYTOCLIPBOARD) (SEDIT:RESET-COMMANDS))]) (GETCLIPBOARD [LAMBDA NIL (* ; "Edited 8-Aug-2020 07:56 by rmk:") (* ; "Edited 25-Apr-2018 16:56 by rmk:") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbpaste")) (\EXTERNALFORMAT s CLIPBOARD-FORMAT) [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (RETFROM (FUNCTION READCCODE) NIL] (CONCATCODES (BIND C WHILE (SETQ C (READCCODE s)) COLLECT C]) (PUTCLIPBOARD [LAMBDA (OBJECT PRINTFN) (* ; "Edited 8-Aug-2020 07:56 by rmk:") (* ; "Edited 25-Apr-2018 16:49 by rmk:") (* ;; "Clipboard is UNICODE and UTF8") (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM "pbcopy")) (\EXTERNALFORMAT s CLIPBOARD-FORMAT) (IF PRINTFN THEN (APPLY* PRINTFN OBJECT s) ELSE (PRIN3 OBJECT s]) (PASTEFROMCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 13:56 by rmk:") (* ; "Edited 17-Apr-2018 23:11 by rmk:") (* ;;  "Should be able to just call COPYINSERT, but the default BKSYSBUF puts in string qujotes ") (LET ((STR (GETCLIPBOARD))) (IF (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'COPYINSERTFN) THEN (COPYINSERT STR) ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C]) (LISPINTERRUPTS.PASTE [LAMBDA NIL (* ; "Edited 18-Apr-2018 22:59 by rmk:") (* ;; "So paste interrupts will be installed in every process") (APPEND [LIST (LIST (CHARCODE "1,v") '(PASTEFROMCLIPBOARD)) (LIST (CHARCODE "1,V") '(PASTEFROMCLIPBOARD] (LISPINTERRUPTS.ORIG]) ) (DEFINEQ (TEDIT.COPYTOCLIPBOARD [LAMBDA NIL (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM]) (TEDIT.EXTRACTTOCLIPBOARD [LAMBDA NIL (* ; "Edited 19-Apr-2020 12:17 by rmk:") (* ; "Edited 18-Apr-2018 00:02 by rmk:") (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS] (IF TEXTSTREAM THEN (PUTCLIPBOARD (TEDIT.SEL.AS.STRING TEXTSTREAM)) (TEDIT.DELETE TEXTSTREAM (TEDIT.GETSEL TEXTSTREAM]) ) (DEFINEQ (SEDIT.COPYTOCLIPBOARD [LAMBDA (CONTEXT) (* ; "Edited 8-Aug-2020 15:25 by rmk:") (* ; "Edited 24-Apr-2018 20:39 by rmk:") (* ; "Edited 24-Apr-2018 20:33 by rmk:") (* ; "Edited 23-Apr-2018 18:19 by rmk:") [CL:MULTIPLE-VALUE-BIND (SEL SELTYPE) (SEDIT:GET-SELECTION CONTEXT) (* ;; "SEL could be a list of several elements, or a structure, depending on SELTYPE. ") (* ;; "SELTYPE=NIL means not a valid selection, and SEL is NIL. Non-NIL values are :SUB-LIST, :CHARACTERS, and T") (CL:WHEN SELTYPE [PUTCLIPBOARD (CONS SEL (EQ SELTYPE :SUB-LIST)) (FUNCTION (LAMBDA (PAIR STREAM) (LET ((*PRINT-PRETTY* T) (PRETTYTABFLG NIL) (FONTCHANGEFLG NIL) (%#RPARS NIL)) (DECLARE (SPECVARS *PRINT-PRETTY* %#RPARS PRETTYTABFLG FONTCHANGEFLG)) (PRINTDEF (CAR PAIR) 0 NIL (CDR PAIR) NIL STREAM])] T]) ) (RPAQ? CLIPBOARD-FORMAT :UTF8) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILESLOAD (SYSLOAD) UNIXCOMM UNICODE) (INSTALL-CLIPBOARD) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLIPBOARD COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1216 5170 (INSTALL-CLIPBOARD 1226 . 3048) (GETCLIPBOARD 3050 . 3649) (PUTCLIPBOARD 3651 . 4126) (PASTEFROMCLIPBOARD 4128 . 4745) (LISPINTERRUPTS.PASTE 4747 . 5168)) (5171 5930 ( TEDIT.COPYTOCLIPBOARD 5181 . 5462) (TEDIT.EXTRACTTOCLIPBOARD 5464 . 5928)) (5931 7470 ( SEDIT.COPYTOCLIPBOARD 5941 . 7468))))) STOP \ No newline at end of file diff --git a/library/COLOR b/library/COLOR new file mode 100644 index 00000000..87c494fc --- /dev/null +++ b/library/COLOR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 9-Nov-90 20:59:31" {DSK}project3>color>SOURCES>COLOR.;2 62858 changes to%: (FNS MAPOFACOLOR) previous date%: "27-Jan-87 15:56:46" {DSK}release>alpha>library>COLOR.;1) (* ; " Copyright (c) 1982, 1983, 1985, 1986, 1987, 1990 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) (* ; "Edited 9-Nov-90 20:45 by TS") (* creates a gray color map *) (DECLARE (GLOBALVARS \COLORSCREEN)) (PROG (MAXCOLOR RED GREEN BLUE OPRED OPGREEN OPBLUE COLORMAP) [SETQ MAXCOLOR (MAXIMUMCOLOR (OR BITSPERPIXEL (SETQ BITSPERPIXEL (FETCH (SCREEN SCBITSPERPIXEL ) OF \COLORSCREEN] (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.07 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.07 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 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2458 17510 (DISPLAYCOLORLEVELS 2468 . 3586) (DISPLAYHLSLEVELS 3588 . 3928) (HLSLEVEL 3930 . 4665) (HLSTORGB 4667 . 6096) (HLSVALUEFN 6098 . 6975) (HLSVALUEFROMLEVEL 6977 . 7309) ( LEVELFROMHLSVALUE 7311 . 7648) (RAINBOWMAP 7650 . 14659) (RGBTOHLS 14661 . 17508)) (17511 19297 ( OVERPAINT 17521 . 18282) (BITMAPFROMSTRING 18284 . 18774) (SHADEBITMAP 18776 . 19295)) (19335 35945 ( EDITCOLORMAP 19345 . 20564) (EDITCOLORMAP.BUTTONEVENTFN 20566 . 24296) (EDITCOLORMAP.REDISPLAYFN 24298 . 26657) (EDITCOLORMAP.VALUELEVEL 26659 . 27152) (EDITCOLORMAP.WINDOWLEVEL 27154 . 27657) ( CHANGECOLORLEVELS 27659 . 29786) (GETCOLOR#FROMUSER 29788 . 31106) (GETCOLOR#FROMSCREEN 31108 . 31666) (DISPLAYCOLORLEVEL 31668 . 33092) (FILLINREGION 33094 . 33561) (AREAFILL 33563 . 33825) (CENTEREDLEFT 33827 . 34153) (OUTLINEAREA 34155 . 35384) (OUTLINEREGION 35386 . 35943)) (35946 44537 ( ADJUSTCOLORMAP 35956 . 36476) (SHOWCOLORBLOCKS 36478 . 37945) (MAPOFACOLOR 37947 . 40816) ( COLORHEXPATTERN 40818 . 44535)) (45003 54605 (CNSMENUINIT 45013 . 45648) (CNSTOCSL 45650 . 46912) ( CNSTORGB 46914 . 47161) (CSLTOCNS 47163 . 48236) (DICOLOR.FROM.USER 48238 . 49997) (GETCNS 49999 . 50203) (HLSTOCSL 50205 . 53705) (CSLTOHLS 53707 . 54375) (RGBTOCNS 54377 . 54603)) (56588 58839 ( DICOLOR.hueN 56598 . 56916) (DICOLOR.hueNvalue 56918 . 57097) (DICOLOR.hueNname 57099 . 57276) ( DICOLOR.lightnessN 57278 . 57626) (DICOLOR.lightnessNvalue 57628 . 57825) (DICOLOR.lightnessNname 57827 . 58022) (DICOLOR.saturationN 58024 . 58435) (DICOLOR.saturationNvalue 58437 . 58637) ( DICOLOR.saturationNname 58639 . 58837))))) STOP \ No newline at end of file diff --git a/library/COPYFILES b/library/COPYFILES new file mode 100644 index 00000000..f3353820 --- /dev/null +++ b/library/COPYFILES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 6-Apr-2018 21:14:29"  {DSK}kaplan>Local>medley3.5>lispcore>library>COPYFILES.;2 23656 changes to%: (FNS MAPFILES) previous date%: "23-Mar-93 02:39:53" {DSK}kaplan>Local>medley3.5>lispcore>library>COPYFILES.;1) (* ; " Copyright (c) 1989, 1990, 1991, 1993, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COPYFILESCOMS) (RPAQQ COPYFILESCOMS ((FNS COPYFILES MAPFILES MAPFILES1 COPIEDFILENAME COPIEDFILEPATTERN COPIEDFILEMATCH COPIEDFROMSPEC COPIEDTOSPEC ESPATTERN NOHOST COMPAREFILES) (COMS (* ;; "For concatenating a list of files into one file.") (FNS CONCATFILES)) (COMS (* ;; "For splitting a big file into several files.") (FNS SPLITFILE)) (COMS (* ;; "For making DOS file systems") (FNS DOSLINKER SHORTEN)) (I.S.OPRS INFILES))) (DEFINEQ (COPYFILES (LAMBDA (FROMSPEC TOSPEC OPTIONS) (DECLARE (SPECVARS FROMSPEC TOSPEC)) (* ; "Edited 27-Sep-89 15:07 by bvm") (* ;; "Copies the files specified in FROMSPEC to the destination in TOSPEC. Which versions get copied, whether to copy old files, etc. is controlled by OPTIONS.") (SETQ TOSPEC (\ADD.CONNECTED.DIR TOSPEC)) (SETQ FROMSPEC (\ADD.CONNECTED.DIR FROMSPEC)) (LET ((*UPPER-CASE-FILE-NAMES* NIL) (COPYFILESOUTPUT T) (COPYFILES.WHENTOSKIP (FUNCTION ILEQ)) (COPYFILESALWAYS T) (COPYFILESVERSIONS NIL) (COPYFILESASK NIL) (COPYFILESASKDEFAULT) (COPYFILESREPLACE NIL) (COPYFILESPURGESOURCE NIL) (COPYFILESPURGE NIL) (COPYFILESTERSE) (COPYFILESTOSPEC (COPIEDTOSPEC TOSPEC)) (SECONDARYSPEC) (COPYFILESFN (QUOTE COPYFILE)) (COPYFILESSKIPFN (QUOTE NILL)) (DONTCOPY) COPYFILESFROMSPEC) (DECLARE (SPECVARS . T)) (for X inside OPTIONS do (* ;; "Run thru the options, turning them into internal flag settings and functional specifications.") (SELECTQ X ((QUIET :QUIET) (* ; "Don't want to hear about files as they're copied. Set the output file to NIL to suppress printing.") (SETQ COPYFILESOUTPUT NIL)) ((TERSE :TERSE) (* ; "Only print a . per file copied. Set the TERSE flag.") (SETQ COPYFILESOUTPUT NIL) (SETQ COPYFILESTERSE T)) ((RENAME MOVE :RENAME :MOVE) (* ; "He wants the files moved, not copied.") (SETQ COPYFILESFN (QUOTE RENAMEFILE))) ((ALWAYS :ALWAYS) (* ; "ALWAYS copy the files specified.") (SETQ COPYFILESALWAYS T) (* ; "Tell it so") (SETQ COPYFILES.WHENTOSKIP (FUNCTION NILL)) (* ; "And say never to skip a potential file")) (> (* ; "Only copy if the source has a newer version than the destination.") (SETQ COPYFILES.WHENTOSKIP (FUNCTION ILEQ)) (SETQ COPYFILESALWAYS NIL)) ((= =A) (* ; "= without ALWAYS doesn't make a lot of sense") (SETQ COPYFILES.WHENTOSKIP (FUNCTION TRUE)) (SETQ COPYFILESALWAYS T)) ((%# /=) (* ; "Skip files that are the same on the destination") (SETQ COPYFILES.WHENTOSKIP (FUNCTION EQUAL)) (SETQ COPYFILESALWAYS NIL)) (ALLVERSIONS (SETQ COPYFILESVERSIONS T)) ((%#A /=A) (SETQ COPYFILES.WHENTOSKIP (FUNCTION EQUAL)) (SETQ COPYFILESALWAYS T)) (>A (SETQ COPYFILES.WHENTOSKIP (FUNCTION ILEQ)) (SETQ COPYFILESALWAYS T)) ((ASK :ASK) (SETQ COPYFILESASK T)) ((PURGE :PURGE) (SETQ COPYFILESPURGE T)) ((PURGESOURCE :PURGESOURCE) (SETQ COPYFILESPURGESOURCE T) (SETQ COPYFILESALWAYS NIL)) ((REPLACE :REPLACE) (SETQ COPYFILESREPLACE T)) (SELECTQ (CAR (LISTP X)) (OUTPUT (SETQ COPYFILESOUTPUT (OPENSTREAM (CADR X) (QUOTE OUTPUT) (QUOTE NEW)))) (ASK (SETQ COPYFILESASK T) (SETQ COPYFILESASKDEFAULT (CADR X))) (DONTCOPY (SETQ DONTCOPY (CDR X))) (COPYFN (* ; "Use this instead of COPYFILE") (SETQ COPYFILESFN (CADR X))) (SECONDARY (* ;; "Use FROMSPECT/TOSPEC to decide what files to copy, but actually do the copying to this secondary spec (if the file's not there already). Also, if we skip a file because the date comparison failed or the destination doesn't exist, we delete the corresponding file(s) on the secondary location. This is pretty strange --bvm.") (SETQ SECONDARYSPEC (COPIEDTOSPEC (CADR X))) (SETQ COPYFILESFN (FUNCTION (LAMBDA (SOURCE DEST) (* ;; "This gets called when we're to %"copy%" from SOURCE to DEST") (LET (DST FULLDST) (if (CAR (ERSETQ (AND (SETQ FULLDST (INFILEP (SETQ DST (COPIEDFILENAME SOURCE COPYFILESFROMSPEC SECONDARYSPEC)))) (= (GETFILEINFO SOURCE (QUOTE ICREATIONDATE)) (GETFILEINFO FULLDST (QUOTE ICREATIONDATE)))))) then (PRINTOUT COPYFILESOUTPUT "[backed up on " FULLDST "]" T) "!" else (COPYFILE SOURCE DST)))))) (SETQ COPYFILESSKIPFN (FUNCTION (LAMBDA (SOURCE) (* ;; "This gets called when we skip SOURCE") (LET ((BACKUP (COPIEDFILENAME SOURCE COPYFILESFROMSPEC SECONDARYSPEC))) (bind BK while (SETQ BK (INFILEP BACKUP)) do (PRINTOUT COPYFILESOUTPUT " [deleting " BK "...") (COND ((NOT (DELFILE BK)) (PRINTOUT COPYFILESOUTPUT "couldn't!]") (RETURN)) (T (PRINTOUT COPYFILESOUTPUT "ok]"))))))))) (ERROR X "unrecognized option")))) (if (AND COPYFILESASK (NOT COPYFILESOUTPUT)) then (SETQ COPYFILESOUTPUT T)) (if (OR (LISTP COPYFILESTOSPEC) (LISTP SECONDARYSPEC)) then (* ; "copiedfilename will want the from spec broken down to do pattern matching.") (SETQ COPYFILESFROMSPEC (COPIEDFROMSPEC FROMSPEC))) (MAPFILES FROMSPEC (FUNCTION (LAMBDA (FILENAME DT1) (PROG (NEWFILENAME NF CF DT2 HELPFLAG) (DECLARE (SPECVARS HELPFLAG)) (* ; "So that errors don't cause breaks") (if DONTCOPY then (if (CL:MEMBER (UNPACKFILENAME.STRING FILENAME (QUOTE EXTENSION)) DONTCOPY :TEST (QUOTE STRING.EQUAL)) then (AND COPYFILESOUTPUT (PRINTOUT COPYFILESOUTPUT FILENAME " ignored." T)) (RETURN))) (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT .TAB0 0 FILENAME)) (* ; "List the candidate file's name") (OR (ERSETQ (SETQ NEWFILENAME (COPIEDFILENAME FILENAME COPYFILESFROMSPEC COPYFILESTOSPEC COPYFILESVERSIONS))) (RETURN (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT " illegal file name ")))) (* ; "Find out what the file's name would be at the destination.") (if (OR (NOT COPYFILESALWAYS) (NEQ COPYFILES.WHENTOSKIP (QUOTE NILL))) then (* ; "We aren't ALWAYS copying. So have to check this file to see if it meets the copy criteria.") (COND ((SETQ NF (INFILEP NEWFILENAME)) (* ; "There is a file of the same name at the destination. CHeck it out.") (SETQ DT2 (GETFILEINFO NF (QUOTE ICREATIONDATE))) (* ; "The destination file's create date") (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT " [" (GDATE DT1) "]" " vs. " NF "[" (if DT2 then (GDATE DT2) else "no date?") "]")) (* ; "Tell the user we're comparing dates") (COND ((AND DT2 (CL:FUNCALL COPYFILES.WHENTOSKIP DT1 DT2)) (* ; "If the file has a create date, and it meets the SKIP criteria, then skip over this file") (CL:FUNCALL COPYFILESSKIPFN FILENAME) (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT " skipped.")) (RETURN)))) (COPYFILESPURGESOURCE (* ; "We're to purge the source directory of non-corresponding files") (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT " (no corresponding " NEWFILENAME "), ")) (COND ((OR (NOT COPYFILESASK) (EQ (QUOTE Y) (ASKUSER DWIMWAIT COPYFILESASKDEFAULT "delete? " NIL T))) ((LAMBDA (STR) (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT STR))) (if (DELFILE FILENAME) then " deleted." else " couldn't delete.")))) (RETURN)) ((NOT COPYFILESALWAYS) (* ; "file doesn't exist on destination") (CL:FUNCALL COPYFILESSKIPFN FILENAME) (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT " does not exist on destination -- skipped")) (RETURN)))) (if (AND COPYFILESREPLACE NF) then (SETQ NEWFILENAME NF)) (if COPYFILESOUTPUT then (* ; "Write out the file's new name, and tell him we're copying or moving it.") (printout COPYFILESOUTPUT (SELECTQ COPYFILESFN (COPYFILE " copy") (RENAMEFILE " rename") " process")) (if (NOT NF) then (printout COPYFILESOUTPUT " to (new file) " NEWFILENAME))) (COND ((AND COPYFILESASK (NEQ (ASKUSER DWIMWAIT COPYFILESASKDEFAULT "? " NIL T) (QUOTE Y))) (RETURN))) (OR (ERSETQ (SETQ CF (CL:FUNCALL COPYFILESFN FILENAME NEWFILENAME))) (RETURN (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT " failed.")))) (if COPYFILESOUTPUT then (if (AND (NOT COPYFILESASK) (NOT NF) (STRPOS NEWFILENAME CF 1 NIL 1 NIL (UPPERCASEARRAY))) then (printout COPYFILESOUTPUT (OR (SUBSTRING CF (ADD1 (NCHARS NEWFILENAME))) ".")) else (printout COPYFILESOUTPUT " => " CF)))) (AND COPYFILESTERSE (PRIN1 "." COPYFILESTERSE)))) (QUOTE (ICREATIONDATE)) "*" (if COPYFILESVERSIONS then "*" else "") NIL (SELECTQ (fetch (FDEV GENERATEFILES) of (\GETDEVICEFROMNAME FROMSPEC)) ((\FTP.GENERATEFILES \LEAF.GENERATEFILES \NSFILING.GENERATEFILES \TCPFTP.GENERATEFILES) (* ; "If source is PupFtp, TCP, or NS, enumerate the whole directory first, lest some awkward copy cause the source enumeration stream to die.") T) NIL)) (if COPYFILESPURGE then (* ; "delete from source if doesn't exist on destination") (AND COPYFILESOUTPUT (printout COPYFILESOUTPUT T "Deleting files on destination but not on source" T)) (COPYFILES TOSPEC FROMSPEC (APPEND (if COPYFILESOUTPUT then (LIST (LIST (QUOTE OUTPUT) COPYFILESOUTPUT))) (if COPYFILESASK then (LIST (LIST (QUOTE ASK) COPYFILESASKDEFAULT))) (QUOTE (= PURGESOURCE))))) (COND (COPYFILESOUTPUT (TAB 0 0 COPYFILESOUTPUT) (NEQ COPYFILESOUTPUT T) (CLOSEF COPYFILESOUTPUT))))) ) (MAPFILES [LAMBDA (FILESPEC FN ATTRIBUTES DEFAULTEXT DEFAULTVERS INCLUDE-DIRECTORIES ENUMERATE-FIRST) (* ; "Edited 6-Apr-2018 21:14 by rmk:") (* ;; "Run thru all the files that match FILESPEC, calling FN on each such file name, with remaining args being the value of each of the ATTRIBUTES of the file") (if (LISTP FILESPEC) then (for X in FILESPEC do (MAPFILES X FN DEFAULTEXT DEFAULTVERS ATTRIBUTES INCLUDE-DIRECTORIES ENUMERATE-FIRST)) elseif [OR (STRPOS "*" FILESPEC) (FMEMB (NTHCHARCODE FILESPEC -1) (CHARCODE (/ > %) %] } %:] then (* ; "Pattern or directory spec") (SETQ FILESPEC (DIRECTORY.FILL.PATTERN FILESPEC DEFAULTEXT DEFAULTVERS)) (if ENUMERATE-FIRST then (* ;  "Generate all the files first, then apply fn") (for PAIR in [XCL:WITH-COLLECTION (MAPFILES1 FILESPEC ATTRIBUTES INCLUDE-DIRECTORIES (FUNCTION (CL:LAMBDA (NAME &REST ATTRS) (XCL:COLLECT (CONS NAME ATTRS] do (CL:APPLY FN (CAR PAIR) (CDR PAIR))) else (* ; "Call on each one as we go") (MAPFILES1 FILESPEC ATTRIBUTES INCLUDE-DIRECTORIES FN)) elseif (SETQ FILESPEC (INFILEP FILESPEC)) then (CL:APPLY FN FILESPEC (for ATTR inside ATTRIBUTES collect (GETFILEINFO FILESPEC ATTR]) (MAPFILES1 (LAMBDA (FILESPEC ATTRIBUTES INCLUDE-DIRECTORIES FN) (* ; "Edited 27-Sep-89 14:49 by bvm") (* ;; "Enumerate FILESPEC (pattern must already be filled) and apply FN to each file and its ATTRIBUTES") (RESETLST (LET ((FILEGROUP (\GENERATEFILES FILESPEC (SETQ ATTRIBUTES (MKLIST ATTRIBUTES)) (QUOTE (SORT RESETLST)))) NAME LEN) (while (SETQ NAME (\GENERATENEXTFILE FILEGROUP)) unless (PROGN (* ; "Skip IFS's .;1 file. Also other dir files unless INCLUDE-DIRECTORIES is true.") (OR (AND (>= (SETQ LEN (NCHARS NAME)) 4) (STRING-EQUAL NAME ".;1" :START1 (- LEN 4))) (AND (NOT INCLUDE-DIRECTORIES) (FMEMB (NTHCHARCODE NAME LEN) (CHARCODE (/ >)))))) do (if (NULL (CDR ATTRIBUTES)) then (* ; "Optimize slightly for the case of one attribute") (CL:FUNCALL FN NAME (\GENERATEFILEINFO FILEGROUP (CAR ATTRIBUTES))) else (CL:APPLY FN NAME (for ATTR in ATTRIBUTES collect (\GENERATEFILEINFO FILEGROUP ATTR)))))))) ) (COPIEDFILENAME (LAMBDA (FILENAME COPIEDFROMSPEC COPIEDTOSPEC PRESERVEVERSION) (* ; "Edited 27-Sep-89 15:03 by bvm") (* ;; "FILENAME is the file produced by the directory enumeration. COPIEDFROMSPEC is the parsed 'FROM' specification, and COPIEDTOSPEC is either a directory specification (string) or else a list, CDR of which is a list of character atoms.") (SETQ FILENAME (COND ((LISTP COPIEDTOSPEC) (* ; "destination is a pattern, so have to be fancy. NOHOST strips off the HOST field") (CONCATLIST (LET ((FROMCHARS (NOHOST (UNPACK FILENAME)))) (if (NOT PRESERVEVERSION) then (* ; "Discard the version") (RPLACD (NLEFT FROMCHARS 1 (FMEMB (QUOTE ;) FROMCHARS)))) (COPIEDFILEPATTERN COPIEDFROMSPEC (CDR COPIEDTOSPEC) FROMCHARS)))) (T (CL:APPLY (FUNCTION PACKFILENAME.STRING) (QUOTE DIRECTORY) COPIEDTOSPEC (QUOTE HOST) NIL (QUOTE DEVICE) NIL (QUOTE DIRECTORY) NIL (BQUOTE ((\,@ (AND (NOT PRESERVEVERSION) (QUOTE (VERSION NIL)))) BODY (\, FILENAME))))))) (COND ((EQ (NTHCHARCODE FILENAME -1) (CHARCODE %.)) (* ;; "this is a terrible kludge, to get around the problem that for some devices, (INFILEP 'FOO.') fails while (INFILEP 'FOO') doesn't. This stripping off of a terminal '.' doesn't hurt, but doesn't belong here. Necessary for getting a working version for the harmony release.") (SUBSTRING FILENAME 1 -2 FILENAME)) (T FILENAME))) ) (COPIEDFILEPATTERN (LAMBDA (FRPAT TOPAT CHARS) (* ; "Edited 27-Sep-89 15:58 by bvm") (while (AND FRPAT CHARS (EQ (U-CASE (CAR FRPAT)) (U-CASE (CAR CHARS)))) do (* ; "Skip to the first place where pattern and actual name differ") (pop FRPAT) (pop CHARS)) (NCONC (on old TOPAT while (NEQ (CAR TOPAT) (QUOTE *)) collect (CAR TOPAT)) (COND ((AND FRPAT (NEQ (CAR FRPAT) (QUOTE *))) (* ; "Ran out of pattern before getting to a *") (if (AND (NULL CHARS) (OR (if (AND (EQ (CAR FRPAT) (QUOTE %.)) (EQ (CADR FRPAT) (QUOTE *))) then (NULL (SETQ FRPAT (CDDR FRPAT)))) (EQUAL FRPAT (QUOTE (; *)))) (OR (NULL TOPAT) (EQUAL TOPAT (QUOTE (*))))) then NIL else (ERROR "--From Spec doesn't match generated file"))) (TOPAT (* ; "both TOPAT and FRPAT start with *") (NCONC (LDIFF CHARS (SETQ CHARS (for X on CHARS when (COPIEDFILEMATCH X (CDR FRPAT)) do (* ; "Find the last tail of CHARS that matches the pattern") (SETQ $$VAL X)))) (COPIEDFILEPATTERN (CDR FRPAT) (CDR TOPAT) CHARS))) (T (OR (COPIEDFILEMATCH CHARS FRPAT) (ERROR "file pattern doesn't match")) NIL)))) ) (COPIEDFILEMATCH (LAMBDA (CHARS FRPAT) (* ; "Edited 27-Sep-89 15:44 by bvm") (PROG ((SEMI* (QUOTE (; *)))) LP (if (NULL FRPAT) then (RETURN (NULL CHARS)) elseif (EQ (CAR FRPAT) (QUOTE *)) then (* ; "Match arbitrarily many CHARS") (RETURN (OR (NULL (SETQ FRPAT (CDR FRPAT))) (EQUAL FRPAT SEMI*) (find X on CHARS suchthat (COPIEDFILEMATCH X FRPAT)))) elseif (NULL CHARS) then (RETURN (EQUAL FRPAT SEMI*)) elseif (EQ (U-CASE (pop FRPAT)) (U-CASE (pop CHARS))) then (GO LP) else (RETURN)))) ) (COPIEDFROMSPEC (LAMBDA (FROMSPEC) (* ; "Edited 27-Sep-89 15:52 by bvm") (* ;; "Return something for copiedfilepattern to work on") (SETQ FROMSPEC (MKSTRING FROMSPEC)) (SETQ FROMSPEC (NOHOST (ESPATTERN (LET ((DIREND (for I from (SUB1 (OR (CL:POSITION #\* FROMSPEC) (NCHARS FROMSPEC))) to 0 by -1 do (CASE (CL:CHAR FROMSPEC I) ((#\/ #\> #\}) (RETURN I))))) CAN) (if (AND DIREND (SETQ CAN (DIRECTORYNAME (CL:SUBSEQ FROMSPEC 0 (ADD1 DIREND))))) then (* ; "Canonicalize the directory before we proceed, so that files coming back have a hope of matching") (CONCAT CAN (CL:SUBSEQ FROMSPEC (ADD1 DIREND))) else FROMSPEC))))) (if (NOT (FMEMB (QUOTE ;) FROMSPEC)) then (* ; "Add ;* to match gracefully against real file names like foo.baz;3") (NCONC FROMSPEC (LIST (QUOTE ;) (QUOTE *))) else FROMSPEC)) ) (COPIEDTOSPEC (LAMBDA (SPEC) (* ; "Edited 29-Oct-87 16:23 by jds") (* ;; "Create the spec for what file(s) are to be copied TO: If there's a * in the spec or there's more than just directory specified, then return the pattern for filename matching; if a directory got specified, return that.") (COND ((STRPOS "*" SPEC) (* ; "There are wildcards in the name.") (CONS (QUOTE PATTERN) (ESPATTERN SPEC))) ((UNPACKFILENAME.STRING SPEC (QUOTE NAME)) (* ; "There's more than just a directory spec.") (CONS (QUOTE PATTERN) (ESPATTERN SPEC))) (T (* ; "It's a directory (or had better be!)") (OR (DIRECTORYNAME SPEC NIL T) (ERROR SPEC "not a valid directory"))))) ) (ESPATTERN (LAMBDA (X) (* ; "Edited 27-Sep-89 15:50 by bvm") (SETQ X (UNPACK X)) (for Y on X do (SELECTQ (CAR Y) ((*) (* ; "Turn *.*; into *;") (if (AND (EQ (CADR Y) (QUOTE %.)) (EQ (CADDR Y) (QUOTE *)) (FMEMB (CADDDR Y) (QUOTE (NIL ;)))) then (RPLACD Y (CDDDR Y)))) NIL)) X) ) (NOHOST (LAMBDA (UP) (SELECTQ (CAR UP) (({ %( %[) (do (pop UP) (SELECTQ (CAR UP) (NIL (RETURN)) ((} %) %]) (RETURN (pop UP))) (%' (pop UP)) NIL))) NIL) UP) ) (COMPAREFILES [LAMBDA (OLDFILE NEWFILE OSTART OEND) (* ; "Edited 9-Apr-91 16:42 by jds") (* ;  "Compare two files to see if their contents are the same. ") (* ;; "If OSTART & OEND are specified, they are as for COPYBYTES--I.E., fileptrs into the OLD file to compare the new file to.") [CL:WITH-OPEN-STREAM [OSTREAM (OPENSTREAM OLDFILE 'INPUT 'OLD '(SEQUENTIAL T] (CL:WITH-OPEN-STREAM [NSTREAM (OPENSTREAM NEWFILE 'INPUT 'OLD '(SEQUENTIAL T] (LET (OLEN NLEN NBYTES OBYTE NBYTE) (SETQ OLEN (GETFILEINFO OSTREAM 'LENGTH)) (SETQ NLEN (GETFILEINFO NSTREAM 'LENGTH)) [COND [OSTART (* ;  "He specified a starting fileptr or a char count.") (COND ((NOT OEND) (* ;  "It was a char count (no ending point specified)") (SETQ NBYTES OSTART) (SETQ OSTART 0)) (T (* ; "He specified an ending point.") (SETFILEPTR OSTREAM OSTART) (SETQ NBYTES (IDIFFERENCE OEND OSTART)) (SETQ OSTART 0] (T (* ;  "Nothing specified; run thru the whole file.") (SETQ OSTART 0) (SETQ NBYTES OLEN) (COND ((NOT (EQP OLEN NLEN)) (* ;  "If they files are of different lengths, they aren't the same.") (ERROR "File lengths differ: " (CONCAT OLEN " vs " NLEN] [COND (OLEN (* ;  "FTP returns NIL for the length of an empty file!") (for BYTEPOS from OSTART to (SUB1 NBYTES) do (COND ((NEQ (SETQ OBYTE (BIN OSTREAM)) (SETQ NBYTE (BIN NSTREAM))) (PRINTOUT T "Files differ at byte " BYTEPOS ", old-file has " OBYTE " but new file has " NBYTE "." T) (OR (ASKUSER NIL NIL "Continue comparing?") (RETURN] (CLOSEF? OSTREAM) (CLOSEF? NSTREAM] T]) ) (* ;; "For concatenating a list of files into one file.") (DEFINEQ (CONCATFILES (LAMBDA (INPUT-FILES OUTPUT-FILE) (CL:WITH-OPEN-STREAM (OUT (OPENSTREAM OUTPUT-FILE (QUOTE OUTPUT) (QUOTE NEW) (QUOTE (SEQUENTIAL T)))) (for FILE in INPUT-FILES do (CL:WITH-OPEN-STREAM (IN (OPENSTREAM FILE (QUOTE INPUT) (QUOTE OLD) (QUOTE (SEQUENTIAL T)))) (COPYBYTES IN OUT))))) ) ) (* ;; "For splitting a big file into several files.") (DEFINEQ (SPLITFILE [LAMBDA (FILE SPLIT-SIZE) (* ; "Edited 26-Jan-93 20:46 by jds") (CL:WITH-OPEN-STREAM (INSTR (OPENSTREAM FILE 'INPUT 'OLD)) (for I from 1 as START from 0 by SPLIT-SIZE while (ILESSP START (GETEOFPTR INSTR)) do (CL:WITH-OPEN-STREAM (OUTSTR (OPENSTREAM (PACKFILENAME 'VERSION NIL 'NAME (CONCAT (UNPACKFILENAME.STRING FILE 'NAME) I) 'BODY FILE) 'OUTPUT 'NEW)) (COPYBYTES INSTR OUTSTR START (IMIN (GETEOFPTR INSTR) (+ START SPLIT-SIZE]) ) (* ;; "For making DOS file systems") (DEFINEQ (DOSLINKER [LAMBDA (FILES OLDDIR STREAM) (* ; "Edited 23-Mar-93 02:38 by jds") (for FILE in FILES do (PRINTOUT STREAM "ln -s " OLDDIR FILE " " (L-CASE (SHORTEN (UNPACKFILENAME.STRING FILE 'NAME) 8)) "." (L-CASE (SHORTEN (UNPACKFILENAME.STRING FILE 'EXTENSION) 3)) T]) (SHORTEN [LAMBDA (STRING LEN) (SUBSTRING STRING 1 (IMIN LEN (NCHARS STRING]) ) (DECLARE%: EVAL@COMPILE (I.S.OPR 'INFILES NIL '[SUBST (GENSYM) 'GENVAR '(BIND GENVAR _ (\GENERATEFILES BODY NIL '(SORT)) EACHTIME (PROGN (OR (SETQ I.V. (\GENERATENEXTFILE GENVAR)) (GO $$OUT)) (IF (LISTP I.V.) THEN (SETQ I.V. (CONCATCODES I.V.] T) ) (PUTPROPS COPYFILES COPYRIGHT ("Venue & Xerox Corporation" 1989 1990 1991 1993 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1047 20469 (COPYFILES 1057 . 9186) (MAPFILES 9188 . 11549) (MAPFILES1 11551 . 12470) ( COPIEDFILENAME 12472 . 13818) (COPIEDFILEPATTERN 13820 . 14874) (COPIEDFILEMATCH 14876 . 15368) ( COPIEDFROMSPEC 15370 . 16169) (COPIEDTOSPEC 16171 . 16831) (ESPATTERN 16833 . 17114) (NOHOST 17116 . 17277) (COMPAREFILES 17279 . 20467)) (20536 20846 (CONCATFILES 20546 . 20844)) (20909 22086 (SPLITFILE 20919 . 22084)) (22132 23009 (DOSLINKER 22142 . 22919) (SHORTEN 22921 . 23007))))) STOP \ No newline at end of file diff --git a/library/DANDELIONKEYBOARDS b/library/DANDELIONKEYBOARDS new file mode 100644 index 00000000..68d06fad --- /dev/null +++ b/library/DANDELIONKEYBOARDS @@ -0,0 +1 @@ +((EUROPEAN ((100 (53 197 NOLOCKSHIFT)) (101 (52 196 NOLOCKSHIFT)) (102 (54 198 NOLOCKSHIFT)) (103 ( 61887 61759 LOCKSHIFT)) (104 (55 199 NOLOCKSHIFT)) (105 (61888 61760 LOCKSHIFT)) (106 (61872 61744 LOCKSHIFT)) (107 (61860 61732 LOCKSHIFT)) (108 (48 126 NOLOCKSHIFT)) (109 (61892 61764 LOCKSHIFT)) ( 110 (203 207 NOLOCKSHIFT)) (111 (61919 61791 LOCKSHIFT)) (112 (47 191 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 195 NOLOCKSHIFT)) (117 (50 194 NOLOCKSHIFT)) (118 (61873 61745 LOCKSHIFT)) (119 (61858 61730 LOCKSHIFT)) (120 (61874 61746 LOCKSHIFT)) (121 (61859 61731 LOCKSHIFT)) (122 (57 202 NOLOCKSHIFT)) (123 (61886 61758 LOCKSHIFT)) (124 (61864 61736 LOCKSHIFT)) (125 (61903 61775 LOCKSHIFT)) (126 (61908 61780 LOCKSHIFT)) (127 (241 225 LOCKSHIFT)) (128 (187 170 LOCKSHIFT)) ( 129 (249 233 LOCKSHIFT)) (132 (49 193 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61905 61777 LOCKSHIFT)) (137 (61869 61741 LOCKSHIFT)) (138 (61877 61749 LOCKSHIFT)) (139 (61906 61778 LOCKSHIFT)) (140 (251 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 ( 250 234 LOCKSHIFT)) (143 (59 58 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (171 186 LOCKSHIFT )) (148 (61904 61776 LOCKSHIFT)) (149 (61920 61792 LOCKSHIFT)) (150 (61921 61793 LOCKSHIFT)) (151 ( 61857 61729 LOCKSHIFT)) (152 (61863 61735 LOCKSHIFT)) (153 (56 200 NOLOCKSHIFT)) (154 (61900 61772 LOCKSHIFT)) (155 (239 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( 246 230 LOCKSHIFT)) (159 (207 176 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (logic ((100 ( 53 37 NOLOCKSHIFT)) (101 (52 164 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61258 61260 NOLOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (61292 61293 NOLOCKSHIFT)) (106 (61271 61270 NOLOCKSHIFT) ) (107 (61284 61285 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61307 61306 NOLOCKSHIFT)) (110 (45 177 NOLOCKSHIFT)) (111 (61269 61268 LOCKSHIFT)) (112 (172 174 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61240 61241 NOLOCKSHIFT)) (119 ( 61234 61235 NOLOCKSHIFT)) (120 (61266 61262 NOLOCKSHIFT)) (121 (61365 61365 NOLOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (61275 61274 NOLOCKSHIFT)) (124 (61300 61299 NOLOCKSHIFT)) (125 (61273 61272 NOLOCKSHIFT)) (126 (61282 61283 NOLOCKSHIFT)) (127 (61256 61257 NOLOCKSHIFT)) (128 (61356 61356 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61250 61251 NOLOCKSHIFT)) (137 (61298 61297 NOLOCKSHIFT)) (138 (61305 61303 NOLOCKSHIFT)) (139 (61265 61264 NOLOCKSHIFT)) (140 (61364 61364 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (61281 233 NOLOCKSHIFT)) (143 (61351 61351 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (61357 61357 NOLOCKSHIFT)) (148 (61279 61278 NOLOCKSHIFT)) (149 (61239 61238 NOLOCKSHIFT)) (150 (61290 61290 NOLOCKSHIFT)) (151 (61263 61261 NOLOCKSHIFT)) (152 (61295 61295 NOLOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61252 61253 NOLOCKSHIFT)) (155 (61254 61255 NOLOCKSHIFT) ) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (MATH ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61284 61285 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (174 61245 NOLOCKSHIFT)) (107 (61369 61363 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61254 61255 NOLOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (173 61246 LOCKSHIFT)) ( 112 (47 61300 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61282 61283 LOCKSHIFT)) (119 (61287 61286 NOLOCKSHIFT)) (120 (61301 61302 NOLOCKSHIFT)) (121 (61351 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (175 61247 LOCKSHIFT)) (124 ( 180 184 LOCKSHIFT)) (125 (172 61244 LOCKSHIFT)) (126 (61256 61257 LOCKSHIFT)) (127 (44 61250 NOLOCKSHIFT)) (128 (61298 61253 NOLOCKSHIFT)) (129 (93 61265 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) ( 133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 ( 61356 61362 LOCKSHIFT)) (138 (61254 61291 NOLOCKSHIFT)) (139 (98 61360 NOLOCKSHIFT)) (140 (61309 177 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 61251 NOLOCKSHIFT)) (143 (61299 61252 NOLOCKSHIFT)) ( 144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (61358 82 LOCKSHIFT)) (149 (61296 61266 NOLOCKSHIFT)) (150 (61305 61303 NOLOCKSHIFT)) (151 (61308 61267 LOCKSHIFT)) (152 (61288 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61357 61361 NOLOCKSHIFT)) (155 (61292 61293 LOCKSHIFT)) ( 156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 61264 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (OFFICE ((100 (61397 61381 NOLOCKSHIFT)) (101 ( 61396 61380 NOLOCKSHIFT)) (102 (61398 61382 NOLOCKSHIFT)) (103 (8557 8554 NOLOCKSHIFT)) (104 (61399 61383 NOLOCKSHIFT)) (105 (61232 8743 NOLOCKSHIFT)) (106 (61346 8571 NOLOCKSHIFT)) (107 (188 86 NOLOCKSHIFT)) (108 (61402 61386 NOLOCKSHIFT)) (109 (210 8738 NOLOCKSHIFT)) (110 (61437 61438 NOLOCKSHIFT)) (111 (163 8558 NOLOCKSHIFT)) (112 (61248 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (61395 61379 NOLOCKSHIFT)) (117 (61394 61378 NOLOCKSHIFT)) (118 (185 8553 NOLOCKSHIFT)) ( 119 (176 8546 NOLOCKSHIFT)) (120 (167 8744 NOLOCKSHIFT)) (121 (97 8745 NOLOCKSHIFT)) (122 (61401 61385 NOLOCKSHIFT)) (123 (162 8570 NOLOCKSHIFT)) (124 (61437 88 NOLOCKSHIFT)) (125 (111 8569 NOLOCKSHIFT)) (126 (61289 8737 NOLOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (61393 61377 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61233 8742 NOLOCKSHIFT)) (137 (61438 67 NOLOCKSHIFT)) (138 (8739 74 NOLOCKSHIFT)) (139 (190 61436 NOLOCKSHIFT)) (140 (189 90 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( 142 (61249 62 NOLOCKSHIFT)) (143 (61352 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 61280 NOLOCKSHIFT)) (148 (212 8574 NOLOCKSHIFT)) (149 (61354 8573 NOLOCKSHIFT)) (150 (61286 8741 NOLOCKSHIFT)) (151 (165 8572 NOLOCKSHIFT)) (152 (61368 8740 NOLOCKSHIFT)) (153 (61400 61384 NOLOCKSHIFT)) (154 (173 175 NOLOCKSHIFT)) (155 (172 174 NOLOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61406 61368 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (DVORAK ((100 (49 42 NOLOCKSHIFT)) (101 (51 41 NOLOCKSHIFT)) (102 (57 37 NOLOCKSHIFT)) (103 (46 62 NOLOCKSHIFT)) (104 (48 38 NOLOCKSHIFT)) (105 (101 69 LOCKSHIFT)) (106 (103 71 LOCKSHIFT)) (107 (107 75 LOCKSHIFT)) (108 (54 45 NOLOCKSHIFT)) (109 (116 84 LOCKSHIFT)) (110 (56 95 NOLOCKSHIFT)) (111 (108 76 LOCKSHIFT)) (112 (122 90 LOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (53 40 NOLOCKSHIFT)) (117 (55 35 NOLOCKSHIFT)) (118 (44 60 NOLOCKSHIFT)) (119 (63 47 NOLOCKSHIFT)) ( 120 (111 79 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (52 164 NOLOCKSHIFT)) (123 (99 67 LOCKSHIFT)) ( 124 (113 81 LOCKSHIFT)) (125 (114 82 LOCKSHIFT)) (126 (110 78 LOCKSHIFT)) (127 (119 87 LOCKSHIFT)) ( 128 (44 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (33 64 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (117 85 LOCKSHIFT)) (137 (106 74 LOCKSHIFT)) (138 (104 72 LOCKSHIFT)) (139 (120 88 LOCKSHIFT)) (140 (59 58 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (118 86 LOCKSHIFT)) (143 (115 83 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (169 170 NOLOCKSHIFT)) (148 (112 80 LOCKSHIFT)) (149 (121 89 LOCKSHIFT)) (150 (105 73 LOCKSHIFT)) (151 (102 70 LOCKSHIFT)) (152 (100 68 LOCKSHIFT)) (153 (50 162 NOLOCKSHIFT)) (154 (98 66 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( 91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (GREEK ((100 ( 53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (9830 69 LOCKSHIFT)) ( 104 (55 38 NOLOCKSHIFT)) (105 (9829 9797 LOCKSHIFT)) (106 (9849 9817 LOCKSHIFT)) (107 (115 9814 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (9837 9805 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (9843 9811 LOCKSHIFT)) (112 (47 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (9853 9821 LOCKSHIFT)) (119 (9835 9803 LOCKSHIFT)) (120 (9846 9814 LOCKSHIFT)) (121 (9825 9793 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (9836 9804 LOCKSHIFT)) (124 ( 9851 9819 LOCKSHIFT)) (125 (9842 9810 LOCKSHIFT)) (126 (9838 9806 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT) ) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (9850 9818 LOCKSHIFT)) (137 (9841 9809 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (9826 66 LOCKSHIFT)) (140 (9833 9801 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (9845 9813 LOCKSHIFT)) (149 (9848 9816 LOCKSHIFT)) (150 (9828 9796 LOCKSHIFT)) (151 (9852 9820 LOCKSHIFT)) (152 (9834 9802 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) ( 154 (9840 9808 LOCKSHIFT)) (155 (9839 9807 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT ) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (ITALIAN ((100 (53 61903 NOLOCKSHIFT)) (101 (52 61886 NOLOCKSHIFT)) (102 (54 61919 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) ( 116 (51 61872 NOLOCKSHIFT)) (117 (50 61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (39 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) ( 145 (95 170 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) ( 151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) ( 155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (SPANISH ((100 (53 61904 NOLOCKSHIFT)) (101 (52 61887 NOLOCKSHIFT)) (102 (54 61920 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 61873 NOLOCKSHIFT)) (117 (50 61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 ( 97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 ( 111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (59 58 NOLOCKSHIFT)) (129 (203 187 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) ( 143 (61900 61772 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (161 191 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61925 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (44 171 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (FRENCH ((100 (53 61905 NOLOCKSHIFT)) (101 (52 61888 NOLOCKSHIFT)) (102 (54 61921 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) ( 105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) ( 109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 61874 NOLOCKSHIFT)) (117 (50 61859 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (39 61857 NOLOCKSHIFT)) (129 (61872 61892 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (61869 61741 LOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61919 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61873 61877 LOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (GERMAN ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (251 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) ( 116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) ( 120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) ( 124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) ( 128 (39 34 NOLOCKSHIFT)) (129 (61863 61735 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT )) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 ( 121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 ( 109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61908 61780 LOCKSHIFT)) (159 (61925 61797 LOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION) (STANDARD-RUSSIAN (( 100 (34 52 NOLOCKSHIFT)) (101 (47 51 NOLOCKSHIFT)) (102 (58 53 NOLOCKSHIFT)) (103 (10085 10037 LOCKSHIFT)) (104 (44 54 NOLOCKSHIFT)) (105 (10067 10019 LOCKSHIFT)) (106 (10068 10020 LOCKSHIFT)) (107 (10078 10030 LOCKSHIFT)) (108 (63 57 NOLOCKSHIFT)) (109 (10077 10029 LOCKSHIFT)) (110 (37 48 NOLOCKSHIFT)) (111 (10073 10025 LOCKSHIFT)) (112 (10071 10023 LOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (45 50 NOLOCKSHIFT)) (117 (61352 49 NOLOCKSHIFT)) (118 (10088 10040 LOCKSHIFT)) (119 ( 10075 10027 LOCKSHIFT)) (120 (10093 10045 LOCKSHIFT)) (121 (10086 10038 LOCKSHIFT)) (122 (95 56 NOLOCKSHIFT)) (123 (10090 10042 LOCKSHIFT)) (124 (10089 10041 LOCKSHIFT)) (125 (10091 10043 LOCKSHIFT) ) (126 (10069 10021 LOCKSHIFT)) (127 (10066 10018 LOCKSHIFT)) (128 (10095 10047 LOCKSHIFT)) (129 ( 10092 10044 LOCKSHIFT)) (132 (167 43 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (10065 10017 LOCKSHIFT)) (137 (10083 10035 LOCKSHIFT)) (138 (10080 10032 LOCKSHIFT)) (139 (10074 10026 LOCKSHIFT)) (140 (10097 10049 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( 142 (10096 10048 LOCKSHIFT)) (143 (10072 10024 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (41 40 NOLOCKSHIFT)) (148 (10076 10028 LOCKSHIFT)) (149 (10070 10022 LOCKSHIFT)) (150 (10081 10033 LOCKSHIFT)) (151 (10079 10031 LOCKSHIFT)) (152 (10082 10034 LOCKSHIFT)) (153 (46 55 NOLOCKSHIFT)) (154 (10084 10036 LOCKSHIFT)) (155 (10094 10046 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (10087 10039 LOCKSHIFT)) (159 (33 61 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DANDELION)) \ No newline at end of file diff --git a/library/DATABASEFNS b/library/DATABASEFNS new file mode 100644 index 00000000..18f7dc7d --- /dev/null +++ b/library/DATABASEFNS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "11-Jun-90 14:51:14" {DSK}local>lde>lispcore>library>DATABASEFNS.;3 17357 changes to%: (VARS DATABASEFNSCOMS) previous date%: "23-May-90 16:15:36" {DSK}local>lde>lispcore>library>DATABASEFNS.;2) (* ; " Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DATABASEFNSCOMS) (RPAQQ DATABASEFNSCOMS [ (* ;; "Does automatic Masterscope database maintenance") [DECLARE%: FIRST (P (VIRGINFN 'LOAD T) (MOVD? 'LOAD 'OLDLOAD) (VIRGINFN 'LOADFROM T) (MOVD? 'LOADFROM 'OLDLOADFROM) (VIRGINFN 'MAKEFILE T) (MOVD? 'MAKEFILE 'OLDMAKEFILE] (FNS DBFILE DBFILE1 DBFILE2 LOAD LOADFROM MAKEFILE) (ADDVARS (LINKEDFNS OLDLOAD)) (P (RELINK 'MAKEFILES)) (FNS DUMPDB LOADDB MAKEDB) (PROP PROPTYPE DATABASE) (INITVARS (LOADDBFLG 'ASK) (SAVEDBFLG 'ASK)) (ADDVARS (MAKEFILEFORMS (MAKEDB FILE))) (* ; "To permit MSHASH interface") (INITVARS (MSHASHFILENAME) (MSFILETABLE)) (LOCALVARS . T) (BLOCKS (LOADDB LOADDB DBFILE DBFILE1 DBFILE2 (NOLINKFNS . T))) (DECLARE%: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T]) (* ;; "Does automatic Masterscope database maintenance") (DECLARE%: FIRST (VIRGINFN 'LOAD T) (MOVD? 'LOAD 'OLDLOAD) (VIRGINFN 'LOADFROM T) (MOVD? 'LOADFROM 'OLDLOADFROM) (VIRGINFN 'MAKEFILE T) (MOVD? 'MAKEFILE 'OLDMAKEFILE) ) (DEFINEQ (DBFILE [LAMBDA (FILE ASKFLAG) (* lmm "29-APR-81 20:27") (* Finds a database file that corresponds to the contents of FILE.  Looks in directory of FILE, and also in the directory that file originally came  from, if it was copied. Returns NIL if no database file is found, else  (fulldbfilename . filedates)%, where filedates identifies the name under which  the file that the database corresponds to is currently known.  -  If FILE doesn't have a version, tries to get database for version in core, or  most recent version if it hasn't been loaded) (DECLARE (GLOBALVARS COMPILE.EXT FILERDTBL)) [COND ((NULL FILE) (SETQ FILE (INPUT))) ((EQ (FILENAMEFIELD FILE 'EXTENSION) COMPILE.EXT) (* Map compiled file into symbolic  name) (SETQ FILE (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY FILE] (PROG [(FILEDATES (COND [(AND (NULL (FILENAMEFIELD FILE 'VERSION)) (CAR (GETPROP (NAMEFIELD FILE) 'FILEDATES] ([SETQ FILE (COND (ASKFLAG (INFILEP FILE)) (T (FINDFILE FILE] (CONS (FILEDATE FILE) FILE] (AND FILEDATES (RETURN (DBFILE1 FILE FILEDATES]) (DBFILE1 [LAMBDA (F FILEDATES) (* jds "25-Sep-86 20:04") (* Searches databases based on F to find one that matches FILEDATES.  Returns (dbfilename . filedates) if successful.  For efficiency, checks the most likely highest version first, before doing the  directory enumeration) (PROG ((HIGHEST (INFILEP (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION 'NIL 'BODY F))) DBF) (RETURN (COND ((NULL HIGHEST) (* ;  "No file matches the name we gave, so punt.") NIL) ((SETQ DBF (DBFILE2 HIGHEST FILEDATES)) (* ; "The most recent one matches.") (CONS DBF FILEDATES)) (T (* ;  "Hunt back thru back versions looking for a matching one.") (for DBF in (REMOVE HIGHEST (FILDIR (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION '* 'BODY F))) when (SETQ DBF (DBFILE2 DBF FILEDATES)) do (RETURN (CONS DBF FILEDATES]) (DBFILE2 [LAMBDA (DBF FILEDATES) (* jds "25-Sep-86 20:01") (* T if DBF is the name of the database file matching FILEDATES) (DECLARE (GLOBALVARS FILERDTBL)) [RESETSAVE (SETQ DBF (OPENSTREAM DBF 'INPUT)) '(PROGN (CLOSEF? OLDVALUE] (* The close is done in the LOADDB RESETLST, except when a candidate file isn't  correct) (SKREAD DBF) (* Skip LOAD error message) (COND ((STREQUAL (CAR FILEDATES) (CAR (READ DBF FILERDTBL))) DBF) (T (CLOSEF DBF) NIL]) (LOAD [LAMBDA (FILE LDFLG PRINTFLG) (* lmm "29-APR-81 20:27") (SETQ FILE (OLDLOAD FILE LDFLG PRINTFLG)) (COND ((NEQ LDFLG 'SYSLOAD) (LOADDB FILE T))) FILE]) (LOADFROM [LAMBDA (FILE FNS LDFLG) (* lmm "29-APR-81 20:27") (SETQ FILE (OLDLOADFROM FILE FNS LDFLG)) (LOADDB FILE T) FILE]) (MAKEFILE [LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE) (* lmm "29-APR-81 20:27") (SETQ FILE (OLDMAKEFILE FILE OPTIONS REPRINTFNS SOURCEFILE)) (DUMPDB FILE T) FILE]) ) (ADDTOVAR LINKEDFNS OLDLOAD) (RELINK 'MAKEFILES) (DEFINEQ (DUMPDB [LAMBDA (FILE PROPFLG) (* ; "Edited 2-Dec-86 07:59 by jds") (* Dumps a Masterscope database for functions in FILE.  Checks the DATABASE property if PROPFLG=T which is how the MAKEFILE advice  calls it. A user-level call would default PROPFLG to NIL.) (* The FILE check is because MAKEFILE returns a list when it doesn't understand  the options) (DECLARE (GLOBALVARS MSHASHFILENAME MSFILETABLE SAVEDBFLG)) (AND FILE (LITATOM FILE) (PROG (DBFILE (FL (NAMEFIELD FILE)) FNS (FFNS (FILEFNSLST FILE))) (COND (FFNS) ((AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE))) (* Always dump if this is a known file) (SETQ PROPFLG NIL)) (T (COND (PROPFLG (/REMPROP FL 'DATABASE)) (T (printout T T FILE " has no functions." T))) (RETURN))) (SETQ FNS FFNS) (COND ([OR (NULL PROPFLG) (EQ (GETPROP FL 'DATABASE) 'YES) (EQ SAVEDBFLG 'YES) (AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE] (* If MSHASH is loaded, only dump functions in the local database) [COND (MSHASHFILENAME (SETQ FNS (for FN in FNS when (PROGN (UPDATEFN FN) (LOCALFNP FN)) collect FN] [RESETLST [RESETSAVE (SETQ DBFILE (OPENSTREAM (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION NIL 'BODY FILE) 'OUTPUT 'NEW)) '(PROGN (CLOSEF? OLDVALUE) (AND RESETSTATE (DELFILE OLDVALUE] (RESETSAVE (OUTPUT DBFILE)) (PRIN1 "(PROGN (PRIN1 %"Use LOADDB to load database files! %" T) (ERROR!)) ") [AND MSFILETABLE (STORETABLE FL MSFILETABLE (PRINT (CAR (GETPROP FL 'FILEDATES] (COND (MSHASHFILENAME (UPDATECONTAINS FL FFNS T))) (* T flag means that the function won't be erased--it might still be  interesting) (printout NIL "FNS " |.P2| FFNS T) (* So the database file knows which functions are on the file) (COND (FNS (DUMPDATABASE FNS)) (T (printout NIL "STOP" T] [COND (PROPFLG (PRINT (FULLNAME DBFILE) T)) (T (/PUT FL 'DATABASEFILENAME DBFILE) (* Remember that we have this file  valid already.) (/PUT FL 'DATABASE 'YES] (* Take future note of the databae on a user call) (RETURN (FULLNAME DBFILE]) (LOADDB [LAMBDA (FILE ASKFLAG) (* ; "Edited 2-Dec-86 08:01 by jds") (* Loads the database file corresponding to FILE, asking for confirmation only  if ASKFLAG is T, which is the case from the advice on LOAD but not from usual  user-level calls. Before asking, it looks around first to see whether a  database file of the appropriate name really exists.) (DECLARE (GLOBALVARS MSHASHFILENAME MSFILETABLE MSARGTABLE DWIMWAIT FILERDTBL LOADDBFLG)) (RESETLST (PROG* [TEM NEWFNS FORFILE (NF (NAMEFIELD FILE)) (DBSTREAM (DBFILE FILE ASKFLAG)) (DBFILE (FULLNAME (CAR DBSTREAM] (COND (DBSTREAM (SETQ FORFILE (CDR DBSTREAM)) (SETQ DBSTREAM (CAR DBSTREAM))) (T (COND ((NULL ASKFLAG) (printout T "no database file found for " NF T))) (RETURN))) (COND ([COND [ASKFLAG (COND ((EQ (GETPROP NF 'DATABASEFILENAME) DBFILE) (* If the database for this very file has already been loaded, don't bother  doing it again.) (printout T "Database " DBFILE " already loaded." T) NIL) (T (SELECTQ (GETPROP NF 'DATABASE) (YES T) (NO NIL) (SELECTQ LOADDBFLG (YES (/PUT NF 'DATABASE 'YES)) (NO (/PUT NF 'DATABASE 'NONE) NIL) (OR (AND MSFILETABLE (TESTTABLE NF (CADR MSFILETABLE ))) (COND ((EQ (ASKUSER DWIMWAIT 'Y (LIST "load database for" NF)) 'Y) (/PUT NF 'DATABASE 'YES)) (T (/PUT NF 'DATABASE 'NO) NIL] (T (/PUT NF 'DATABASE 'YES] (LISPXPRINT (FULLNAME DBFILE) T) (* DBSTREAM was opened in DBFILE) (RESETSAVE (INPUT DBSTREAM)) [COND ((EQ (SETQ TEM (READ NIL FILERDTBL)) 'FNS) (SETQ NEWFNS (READ NIL FILERDTBL)) (COND ((EQ (SETQ TEM (READ NIL FILERDTBL)) 'ARGS) [COND [MSHASHFILENAME (bind F while (SETQ F (READ NIL FILERDTBL)) do (STORETABLE F MSARGTABLE (READ NIL FILERDTBL] (T (while (READ NIL FILERDTBL] (SETQ TEM (READ NIL FILERDTBL] (COND ((OR (EQ (CAR (LISTP TEM)) 'READATABASE) (EQ TEM 'STOP)) (COND ((NEQ TEM 'STOP) (* It must be (READATABASE)) (READATABASE))) (COND (MSHASHFILENAME (UPDATECONTAINS NF NEWFNS))) (AND MSFILETABLE (STORETABLE NF MSFILETABLE FORFILE)) (* This is done whether or not there is a hashfile.) (UPDATEFILES) (* Mark any edited fns as needing to  be reanalyzed.) (for FN in (CDR (GETP NF 'FILE)) when (OR (EXPRP FN) (GETP FN 'EXPR)) do (MSMARKCHANGED FN))) (T (printout T T DBFILE " is not a database file!" T) (* So that value of LOADDB is NIL) (SETQ DBFILE NIL))) (/PUT NF 'DATABASEFILENAME DBFILE) (* Remember the name of the database  we just loaded.) (RETURN (FULLNAME DBFILE]) (MAKEDB [LAMBDA (F) (* DECLARATIONS%: UNDOABLE) (* rmk%: " 9-NOV-83 02:56") (DECLARE (GLOBALVARS SAVEDBFLG MSFILETABLE DWIMWAIT)) (SETQ F (NAMEFIELD F)) (* The extension is stripped off for purposes of the DATABASE.  This maps compiled files into the root name, but means that we can't have  multiple-extension files with different database status) (COND ((INFILECOMS? T 'FNS (FILECOMS F)) (OR (FMEMB (GETPROP F 'DATABASE) '(YES NO)) (FMEMB SAVEDBFLG '(YES NO)) (AND MSFILETABLE (TESTTABLE F (CADR MSFILETABLE))) (/PUT F 'DATABASE (COND ((EQ 'Y (ASKUSER DWIMWAIT 'N "Do you want a Masterscope Database for this file? ") ) 'YES) (T 'NO]) ) (PUTPROPS DATABASE PROPTYPE IGNORE) (RPAQ? LOADDBFLG 'ASK) (RPAQ? SAVEDBFLG 'ASK) (ADDTOVAR MAKEFILEFORMS (MAKEDB FILE)) (* ; "To permit MSHASH interface") (RPAQ? MSHASHFILENAME ) (RPAQ? MSFILETABLE ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: LOADDB LOADDB DBFILE DBFILE1 DBFILE2 (NOLINKFNS . T)) ) (DECLARE%: EVAL@COMPILE DONTCOPY (RESETSAVE DWIMIFYCOMPFLG T) ) (PUTPROPS DATABASEFNS COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1742 6250 (DBFILE 1752 . 3400) (DBFILE1 3402 . 4925) (DBFILE2 4927 . 5616) (LOAD 5618 . 5848) (LOADFROM 5850 . 6038) (MAKEFILE 6040 . 6248)) (6306 16783 (DUMPDB 6316 . 10038) (LOADDB 10040 . 15695) (MAKEDB 15697 . 16781))))) STOP \ No newline at end of file diff --git a/library/DEDIT b/library/DEDIT new file mode 100644 index 00000000..49ed0d18 --- /dev/null +++ b/library/DEDIT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "29-Aug-91 13:42:59" |{PELE:MV:ENVOS}LIBRARY>DEDIT.;4| 110005 changes to%: (FNS SETUPDEDITW) (RECORDS STACK) (MACROS EDITBLOCKCALL CONTROLCODE OVERLAP SHIFTSELECTKEYS) previous date%: "27-Aug-91 13:00:13" |{PELE:MV:ENVOS}LIBRARY>DEDIT.;3|) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. The following program was created in 1982 but has not been published within the meaning of the copyright law, is furnished under license, and may not be used, copied and/or disclosed except in accordance with the terms of said license. ") (PRETTYCOMPRINT DEDITCOMS) (RPAQQ DEDITCOMS [(COMS (* ; "User entry to the editor") (PROP (Definition-for-EDITL Definition-for-EDITE Definition-for-EDITDATE) DEDIT) [DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (*DISPLAY-EDITOR* 'DEDIT] (FNS DEDITIT)) (COMS (* ; "Hooks between tty editor and DEDIT. We redefine EDITL to get into DEDIT from system editor calls") (FNS DEDITL DEDITL0 DEDITTTYFN)) (COMS (* ; "Basic DEDIT menu commands") (FNS DEDITAfter DEDITBefore DEDITDelete DEDITReplace DEDITSwitch DEDITBI DEDITBO DEDITLI DEDITLO DEDITRI DEDITRO DEDITUndo UNDOCHOOSE DEDITFind DEDITSwap DEDITCenter DEDITCopy DEDITReprint DEDITEditCom DEDITARGS DEDITBreak DEDITEval DEDITExit) (FNS DEDITEdit DEDITCEdit DEDIT.TTYinEdit DEDITDatatype) (ADDVARS (DT.EDITMACROS))) (COMS (* ; "Structure changing") (FNS SETPTRTO DEDITCONS DEDITZAPCAR DEDITZAPCDR DEDITZAPNODE DEDITZAPBOTH DEDITFZAP DEDITZAPCLISP DEDITZAPCHANGES DEDITMOVETAILDOWN DUNDOEDITL DUNDOEDITCOM DUNDOEDITCOM1)) (COMS (* ;  "Selection code. Select expressions or from the command menu") (FNS DEDITSLCTLP DEDITUSER SELECTKEYS DODEDITTYPEDCOM DEDITREADLINE SHADEIFNOTBUF DEDITBUTTONFN DEDITRIGHTBUTTONFN DEDITWINDOWENTRYFN SELECTELEMENT SELECTREAD SELECTTREE SEARCHMAP WITHINME ONAPARENP SELECTDONE INWINDOW FINDLCA DOMINATE?) (ALISTS (DEDITTYPEINCOMS F S Z)) (PROP VARTYPE DEDITTYPEINCOMS)) (COMS (* ; "Handling the selection stack") (FNS POPSELECTION PUSHSELECTION NXTSELECTION TOPSELECTION SWITCHANDSHADE SHADESELECTION SHADESELECTION1 SHADESELECTION2 OVERLAPSELBAND PUSHEDITCHAIN MAKESELCHAIN PUSHINTOBUF DUMMYMAPENTRY FLIPSELS FLIPSELSIN FIXUPSEL NEWSELFOR)) (COMS (* ;  "Initializing and flushing edit windows") (FNS ACTIVEEDITW FINDEDITW GETEDITW GETDEDITDEF4 MAKEEDITW NAMEOFEDITW PURGEW MAKECPOSBE SAMEEDITW SETUPDEDITW TOPEDITW UNDEDITW WHICHEDITW ZORCHEDITW ZORCHEDWP UNZORCHME) (INITVARS (DEditLinger T))) (COMS (* ; "Manipulating the Edit menu") (FNS SETEDITMENU CACHEDEDITCOMS FINDEDITCOM READEDITMENU SHADEMENUENTRY DEDITMENURESTORE) [VARS (*DEDIT-MENU-COMMANDS* '((After DEDITAfter) (Before DEDITBefore) (Delete DEDITDelete) (Replace DEDITReplace) (Switch DEDITSwitch) ("( )" DEDITBI ("( ) in" DEDITBI) ("( in" DEDITLI) (") in" DEDITRI)) ("( ) out" DEDITBO ("( ) out" DEDITBO) ("( out" DEDITLO) (") out" DEDITRO)) (Undo DEDITUndo (Undo DEDITUndo) (!Undo (DEDITUndo T)) (?Undo (UNDOCHOOSE)) (&Undo (UNDOCHOOSE T))) (Find DEDITFind) (Swap DEDITSwap (Center DEDITCenter) (Clear (SETQ \DEDITSELECTIONS NIL)) (Copy DEDITCopy) (Pop (POPSELECTION)) (Swap DEDITSwap)) (Reprint DEDITReprint) [Edit DEDITEdit [DEdit (DEDITEdit 'DISPLAY 'Def) NIL (SUBITEMS ("DEdit Def" (DEDITEdit 'DISPLAY 'Def)) ("DEdit Form" (DEDITEdit 'DISPLAY 'Form] [TTYEdit (DEDITEdit 'TELETYPE 'Def) NIL (SUBITEMS ("TTYEdit Def" (DEDITEdit 'TELETYPE 'Def)) ("TTYEdit Form" (DEDITEdit 'TELETYPE 'Form] (TTYIn% Form (DEDITEdit 'DEDIT.TTYinEdit 'Form] [EditCom DEDITEditCom (?= DEDITARGS) (GETD (DEDITEditCom 'GETD)) (CL (DEDITEditCom 'CL)) (DW (DEDITEditCom 'DW)) (REPACK (DEDITEditCom 'REPACK)) (CAP (DEDITEditCom 'CAP)) (LOWER (DEDITEditCom 'LOWER)) (RAISE (DEDITEditCom 'RAISE] (Break DEDITBreak) (Eval DEDITEval) (Exit DEDITExit (OK DEDITExit) (STOP (DEDITExit T] (GLOBALVARS *DEDIT-MENU-COMMANDS*)) (COMS (* ;  "Maintaining deditmap entries and the edit chain") (FNS BUFSELP EDITWINDOWP GETLEFT GETMEBP HASASBP TAILOF DOTTEDEND GETME4 GETSELMAP DEARME DPCDRSEL GETDPME GETEBUF GETEBUFREGION GETEDITCHAIN GETDEDITMAP GETMAP? UNPURGEDP SUBSELOF SETDEDITMAP TAKEDOWN) (INITVARS (*DEDIT-BUFFER-HEIGHT* 60)) (GLOBALVARS *DEDIT-BUFFER-HEIGHT*)) (COMS (FNS DEDITRESHAPEFN DEDITREPAINTFN) (FNS RESETDEDIT DEDITDATE DEDITMARKASCHANGED) (FNS COPYCONS COPYOUTCONS MAPENTRYP THELIST) (FNS CANT)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS STACK) (MACROS EDITBLOCKCALL CONTROLCODE OVERLAP SHIFTSELECTKEYS) (CONSTANTS (LINETHICKNESS 2) (PRIMSHADE 65535) (SECSHADE 3598) (SWITCHSHADE (LOGXOR PRIMSHADE SECSHADE)) (READSHADE 23130) (CHANGEDSHADE 8840)) (GLOBALVARS DEditWindow \DEDITMNUW \DEDITBUFW \DEDITALLOWSELS \DEDITWINDOWS \DEDITSELECTIONS DT.EDITMACROS UPFINDFLG) (SPECVARS ATM EDITCHANGES EDITHIST LASTAIL UNDOLST UNDOLST1)) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) DEDITPP)) [DECLARE%: DONTEVAL@LOAD DOCOPY (FILES DSPRINTDEF NEWPRINTDEF DEDITPP) (P (AND (GETD 'RESETDEDIT) (RESETDEDIT] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CANT]) (* ; "User entry to the editor") (PUTPROPS DEDIT Definition-for-EDITL DEDITL) (PUTPROPS DEDIT Definition-for-EDITE TTY/EDITE) (PUTPROPS DEDIT Definition-for-EDITDATE DEDITDATE) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQQ *DISPLAY-EDITOR* DEDIT) ) (DEFINEQ (DEDITIT [LAMBDA (EFN EARGS EMODE) (* bas%: "21-MAR-83 20:38") (RESETFORM (EDITMODE EMODE) (APPLY EFN EARGS]) ) (* ; "Hooks between tty editor and DEDIT. We redefine EDITL to get into DEDIT from system editor calls") (DEFINEQ (DEDITL [LAMBDA (L COMS ATM MESS EDITCHANGES) (* bas%: "19-JUN-83 23:58") (* Value is edit push-down list L. EDITCHANGES is used for destructively marking whether the edit made any changes.) (RESETLST (RESETSAVE \DEDITSELECTIONS (create STACK)) (COND (COMS (RESETSAVE EDITMACROS (CONS '(TTY%: NIL (E (DEDITTTYFN ATM TYPE) T)) EDITMACROS)) (NORMAL/EDITL L COMS ATM MESS EDITCHANGES)) (T (AND MESS (printout PROMPTWINDOW .TAB0 0 MESS T)) [PROG [MARKLST UNDOLST UNDOLST0 UNDOLST1 UNFIND LASTAIL TMP (EXPR (CAR (LAST L] (* EXPR is the top level expression. L is usually a list of only one element, i.e. you usually start editing at the top, but not necessarily, since editl can be called directly.) [COND ([OR (EQ EXPR (GETPROP 'EDIT 'LASTVALUE)) [AND ATM (EQ EXPR (SETQ TMP (GETPROP ATM 'EDIT-SAVE] (SOME (CAR LISPXHISTORY) (FUNCTION (LAMBDA (X) (EQ EXPR (SETQ TMP (CADR (MEMB 'EDIT X] (* First clause is old method of always saving last call on editor property list. Second clause searches history list for a call to editor corresponding to this expression.) (SETQ MARKLST (CADR TMP)) (SETQ UNDOLST (CADDR TMP)) (COND ((CAR UNDOLST) (* Don't want to block it twice.) (push UNDOLST NIL))) (SETQ UNDOLST0 UNDOLST) (* Marks UNDOLST as of this entry to editor, so UNDO of this entire EDIT session won't go too far back.) (SETQ UNFIND (CDDDR TMP] (COND [(PROG1 (DEDITL0 EXPR (GETEDITW ATM (AND (BOUNDP 'TYPE) TYPE))) (* Even if some error occurs, still want to move undo information to LISPXHISTORY.) [COND (UNDOLST1 (push UNDOLST (CONS T (CONS \DEDITSELECTIONS UNDOLST1] (AND LISPXHIST (NEQ UNDOLST UNDOLST0) (UNDOSAVE (LIST 'DUNDOEDITL \DEDITSELECTIONS UNDOLST UNDOLST0) LISPXHIST)) (* Makes entire DEDITL undoable.) ) (* Normal OK exit) (AND ATM (LITATOM ATM) (REMPROP ATM 'EDIT-SAVE)) [SETQ TMP (CONS EXPR (CONS MARKLST (CONS UNDOLST (LIST EXPR] (PUTPROP 'EDIT 'LASTVALUE TMP) (COND (LISPXHIST (NCONC LISPXHIST (LIST 'EDIT TMP] (T (ERROR!] L]) (DEDITL0 [LAMBDA (EXPR EDS SEL) (* bvm%: "31-Jul-86 14:35") (* * "DEDITL0 should only be called while under DEDITL or DEDITTTYFN since the global states of the edit are all bound there. Note that individual calls to DEDITL0 are not undoable, because structure changes are saved on UNDOLST1 and only moved to UNDOLST at the end of each command. DEDITL finally moves UNDOLST to LISPXHISTORY.") (RESETSAVE NIL (LIST 'SETCURSOR (CURSOR WAITINGCURSOR))) [LET ((PM (GETMAP? EDS)) (ENV (DEDIT-MAKE-READER-ENV EXPR)) OLDENV) (COND ((AND PM (EQ EXPR (fetch SELEXP of PM)) (SETQ OLDENV (WINDOWPROP EDS 'READER-ENVIRONMENT)) (EQUAL-READER-ENVIRONMENT OLDENV ENV)) (* "Editing the same thing that's in the window now, and in the same reader environment") (TOTOPW EDS) (* "Window might have been closed") ) (T (WINDOWPROP EDS 'READER-ENVIRONMENT ENV) (SETUPDEDITW EDS (LIST EXPR] (AND SEL (PUSHEDITCHAIN SEL)) (* "ERSETQ prevents UNDOLST lossage due to ^E") (ERSETQ (bind EDITHIST COM ACT SS do (until (SETQ COM (DEDITSLCTLP EDS))) (SETQ SS \DEDITSELECTIONS) (* "Save selection stack") (SETQ ACT (CDR COM)) (* "Unpack CONS from READEDITMENU") (SETQ COM (CAR COM)) [COND (EDITHISTORY (COND ((PROG1 (AND ATM (NOT EDITHIST)) (* First time thru) (EDITBLOCKCALL EDITSAVE COM) (* Sets EDITHIST) ) (LISPXPUT '*FIRSTPRINT* (LIST 'EDITL2 ATM T) NIL EDITHIST] (SETQ UNDOLST1 NIL) (* "Holds any changes from execution of this command.") (COND [(PROG1 [ERSETQ (COND ((LITATOM ACT) (APPLY* ACT)) (T (EVAL ACT] [COND (UNDOLST1 (REPPCHANGES UNDOLST1) (push UNDOLST (SETQ UNDOLST1 (CONS COM (CONS SS UNDOLST1] (COND (EDITHIST (* "Set in EDITSAVE.") (RPLACA EDITHIST UNDOLST1] (T (* "Restore selections") (SETQ \DEDITSELECTIONS SS))) (* "Only way out is a RETFROM via one of the exit fns") ]) (DEDITTTYFN [LAMBDA (NAME TYPE) (* bas%: " 7-AUG-83 16:38") (* Provides DEDIT interface to TTY%: commands from under standard editor) (DECLARE (USEDFREE L LASTAIL)) (* From EDITL0) (PROG [UNDOLST TEM (TE (CAR (LAST L] [RESETLST (* The RESETLST is for DEDITL0; the binding of UNDOLST1 protects the containing EDIT; TEM=T unless DEDITL0 was STOPed) (PROG (UNDOLST1) (SETQ TEM (DEDITL0 TE (GETEDITW NAME TYPE) L] (AND UNDOLST (push UNDOLST1 (CONS 'GROUPED UNDOLST))) (COND (TEM [SETQ L (OR (AND (SUBSELOF TE (TOPSELECTION T)) (GETEDITCHAIN (TOPSELECTION T))) (for I on L thereis (AND (SUBSELOF TE (CAR I)) (SETQ LASTAIL (CAR I] (* Reset edit chain only if current selection still points to some part of the expression being edited) ) ([EVALV 'COMS (SETQ TEM (STKPOS 'EDITL0] (RETEVAL TEM '(ERROR!) T)) (T (SHOULDNT]) ) (* ; "Basic DEDIT menu commands") (DEFINEQ (DEDITAfter [LAMBDA NIL (* bas%: "17-MAR-83 22:15") (PROG ([NU (COPY (CAR (POPSELECTION] (TGT (POPSELECTION))) (DEDITZAPCDR TGT (PUSHSELECTION (COND ((DPCDRSEL TGT) (DEDITCONS (CDR TGT) NU TGT)) (T (DEDITCONS NU (CDR TGT) TGT]) (DEDITBefore [LAMBDA NIL (* bas%: "16-MAR-83 12:40") (PROG ((SRC (POPSELECTION)) (TGT (POPSELECTION))) (PUSHSELECTION (SETPTRTO TGT (DEDITCONS (COPY (CAR SRC)) (COND ((DPCDRSEL TGT) (CDR TGT)) (T TGT)) TGT]) (DEDITDelete [LAMBDA NIL (* bas%: "16-MAR-83 11:51") (* Deletes top elt from structure. Pushes it back on into the buffer) (PROG ((S (POPSELECTION))) [PUSHINTOBUF (LIST (COPY (CAR S] (* Copy keeps structure in buffer separate from that on undolst, which may later get inserted back) (SETPTRTO S (COND ((DPCDRSEL S) NIL) (T (CDR S]) (DEDITReplace [LAMBDA NIL (* bas%: " 5-JUL-83 23:50") (PROG ((SRC (POPSELECTION)) (TGT (TOPSELECTION))) (DEDITZAPCAR TGT (SUBST (CAR TGT) (OR EDITEMBEDTOKEN (CONSTANT (PACK NIL))) (CAR SRC]) (DEDITSwitch [LAMBDA NIL (* bas%: "16-MAR-83 21:05") (PROG ((A (TOPSELECTION)) (B (NXTSELECTION))) (COND ((OR (DOMINATE? A B) (DOMINATE? B A)) (CANT "Switch into oneself"))) (DEDITZAPCAR A (PROG1 (CAR B) (DEDITZAPCAR B (CAR A]) (DEDITBI [LAMBDA NIL (* bas%: "16-MAR-83 11:51") (PROG ((A (POPSELECTION)) (B (POPSELECTION)) C) (COND ((TAILOF B A)) [(TAILOF A B) (SETQ A (PROG1 B (SETQ B A] (T (CANT "Not brothers!"))) (COND ((DPCDRSEL B)) (T (SETQ C (CDR B)) (* Done in this order in case A=B) (DEDITZAPCDR B NIL))) (DEDITZAPBOTH A (COPYCONS A) C) (PUSHSELECTION A]) (DEDITBO [LAMBDA NIL (* bas%: "12-Sep-84 14:37") (PROG ((TGT (POPSELECTION))) (DEDITMOVETAILDOWN TGT NIL) (SETPTRTO TGT (CAR TGT]) (DEDITLI [LAMBDA NIL (* bas%: " 2-MAR-83 11:33") (PROG ((A (TOPSELECTION))) (DEDITZAPBOTH A (COPYCONS A]) (DEDITLO [LAMBDA NIL (* bas%: " 2-MAR-83 11:34") (PROG ((A (TOPSELECTION))) (DEDITZAPNODE A (THELIST (CAR A]) (DEDITRI [LAMBDA NIL (* bas%: "30-Sep-84 13:19") (PROG (B (A (POPSELECTION))) (OR (CDR A) (CANT "RI at end of tail has no effect")) (* Has no effect and scrambles undo list) [SETQ B (fetch TAIL of (GETMEBP (GETME4 A T] (DEDITMOVETAILDOWN B (CDR A)) (DEDITZAPCDR A NIL) (PUSHSELECTION B]) (DEDITRO [LAMBDA NIL (* bas%: "12-Sep-84 14:40") (DEDITMOVETAILDOWN (TOPSELECTION) NIL]) (DEDITUndo [LAMBDA (END) (* bas%: "12-Sep-84 23:54") (bind FLG for LST on UNDOLST do (OR FLG (SETQ FLG (CAAR LST))) (DUNDOEDITCOM (CAR LST) T) repeatuntil (OR (NULL END) (EQ END (CAR LST)) (NULL (CAR LST))) finally (OR FLG (CANT (COND ((CDR LST) "Undo blocked") (T "Nothing saved"]) (UNDOCHOOSE [LAMBDA (THRUP) (* bas%: "22-Mar-84 23:14") (PROG [(C (RESETFORM (CURSOR DEFAULTCURSOR) (MENU (create MENU ITEMS _ (APPEND (for I in UNDOLST collect (LIST (OR (CAR I) (PACK* "* " (CADR I) " *")) (KWOTE I))) (LIST (LIST '**TOP** NIL))) TITLE _ (COND (THRUP "Undo Thru") (T "Undo One")) CENTERFLG _ T] (COND ((NOT C)) (THRUP (DEDITUndo C)) (T (DUNDOEDITCOM C T]) (DEDITFind [LAMBDA NIL (* bas%: " 5-Apr-84 23:21") (PROG (LASTAIL L TGT UNFIND (COM 'Find)) (DECLARE (SPECVARS L UNFIND COM)) (SETQ L (GETEDITCHAIN (POPSELECTION))) (* Sets LASTAIL) (SETQ TGT (CAR (TOPSELECTION))) (COND ([ERSETQ (RESETVARS (UPFINDFLG) (EDIT4F TGT 'N] (PUSHEDITCHAIN L) (* Uses LASTAIL) ) (T (CANT TGT "Not found"]) (DEDITSwap [LAMBDA NIL (* bas%: "24-MAR-83 15:57") (replace TOPELT of \DEDITSELECTIONS with (PROG1 (NXTSELECTION) (replace NXTELT of \DEDITSELECTIONS with (  TOPSELECTION ]) (DEDITCenter [LAMBDA (NOTIFVIS) (* bas%: "26-Mar-84 15:17") (PROG [AW WO WH (A (GETME4 (TOPSELECTION] (OR A (RETURN)) (SETQ AW (WFROMDS (fetch PDSP of A))) (SETQ WO (WYOFFSET NIL AW)) (SETQ WH (WINDOWPROP AW 'HEIGHT)) (AND NOTIFVIS (OVERLAPSELBAND A (IPLUS WO WH) WO) (RETURN)) (* Make sure the sel highlite is visible) (RESETVARS (\DEDITSELECTIONS) (* Supress selections as they are not up and the scrollw will otherwise take them down) (SCROLLW AW 0 (IDIFFERENCE (IPLUS WO (IQUOTIENT (IDIFFERENCE WH (IDIFFERENCE (fetch STARTY of A) (fetch STOPY of A))) 2)) (fetch STOPY of A]) (DEDITCopy [LAMBDA NIL (* bas%: " 2-MAR-83 11:37") (PUSHINTOBUF (LIST (COPY (CAR (TOPSELECTION]) (DEDITReprint [LAMBDA NIL (* bas%: " 2-MAR-83 11:37") (REPP (GETME4 (TOPSELECTION) T]) (DEDITEditCom [LAMBDA (C) (* bas%: "30-MAR-83 20:55") [OR C (SETQ C (CAR (POPSELECTION] (PROG (TYPE ATM EDITCHANGES LASTAIL LASTP1 LASTP2 TSM SCR (TS (POPSELECTION))) (DECLARE (SPECVARS TYPE ATM EDITCHANGES LASTAIL LASTP1 LASTP2)) (* For DEDITL and EDITL0) [COND ((SETQ TSM (GETME4 TS)) [COND ((SETQ SCR (WINDOWPROP (fetch PDSP of TSM) 'DEDITWHOAMI)) (SETQ ATM (CAR SCR)) (SETQ TYPE (CADR SCR] (SETQ EDITCHANGES (WINDOWPROP (fetch PDSP of TSM) 'DEDITCHANGES] (PUSHEDITCHAIN (EDITL0 (GETEDITCHAIN TS) (MKLIST C]) (DEDITARGS [LAMBDA (F) (* bas%: "26-Mar-84 15:18") (SETQ F (OR F (TOPSELECTION))) (while (LISTP F) do (SETQ F (CAR F))) (PUSHINTOBUF (LIST (CONS F (COPY (CAR (OR (AND (LITATOM F) (NLSETQ (SMARTARGLIST F T))) '((not a function]) (DEDITBreak [LAMBDA NIL (* lmm " 1-JUL-84 23:33") (PROG (WHO AMP CARFORM (A (POPSELECTION))) (SETQ AMP (GETME4 A)) [SETQ WHO (AND AMP (WINDOWPROP (fetch PDSP of AMP) 'DEDITWHOAMI] (DEDITZAPCAR A (LIST 'BREAK1 (CAR A) T [BREAKINCOMMENT WHO (LIST 'AROUND (COND ((NLISTP (CAR A)) (CAR A)) (T (CAAR A] NIL)) (OR [COND (AMP (AND (fetch BP of AMP) (FMEMB (CAAR (fetch TAIL of (fetch BP of AMP))) NOBREAKS) (PROMPTPRINT "Break installed inside a NOBREAKS")) (COND ((EQ (CADR WHO) 'FNS) (/PUTPROP (CAR WHO) 'BROKEN-IN T) (/PUTPROP (CAR WHO) 'BRKINFO (LIST (LIST (LIST 'AROUND CARFORM) NIL NIL))) (/SET 'BROKENFNS (CONS (CAR WHO) BROKENFNS] (PROMPTPRINT "Break installed, but not recorded"]) (DEDITEval [LAMBDA NIL (* bas%: "19-Mar-84 09:44") (PROG [(S (CAR (POPSELECTION))) (SP (STKNTH 2 'DEDITL0] (* There are various entry points. They all call DEDITL0 after having done an ERRORSET.) [PUSHINTOBUF (COND ((LITATOM S) (LIST (EVALV S SP))) ((ERSETQ (ENVAPPLY (FUNCTION LISPXEVAL) (LIST S NIL) SP))) (T (LIST 'NOBIND] (RELSTK SP]) (DEDITExit [LAMBDA (STOPFLG) (* mjs "26-Mar-86 12:33") (AND EDITHIST ATM (NOT STOPFLG) (LISPXPUT '*PRINT* (LIST 'EDITL2 ATM) NIL EDITHIST)) (* Hoaky stuff for the edit history list) (RETFROM (FUNCTION DEDITL0) (NOT STOPFLG) T]) ) (DEFINEQ (DEDITEdit [LAMBDA (EDITOR EDITEE) (* bvm%: "30-May-86 16:50") (RESETLST (RESETSAVE (SETCURSOR DEFAULTCURSOR) (LIST 'SETCURSOR WAITINGCURSOR)) (PROG ((S (CAR (TOPSELECTION))) A) (SELECTQ EDITEE ((Def NIL) (COND ((NOT (OR (LISTP S) (LITATOM S))) (DEDITDatatype S)) ((AND (for old (S _ (POPSELECTION)) by (CAR S) while (LISTP S) finally (RETURN (LITATOM S))) (SETQ A (TYPESOF S NIL NIL '?)) (SETQ A (SELECT.ATOM.ASPECT S NIL A))) (RESETSAVE (EDITMODE EDITOR)) (* User can refuse all SELECT.ATOM.ASPECT choices) (EDITDEF S A '?)) (T (CANT "No editable aspect")))) (Form (AND [SETQ S (APPLY* (SELECTQ EDITOR ((TELETYPE DISPLAY) (RESETSAVE (EDITMODE EDITOR)) (FUNCTION EDITE)) EDITOR) (LIST (COPY S] (DEDITZAPCAR (TOPSELECTION) (CAR S)))) (SHOULDNT]) (DEDITCEdit [LAMBDA (E FN) (* bvm%: "30-May-86 16:55") (* * "Edits an expression using the editor defined by FN. FN takes 2 args, the first a list of the expression(s) to edit, the second the edit window. Returns new list of expressions.") (LET ((EW (GETEBUF (TOPEDITW))) V) (SETQ V (APPLY* FN E EW)) (COND ((CDR V) (* Replaced one expression with many) (SETQ V (LIST V))) (T V)) (OR (BUFSELP (GETME4 (TOPSELECTION))) (BUFSELP (GETME4 (NXTSELECTION T))) (SETUPDEDITW EW (COPY V))) V]) (DEDIT.TTYinEdit [LAMBDA (S) (* bvm%: "30-May-86 16:55") (COND ((DEFINEDP 'TTYINEDIT) (DEDITCEdit S 'TTYINEDIT)) (T (CANT "TTYIN not loaded"]) (DEDITDatatype [LAMBDA (obj) (* bvm%: " 4-NOV-83 18:43") (PROG ((DTMAC (FASSOC (TYPENAME obj) DT.EDITMACROS)) newObj source installSourceFn changedFlg) (DECLARE (SPECVARS changedFlg)) (OR DTMAC (RETURN (INSPECT obj))) (* CADR is a function which gets a list structure source for the datatype. CADDR is a function which installs the source back in the dataType. It is called when the source has been changed in the editing.) (COND ((NULL (SETQ source (APPLY* (CADR DTMAC) obj))) (* If this fn returns NIL, we assume it has done any desired editing itself) (RETURN))) (SETQ installSourceFn (CADDR DTMAC)) LP [SETQ source (EDITE source NIL obj (TYPENAME obj) (FUNCTION (LAMBDA NIL (SETQ changedFlg T] [COND ((NOT changedFlg) (RETURN)) ((NLSETQ (SETQ newObj (OR (APPLY* installSourceFn obj source) obj))) (RETURN (DEDITZAPCAR (TOPSELECTION) newObj] (PROMPTPRINT "Error in datatype edit source") (GO LP)) (DEDITReprint]) ) (ADDTOVAR DT.EDITMACROS ) (* ; "Structure changing") (DEFINEQ (SETPTRTO [LAMBDA (X Y) (* bas%: "12-Sep-84 16:25") (PROG (XM BK TEM) (COND ((NOT (SETQ XM (GETME4 X))) (CANT "Already deleted!")) ([SETQ TEM (GETLEFT XM (SETQ BK (GETMEBP XM] (DEDITZAPCDR TEM Y)) ((fetch BP of BK) (DEDITZAPCAR BK Y)) ((NLISTP Y) (CANT "Delete last list element")) (T [DEDITZAPBOTH X (CAR Y) (COND ((EQ X (CDR Y)) (RPLNODE2 Y X)) (T (CDR Y] (SETQ Y X))) (RETURN Y]) (DEDITCONS [LAMBDA (A D BROTHER) (* bas%: "25-MAR-83 17:12") (fetch TAIL of (DUMMYMAPENTRY (CONS A D) (GETMEBP (OR (GETME4 BROTHER) (CANT "Invalid target"]) (DEDITZAPCAR [LAMBDA (M A) (* bas%: " 2-MAR-83 15:38") (DEDITZAPBOTH M A (CDR (OR (LISTP M) (fetch TAIL of M]) (DEDITZAPCDR [LAMBDA (M D) (* bas%: "25-JUL-82 16:23") (DEDITZAPBOTH M (CAR (OR (LISTP M) (fetch TAIL of M))) D]) (DEDITZAPNODE [LAMBDA (M C) (* bas%: "27-JUL-81 04:48") (DEDITZAPBOTH M (CAR C) (CDR C]) (DEDITZAPBOTH [LAMBDA (CC A D ENT) (* bas%: "18-Mar-84 15:19") (* ALL edit changes go through this function.) (COND [[SETQ ENT (COND [(type? DEDITMAP CC) (PROG1 CC (SETQ CC (fetch TAIL of CC] (T (GETME4 CC] (COND ((fetch BP of ENT)) ((BUFSELP ENT)) ((AND (EQ D (CDR CC)) (LISTP (CAR CC)) (LISTP A)) (SETQ CC (CAR CC)) (* We cant effect the dummy CONS held onto by the editor as that wont be seen by someone holding the defn (old EDIT just took error here) Here we try to oblige by sliding down into the first cell of the defn But we have to remove any pointers that the new CAR or CDR might have to the original cell, lest we create a cycle.) (SETQ D (COPYOUTCONS (CDR A) CC)) (SETQ A (COPYOUTCONS (CAR A) CC))) (T (CANT "Alter top"))) [COND ((DPCDRSEL ENT) [SETQ CC (LAST (fetch SELEXP of (fetch BP of ENT](* Real CONS) (SETQ D (COND ((NEQ A (CDR CC)) A) (T D))) (SETQ A (CAR CC)) (PROG ((V (DOTTEDEND D))) (COND (V (DEDITFZAP (fetch TAIL of ENT) V V)) (T (PUTHASH (fetch TAIL of (fetch BP of ENT)) NIL \DEDITDPHASH) (PUTHASH (fetch TAIL of ENT) NIL \DEDITMEHASH] (AND EDITSMASHUSERFN (APPLY* EDITSMASHUSERFN CC (GETEDITCHAIN ENT))) (COND ((DEDITFZAP CC A D) [PROG [(TEM (CDR (WINDOWPROP (fetch PDSP of ENT) 'DEDITCHANGES] (* Undoably smashes EDITCHANGES from call in which change is being made, unless already set) (OR (NOT TEM) (CAR TEM) (DEDITFZAP TEM T (CDR TEM] (AND CHANGESARRAY (DEDITZAPCHANGES ENT)) (* A smashed cell is always changed) (for (E _ ENT) by (fetch BP of E) while E do (DEDITZAPCLISP (fetch SELEXP of E] (T (AND EDITSMASHUSERFN (APPLY* EDITSMASHUSERFN CC (LIST CC))) (DEDITFZAP CC A D]) (DEDITFZAP [LAMBDA (CC A D) (* bas%: "18-Mar-84 15:11") (* Smashes cons CC and makes UNDOLST entry but uses no other context. Used for making changes to editor structures sauch as the undo list itself) (PROG ((OA (CAR CC)) (OD (CDR CC))) (* Dont smash EQ values. Slow b/c of refcnts and clutters up UNDOLST) (RETURN (AND (COND ((EQ D OD) (AND (NEQ A OA) (FRPLACA CC A))) ((EQ A OA) (FRPLACD CC D)) (T (RPLNODE CC A D))) (push UNDOLST1 (CONS CC (CONS OA OD]) (DEDITZAPCLISP [LAMBDA (CC) (* bas%: "30-MAR-83 23:01") (* Deletes CLISP translation. Not made part of the edit event, because of the possibility of the user performing two changes, and then undoing the first, which would then restore the translation, even though it no longer corresponds to the untranslated and changed CLISP.) (COND ((NLISTP CC)) [(AND CLISPTRANFLG (EQ CLISPTRANFLG (CAR CC))) (COND ((LISTP (CDDR CC)) (/RPLNODE2 CC (CDDR CC))) (T (* CLISP% used to translate an atom e.g. QLISP does this.) (SHOULDNT] ((AND CLISPARRAY (GETHASH CC CLISPARRAY)) (/PUTHASH CC NIL CLISPARRAY]) (DEDITZAPCHANGES [LAMBDA (ME) (* bas%: "18-OCT-81 22:29") (COND ((for (I _ ME) by (fetch BP of I) while I never (GETHASH (fetch TAIL of I) CHANGESARRAY)) [push UNDOLST1 (CONS 'LISPXHIST (LIST (LIST '/PUTHASH (fetch TAIL of ME) (GETHASH (fetch TAIL of ME) CHANGESARRAY) CHANGESARRAY] (* Done this way for efficiency rather than going through editcom1 since we know what to undosave.) (PUTHASH (fetch TAIL of ME) ATM CHANGESARRAY]) (DEDITMOVETAILDOWN [LAMBDA (C NUTAIL) (* bas%: "12-Sep-84 14:41") (* This moves C's current CDR to the end of the list which is its current CAR and replaces that CDR which it has just moved with NUTAIL. Order of moves helps simplify REPP) (DEDITZAPCDR (LAST (THELIST (CAR C))) (PROG1 (CDR C) (DEDITZAPCDR C NUTAIL]) (DUNDOEDITL [LAMBDA (SS ULST ULST0) (* lmm "26-Jul-86 23:35") (PROG (UNDOLST1 WAI) (for X on ULST until (EQ X ULST0) do (DUNDOEDITCOM (CAR X)) when (CAR X)) (OR UNDOLST1 (SHOULDNT)) (* Must have some changes to undo) [bind TMP for I in ULST when [for J in (CDDDR I) thereis (SETQ TMP (WHICHEDITW (CAR J] do (AND (SETQ TMP (WINDOWPROP TMP 'DEDITWHOAMI)) (FMEMB (CADR TMP) FILEPKGTYPES) (MARKASCHANGED (CAR TMP) (CADR TMP] (DEDITFZAP ULST (CAR ULST0) (CDR ULST0)) (* So undo can be UNDOne.) (COND (LISPXHIST (UNDOSAVE [LIST 'DUNDOEDITL SS (LIST (CONS T (CONS SS UNDOLST1] LISPXHIST]) (DUNDOEDITCOM [LAMBDA (X FLG) (* bas%: "12-Feb-84 21:25") (* If FLG is T, name of command is printed.) (COND ((NLISTP X) (CANT "Garbage on DEDIT UNDO list") (* Used to elseif (AND (CADR X) (NOT (SAMEEXPR \DSPRINTBP (fetch TOPELT of (CADR X))))) then (* The saved \DEDITSELECTIONS was not from the edit expression) (CANT "UNDO on different expression")) ) ((CAR X) (DUNDOEDITCOM1 X) (* else has been undone before, dont UNDO it again.) )) (COND (FLG (SETQ \DEDITSELECTIONS (CADR X)) (printout PROMPTWINDOW T (OR (CAR X) "Already") " undone."))) (DEDITFZAP X NIL (COPYCONS X)) (* Marks X so UNDO will skip it in future. UNDOing this UNDO will unmark it) T]) (DUNDOEDITCOM1 [LAMBDA (C) (* bas%: "21-MAR-83 19:43") (* Takes a single entry on UNDOLST, i.e. list of the form (command-name \DEDITSELECTIONS . UNDOLST1) and maps down the UNDOLST1 portion performing the corresonding DEDITSMASHes.) (for X in (CDDR C) do (SELECTQ (CAR X) (GROUPED (* Used by TTY%: command, which must add entire UNDOLST from subordinate call to EDITL0 to its own UNDOLST1.) (for X in (CDR X) do (DUNDOEDITCOM1 X))) (LISPXHIST (EDITBLOCKCALL EDITCOM1 (CDR X))) (DEDITZAPNODE (CAR X) (CDR X]) ) (* ; "Selection code. Select expressions or from the command menu") (DEFINEQ (DEDITSLCTLP [LAMBDA (CDS) (* mjs "26-Mar-86 16:27") (* Does selections until a command is given) (RESETLST (RESETSAVE (DEDITUSER T)) (RESETSAVE \DEDITALLOWSELS T) (CAR (ERSETQ (bind CMD do (WAIT.FOR.TTY) (SETEDITMENU (COND ((KEYDOWNP 'TAB) NIL) (T CDS))) [COND ((NOT (\SYSBUFP)) (SETQ CMD (READEDITMENU))) ((EQ (\PEEKSYSBUF) (CHARCODE TAB)) (\GETSYSBUF) (* Flush TAB char) ) [(SETQ CMD (DODEDITTYPEDCOM (GETEBUF CDS] (T (SELECTKEYS (GETEBUF CDS] (AND CMD (RETURN CMD)) (BLOCK]) (DEDITUSER [LAMBDA (DS) (* bas%: "12-Apr-84 20:17") (FLIPSELS) (SETCURSOR (COND (DS DEFAULTCURSOR) (T WAITINGCURSOR))) (NOT DS]) (SELECTKEYS [LAMBDA (W) (* mjs "26-Mar-86 16:19") (PROG ((LINE (DEDITREADLINE NIL W))) (SHADEIFNOTBUF (NXTSELECTION T) SECSHADE) (* Push shading) (SHADEIFNOTBUF (TOPSELECTION T) SWITCHSHADE) (SHADESELECTION (SETUPDEDITW W (PUSHSELECTION (LIST LINE))) PRIMSHADE]) (DODEDITTYPEDCOM [LAMBDA (W) (* mjs "26-Mar-86 16:19") (bind (C _ (\PEEKSYSBUF)) for I in DEDITTYPEINCOMS do (COND ((EQ C (CONTROLCODE (CAR I))) (\GETSYSBUF) (printout W (CADR I) ": ") (RETURN (CONS (CADR I) (CONS (CADDR I) (DEDITREADLINE T W]) (DEDITREADLINE [LAMBDA (ASLIST W) (* mjs "26-Mar-86 16:19") (* Read a line of input from T. This is like the grunge that goes on inside of LISPX, figuring out where the line ends...) (RESETLST (RESETSAVE (TTYDISPLAYSTREAM W)) (RESETSAVE \DEDITALLOWSELS NIL) (PROG ((FIRSTITEM (APPLY* LISPXREADFN T T)) CH LINE) (RETURN (COND ((AND (LISTP FIRSTITEM) (OR (SYNTAXP (SETQ CH (CHCON1 (LASTC T))) 'RIGHTPAREN T) (SYNTAXP CH 'RIGHTBRACKET T))) (* A list is the first thing typed. Usually, there is no more, but you could get a list from an "atomic" form if it had a read macro that turned it into a list) (COND (ASLIST (LIST FIRSTITEM)) (T FIRSTITEM))) ((OR (CDR (SETQ LINE (READLINE T (LIST FIRSTITEM) T))) ASLIST) (* There was more, so return whole list) LINE) (T (* Single atom) FIRSTITEM]) (SHADEIFNOTBUF [LAMBDA (X TXT) (* bas%: "13-MAR-83 19:59") (AND X (SETQ X (GETSELMAP X)) (NOT (BUFSELP X)) (SHADESELECTION X TXT]) (DEDITBUTTONFN [LAMBDA (W) (* bas%: " 1-Apr-84 15:34") (TOTOPW W) (* Bring it up, if nothing else) (COND ((SHIFTSELECTKEYS) (SELECTREAD W)) (\DEDITALLOWSELS (SELECTELEMENT W]) (DEDITRIGHTBUTTONFN [LAMBDA (W) (* bas%: " 1-Apr-84 15:31") (TOTOPW W) (* Bring it up, if nothing else) (COND ((AND \DEDITALLOWSELS (INWINDOW W)) (SELECTTREE W)) (T (DOWINDOWCOM W]) (DEDITWINDOWENTRYFN [LAMBDA (W) (* bas%: " 1-Apr-84 15:19") (* Shift the tty process if not a shift select and not currently tty proc) (TOTOPW W) (* Bring it up, if nothing else) (COND ((SHIFTSELECTKEYS) (SELECTREAD W)) (T (GIVE.TTY.PROCESS W]) (SELECTELEMENT [LAMBDA (DS) (* bas%: "24-MAR-83 16:01") (bind N M (TE _ (GETSELMAP (TOPSELECTION T))) (NE _ (GETSELMAP (NXTSELECTION T))) until (SELECTDONE DS) do (AND (SETQ M (SEARCHMAP DS)) (LASTMOUSESTATE MIDDLE) (SETQ M (fetch BP of M))) (COND ((EQ M N)) (T (COND ((AND N M)) (T (SHADESELECTION NE SECSHADE) (* Virtual push/pop) (SHADESELECTION TE SWITCHSHADE))) (SHADESELECTION N PRIMSHADE) (SHADESELECTION M PRIMSHADE) (SETQ N M))) finally (AND M (PUSHSELECTION (fetch TAIL of M]) (SELECTREAD [LAMBDA (DS) (* bvm%: " 4-Jun-86 18:48") (bind M N while (SHIFTSELECTKEYS) do (until (SELECTDONE DS) do (AND (SETQ M (SEARCHMAP DS)) (LASTMOUSESTATE MIDDLE) (SETQ M (fetch BP of M))) (COND [(AND N M) (COND ((EQ M N)) (T (SHADESELECTION N READSHADE) (SHADESELECTION M READSHADE] (T (SHADESELECTION (OR N M) READSHADE))) (SETQ N M)) finally (COND (M (SHADESELECTION M READSHADE) (WITH-READER-ENVIRONMENT (WINDOWPROP DS 'READER-ENVIRONMENT) (BKSYSBUF (fetch SELEXP of M) T) (COND ((LISTP (fetch SELEXP of M))) (T (BKSYSCHARCODE (CHARCODE SPACE]) (SELECTTREE [LAMBDA (DS) (* bas%: " 1-Apr-84 15:17") (bind (OT _ (GETME4 (TOPSELECTION) T)) until (SELECTDONE DS) do (SWITCHANDSHADE (FINDLCA OT (SEARCHMAP DS]) (SEARCHMAP [LAMBDA (PDS) (* bas%: "20-Apr-84 14:37") (PROG (L S (E (GETDEDITMAP PDS)) (LX (LASTMOUSEX PDS)) (LY (LASTMOUSEY PDS))) [while E until (AND (WITHINME E LX LY) (OR [NOT (SETQ L (LISTP (fetch SELEXP of (SETQ S E] (ONAPARENP E LX LY))) do (* The until clause is true if either E covers mouse and has no descendents or we're on a paren) (* Either pending tail or embedded descendents to search) [COND [(NOT (SETQ E (GETME4 L S] ((HASASBP E S)) (T (REPP S) (* Substructure has been smashed. Reprint and start over.) (SETQ E (GETME4 (fetch TAIL of S) T)) (SETQ S (fetch BP of E)) (SETQ L (fetch TAIL of E] (SETQ L (CDR (LISTP L] (RETURN E]) (WITHINME [LAMBDA (E X Y) (* bas%: "30-MAR-83 14:24") (PROG [(FA (FONTPROP (fetch FNT of E) 'ASCENT)) (FD (FONTPROP (fetch FNT of E) 'DESCENT] (RETURN (COND ((IGREATERP Y (IPLUS FA (fetch STARTY of E))) NIL) [(IGEQ Y (IDIFFERENCE (fetch STARTY of E) FD)) (AND (IGEQ X (fetch STARTX of E)) (OR (ILESSP X (fetch STOPX of E)) (NEQ (fetch STARTY of E) (fetch STOPY of E] ((ILESSP Y (IDIFFERENCE (fetch STOPY of E) FD)) NIL) [(IGREATERP Y (IPLUS FA (fetch STOPY of E] (T (ILESSP X (fetch STOPX of E]) (ONAPARENP [LAMBDA (E X Y) (* bas%: "30-MAR-83 14:24") (PROG ((EF (fetch FNT of E))) (RETURN (OR [AND (ILESSP X (fetch LPEND of E)) (IGEQ Y (IDIFFERENCE (fetch STARTY of E) (FONTPROP EF 'DESCENT] (AND (IGEQ X (fetch RPSTART of E)) (ILESSP Y (IPLUS (fetch STOPY of E) (FONTPROP EF 'ASCENT]) (SELECTDONE [LAMBDA (PDS) (* bas%: "28-JUL-82 22:42") (OR (MOUSESTATE UP) (NOT (INWINDOW PDS]) (INWINDOW [LAMBDA (DS) (* bas%: "27-AUG-82 12:38") (INSIDE? (DSPCLIPPINGREGION NIL DS) (LASTMOUSEX DS) (LASTMOUSEY DS]) (FINDLCA [LAMBDA (S1 S2) (* bas%: " 1-Apr-84 15:17") (COND ((NOT S2) S1) ((EQ (fetch PDSP of S1) (fetch PDSP of S2)) (for old S1 while S1 by (fetch BP of S1) thereis (DOMINATE? S1 S2]) (DOMINATE? [LAMBDA (SUP SUB) (* bas%: " 4-Apr-84 13:06") (OR (EQ SUP SUB) (PROG [(S1 (OR (MAPENTRYP SUP) (GETME4 SUP))) (S2 (OR (MAPENTRYP SUB) (GETME4 SUB] (RETURN (COND ((AND S1 S2) (for old S2 by (fetch BP of S2) while S2 thereis (EQ S1 S2))) (T (for I on (CAR (LISTP SUP)) thereis (DOMINATE? I SUB]) ) (ADDTOVAR DEDITTYPEINCOMS [F Find (NLAMBDA (TGT) (PUSHSELECTION (LIST TGT)) (DEDITSwap) (DEDITFind] [S Substitute (NLAMBDA (OLD NEW) (DEDITEditCom (LIST 'R OLD NEW] [Z EditCom (NLAMBDA EC (DEDITEditCom EC]) (PUTPROPS DEDITTYPEINCOMS VARTYPE ALIST) (* ; "Handling the selection stack") (DEFINEQ (POPSELECTION [LAMBDA NIL (* bas%: "21-MAR-83 19:43") (PROG1 (TOPSELECTION) (pop \DEDITSELECTIONS]) (PUSHSELECTION [LAMBDA (S) (* bas%: "21-MAR-83 19:43") (push \DEDITSELECTIONS S) S]) (NXTSELECTION [LAMBDA (NOERR) (* bas%: "24-MAR-83 15:52") (OR (fetch NXTELT of \DEDITSELECTIONS) (AND (NOT NOERR) (CANT "No second selection"]) (TOPSELECTION [LAMBDA (NOERR) (* bas%: "24-MAR-83 15:52") (OR (fetch TOPELT of \DEDITSELECTIONS) (AND (NOT NOERR) (CANT "Too few selections"]) (SWITCHANDSHADE [LAMBDA (NU) (* bas%: " 1-Apr-84 15:29") (* Like a POP/PUSH sequence but no CONS) (COND [(OR (NOT NU) (EQ (fetch TAIL of NU) (TOPSELECTION T] (T (SHADESELECTION (GETME4 (TOPSELECTION T) T) PRIMSHADE) (replace TOPELT of \DEDITSELECTIONS with (fetch TAIL of NU)) (SHADESELECTION NU PRIMSHADE]) (SHADESELECTION [LAMBDA (S SHADE) (* rrb "13-Feb-86 16:45") (AND S (SHADESELECTION1 S SHADE]) (SHADESELECTION1 [LAMBDA (S TXT) (* bvm%: "22-May-86 12:49") (LET ((START (fetch STARTY of S)) (STOP (fetch STOPY of S))) (COND ((EQ START STOP) (* "All on one line. Last clause handles this in general, but test common case here for efficiency") (SHADESELECTION2 S START (fetch STARTX of S) (fetch STOPX of S) TXT)) ((LISTP (fetch SELEXP of S)) (* "Shade the parens and every element") (SHADESELECTION2 S START (fetch STARTX of S) (fetch LPEND of S) TXT) [for E on (fetch SELEXP of S) do (SHADESELECTION1 (GETME4 E S) TXT) finally (COND (E (* Dotted pair) (SHADESELECTION1 (GETME4 E S) TXT] (SHADESELECTION2 S STOP (fetch RPSTART of S) (fetch STOPX of S) TXT)) (T (* "A non-list spanning more than one line, probably a string. We don't know where the internal margins are, so be conservative") (LET* [(DS (fetch PDSP of S)) [LEFT (COND [(fetch LONGSTRINGP of S) (fetch STARTX of (COND ((fetch LONGSTRING1MARGINP of S) S) (T (fetch BP of S] (T (DSPLEFTMARGIN NIL DS] (RIGHT (COND ((fetch LONGSTRINGSYMMETRICP of S) (IDIFFERENCE (DSPRIGHTMARGIN NIL DS) LEFT)) (T (DSPRIGHTMARGIN NIL DS] (for I from START by (IMINUS (FONTPROP (fetch FNT of S) 'HEIGHT)) to STOP do (SHADESELECTION2 S I (COND ((EQ I START) (fetch STARTX of S)) (T LEFT)) (COND ((EQ I STOP) (fetch STOPX of S)) (T RIGHT)) TXT]) (SHADESELECTION2 [LAMBDA (S CY SX EX SHADE) (* bas%: "13-JUL-82 10:02") (BITBLT NIL NIL NIL (fetch PDSP of S) SX (IDIFFERENCE CY (ADD1 LINETHICKNESS)) (IDIFFERENCE EX SX) LINETHICKNESS 'TEXTURE 'INVERT SHADE]) (OVERLAPSELBAND [LAMBDA (S H L) (* bas%: "26-Mar-84 15:17") (OVERLAP (SUB1 (fetch STARTY of S)) (IDIFFERENCE (fetch STOPY of S) (ADD1 LINETHICKNESS)) H L]) (PUSHEDITCHAIN [LAMBDA (C) (* bas%: "30-MAR-83 22:19") [PUSHSELECTION (PROG ((X (MAKESELCHAIN C))) (RETURN (COND ((MAPENTRYP X) (fetch TAIL of X)) (T C] (DEDITCenter T]) (MAKESELCHAIN [LAMBDA (LST) (* bas%: " 5-Apr-84 21:03") (* Makes dummy map entries until the whole chain is linked into an extant map. This is necessary so subsequent commands from a Multiple can find their way around) (PROG (TMP) (DECLARE (USEDFREE LASTAIL)) (COND [(CDR (THELIST LST)) (SETQ TMP (OR [COND ((LISTP (CAR LST)) (TAILP (CAR LST) (CADR LST))) (T (OR (TAILP LASTAIL (CADR LST)) (EQ (CAR LST) (DOTTEDEND (CADR LST] (FMEMB (CAR LST) (CADR LST)) (CANT "Inconsistent EDIT chain"))) (RETURN (OR (GETME4 TMP) (DUMMYMAPENTRY TMP (MAKESELCHAIN (CDR LST] (T (SETQ TMP (GETME4 (CAR LST))) (RETURN (AND (MAPENTRYP TMP) (GETMEBP TMP]) (PUSHINTOBUF [LAMBDA (V) (* bas%: " 4-MAR-83 12:23") (AND V (PUSHSELECTION V]) (DUMMYMAPENTRY [LAMBDA (E B) (* bas%: "12-Sep-84 10:46") (* Dummys are marked by having EQ startx and stopx) (MAKEMAPENTRY (OR (LISTP E) (MAKEDOTPTAIL E B)) B 0 0 0 0 (fetch F# of B]) (FLIPSELS [LAMBDA NIL (* bas%: "26-Mar-84 18:21") (* Turns selections on or off across possible movement) (PROG [(TM (FIXUPSEL (TOPSELECTION T] (SHADESELECTION (FIXUPSEL (NXTSELECTION T) (BUFSELP TM)) SECSHADE) (SHADESELECTION TM PRIMSHADE]) (FLIPSELSIN [LAMBDA (DS H L) (* bas%: " 4-Apr-84 13:18") (* Turns selections on or off across possible movement) (SETQ DS (WINDOWPROP DS 'DSP)) (PROG (S) (AND (SETQ S (GETME4 (NXTSELECTION T))) (EQ DS (fetch PDSP of S)) (OVERLAPSELBAND S H L) (SHADESELECTION (UNPURGEDP S) SECSHADE)) (AND (SETQ S (GETME4 (TOPSELECTION T))) (EQ DS (fetch PDSP of S)) (OVERLAPSELBAND S H L) (SHADESELECTION (UNPURGEDP S) PRIMSHADE]) (FIXUPSEL [LAMBDA (X BUFBUSY) (* bas%: "24-Jun-84 17:48") (* Returns a new selection if X is not OK) (AND X (OR (GETSELMAP X) (AND (PROG1 (UNZORCHME (GETME4 X)) (* GETME4 and thus the UNZORCHME only succeeds after GETSELMAP has failed if X's map has been invalidated. Usually the result is that X should be flushed into the edit buffer. However, if X is invalid b/c the whole window has been ZORCHed (by a background MARKASCHANGED e.g.) then we reestablish the whole window and try again) ) (GETSELMAP X)) (AND (NOT BUFBUSY) (SETUPDEDITW (GETEBUF (TOPEDITW)) (NEWSELFOR X]) (NEWSELFOR [LAMBDA (X) (* bas%: "24-MAR-83 16:03") (PROG ((Y (CONS (COPY (CAR X)) NIL))) (COND ((EQ X (TOPSELECTION T)) (replace TOPELT of \DEDITSELECTIONS with Y)) ((EQ X (NXTSELECTION T)) (replace NXTELT of \DEDITSELECTIONS with Y)) (T (SHOULDNT))) (RETURN Y]) ) (* ; "Initializing and flushing edit windows") (DEFINEQ (ACTIVEEDITW [LAMBDA (W ONFLG) (* lmm " 9-Jul-85 16:30") (WINDOWPROP W 'BUTTONEVENTFN (AND ONFLG (FUNCTION DEDITBUTTONFN))) [WINDOWPROP W 'RIGHTBUTTONFN (COND (ONFLG (FUNCTION DEDITRIGHTBUTTONFN)) (T (FUNCTION DOWINDOWCOM] (WINDOWPROP W 'RESHAPEFN (AND ONFLG (FUNCTION DEDITRESHAPEFN))) (WINDOWPROP W 'REPAINTFN (AND ONFLG (FUNCTION DEDITREPAINTFN))) (WINDOWPROP W 'SCROLLFN (AND ONFLG (FUNCTION SCROLLBYREPAINTFN))) (WINDOWPROP W 'PROCESS (THIS.PROCESS)) (* So that bugging in this window can switch tty to us) [WINDOWPROP W 'WINDOWENTRYFN (COND (ONFLG (FUNCTION DEDITWINDOWENTRYFN)) (T (FUNCTION GIVE.TTY.PROCESS] (DSPSCROLL (COND (ONFLG 'OFF) (T T)) W) (* Buffer can get this turned on) W]) (FINDEDITW [LAMBDA (NAME TYPE) (* bas%: "12-Sep-84 22:24") (for I in \DEDITWINDOWS thereis (SAMEEDITW I NAME TYPE]) (GETEDITW [LAMBDA (ATM TYPE) (* rrb " 2-Oct-85 18:44") (SELECTQ TYPE (NIL (OR ATM (SETQ ATM (CONCAT " "))) (* A unique, but invisible tag) (SETQQ TYPE expression)) (PROP (SETQQ TYPE FNS)) NIL) (PROG [(W (OR (FINDEDITW ATM TYPE) (MAKEEDITW ATM TYPE] (RESETSAVE NIL (LIST 'UNDEDITW (push \DEDITWINDOWS W))) (* make this process be the process for this window so that clicking in it will give the tty to this Dedit.) (WINDOWPROP W 'PROCESS (THIS.PROCESS)) (RETURN (WINDOWPROP W 'DSP]) (GETDEDITDEF4 [LAMBDA (W) (* bas%: "10-Mar-84 11:55") (PROG [NAME (TYPE (WINDOWPROP W 'DEDITWHOAMI] (RETURN (AND (SETQ NAME (CAR TYPE)) (LITATOM NAME) (SETQ TYPE (CADR TYPE)) (NEQ TYPE 'expression) (GETDEF NAME TYPE NIL '(NOCOPY NOERROR]) (MAKEEDITW [LAMBDA (NAME TYP) (* rrb " 2-Oct-85 18:44") (PROG [(W (COND ((TOPEDITW) (WINDOWPROP (TOPEDITW) 'DEDITCACHED NIL)) (T (WINDOWP DEditWindow] (DECLARE (USEDFREE EDITCHANGES)) (AND (COND [(NOT W) (SETQ W (CREATEW NIL (NAMEOFEDITW NAME TYP] ((NOT (SAMEEDITW W NAME TYP)) (CLEARW W) (WINDOWPROP W 'TITLE (NAMEOFEDITW NAME TYP)) T)) (WINDOWPROP W 'DEDITWHOAMI (LIST NAME TYP))) (WINDOWPROP W 'DEDITCHANGES EDITCHANGES) (* Associates changes with changed structure) (RETURN W]) (NAMEOFEDITW [LAMBDA (NAME TYPE) (* bas%: "30-MAR-83 18:41") (CONCAT "DEdit of " (SELECTQ TYPE (FNS "function") (PROPS (COND [(CADR (LISTP NAME)) (PROG1 (CONCAT (CADR NAME) " property of ") (SETQ NAME (CAR NAME] (T "property list of"))) (VARS (COND [(AND (STREQUAL (SUBSTRING NAME -4 -1) "COMS") (HASDEF (SUBSTRING NAME 1 -5) 'FILE)) (PROG1 "filecoms for file" (SETQ NAME (SUBSTRING NAME 1 -5] (T "variable"))) TYPE) " " NAME]) (PURGEW [LAMBDA (W DONTCLR) (* rmk%: "13-Sep-84 16:49") [PROG [(WDS (COND ((WINDOWP W) (WINDOWPROP W 'DSP)) (T (PROG1 W (SETQ W (WFROMDS W] [COND ((EQ W DEditWindow) (CLRHASH \DEDITMEHASH) (CLRHASH \DEDITDPHASH)) (T (MAPHASH \DEDITMEHASH (FUNCTION (LAMBDA (X Y) (AND (EQ WDS (fetch PDSP of X)) (PUTHASH Y NIL \DEDITMEHASH] [for I to (ARRAYSIZE \DEDITDSPS) when (EQ WDS (ELT \DEDITDSPS I)) do (RETURN (SETA \DEDITDSPS I (WINDOWPROP WDS 'REGION] (WINDOWPROP W 'EDITEXPR NIL) (COND (DONTCLR) (T (DSPTEXTURE WHITESHADE W) (DSPFONT DEFAULTFONT W) (* Font first to get CLEARW right) (CLEARW W) (MAKECPOSBE (DSPXPOSITION NIL W) (CONSTANT (IDIFFERENCE MAX.SMALLP 1535)) W] W]) (MAKECPOSBE [LAMBDA (X Y DS) (* bas%: " 4-Apr-84 13:11") (PROG [(DX (IDIFFERENCE X (DSPXPOSITION NIL DS))) (DY (IDIFFERENCE Y (DSPYPOSITION NIL DS] (WXOFFSET (IMINUS DX) DS) (WYOFFSET (IMINUS DY) DS) (RELMOVETO DX DY DS]) (SAMEEDITW [LAMBDA (W NAME TYPE) (* bas%: "15-FEB-82 18:16") (PROG [(TMP (WINDOWPROP W 'DEDITWHOAMI] (RETURN (AND TMP (EQ NAME (CAR TMP)) (EQ TYPE (CADR TMP]) (SETUPDEDITW [LAMBDA (W CONTENTS) (* ; "Edited 29-Aug-91 13:38 by jds") (* ;; "Set up the DEDIT editing window W to be editing CONTENTS.") (* ;; "Must bind several specials that control the pretty printer here, because this is where we can figure out the information:") (* ;; " FIRSTPOS = left margin") (* ;; " RMARGIN = right margin") (* ;; " FILEFLG = are we printing to a file? (No!)") (LET ((FIRSTPOS (DSPLEFTMARGIN NIL *STANDARD-OUTPUT*)) (RMARGIN (DSPRIGHTMARGIN NIL W)) (FILEFLG NIL) (COMMENTCOL NIL)) (DECLARE (SPECVARS FIRSTPOS RMARGIN FILEFLG COMMENTCOL)) (PROG1 (SETDEDITMAP W CONTENTS) (ACTIVEEDITW W T]) (TOPEDITW [LAMBDA NIL (* bas%: "18-MAR-83 15:25") (CAR \DEDITWINDOWS]) (UNDEDITW [LAMBDA (WDS) (* bvm%: "22-May-86 12:46") (* * "Desensitizes DEDIT windows and removes surplus ones") (COND (\DEDITMNUW (WINDOWPROP \DEDITMNUW 'PROCESS NIL) (CLOSEW \DEDITMNUW))) (PROG [(W (WFROMDS (OR (CAR (LISTP WDS)) (SHOULDNT] (DECLARE (USEDFREE DEditLinger)) (TAKEDOWN (WINDOWPROP W 'EDITBUF)) (SETQ \DEDITBUFW NIL) [COND ((EQ WDS \DEDITWINDOWS) (SETQ \DEDITWINDOWS (CDR WDS))) (T (for I on \DEDITWINDOWS when (EQ WDS (CDR I)) do (RETURN (RPLACD I (CDDR I))) finally (SHOULDNT "DEDITDSPS tangled"] (COND [\DEDITWINDOWS (COND ((FMEMB W \DEDITWINDOWS)) (T (WINDOWPROP W 'DEDITCACHED NIL) (* "Discard my cache; cache me on next") (WINDOWPROP (TOPEDITW) 'DEDITCACHED W) (SETQ \DEDITBUFW (WINDOWPROP (TOPEDITW) 'EDITBUF)) (TAKEDOWN W] (T (COND ((AND RESETSTATE (CADR (WINDOWPROP W 'DEDITCHANGES NIL))) (ZORCHEDITW W))) (OR (WINDOWP DEditWindow) (SETQ DEditWindow W)) (WINDOWPROP W 'PROCESS NIL) (OR DEditLinger (CLOSEW W]) (WHICHEDITW [LAMBDA (CC) (* bas%: " 4-FEB-83 15:45") (bind SCR for TMP from (GETME4 CC) by (fetch BP of TMP) while TMP do (AND (SETQ SCR (EDITWINDOWP (fetch PDSP of TMP))) (RETURN SCR]) (ZORCHEDITW [LAMBDA (W) (* hdj "19-Jul-85 11:35") (AND W [PROG ((V (GETMAP? W))) (COND ((AND V (NOT (fetch BP of V))) (replace BP of V with (create DEDITMAP D# _ (fetch D# of V))) (RETURN T] (ACTIVEWP (WFROMDS W)) (PROGN (DSPTEXTURE CHANGEDSHADE W) (DSPFILL NIL CHANGEDSHADE 'PAINT W]) (ZORCHEDWP [LAMBDA (W) (* bas%: "11-Mar-84 22:33") (PROG [(WM (GETME4 (WINDOWPROP W 'EDITEXPR] (* ZORCHed windows have a dummy map in the BP of their EDITEXPR's map) (RETURN (AND WM (fetch BP of WM]) (UNZORCHME [LAMBDA (M) (* bas%: "11-Mar-84 23:15") (AND M (PROG ((W (fetch PDSP of M))) (COND ((ZORCHEDWP W) (RETURN (SETDEDITMAP W (LIST (GETDEDITDEF4 W]) ) (RPAQ? DEditLinger T) (* ; "Manipulating the Edit menu") (DEFINEQ (SETEDITMENU [LAMBDA (EW) (* bvm%: "30-May-86 16:04") (DECLARE (GLOBALVARS \DEDITCOMS)) (PROG (MR X Y H W IMAGE) [SETQ MR (AND (WINDOWP \DEDITMNUW) (WINDOWPROP \DEDITMNUW 'REGION] (* The WINDOWP check on \DEDITMNUW is b/c it can be a displaystream if user interrupts out of READEDITMENU in which case it must be rebuilt b/c of possible undone inversions) [COND (MR (SETQ W (fetch (REGION WIDTH) of MR)) (SETQ H (fetch (REGION HEIGHT) of MR))) (T (SETQ IMAGE (CACHEDEDITCOMS *DEDIT-MENU-COMMANDS*)) (SETQ W (ITIMES 2 (SUB1 WBorder))) (SETQ H (IPLUS (BITMAPHEIGHT IMAGE) (IMINUS (DSPLINEFEED NIL WindowTitleDisplayStream)) W)) (SETQ W (IPLUS (BITMAPWIDTH IMAGE) W] [COND [EW (PROG (ER) (SETQ ER (WINDOWPROP EW 'REGION)) (SETQ X (fetch (REGION PRIGHT) of ER)) (SETQ Y (IDIFFERENCE (fetch (REGION PTOP) of ER) H] (T (GETMOUSESTATE) (SETQ X (IDIFFERENCE LASTMOUSEX WBorder)) (SETQ Y (IDIFFERENCE LASTMOUSEY (WINDOWPROP \DEDITMNUW 'YOFFSET] (SETQ X (IMIN X (IDIFFERENCE SCREENWIDTH W))) [SETQ Y (IMAX 0 (IMIN Y (IDIFFERENCE SCREENHEIGHT H] [COND (MR (COND [(AND (EQ X (fetch (REGION LEFT) of MR)) (EQ Y (fetch (REGION BOTTOM) of MR] (T (MOVEW \DEDITMNUW X Y))) (TOTOPW \DEDITMNUW)) (T (PROG (NUR) (SETQ NUR (create REGION LEFT _ X BOTTOM _ Y WIDTH _ W HEIGHT _ H)) [COND ((DISPLAYSTREAMP \DEDITMNUW) (SETQ \DEDITMNUW (WFROMDS \DEDITMNUW)) (WINDOWPROP \DEDITMNUW 'RESHAPEFN NIL) (SHAPEW \DEDITMNUW NUR)) (T (SETQ \DEDITMNUW (CREATEW NUR 'EditOps] (WINDOWPROP \DEDITMNUW 'RESHAPEFN 'DON'T)) (BITBLT IMAGE 1 1 \DEDITMNUW 0 0 W H 'INPUT 'REPLACE) (* The 1,1 removes the menu border) (WINDOWPROP \DEDITMNUW 'IMAGE IMAGE) (WINDOWPROP \DEDITMNUW 'ITEMHEIGHT (FONTPROP MENUFONT 'HEIGHT)) (WINDOWPROP \DEDITMNUW 'YOFFSET (IQUOTIENT H 2)) (WINDOWPROP \DEDITMNUW 'REPAINTFN 'DEDITMENURESTORE] (WINDOWPROP \DEDITMNUW 'PROCESS (THIS.PROCESS)) (* Allow the menu window to also respond to tty switching) (RETURN \DEDITMNUW]) (CACHEDEDITCOMS [LAMBDA (COMLIST) (* bvm%: "30-May-86 16:20") (* * "Builds a menu image from the commands in COMLIST. Sets arrays EDITMENU\COMS and EDITMENU\SUBS with elements in INVERSE order for convenience of READEDITMENU") (DECLARE (GLOBALVARS EDITMENU\COMS EDITMENU\SUBS)) (LET* ((N (LENGTH COMLIST)) (COMS (ARRAY N NIL NIL 0)) (SUBMENUS (ARRAY N NIL NIL 0))) [for ITEM in COMLIST as J from (SUB1 N) by -1 do (SETA COMS J (CONS (CAR ITEM) (CADR ITEM))) (* The main item) (SETA SUBMENUS J (AND (CDDR ITEM) (create MENU ITEMS _ [for Q in (CDDR ITEM) collect `(,(CAR Q) '(,(CAR Q) ,@(CADR Q)) ,@(CDDR Q] CENTERFLG _ T MENUOFFSET _ (create POSITION XCOORD _ -1 YCOORD _ (IQUOTIENT (ITIMES (FONTPROP MENUFONT 'HEIGHT) (LENGTH (CDDR ITEM))) 2] (SETQ EDITMENU\COMS COMS) (SETQ EDITMENU\SUBS SUBMENUS) (CHECK/MENU/IMAGE (create MENU ITEMS _ COMLIST CENTERFLG _ T]) (FINDEDITCOM [LAMBDA (C L EFLG) (* bas%: "19-NOV-82 15:28") (for I on L thereis (OR (EQUAL C (CAR (CADR I))) (AND EFLG (NOT (CDR I]) (READEDITMENU [LAMBDA NIL (* lmm " 4-Nov-85 22:47") (DECLARE (GLOBALVARS EDITMENU\COMS EDITMENU\SUBS)) (bind OTHERS VAL N OLDN MOUSEISDOWN MOUSEWASDOWN EMDS (VLF _ (WINDOWPROP \DEDITMNUW 'ITEMHEIGHT)) first (PROGN [SETQ \DEDITMNUW (SETQ EMDS (WINDOWPROP \DEDITMNUW 'DSP] (* Clear menu to protect against ^E) ) eachtime (GETMOUSESTATE) while (AND (EQ \DEDITMNUW EMDS) (NOT (READP T)) (OR (COND ((SHIFTDOWNP 'CTRL) (COND (VAL (SHADEMENUENTRY N EMDS VLF 'HOLLOW OTHERS) (push OTHERS (CONS N VAL)) (SETQ VAL NIL))) OTHERS)) (INWINDOW EMDS)) (NOT VAL)) when (INWINDOW EMDS) do (SETQ OLDN N) (SETQ N (IQUOTIENT (LASTMOUSEY EMDS) VLF)) [COND ((AND [EQ (SETQ MOUSEWASDOWN MOUSEISDOWN) (SETQ MOUSEISDOWN (LASTMOUSESTATE (NOT UP] (EQ N OLDN)) (* Nothing going on) (OR MOUSEISDOWN (BLOCK)) (* But dont block if mouse is down lest we miss an upclick) ) (T (COND ((EQ N OLDN) (SHADEMENUENTRY N EMDS VLF 'HOLLOW OTHERS)) (T (SHADEMENUENTRY OLDN EMDS VLF MOUSEWASDOWN OTHERS) (SHADEMENUENTRY N EMDS VLF MOUSEISDOWN OTHERS))) (COND ((AND (LASTMOUSESTATE MIDDLE) (ELT EDITMENU\SUBS N)) (* Submenu) (SETQ VAL (MENU (ELT EDITMENU\SUBS N))) (SETQ MOUSEISDOWN NIL) (SHADEMENUENTRY N EMDS VLF 'HOLLOW OTHERS)) ((AND (NOT MOUSEISDOWN) MOUSEWASDOWN N) (* Mouse has come up and a com is selected) (SETQ VAL (ELT EDITMENU\COMS N] finally (SHADEMENUENTRY N EMDS VLF MOUSEISDOWN OTHERS) (for I on OTHERS do (SHADEMENUENTRY (CAAR I) EMDS VLF 'FILL (CDR I))) [AND VAL OLDN (WINDOWPROP EMDS 'YOFFSET (ITIMES VLF (ADD1 OLDN] (SETQ \DEDITMNUW (COND (\DEDITMNUW (WFROMDS EMDS)) (T EMDS))) (* Exited cleanly, restore global) (RETURN (COND [OTHERS (AND VAL (bind CS XS for I in (CONS (CONS OLDN VAL) OTHERS) do (push CS (CADR I)) (push XS (MKLIST (CDDR I))) finally (RETURN (CONS CS (CONS 'PROGN XS] (T VAL]) (SHADEMENUENTRY [LAMBDA (V EMDS DLF BOXFLG OTHERS) (* ; "Edited 11-Jun-90 14:53 by mitani") (* BOXFLG encoding%: T=FILL NIL=BOX  for common cases of MOUSEDOWN  controls) (AND V (NOT (FASSOC V OTHERS)) (PROG [(D (SELECTQ BOXFLG ((FILL T) 0) (HOLLOW 1) ((BOX NIL) (SHADEMENUENTRY V EMDS DLF 'FILL) 1) (SHOULDNT] (BITBLT NIL NIL NIL EMDS D (IPLUS D (ITIMES V DLF)) (IDIFFERENCE (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL EMDS)) (IPLUS D D)) (IDIFFERENCE DLF (IPLUS D D)) 'TEXTURE 'INVERT BLACKSHADE]) (DEDITMENURESTORE [LAMBDA (W R) (* bas%: " 5-Apr-84 19:56") (BITBLT (WINDOWPROP W 'IMAGE) 1 1 W 0 0 NIL NIL 'INPUT 'REPLACE NIL R]) ) (RPAQQ *DEDIT-MENU-COMMANDS* [(After DEDITAfter) (Before DEDITBefore) (Delete DEDITDelete) (Replace DEDITReplace) (Switch DEDITSwitch) ("( )" DEDITBI ("( ) in" DEDITBI) ("( in" DEDITLI) (") in" DEDITRI)) ("( ) out" DEDITBO ("( ) out" DEDITBO) ("( out" DEDITLO) (") out" DEDITRO)) (Undo DEDITUndo (Undo DEDITUndo) (!Undo (DEDITUndo T)) (?Undo (UNDOCHOOSE)) (&Undo (UNDOCHOOSE T))) (Find DEDITFind) (Swap DEDITSwap (Center DEDITCenter) (Clear (SETQ \DEDITSELECTIONS NIL)) (Copy DEDITCopy) (Pop (POPSELECTION)) (Swap DEDITSwap)) (Reprint DEDITReprint) [Edit DEDITEdit [DEdit (DEDITEdit 'DISPLAY 'Def) NIL (SUBITEMS ("DEdit Def" (DEDITEdit 'DISPLAY 'Def)) ("DEdit Form" (DEDITEdit 'DISPLAY 'Form] [TTYEdit (DEDITEdit 'TELETYPE 'Def) NIL (SUBITEMS ("TTYEdit Def" (DEDITEdit 'TELETYPE 'Def)) ("TTYEdit Form" (DEDITEdit 'TELETYPE 'Form] (TTYIn% Form (DEDITEdit 'DEDIT.TTYinEdit 'Form] [EditCom DEDITEditCom (?= DEDITARGS) (GETD (DEDITEditCom 'GETD)) (CL (DEDITEditCom 'CL)) (DW (DEDITEditCom 'DW)) (REPACK (DEDITEditCom 'REPACK)) (CAP (DEDITEditCom 'CAP)) (LOWER (DEDITEditCom 'LOWER)) (RAISE (DEDITEditCom 'RAISE] (Break DEDITBreak) (Eval DEDITEval) (Exit DEDITExit (OK DEDITExit) (STOP (DEDITExit T]) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *DEDIT-MENU-COMMANDS*) ) (* ; "Maintaining deditmap entries and the edit chain") (DEFINEQ (BUFSELP [LAMBDA (E) (* bas%: "21-MAR-83 19:53") (AND E \DEDITBUFW (EQ (fetch PDSP of E) (WINDOWPROP \DEDITBUFW 'DSP]) (EDITWINDOWP [LAMBDA (W) (* rmk%: " 1-SEP-83 11:23") (AND (OR (WINDOWP W) (DISPLAYSTREAMP W)) (WINDOWPROP W 'EDITEXPR) (WINDOWPROP W 'DSP]) (GETLEFT [LAMBDA (SEL BK) (* bas%: "16-MAR-83 09:45") (AND (OR BK (SETQ BK (fetch BP of SEL))) (for I on (fetch SELEXP of BK) when (COND ((LISTP (CDR I)) (EQ (CDR I) (fetch TAIL of SEL))) ((CDR I) (EQ (CDR I) (fetch SELEXP of SEL))) (T NIL)) do (RETURN (GETME4 I]) (GETMEBP [LAMBDA (E) (* bas%: "13-OCT-81 16:21") (OR (fetch BP of E) (CANT "At top"]) (HASASBP [LAMBDA (M F) (* bas%: "11-Mar-84 21:57") (OR (TAILP (OR (LISTP M) (SETQ M (fetch TAIL of M))) (fetch SELEXP of F)) (AND (NLISTP (CDR M)) (EQ M (GETHASH (fetch TAIL of F) \DEDITDPHASH]) (TAILOF [LAMBDA (A B) (* bas%: "11-Mar-84 23:31") (OR (TAILP A B) (AND (SETQ A (DPCDRSEL A)) (SETQ B (GETME4 B)) (EQ (fetch BP of A) (fetch BP of B]) (DOTTEDEND [LAMBDA (C) (* bas%: "16-MAR-83 21:32") (COND ((LISTP C) (CDR (LAST C))) (T C]) (GETME4 [LAMBDA (C B) (* bas%: "11-Mar-84 23:09") (AND C (OR (GETHASH C \DEDITMEHASH) (SELECTQ B (NIL NIL) (T (SHOULDNT "No MapEntry")) (PROGN (OR (MAPENTRYP B) (SETQ B (GETME4 B T))) (OR [COND ((LISTP C) (HASASBP C B)) (T (EQ C (DOTTEDEND (fetch SELEXP of B] (SHOULDNT "Invalid BP")) (COND ((NLISTP C) (GETDPME B)) [(MAPENTRYP (MAPHASH \DEDITMEHASH (FUNCTION (LAMBDA (X Y) (AND (EQ B (fetch BP of X)) (EQUAL C Y) (PROGN (PUTHASH Y NIL \DEDITMEHASH) (replace TAIL of X with C) (PUTHASH C X \DEDITMEHASH) (RETFROM 'MAPHASH X] (T (DEARME B]) (GETSELMAP [LAMBDA (X) (* bas%: "12-Sep-84 10:40") (* Gets ME iff it is unpurged and not a dummy ie visible for a SHADESELECTIOn etc) (AND (SETQ X (GETME4 X)) (NEQ (fetch STARTX of X) (fetch STOPX of X)) (UNPURGEDP X]) (DEARME [LAMBDA (B) (* bas%: " 7-MAR-83 22:49") (REPP B) (for (SP _ (REALSTKNTH -1 'GETME4)) by (STKPOS (STKNAME SP) -1 (STKNTH -1 SP SP) SP) while SP when (EQ B (STKARG 1 SP)) do (RETEVAL SP [CONS (STKNAME SP) (CONS (GETME4 (fetch TAIL of B) T) (CDR (STKARGS SP] T) finally (RETURN (GETME4 (fetch TAIL of B) T]) (DPCDRSEL [LAMBDA (ME) (* bas%: "21-MAR-83 19:58") (AND [OR (type? DEDITMAP ME) (AND (CDR (LISTP ME)) (NLISTP (CDR ME)) (SETQ ME (GETME4 ME] (fetch BP of ME) (EQ ME (GETDPME (fetch BP of ME))) ME]) (GETDPME [LAMBDA (B) (* bas%: "21-MAR-83 19:48") (GETME4 (GETHASH (fetch TAIL of B) \DEDITDPHASH) T]) (GETEBUF [LAMBDA (EW) (* bvm%: "27-May-86 15:15") (* * "Return the edit buffer window for main window EW, reshaping or moving it as needed if windows have moved in the meantime. Maybe should do this with attached windows.") (LET ((MAINREG (WINDOWPROP EW 'REGION)) (EBW (WINDOWPROP EW 'EDITBUF)) EBWREG LEFT) (COND ((AND \DEDITBUFW (NEQ EBW \DEDITBUFW)) (CLOSEW \DEDITBUFW))) (COND ((NOT EBW) (SETQ EBW (CREATEW (GETEBUFREGION MAINREG (OR (FIXP *DEDIT-BUFFER-HEIGHT*) 60) EW) "Edit buffer")) (WINDOWPROP EBW 'PAGEFULLFN (FUNCTION NILL)) (WINDOWPROP EW 'EDITBUF EBW)) ((PROGN (PURGEW (ACTIVEEDITW EBW NIL)) (SETQ EBWREG (WINDOWPROP EBW 'REGION)) (NEQ (fetch (REGION WIDTH) of MAINREG) (fetch (REGION WIDTH) of EBWREG))) (* "User reshaped edit window to different width. Reshape it now to the main window's width, user's height. No DEdit specific reshaping will happen because window is now inactive") (SHAPEW EBW (GETEBUFREGION MAINREG (fetch (REGION HEIGHT) of EBWREG) EBW))) ((NEQ (SETQ LEFT (fetch (REGION LEFT) of MAINREG)) (fetch (REGION LEFT) of EBWREG)) (* "Window strayed somehow, move it to the right place") (MOVEW EBW LEFT (IDIFFERENCE (fetch (REGION BOTTOM) of MAINREG) (fetch (REGION HEIGHT) of EBWREG))) (OPENW EBW)) (T (OPENW EBW))) (WINDOWPROP EBW 'READER-ENVIRONMENT (WINDOWPROP EW 'READER-ENVIRONMENT)) (WINDOWPROP (SETQ \DEDITBUFW EBW) 'DSP]) (GETEBUFREGION [LAMBDA (MAINREG HEIGHT EW) (* bvm%: "27-May-86 15:07") (LET* ((FONTHEIGHT (FONTPROP EW 'HEIGHT)) (TOTALHEIGHT (HEIGHTIFWINDOW HEIGHT T)) (BOTTOM (IDIFFERENCE (fetch (REGION BOTTOM) of MAINREG) TOTALHEIGHT)) EXCESS) [COND ((LESSP BOTTOM 0) (* "Region overlaps bottom of screen, so force it on") (SETQ BOTTOM 0) [SETQ HEIGHT (IDIFFERENCE HEIGHT (IDIFFERENCE TOTALHEIGHT (SETQ TOTALHEIGHT (IDIFFERENCE (fetch (REGION BOTTOM) of MAINREG) BOTTOM] (COND ((LESSP HEIGHT 0) (* "Eek, it's off screen entirely. Make it one high just for giggles") (SETQ TOTALHEIGHT (HEIGHTIFWINDOW (SETQ HEIGHT FONTHEIGHT) T] [COND ((NEQ (SETQ EXCESS (IREMAINDER HEIGHT FONTHEIGHT)) 0) (* Try to make window integral number of lines high) (SETQ TOTALHEIGHT (IDIFFERENCE TOTALHEIGHT EXCESS)) (SETQ BOTTOM (IPLUS BOTTOM EXCESS] (create REGION LEFT _ (fetch (REGION LEFT) of MAINREG) BOTTOM _ BOTTOM WIDTH _ (fetch (REGION WIDTH) of MAINREG) HEIGHT _ TOTALHEIGHT]) (GETEDITCHAIN [LAMBDA (E) (* bas%: "30-MAR-83 21:45") (DECLARE (USEDFREE LASTAIL)) (COND ((LISTP E) (SETQ LASTAIL E) (SETQ E (OR (GETME4 E) E))) ((type? DEDITMAP E) (SETQ LASTAIL (fetch TAIL of E))) (E (SHOULDNT))) (OR (LISTP E) (for (I _ E) by (fetch BP of I) while I collect (fetch SELEXP of I]) (GETDEDITMAP [LAMBDA (DS) (* bas%: "11-Mar-84 23:15") (OR (GETMAP? DS) (SETDEDITMAP DS (COND ((ZORCHEDWP DS) (LIST (GETDEDITDEF4 DS))) (T (WINDOWPROP DS 'EDITEXPR]) (GETMAP? [LAMBDA (W) (* bas%: " 8-Mar-84 14:38") (GETSELMAP (WINDOWPROP W 'EDITEXPR]) (UNPURGEDP [LAMBDA (M) (* bas%: "11-Mar-84 23:09") (* This is unfortunately an expensive operation as some edit operations can cut a cons out of the structure being edited without that being obvious at the time it happens. The only way therefore to be sure that a ME really is valid is to chase its BPs all the way out to the top.) (AND (EQ M (GETME4 (fetch TAIL of M))) [OR (NOT (fetch BP of M)) (AND (HASASBP M (fetch BP of M)) (UNPURGEDP (fetch BP of M] M]) (SUBSELOF [LAMBDA (TOP SUB) (* bas%: " 8-Mar-84 14:11") (for (S2 _ (GETSELMAP SUB)) by (fetch BP of S2) while S2 thereis (EQ TOP (fetch SELEXP of S2]) (SETDEDITMAP [LAMBDA (DW V) (* bas%: "24-Jun-84 17:33") (PURGEW DW) (* Remove EDITEXPR and reset window) [SETQ V (DEPRINTDEF (MKLIST V) (DSPLEFTMARGIN NIL DW) DEFAULTFONT (WINDOWPROP DW 'DSP] (WINDOWPROP DW 'EDITEXPR (fetch TAIL of V)) [WINDOWPROP DW 'EXTENT (create REGION LEFT _ 0 BOTTOM _ (LOWPT V) WIDTH _ (WINDOWPROP DW 'WIDTH) HEIGHT _ (ADD1 (IDIFFERENCE (HIPT V) (LOWPT V] V]) (TAKEDOWN [LAMBDA (WDS) (* bas%: " 4-Apr-84 13:27") (COND (WDS (PURGEW WDS T) (CLOSEW WDS]) ) (RPAQ? *DEDIT-BUFFER-HEIGHT* 60) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *DEDIT-BUFFER-HEIGHT*) ) (DEFINEQ (DEDITRESHAPEFN [LAMBDA (W X1 X2) (* bas%: " 4-Apr-84 13:12") (AND (EDITWINDOWP W) (RESETFORM (CURSOR WAITINGCURSOR) (SETDEDITMAP W (WINDOWPROP W 'EDITEXPR)) (FLIPSELSIN W (IPLUS (WYOFFSET NIL W) (WINDOWPROP W 'HEIGHT)) (WYOFFSET NIL W]) (DEDITREPAINTFN [LAMBDA (WDS R) (* ; "Edited 11-Jun-90 14:53 by mitani") (PROG ((H (fetch (REGION PTOP) of R)) (L (fetch (REGION BOTTOM) of R))) (REFRESHIF WDS H L) (FLIPSELSIN WDS H L]) ) (DEFINEQ (RESETDEDIT [LAMBDA NIL (* jow "16-Oct-86 11:24") (DECLARE (GLOBALVARS \DEDITCOMS)) (pushnew MARKASCHANGEDFNS (FUNCTION DEDITMARKASCHANGED)) (PROGN (* ;; "DEdit wants to save these definitions. Must take them from TTY/ now because EDITINTERFACE moved them.") (MOVD 'TTY/EDITL 'NORMAL/EDITL) (MOVD 'TTY/EDITDATE 'NORMAL\EDITDATE) (EDITMODE 'DEDIT)) (PROGN (for I in (CONS DEditWindow (LISTP \DEDITWINDOWS)) when (WINDOWP I) do (CLOSEW I)) (SETQ DEditWindow NIL) (* Initialize DEDIT globals) (SETQ \DEDITWINDOWS NIL) (SETQ \DEDITALLOWSELS NIL) (SETQ \DEDITSELECTIONS NIL) (SETQ \DEDITBUFW NIL) (SETQ \DEDITMNUW NIL) (SETQ \DEDITMEHASH (HASHARRAY 255)) (SETQ \DEDITDPHASH (HASHARRAY 255)) (SETQ \DEDITFONTS NIL) (SETQ \DEDITDSPS (ARRAY 8)) (* 8 is arbitrary) ) T]) (DEDITDATE [LAMBDA (OLDATE INITLS) (* bas%: " 5-FEB-83 19:36") (PROG1 (NORMAL\EDITDATE OLDATE INITLS) (PROG (ODM W) (AND (SETQ ODM (GETME4 (LISTP OLDATE))) (SETQ ODM (fetch BP of ODM)) [ACTIVEWP (SETQ W (WFROMDS (fetch PDSP of ODM] (GETMAP? W) (REPP ODM]) (DEDITMARKASCHANGED [LAMBDA (NAME TYPE REASON) (* lmm "29-Jul-85 21:11") (* MARKASCHANGED is called after DEDITL exits. Hence a scan of the \DEDITWINDOWS chain finds all active DEDITs excluding the one just exited. The separate test on DEditWindow discriminates between exit from topmost DEDIT and other changes to the top level window) (ZORCHEDITW (COND ((FINDEDITW NAME TYPE)) (T (AND (WINDOWP DEditWindow) (SAMEEDITW DEditWindow NAME TYPE) (NOT (CADR (WINDOWPROP DEditWindow 'DEDITCHANGES NIL))) DEditWindow]) ) (DEFINEQ (COPYCONS [LAMBDA (C) (* bas%: "22-FEB-82 14:20") (CONS (CAR C) (CDR C]) (COPYOUTCONS [LAMBDA (C1 C2) (* bas%: "18-Mar-84 15:09") (* Returns C1 with any instances of C2 COPYCONSed out) (COND ((NLISTP C1) C1) ((EQ C1 C2) (COPYCONS C1)) (T (PROG ((CA (COPYOUTCONS (CAR C1) C2)) (CD (COPYOUTCONS (CDR C1) C2))) (RETURN (COND ((AND (EQ CA (CAR C1)) (EQ CD (CDR C1))) C1) (T (CONS CA CD]) (MAPENTRYP [LAMBDA (V) (* bas%: "21-MAR-83 19:58") (AND (type? DEDITMAP V) V]) (THELIST [LAMBDA (X) (* bas%: "21-JUL-82 18:11") (OR (LISTP X) (CANT "Not a list!"]) ) (DEFINEQ (CANT [LAMBDA NMSGS (* hdj " 7-May-86 11:09") (* Report error by flashing window) (DSPRESET PROMPTWINDOW) (printout PROMPTWINDOW T "Can't: ") (for I to NMSGS do (printout PROMPTWINDOW %, (ARG NMSGS I))) (FLASHWINDOW PROMPTWINDOW) (ERROR!]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD STACK (TOPELT NXTELT) (CREATE NIL)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS EDITBLOCKCALL MACRO (F (CONS (PACK* '\EDITBLOCK/ (CAR F)) (CDR F)))) (PUTPROPS CONTROLCODE MACRO [(CHAR) (IDIFFERENCE (CHCON1 CHAR) (CONSTANT (IDIFFERENCE (CHARCODE A) (CHARCODE ^A]) (PUTPROPS OVERLAP MACRO [OPENLAMBDA (H1 L1 H2 L2) (NOT (OR (ILESSP H1 L2) (ILESSP H2 L1]) (PUTPROPS SHIFTSELECTKEYS MACRO [NIL (OR (SHIFTDOWNP 'SHIFT) (KEYDOWNP 'COPY]) ) (DECLARE%: EVAL@COMPILE (RPAQQ LINETHICKNESS 2) (RPAQQ PRIMSHADE 65535) (RPAQQ SECSHADE 3598) (RPAQ SWITCHSHADE (LOGXOR PRIMSHADE SECSHADE)) (RPAQQ READSHADE 23130) (RPAQQ CHANGEDSHADE 8840) (CONSTANTS (LINETHICKNESS 2) (PRIMSHADE 65535) (SECSHADE 3598) (SWITCHSHADE (LOGXOR PRIMSHADE SECSHADE)) (READSHADE 23130) (CHANGEDSHADE 8840)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DEditWindow \DEDITMNUW \DEDITBUFW \DEDITALLOWSELS \DEDITWINDOWS \DEDITSELECTIONS DT.EDITMACROS UPFINDFLG) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS ATM EDITCHANGES EDITHIST LASTAIL UNDOLST UNDOLST1) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) DEDITPP) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD DSPRINTDEF NEWPRINTDEF DEDITPP) (AND (GETD 'RESETDEDIT) (RESETDEDIT)) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CANT) ) (PUTPROPS DEDIT COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (10154 10329 (DEDITIT 10164 . 10327)) (10445 18396 (DEDITL 10455 . 13796) (DEDITL0 13798 . 17062) (DEDITTTYFN 17064 . 18394)) (18439 31433 (DEDITAfter 18449 . 19026) (DEDITBefore 19028 . 19577) (DEDITDelete 19579 . 20134) (DEDITReplace 20136 . 20484) (DEDITSwitch 20486 . 20906) (DEDITBI 20908 . 21543) (DEDITBO 21545 . 21764) (DEDITLI 21766 . 21950) (DEDITLO 21952 . 22140) (DEDITRI 22142 . 22653) (DEDITRO 22655 . 22819) (DEDITUndo 22821 . 23497) (UNDOCHOOSE 23499 . 24528) (DEDITFind 24530 . 25110) (DEDITSwap 25112 . 25612) (DEDITCenter 25614 . 27079) (DEDITCopy 27081 . 27242) ( DEDITReprint 27244 . 27412) (DEDITEditCom 27414 . 28317) (DEDITARGS 28319 . 28724) (DEDITBreak 28726 . 30350) (DEDITEval 30352 . 31008) (DEDITExit 31010 . 31431)) (31434 35571 (DEDITEdit 31444 . 33159) (DEDITCEdit 33161 . 33908) (DEDIT.TTYinEdit 33910 . 34139) (DEDITDatatype 34141 . 35569)) (35638 46283 (SETPTRTO 35648 . 36384) (DEDITCONS 36386 . 36678) (DEDITZAPCAR 36680 . 36888) (DEDITZAPCDR 36890 . 37110) (DEDITZAPNODE 37112 . 37270) (DEDITZAPBOTH 37272 . 40061) (DEDITFZAP 40063 . 40838) ( DEDITZAPCLISP 40840 . 41736) (DEDITZAPCHANGES 41738 . 42579) (DEDITMOVETAILDOWN 42581 . 43030) ( DUNDOEDITL 43032 . 44001) (DUNDOEDITCOM 44003 . 45439) (DUNDOEDITCOM1 45441 . 46281)) (46361 58474 ( DEDITSLCTLP 46371 . 47728) (DEDITUSER 47730 . 47962) (SELECTKEYS 47964 . 48430) (DODEDITTYPEDCOM 48432 . 48898) (DEDITREADLINE 48900 . 50425) (SHADEIFNOTBUF 50427 . 50640) (DEDITBUTTONFN 50642 . 50954) ( DEDITRIGHTBUTTONFN 50956 . 51274) (DEDITWINDOWENTRYFN 51276 . 51675) (SELECTELEMENT 51677 . 52496) ( SELECTREAD 52498 . 53997) (SELECTTREE 53999 . 54274) (SEARCHMAP 54276 . 55606) (WITHINME 55608 . 56650 ) (ONAPARENP 56652 . 57206) (SELECTDONE 57208 . 57369) (INWINDOW 57371 . 57568) (FINDLCA 57570 . 57897 ) (DOMINATE? 57899 . 58472)) (58918 68994 (POPSELECTION 58928 . 59103) (PUSHSELECTION 59105 . 59254) ( NXTSELECTION 59256 . 59485) (TOPSELECTION 59487 . 59715) (SWITCHANDSHADE 59717 . 60363) ( SHADESELECTION 60365 . 60513) (SHADESELECTION1 60515 . 63486) (SHADESELECTION2 63488 . 63813) ( OVERLAPSELBAND 63815 . 64079) (PUSHEDITCHAIN 64081 . 64469) (MAKESELCHAIN 64471 . 65692) (PUSHINTOBUF 65694 . 65833) (DUMMYMAPENTRY 65835 . 66237) (FLIPSELS 66239 . 66758) (FLIPSELSIN 66760 . 67563) ( FIXUPSEL 67565 . 68532) (NEWSELFOR 68534 . 68992)) (69050 79107 (ACTIVEEDITW 69060 . 70096) (FINDEDITW 70098 . 70278) (GETEDITW 70280 . 70960) (GETDEDITDEF4 70962 . 71359) (MAKEEDITW 71361 . 72232) ( NAMEOFEDITW 72234 . 73302) (PURGEW 73304 . 74464) (MAKECPOSBE 74466 . 74814) (SAMEEDITW 74816 . 75054) (SETUPDEDITW 75056 . 75852) (TOPEDITW 75854 . 75981) (UNDEDITW 75983 . 77655) (WHICHEDITW 77657 . 77968) (ZORCHEDITW 77970 . 78511) (ZORCHEDWP 78513 . 78813) (UNZORCHME 78815 . 79105)) (79178 89100 ( SETEDITMENU 79188 . 82317) (CACHEDEDITCOMS 82319 . 84329) (FINDEDITCOM 84331 . 84553) (READEDITMENU 84555 . 87836) (SHADEMENUENTRY 87838 . 88899) (DEDITMENURESTORE 88901 . 89098)) (91041 103255 (BUFSELP 91051 . 91260) (EDITWINDOWP 91262 . 91489) (GETLEFT 91491 . 92216) (GETMEBP 92218 . 92380) (HASASBP 92382 . 92736) (TAILOF 92738 . 93017) (DOTTEDEND 93019 . 93188) (GETME4 93190 . 94770) (GETSELMAP 94772 . 95136) (DEARME 95138 . 95879) (DPCDRSEL 95881 . 96238) (GETDPME 96240 . 96440) (GETEBUF 96442 . 98517) (GETEBUFREGION 98519 . 100439) (GETEDITCHAIN 100441 . 100928) (GETDEDITMAP 100930 . 101256) (GETMAP? 101258 . 101404) (UNPURGEDP 101406 . 102071) (SUBSELOF 102073 . 102317) (SETDEDITMAP 102319 . 103082) (TAKEDOWN 103084 . 103253)) (103367 104075 (DEDITRESHAPEFN 103377 . 103778) (DEDITREPAINTFN 103780 . 104073)) (104076 106397 (RESETDEDIT 104086 . 105212) (DEDITDATE 105214 . 105654) ( DEDITMARKASCHANGED 105656 . 106395)) (106398 107595 (COPYCONS 106408 . 106547) (COPYOUTCONS 106549 . 107288) (MAPENTRYP 107290 . 107438) (THELIST 107440 . 107593)) (107596 107991 (CANT 107606 . 107989))) )) STOP \ No newline at end of file diff --git a/library/DEDITPP b/library/DEDITPP new file mode 100644 index 00000000..64c39567 --- /dev/null +++ b/library/DEDITPP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "20-Jan-93 13:48:30" {DSK}lde>lispcore>library>DEDITPP.;2 42478 previous date%: " 4-Sep-91 13:23:07" {DSK}lde>lispcore>library>DEDITPP.;1) (* ; " Copyright (c) 1986, 1990, 1991, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DEDITPPCOMS) (RPAQQ DEDITPPCOMS ([COMS (* ; "DEDITMAP record and accessors") (DECLARE%: EVAL@COMPILE DONTCOPY (* ;  "DEDITMAP record definition is on DSPRINTDEF because it is needed there") (FILES (LOADCOMP) DSPRINTDEF)) (INITRECORDS DEDITMAP) (FNS DEDIT.LPEND DEDIT.RPSTART MAKEMAPENTRY \DEDITFONT# DSPDSFOR SHOWDEDITMAP) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'DEDITMAP 'SHOWDEDITMAP] (COMS (* ;  "DEDIT entry and incremental reprettyprinting") (FNS DEPRINTDEF DEDIT-MAKE-READER-ENV) (FNS REPP REPPCHANGES REPPUNRAVEL REPPDELETE REPPINSERT REPPTANGLEDP LEADSPACE SPACINGRULE UNPP NXTUSEDX ONELINEP) (FNS MOVEDSMAP ADJUSTXTAIL ADJUSTYTAIL ADJDEEXTENT DSLINEFONT DSLINEFONT1 MAXFONT) (FNS REFRESHIF REFRESHIF1) (FNS COMMENTP HIPT LOWPT WIPE) (FNS RESETCLIP)))) (* ; "DEDITMAP record and accessors") (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) DSPRINTDEF) ) (/DECLAREDATATYPE 'DEDITMAP '(BYTE POINTER BYTE POINTER WORD WORD WORD WORD FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER) '((DEDITMAP 0 (BITS . 7)) (DEDITMAP 2 POINTER) (DEDITMAP 1 (BITS . 7)) (DEDITMAP 4 POINTER) (DEDITMAP 6 (BITS . 15)) (DEDITMAP 7 (BITS . 15)) (DEDITMAP 8 (BITS . 15)) (DEDITMAP 9 (BITS . 15)) (DEDITMAP 4 (FLAGBITS . 0)) (DEDITMAP 4 (FLAGBITS . 16)) (DEDITMAP 4 (FLAGBITS . 32)) (DEDITMAP 4 (FLAGBITS . 48)) (DEDITMAP 2 (FLAGBITS . 0)) (DEDITMAP 2 (FLAGBITS . 16)) (DEDITMAP 2 (FLAGBITS . 32)) (DEDITMAP 2 (FLAGBITS . 48)) (DEDITMAP 10 POINTER)) '12) (DEFINEQ (DEDIT.LPEND [LAMBDA (MAPE) (* bvm%: "22-May-86 12:46") (* ;;; "Xpos of start of expression, following the open paren (or wrapper)") (IPLUS (fetch STARTX of MAPE) (LET ((WRAP (fetch WRAPPER of MAPE)) (FNT (fetch FNT of MAPE))) (COND (WRAP (STRINGWIDTH WRAP FNT)) (T (CHARWIDTH (CHARCODE %() (fetch FNT of MAPE]) (DEDIT.RPSTART [LAMBDA (MAPE) (* bvm%: "22-May-86 12:46") (* ;;; "Xpos where expression ends and right paren starts") (IDIFFERENCE (fetch STOPX of MAPE) (COND ((fetch WRAPPER of MAPE) 0) (T (CHARWIDTH (CHARCODE %)) (fetch FNT of MAPE]) (MAKEMAPENTRY [LAMBDA (TAIL BACK SX SY EX EY FN) (* hdj "19-Jul-85 11:35") (* ;; "Used to check for existing hashlink and do something fancy. Now should not happen except from dummy blocks.") (PUTHASH TAIL (create DEDITMAP BP _ BACK TAIL _ TAIL STARTX _ SX STARTY _ SY STOPX _ EX STOPY _ EY D# _ (COND (BACK (fetch D# of BACK)) (T (DSPDSFOR))) F# _ FN) \DEDITMEHASH]) (\DEDITFONT# [LAMBDA NIL (* kbr%: "25-Aug-85 17:45") (OR \DEDITFONT# (SETQ \DEDITFONT# (PROG (FONT FONTTYPE FONT#) (SETQ FONT (DSPFONT)) (SETQ FONTTYPE (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT)) [OR \DEDITFONTS (SETQ \DEDITFONTS (FONTMAPARRAY NIL 'DISPLAY] [SETQ FONT# (for I to (ARRAYSIZE \DEDITFONTS) thereis (EQ FONT (COND ((EQ FONTTYPE 'DISPLAY) (fetch (FONTCLASS DISPLAYFD) of (ELT \DEDITFONTS I))) (T (FONTCLASSCOMPONENT (ELT \DEDITFONTS I) FONTTYPE NIL T] (RETURN FONT#))) (SHOULDNT]) (DSPDSFOR [LAMBDA (DS) (* hdj "19-Jul-85 11:35") [OR DS (SETQ DS (GETSTREAM NIL 'OUTPUT] (PROG [(V (OR [for I to (ARRAYSIZE \DEDITDSPS) thereis (OR (NOT (STREAMP (ELT \DEDITDSPS I))) (EQ DS (ELT \DEDITDSPS I] (bind [NU _ (ARRAY (ITIMES 2 (ARRAYSIZE \DEDITDSPS] for J to (ARRAYSIZE \DEDITDSPS) do (SETA NU J (ELT \DEDITDSPS J)) finally (SETQ \DEDITDSPS NU) (RETURN J] (SETA \DEDITDSPS V DS) (RETURN V]) (SHOWDEDITMAP [LAMBDA (ME) (* bas%: " 8-Mar-84 13:11") (CONS [APPLY 'CONCAT (APPEND (LIST "{") [bind V TL (Q _ (CAR (fetch TAIL of ME))) while (LISTP Q) do (push V "(") (push TL (COND ((CDR Q) '" --)") (T ")"))) (SETQ Q (CAR Q)) finally (RETURN (COND (V (APPEND V (CONS Q TL))) (T (LIST Q] (LIST " @ " (CONCAT "<" (fetch STARTX of ME) "," (fetch STARTY of ME) " - " (fetch STOPX of ME) "," (fetch STOPY of ME) ">")) (LIST (COND ((UNPURGEDP ME) "}") (T " PURGED}"] (PACK]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (DEFPRINT 'DEDITMAP 'SHOWDEDITMAP) ) (* ; "DEDIT entry and incremental reprettyprinting") (DEFINEQ (DEPRINTDEF [LAMBDA (TAIL LEFT FONT FILE) (* ; "Edited 4-Sep-91 11:56 by jds") (* ;;; "The central pretty-printer for DEDIT -- prints TAIL to FILE with indicated LEFT margin and FONT. TAIL is either an expression, or a map entry whose TAIL we should start printing with.") (* ;;  "JDS 8/27/91: Bind FNSLST and FORMFLG, because they're used freely in the pretty printer.") (SETQ FILE (GETSTREAM FILE 'OUTPUT)) (WITH-READER-ENVIRONMENT (OR (WINDOWPROP FILE 'READER-ENVIRONMENT) (DEDIT-MAKE-READER-ENV)) [LET ((MAKEMAP T) (%#RPARS NIL) (FNSLST NIL) (FORMFLG NIL) (FIRSTPOS (DSPXPOSITION NIL FILE)) (LEFT (DSPXPOSITION NIL FILE)) (RMARGIN (DSPRIGHTMARGIN NIL FILE)) (FILEFLG NIL) (COMMENTCOL NIL)) (DECLARE (SPECVARS MAKEMAP %#RPARS FNSLST FORMFLG FIRSTPOS LEFT RMARGIN FILEFLG COMMENTCOL)) (RESETLST (RESETSAVE **COMMENT**FLG NIL) (RESETSAVE (OUTPUT FILE)) (SETQ \DEDITFONTS (FONTMAPARRAY NIL 'DISPLAY)) [COND ((type? DEDITMAP TAIL) (SETQ MAKEMAP (OR (fetch BP of TAIL) T)) (OR FILE (OUTPUT (fetch PDSP of TAIL))) [OR FONT (SETQ FONT (fetch FNT of (COND ((NEQ MAKEMAP T) MAKEMAP) (T TAIL] (OR LEFT (SETQ LEFT (fetch STARTX of TAIL))) (SETQ TAIL (fetch TAIL of TAIL] (PROG ((FIRSTPOS (DSPLEFTMARGIN)) [RMARGIN (IPLUS (DSPLEFTMARGIN) (IDIFFERENCE (fetch (REGION WIDTH) of (WINDOWPROP FILE 'REGION)) (ITIMES 2 (WINDOWPROP FILE 'BORDER] COMMENTCOL FNSLST TAILFLG FILEFLG CHANGEFLG (FORMFLG T)) (SETFONT FONT FILE) (DSPXPOSITION LEFT FILE) (SUPERPRINT (CAR TAIL) TAIL NIL FILE)))]) (GETME4 TAIL T]) (DEDIT-MAKE-READER-ENV [LAMBDA (EXPR) (* ; "Edited 26-Nov-86 16:38 by bvm:") (* ;;; "Creates a READER-ENVIRONMENT object to control the editing environment of EXPR. For now, just use the current environment") (MAKE-READER-ENVIRONMENT (AND ATM (CL:SYMBOLP ATM) (NEQ ATM 'NOBIND) (CL:SYMBOL-PACKAGE ATM]) ) (DEFINEQ (REPP [LAMBDA (ENT) (* bvm%: " 9-Jun-86 17:11") (bind DS OLDE do (SETQ OLDE ENT) (* ; "Save current value") (SETQ DS (fetch PDSP of ENT)) [COND [(fetch BP of ENT) (* ;; "Subexpression -- move to where it starts now, then reprint the expression with clipping region set to confine the printing to the space now available") (MOVETO (fetch STARTX of ENT) (fetch STARTY of ENT) DS) (RESETFORM (RESETCLIP (CONS DS (UNPP ENT))) (SETQ ENT (DEPRINTDEF ENT NIL NIL DS] (T (* ; "Reprint the entire window") (RETURN (SETDEDITMAP DS (fetch TAIL of ENT] repeatwhile (SETQ ENT (MOVEDSMAP ENT (fetch STOPX of OLDE) (fetch STOPY of OLDE) (fetch STOPX of ENT) (fetch STOPY of ENT]) (REPPCHANGES [LAMBDA (UL) (* bas%: "12-Sep-84 13:57") (for I in (bind CL TEM for UE in (SETQ UL (REPPUNRAVEL UL)) when [AND (SETQ TEM (GETME4 (CAR UE))) (PROG (SCR (BK (OR (fetch BP of TEM) TEM)) (OLDCAR (CADR UE)) (OLDCDR (CDDR UE)) (NEWCAR (CAAR UE)) (NEWCDR (CDAR UE))) (RETURN (COND ((NEQ (NLISTP NEWCAR) (NLISTP OLDCAR)) (SETQ TEM BK)) ((EQ NEWCDR OLDCDR) (NEQ OLDCAR NEWCAR)) ((REPPTANGLEDP (CAR UE) UL) (SETQ TEM BK)) ((for I in CL thereis (DOMINATE? I TEM)) (SETQ TEM BK)) (T (OR (SELECTQ (SETQ SCR (REPPINSERT TEM OLDCDR NEWCDR)) (NIL NIL) (T (SELECTQ (SETQ SCR (REPPDELETE TEM OLDCDR NEWCDR)) (NIL NIL) (T (SETQ TEM BK)) (SETQ TEM SCR))) (SETQ TEM SCR)) (NEQ OLDCAR NEWCAR] unless (for I in CL thereis (DOMINATE? I TEM)) do (push CL TEM) finally (RETURN CL)) when (UNPURGEDP I) do (* ;; "Earlier elements of CL may dominate later ones. If so, the latter will be purged by the former's REPP.") (REPP I]) (REPPUNRAVEL [LAMBDA (UL) (* bas%: "25-JUL-82 21:05") (* ;; "Reverses and unpacks LISPXHIST entries") (PROG (RSLT) LP [COND ((NULL UL) (RETURN RSLT)) [(EQ 'LISPXHIST (CAAR UL)) (for I in (CDAR UL) do (COND ((LISTP (CAR I)) (push RSLT I)) ((EQ (CAR I) '/RPLACA) (push RSLT (CONS (CADR I) (CONS (CADDR I) (CDADR I] (T (push RSLT (CAR UL] (SETQ UL (CDR UL)) (GO LP]) (REPPDELETE [LAMBDA (ENT OCDR NCDR) (* bas%: " 7-Mar-84 18:09") (PROG ([EDGE (for I on OCDR thereis (EQ NCDR (CDR I] NCE OCE SX SY) (COND [(SETQ EDGE (GETME4 EDGE)) (SETQ OCE (GETME4 OCDR T)) [AND NCDR (SETQ NCE (GETME4 NCDR (fetch BP of EDGE))) (COND ((COMMENTP (CAR NCDR)) (SETQ SX (fetch STARTX of NCE] [bind IM for I on OCDR until (EQ I NCDR) when (SETQ IM (GETME4 I)) do (COND ((COMMENTP (CAR I)) (UNPP IM)) (T (COND ((COMMENTP (CAR NCDR)) (UNPP IM))) (OR SX (SETQ SX (fetch STARTX of IM))) (OR SY (SETQ SY (fetch STARTY of IM] (RETURN (COND [NCDR [AND SX (DPCDRSEL NCE) (add SX (WIDTH DOTSTRING (fetch FNT of NCE] (MOVEDSMAP ENT (fetch STARTX of NCE) (fetch STARTY of NCE) (OR SX (fetch STARTX of NCE)) (OR SY (IDIFFERENCE (fetch STOPY of ENT) (IDIFFERENCE (fetch STOPY of EDGE) (fetch STARTY of NCE] (T (MOVEDSMAP ENT (fetch STOPX of EDGE) (fetch STOPY of EDGE) (fetch STOPX of ENT) (fetch STOPY of ENT] (T (RETURN T]) (REPPINSERT [LAMBDA (ENT OCDR NCDR) (* bas%: " 7-MAR-83 09:31") (COND [(AND (LISTP NCDR) (OR (NULL OCDR) (TAILP OCDR NCDR))) (PROG ((EDS (fetch PDSP of ENT)) (ALIGN (SPACINGRULE (fetch BP of ENT))) (DELTAX (CHARWIDTH (CHARCODE SPACE) (fetch FNT of ENT))) (SX (fetch STOPX of ENT)) (SY (fetch STOPY of ENT)) NX NY TMP) (* ; "Doesnt enter PROG unless its an insertion") [SETQ ALIGN (COND (ALIGN (fetch STARTX of ALIGN)) (T (IPLUS DELTAX SX] (RESETFORM (RESETCLIP (CONS EDS (create REGION LEFT _ SX BOTTOM _ SY WIDTH _ 0 HEIGHT _ 0))) (MOVETO SX SY EDS) (for E on NCDR until (EQ E OCDR) first (SETQ TMP ENT) do (LEADSPACE E TMP ALIGN DELTAX EDS) (SETQ TMP (DEPRINTDEF E (DSPXPOSITION NIL EDS) (fetch FNT of (fetch BP of ENT)) EDS)) (replace BP of TMP with (fetch BP of ENT)) finally (LEADSPACE OCDR TMP ALIGN DELTAX EDS))) (SETQ NX (DSPXPOSITION NIL EDS)) (SETQ NY (DSPYPOSITION NIL EDS)) [PROG (NSY (QV (GETME4 OCDR))) (COND (QV (SETQ NSY (fetch STARTY of QV)) (SETQ SX (fetch STARTX of QV)) (COND ((ILESSP NSY SY) (REFRESHIF EDS (HIPT ENT) (ADD1 (HIPT QV))) (* ; "Some action at the end of ENT's line?") (SETQ SY NSY)) ((EQ NSY SY) (* ; "Dont move if insert did not reach rest of line eg a comment") (SETQ NX (IMAX NX SX] (RETURN (MOVEDSMAP TMP SX SY NX NY] (T T]) (REPPTANGLEDP [LAMBDA (E L) (* bas%: " 3-Dec-84 21:45") (* ;; "Can only handle one change per cell because of cancelling changes or one CDR change per command lest different CDR changes share elements") (bind EC CCC for I in L when (GETME4 (CAR I)) do (COND ((NEQ E (CAR I))) (EC (RETURN T)) (T (SETQ EC T))) (COND ((EQ (CDAR I) (CDDR I))) (CCC (RETURN T)) (T (SETQ CCC T]) (LEADSPACE [LAMBDA (E PRV ALIGN DELTAX EDS) (* bas%: " 3-DEC-82 18:40") (COND ((NOT E)) ([AND (LISTP (CAR (fetch TAIL of PRV))) (NOT (COMMENTP (CAR E] (MOVETO ALIGN (IPLUS (DSPYPOSITION NIL EDS) (DSPLINEFEED NIL EDS)) EDS)) (T (RELMOVETO DELTAX 0 EDS]) (SPACINGRULE [LAMBDA (BME) (* bas%: "12-Sep-84 10:46") (* ;; "Looks for someone who might know what the current left margin is and returns that someone.") (bind P Q for E on (fetch SELEXP of BME) unless (COMMENTP (CAR E)) when (SETQ Q (GETSELMAP E)) do (COND ((NEQ (fetch STARTY of Q) (fetch STARTY of BME)) (RETURN Q)) (P) (T (SETQ P Q))) finally (RETURN P]) (UNPP [LAMBDA (ENT) (* ; "Edited 11-Jun-90 14:57 by mitani") (* ;; "Clears region printed by ENT, carefully") (PROG ((EDS (fetch PDSP of ENT)) (H (FONTPROP (fetch FNT of ENT) 'HEIGHT)) (HI (ADD1 (HIPT ENT))) (LO (LOWPT ENT)) R) (SETQ R (DSPCLIPPINGREGION NIL EDS)) (COND ((NOT (fetch BP of ENT)) (WIPE (fetch (REGION LEFT) of R) (fetch (REGION BOTTOM) of R) (fetch (REGION WIDTH) of R) (fetch (REGION HEIGHT) of R) EDS) (RETURN R)) ((ONELINEP ENT) (WIPE (fetch STARTX of ENT) LO (IDIFFERENCE (fetch STOPX of ENT) (fetch STARTX of ENT)) H EDS)) (T (WIPE (fetch STARTX of ENT) (IDIFFERENCE HI H) (IDIFFERENCE (fetch (REGION PRIGHT) of R) (fetch STARTX of ENT)) H EDS) (* ;  "Amazingly enough this is as good as one can do") (WIPE (fetch (REGION LEFT) of R) (IPLUS LO H) (fetch (REGION WIDTH) of R) (IDIFFERENCE (IDIFFERENCE HI H) (IPLUS LO H)) EDS) (WIPE (fetch (REGION LEFT) of R) LO (ADD1 (IDIFFERENCE (fetch STOPX of ENT) (fetch (REGION LEFT) of R))) H EDS))) (RETURN (create REGION LEFT _ (fetch (REGION LEFT) of R) BOTTOM _ (IMAX LO (fetch (REGION BOTTOM) of R)) WIDTH _ (COND ((ONELINEP ENT) (IDIFFERENCE (NXTUSEDX ENT) (fetch (REGION LEFT) of R))) (T (fetch (REGION WIDTH) of R))) HEIGHT _ (IMAX 0 (IDIFFERENCE (IMIN HI (fetch (REGION TOP) of R)) (IMAX LO (fetch (REGION BOTTOM) of R]) (NXTUSEDX [LAMBDA (E) (* ; "Edited 11-Jun-90 14:57 by mitani") (* ;; "Finds the first used X loc on the same line as the end of E") (PROG (V) (RETURN (OR [COND [(SETQ V (CDR (fetch TAIL of E))) (COND [(LISTP V) (SETQ V (GETME4 V (GETMEBP E))) (COND ((EQ (fetch STARTY of V) (fetch STOPY of E)) (fetch STARTX of V] (T (* ; "Dotted pair") (IPLUS (fetch STOPX of E) (CHARWIDTH (CHARCODE SPACE) (fetch FNT of E] ((SETQ V (fetch BP of E)) (COND ((EQ (fetch STOPY of V) (fetch STOPY of E)) (fetch RPSTART of V] (fetch (REGION RIGHT) of (DSPCLIPPINGREGION NIL (fetch PDSP of E]) (ONELINEP [LAMBDA (ENT) (* bas%: " 4-OCT-82 15:26") (EQ (fetch STARTY of ENT) (fetch STOPY of ENT]) ) (DEFINEQ (MOVEDSMAP [LAMBDA (ENT OX OY NX NY) (* ; "Edited 11-Jun-90 14:57 by mitani") (* ;; "APOLOGY: This code and any path by which you got here is a frightful kludge. WARNING: It is also very tricky as there are lots of special cases.") (PROG (OLOW NLOW FONTH NEXT REG BOTTOM LEFT RIGHT WIDTH (DX (IDIFFERENCE NX OX)) (DY (IDIFFERENCE NY OY)) (LINEFONT (DSLINEFONT ENT OY)) (EPDS (fetch PDSP of ENT))) (SETQ FONTH (FONTPROP LINEFONT 'DESCENT)) (SETQ NLOW (IDIFFERENCE NY FONTH)) (SETQ OLOW (IDIFFERENCE OY FONTH)) (SETQ FONTH (FONTPROP LINEFONT 'HEIGHT)) (SETQ REG (DSPCLIPPINGREGION NIL EPDS)) (SETQ BOTTOM (fetch (REGION BOTTOM) of REG)) (SETQ LEFT (fetch (REGION LEFT) of REG)) (SETQ RIGHT (fetch (REGION PRIGHT) of REG)) (SETQ WIDTH (fetch (REGION WIDTH) of REG)) [COND ((ZEROP DX)) (T (for (B _ ENT) by (fetch BP of B) while (fetch BP of B) do (SETQ NEXT (OR (ADJUSTXTAIL (CDR (fetch TAIL of B)) (fetch BP of B) DX OY RIGHT) NEXT))) (* ; "Move the rest of the line") (COND ((AND (ILESSP DX 0) (IGEQ DY 0)) (BITBLT EPDS OX OLOW EPDS NX OLOW (IDIFFERENCE RIGHT OX) FONTH 'INPUT 'REPLACE) (* ; "Move in then blank out far edge") (WIPE (IPLUS RIGHT DX) OLOW (IMINUS DX) FONTH EPDS)) (T (* ; "Image is filled in at exit") (WIPE OX OLOW (IDIFFERENCE RIGHT OX) FONTH EPDS] [COND ((ZEROP DY)) (T (BITBLT EPDS LEFT BOTTOM EPDS LEFT (IPLUS BOTTOM DY) WIDTH (IDIFFERENCE OLOW BOTTOM) 'INPUT 'REPLACE) (for (B _ ENT) by (fetch BP of B) while (fetch BP of B) do (* ;  "Map over everything to the bottom right moving it vertically") (ADJUSTYTAIL (CDR (fetch TAIL of B)) (fetch BP of B) OY DY)) (ADJDEEXTENT EPDS DY) (* ;  "Fix extent and blank inserted space") (COND ((IGREATERP DY 0) (WIPE LEFT (IMIN BOTTOM OLOW) WIDTH DY EPDS) (* ; "Repaint into cleared space") (REFRESHIF EPDS (IPLUS BOTTOM DY) BOTTOM) (* ; "Clear rest of new line") (WIPE NX NLOW (IDIFFERENCE RIGHT NX) FONTH EPDS)) (T [SETQ NLOW (IMIN NLOW (IPLUS DY (fetch (REGION PTOP) of REG] (WIPE LEFT NLOW WIDTH (IMINUS DY) EPDS) (* ;  "Clear possible trash thru which we extended") (WIPE LEFT OLOW WIDTH FONTH EPDS] (REFRESHIF EPDS (IPLUS FONTH -1 (IMAX NLOW OLOW)) (ADD1 NLOW)) (* ;; "Another small kludge. A slightly bigger font like CLISPFONT on the next line might stick up into NLOW and thus get refreshed. Unfortunately, there is no guarrantee that that line will be valid to refresh. Correct solution is to make line spacing on printing such that no two lines touch. For now, we diddle the NLOW value to avoid touching the next line down.") (RETURN NEXT]) (ADJUSTXTAIL [LAMBDA (TAIL BK DX YLINE RIGHT) (* bas%: " 3-Dec-84 22:07") (PROG (OVER) [bind IM for I on TAIL when (SETQ IM (GETME4 I)) do (COND ((NEQ YLINE (fetch STARTY of IM)) (RETURN)) ((IGREATERP RIGHT (add (fetch STARTX of IM) DX))) (T (SETQ OVER BK))) (AND [COND ((LISTP (CAR I)) (ADJUSTXTAIL (CAR I) IM DX YLINE RIGHT)) ((EQ YLINE (fetch STOPY of IM)) (ILEQ RIGHT (add (fetch STOPX of IM) DX] (SETQ OVER BK)) finally (COND ((SETQ IM (GETME4 I BK)) (AND (EQ YLINE (fetch STARTY of IM)) (ILEQ RIGHT (add (fetch STARTX of IM) DX)) (SETQ OVER BK)) (AND (EQ YLINE (fetch STOPY of IM)) (ILEQ RIGHT (add (fetch STOPX of IM) DX)) (SETQ OVER BK] (AND (EQ YLINE (fetch STOPY of BK)) (ILEQ RIGHT (add (fetch STOPX of BK) DX)) (SETQ OVER (OR (fetch BP of BK) BK))) (RETURN OVER]) (ADJUSTYTAIL [LAMBDA (TAIL BK OY D) (* bas%: " 3-Dec-84 22:07") [bind IM for I on TAIL when (SETQ IM (GETME4 I)) do (add (fetch STARTY of IM) D) (COND ((LISTP (CAR I)) (ADJUSTYTAIL (CAR I) IM OY D)) (T (add (fetch STOPY of IM) D))) finally (COND ((SETQ IM (GETME4 I BK)) (add (fetch STARTY of IM) D) (add (fetch STOPY of IM) D] (add (fetch STOPY of BK) D]) (ADJDEEXTENT [LAMBDA (EX DY) (* ; "Edited 11-Jun-90 14:57 by mitani") (OR (SETQ EX (WINDOWPROP EX 'EXTENT)) (SHOULDNT)) (add (fetch (REGION BOTTOM) of EX) DY) (add (fetch (REGION HEIGHT) of EX) (IMINUS DY]) (DSLINEFONT [LAMBDA (E Y) (* bas%: "30-Mar-84 11:22") (DSLINEFONT1 [for old E by (fetch BP of E) thereis (OR (NOT (fetch BP of E)) (AND (ILESSP Y (fetch STARTY of E)) (IGREATERP Y (fetch STOPY of E] Y]) (DSLINEFONT1 [LAMBDA (ENT YLINE) (* bas%: "30-Mar-84 10:52") (AND ENT (bind IM (MFONT _ (AND (OR (EQ YLINE (fetch STARTY of ENT)) (EQ YLINE (fetch STOPY of ENT))) (fetch FNT of ENT))) for I on (LISTP (fetch SELEXP of ENT)) do (SETQ MFONT (MAXFONT MFONT (DSLINEFONT1 (GETME4 I) YLINE))) finally (RETURN MFONT]) (MAXFONT [LAMBDA (F1 F2) (* bas%: "30-Mar-84 10:17") (COND ((IGREATERP (COND ((FONTP F1) (FONTPROP F1 'HEIGHT)) (T 0)) (COND ((FONTP F2) (FONTPROP F2 'HEIGHT)) (T 0))) F1) (T F2]) ) (DEFINEQ (REFRESHIF [LAMBDA (WDS HI LO) (* ; "Edited 11-Jun-90 14:57 by mitani") (* ;;; "Repaints stuff LOWER than HI and on or above LO") (WITH-READER-ENVIRONMENT (OR (WINDOWPROP WDS 'READER-ENVIRONMENT) (SHOULDNT)) (DSPRIGHTMARGIN (PROG1 (DSPRIGHTMARGIN 10000 WDS) (* ;  "We reset margin b/c REFRESHIF is sometimes called with things that would overflow") [LET ((R (DSPCLIPPINGREGION NIL WDS))) (REFRESHIF1 (GETMAP? WDS) (GETSTREAM WDS 'OUTPUT) (IMIN HI (fetch (REGION PTOP) of R)) (IMAX LO (fetch (REGION BOTTOM) of R]) WDS))]) (REFRESHIF1 [LAMBDA (M DS HI LO) (* bvm%: "28-May-86 15:30") (* ;;; "Refresh display of that part of expression indicated by map entry M that lies between ypos HI and LO") (COND ((AND M (OVERLAP HI LO (HIPT M) (LOWPT M))) (COND [(LISTP (fetch SELEXP of M)) (LET ((WRAP (fetch WRAPPER of M))) (COND ([IGREATERP HI (IDIFFERENCE (fetch STARTY of M) (FONTPROP (fetch FNT of M) 'DESCENT] (MOVETO (fetch STARTX of M) (fetch STARTY of M) DS) (DSPFONT (fetch FNT of M) DS) (PRIN3 (OR WRAP '%() DS))) (COND (WRAP (REFRESHIF1 (GETME4 (CDR (fetch SELEXP of M)) M) DS HI LO)) (T [for I on (fetch SELEXP of M) do (REFRESHIF1 (GETME4 I M) DS HI LO) finally (COND (I (SETQ I (GETME4 I M)) (MOVETO (IDIFFERENCE (fetch STARTX of I) (STRINGWIDTH DOTSTRING (fetch FNT of M))) (fetch STARTY of I) DS) (PRIN3 DOTSTRING DS) (* ; "Dotted pair") (REFRESHIF1 I DS HI LO] (COND ([ILEQ LO (IPLUS (fetch STOPY of M) (FONTPROP (fetch FNT of M) 'ASCENT] (MOVETO (fetch RPSTART of M) (fetch STOPY of M) DS) (DSPFONT (fetch FNT of M) DS) (PRIN3 '%) DS] (T (MOVETO (fetch STARTX of M) (fetch STARTY of M) DS) (DSPFONT (fetch FNT of M) DS) (COND ((fetch LONGSTRINGP of M) (LET* ((COMMENTP (NULL (fetch LONGSTRING1MARGINP of M))) [LMARG (fetch STARTX of (COND (COMMENTP (* ; "Inside a comment, the string may be printed with a margin to the left of where the string starts") (fetch BP of M)) (T M] (RMARG (WINDOWPROP DS 'WIDTH)) MAKEMAP) (DECLARE (SPECVARS MAKEMAP)) (PRIN2-LONG-STRING (fetch SELEXP of M) DS T T LMARG (COND ((fetch LONGSTRINGSYMMETRICP of M) (* ; "String symmetrically centered") (IDIFFERENCE RMARG LMARG)) (T RMARG)) COMMENTP))) (T (PRIN4 (fetch SELEXP of M) DS]) ) (DEFINEQ (COMMENTP [LAMBDA (E) (* bas%: "15-NOV-82 22:01") (AND COMMENTFLG (EQ COMMENTFLG (CAR (LISTP E]) (HIPT [LAMBDA (ENT) (* bas%: " 4-OCT-82 15:25") (IPLUS (fetch STARTY of ENT) (FONTPROP (fetch FNT of ENT) 'ASCENT) -1]) (LOWPT [LAMBDA (E) (* bas%: " 4-OCT-82 15:25") (IDIFFERENCE (fetch STOPY of E) (FONTPROP (fetch FNT of E) 'DESCENT]) (WIPE [LAMBDA (X Y W H DS) (* bas%: "19-AUG-82 15:18") (BITBLT NIL NIL NIL DS X Y W H 'TEXTURE 'REPLACE (DSPTEXTURE NIL DS]) ) (DEFINEQ (RESETCLIP [LAMBDA (C) (* bas%: " 8-NOV-82 15:35") (* ;; "For use in RESETFORM. Takes a CONS of a DSP and its new region") (CONS (CAR C) (DSPCLIPPINGREGION (CDR C) (CAR C]) ) (PUTPROPS DEDITPP COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1991 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2753 8377 (DEDIT.LPEND 2763 . 3366) (DEDIT.RPSTART 3368 . 3871) (MAKEMAPENTRY 3873 . 4570) (\DEDITFONT# 4572 . 6112) (DSPDSFOR 6114 . 6790) (SHOWDEDITMAP 6792 . 8375)) (8510 11586 ( DEPRINTDEF 8520 . 11096) (DEDIT-MAKE-READER-ENV 11098 . 11584)) (11587 27175 (REPP 11597 . 12870) ( REPPCHANGES 12872 . 15191) (REPPUNRAVEL 15193 . 16182) (REPPDELETE 16184 . 18154) (REPPINSERT 18156 . 20905) (REPPTANGLEDP 20907 . 21866) (LEADSPACE 21868 . 22254) (SPACINGRULE 22256 . 22876) (UNPP 22878 . 25573) (NXTUSEDX 25575 . 26993) (ONELINEP 26995 . 27173)) (27176 36302 (MOVEDSMAP 27186 . 31748) ( ADJUSTXTAIL 31750 . 33664) (ADJUSTYTAIL 33666 . 34482) (ADJDEEXTENT 34484 . 34808) (DSLINEFONT 34810 . 35219) (DSLINEFONT1 35221 . 35907) (MAXFONT 35909 . 36300)) (36303 41216 (REFRESHIF 36313 . 37176) (REFRESHIF1 37178 . 41214)) (41217 42008 (COMMENTP 41227 . 41380) (HIPT 41382 . 41612) (LOWPT 41614 . 41832) (WIPE 41834 . 42006)) (42009 42376 (RESETCLIP 42019 . 42374))))) STOP \ No newline at end of file diff --git a/library/DES b/library/DES new file mode 100644 index 00000000..6d4a4744 --- /dev/null +++ b/library/DES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "11-Jun-90 15:00:11" {DSK}local>lde>lispcore>library>DES.;2 33092 changes to%: (VARS DESCOMS) previous date%: "24-Jul-87 18:29:27" {DSK}local>lde>lispcore>library>DES.;1) (* ; " Copyright (c) 1985, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DESCOMS) (RPAQQ DESCOMS ((COMS (* ; "Entry points") (FNS DES.BREAKOUT.BLOCKS DES.MAKE.BLOCKS DES.ECB.ENCRYPT DES.ECB.DECRYPT DES.CBC.ENCRYPT DES.CBC.DECRYPT DES.CBCC.ENCRYPT DES.CBCC.DECRYPT DES.PASSWORD.TO.KEY DES.MAKE.KEY)) (COMS (* ; "Implementation") (FNS DES.CORRECT.KEY.PARITY DES.CRYPT.BLOCK DES.KEY.COPY DES.KEY.EQUAL DES.LOOPBODY DES.MAKE.INTERNAL.KEYS DES.PERM.E DES.PERM.INITIAL DES.PERM.INV.INITIAL DES.PERM.P DES.PERM.PC1 DES.PERM.PC2 DES.REC32.LS28 DES.SMAP REC32.XOR REC48.XOR REC64.XOR REC64.XOR.CHK)) (VARS DES.PARITY.TABLE DES.SBOX.1 DES.SBOX.2 DES.SBOX.3 DES.SBOX.4 DES.SBOX.5 DES.SBOX.6 DES.SBOX.7 DES.SBOX.8 DES.SHIFTS (DESKEYSLST)) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS DES.REC.E1 DES.REC.E2 DES.REC32.4 DES.REC32.LS28.IN DES.REC32.LS28.OUT DES.REC48.6 DESBLOCK DESKEY DESKEY.P REC32 REC32.W REC48 REC48.W REC64 REC64.W) ))) (* ; "Entry points") (DEFINEQ (DES.BREAKOUT.BLOCKS (LAMBDA (L) (* ; "Edited 22-May-87 15:30 by bvm:") (* ;; "Converts a list of DES 64-bit blocks into a %"sequence unspecified%" for courier.") (for E in L join (LIST (fetch (DESBLOCK W1) of E) (fetch (DESBLOCK W2) of E) (fetch (DESBLOCK W3) of E) (fetch (DESBLOCK W4) of E)))) ) (DES.MAKE.BLOCKS (LAMBDA (L) (* ; "Edited 24-Jul-87 18:28 by bvm:") (* ;; "Convert L, a courier %"sequence unspecified%" into a list of DES 64-bit blocks, padded on the right if needed by zeros.") (if NIL then (for K on L by (CDDDDR K) collect (create DESBLOCK W1 _ (CAR K) W2 _ (COND ((CADR K)) (0)) W3 _ (COND ((CADDR K)) (0)) W4 _ (COND ((CADDDR K)) (0))))) (while L collect (LET ((B (create DESBLOCK))) (* ; "Blocks are initialized by allocator to zero.") (\PUTBASE B 0 (CAR L)) (if (SETQ L (CDR L)) then (\PUTBASE B 1 (CAR L)) (if (SETQ L (CDR L)) then (\PUTBASE B 2 (CAR L)) (if (SETQ L (CDR L)) then (\PUTBASE B 3 (CAR L)) (SETQ L (CDR L))))) B))) ) (DES.ECB.ENCRYPT (LAMBDA (KEY DAT) (* jwo%: "25-Jun-85 12:24") (LET ((IKLST (DES.MAKE.INTERNAL.KEYS KEY))) (DES.CRYPT.BLOCK IKLST DAT (QUOTE ENCRYPT)))) ) (DES.ECB.DECRYPT (LAMBDA (KEY DAT) (* jwo%: "25-Jun-85 12:24") (LET ((IKLST (DES.MAKE.INTERNAL.KEYS KEY))) (DES.CRYPT.BLOCK IKLST DAT (QUOTE DECRYPT)))) ) (DES.CBC.ENCRYPT (LAMBDA (L) (* jwo%: " 3-Jul-85 17:11") (ERROR "Not Implemented!"))) (DES.CBC.DECRYPT (LAMBDA (KEY L N) (* jwo%: " 8-Aug-85 23:36") (LET ((IKLST (DES.MAKE.INTERNAL.KEYS KEY))) (CONS (DES.CRYPT.BLOCK IKLST (CAR L) (QUOTE DECRYPT)) (COND ((IGREATERP N 1) (DREVERSE (for I from N to 2 by -1 collect (REC64.XOR (CAR (NTH L (SUB1 I))) (DES.CRYPT.BLOCK IKLST (CAR (NTH L I)) (QUOTE DECRYPT)))))) (T NIL))))) ) (DES.CBCC.ENCRYPT (LAMBDA (L) (* jwo%: " 9-Aug-85 01:04") (* ;;; "Note: I'm not bothering with this one right now because I don't think anybody needs it to do Strong Authentication.") (ERROR "Not Implemented!")) ) (DES.CBCC.DECRYPT (LAMBDA (KEY L N) (* jwo%: " 8-Aug-85 22:49") (COND ((NULL N) (SETQ N (LENGTH L)))) (LET ((PL (DES.CBC.DECRYPT KEY L (SUB1 N)))) (NCONC1 PL (REC64.XOR (CAR (NTH L (SUB1 N))) (REC64.XOR (REC64.XOR.CHK PL (SUB1 N)) (DES.CRYPT.BLOCK (DES.MAKE.INTERNAL.KEYS KEY) (CAR (NTH L N)) (QUOTE DECRYPT))))))) ) (DES.PASSWORD.TO.KEY (LAMBDA (PASSWORD) (* jwo%: " 8-Aug-85 23:54") (* ;; "Algorithm documented on page 27 of XSIS Authentication Protocol specification.") (bind (NEWKEY _ (DES.MAKE.KEY)) (STR _ (CONCAT PASSWORD)) (BLOCK _ (create DESBLOCK)) until (STREQUAL STR "") do (PROGN (replace (DESBLOCK W1) of BLOCK with (LET ((CHAR (GNC STR))) (COND (CHAR (L-CASECODE (\DECRYPT.PWD.CHAR (CHCON1 CHAR)))) (T 0)))) (replace (DESBLOCK W2) of BLOCK with (LET ((CHAR (GNC STR))) (COND (CHAR (L-CASECODE (\DECRYPT.PWD.CHAR (CHCON1 CHAR)))) (T 0)))) (replace (DESBLOCK W3) of BLOCK with (LET ((CHAR (GNC STR))) (COND (CHAR (L-CASECODE (\DECRYPT.PWD.CHAR (CHCON1 CHAR)))) (T 0)))) (replace (DESBLOCK W4) of BLOCK with (LET ((CHAR (GNC STR))) (COND (CHAR (L-CASECODE (\DECRYPT.PWD.CHAR (CHCON1 CHAR)))) (T 0)))) (SETQ NEWKEY (DES.ECB.ENCRYPT NEWKEY BLOCK))) finally (RETURN (DES.CORRECT.KEY.PARITY NEWKEY)))) ) (DES.MAKE.KEY (LAMBDA (L) (* jwo%: " 8-Aug-85 22:18") (create DESBLOCK W1 _ (COND ((CAR L)) (0)) W2 _ (COND ((CADR L)) (0)) W3 _ (COND ((CADDR L)) (0)) W4 _ (COND ((CADDDR L)) (0)))) ) ) (* ; "Implementation") (DEFINEQ (DES.CORRECT.KEY.PARITY (LAMBDA (KEY) (* jwo%: " 3-Jul-85 16:52") (replace (DESKEY.P P1) of KEY with (ELT DES.PARITY.TABLE (fetch (DESKEY.P B1) of KEY))) (replace (DESKEY.P P2) of KEY with (ELT DES.PARITY.TABLE (fetch (DESKEY.P B2) of KEY))) (replace (DESKEY.P P3) of KEY with (ELT DES.PARITY.TABLE (fetch (DESKEY.P B3) of KEY))) (replace (DESKEY.P P4) of KEY with (ELT DES.PARITY.TABLE (fetch (DESKEY.P B4) of KEY))) (replace (DESKEY.P P5) of KEY with (ELT DES.PARITY.TABLE (fetch (DESKEY.P B5) of KEY))) (replace (DESKEY.P P6) of KEY with (ELT DES.PARITY.TABLE (fetch (DESKEY.P B6) of KEY))) (replace (DESKEY.P P7) of KEY with (ELT DES.PARITY.TABLE (fetch (DESKEY.P B7) of KEY))) (replace (DESKEY.P P8) of KEY with (ELT DES.PARITY.TABLE (fetch (DESKEY.P B8) of KEY))) KEY) ) (DES.CRYPT.BLOCK (LAMBDA (KLST DAT DIRECTION) (* jwo%: "29-Jun-85 21:28") (LET ((LR (DES.PERM.INITIAL DAT))) (if (EQ DIRECTION (QUOTE ENCRYPT)) then (for I from 1 to 16 do (SETQ LR (DES.LOOPBODY (CAR LR) (CDR LR) (CAR (NTH KLST I))))) else (for I from 16 to 1 do (SETQ LR (DES.LOOPBODY (CAR LR) (CDR LR) (CAR (NTH KLST I)))))) (DES.PERM.INV.INITIAL (CDR LR) (CAR LR)))) ) (DES.KEY.COPY (LAMBDA (K) (* jwo%: " 6-Jul-85 15:26") (create DESKEY W1 _ (fetch (DESKEY W1) of K) W2 _ (fetch (DESKEY W2) of K) W3 _ (fetch (DESKEY W3) of K) W4 _ (fetch (DESKEY W4) of K))) ) (DES.KEY.EQUAL (LAMBDA (X Y) (* jwo%: " 6-Jul-85 15:16") (AND (EQ (fetch (DESKEY W1) of X) (fetch (DESKEY W1) of Y)) (EQ (fetch (DESKEY W2) of X) (fetch (DESKEY W2) of Y)) (EQ (fetch (DESKEY W3) of X) (fetch (DESKEY W3) of Y)) (EQ (fetch (DESKEY W4) of X) (fetch (DESKEY W4) of Y)))) ) (DES.LOOPBODY (LAMBDA (L R K) (* jwo%: "22-Jun-85 21:34") (CONS R (REC32.XOR L (DES.PERM.P (DES.SMAP (REC48.XOR (DES.PERM.E R) K)))))) ) (DES.MAKE.INTERNAL.KEYS (LAMBDA (K) (* ; "Edited 22-May-87 15:49 by bvm:") (* ;; "Returns the %"key schedule%" for key K, a list of 16 48-bit numbers.") (* ;; "The last FOR loop is the actual internal key construction algorithm. The goop wrapped around it variously checks if this key is already first on the DESKEYSLST cache, is later on DESKEYSLST (in which case it does move-to-front), or attaches the newly constructed keys to the front of DESKEYSLST. We should restrict the length of DESKEYSLST so that the cache doesn't grow indefinitely...") (if (NOT (AND DESKEYSLST (DES.KEY.EQUAL (CAAR DESKEYSLST) K))) then (for TL on DESKEYSLST while (CDR TL) when (DES.KEY.EQUAL (CAADR TL) K) do (RETURN (LET ((TEMP (CDR TL))) (* ; "Promote this entry to the front") (RPLACD TL (CDR TEMP)) (RPLACD TEMP DESKEYSLST) (SETQ DESKEYSLST TEMP))) finally (* ; "Compute afresh") (push DESKEYSLST (CONS (DES.KEY.COPY K) (LET* ((CD (DES.PERM.PC1 K)) (C (CAR CD)) (D (CDR CD))) (* ;; "C & D are 28-bit quantities, a permutation of 56 of the bits of K. Cycle the pieces. Total shift over this whole loop is 28 bits.") (for I from 1 to 16 collect (PROGN (for J from 1 to (ELT DES.SHIFTS I) do (SETQ C (DES.REC32.LS28 C)) (SETQ D (DES.REC32.LS28 D))) (DES.PERM.PC2 C D)))))))) (CDAR DESKEYSLST)) ) (DES.PERM.E (LAMBDA (X) (* jwo%: "21-Jun-85 17:40") (create DES.REC48.6 S1 _ (IPLUS (ITIMES 32 (fetch (REC32 BIT32) of X)) (fetch (DES.REC.E1 B1.5) of X)) S2 _ (fetch (DES.REC.E2 B4.9) of X) S3.1 _ (fetch (DES.REC.E1 B8.11) of X) S3.2 _ (fetch (DES.REC.E1 B12.13) of X) S4 _ (IPLUS (ITIMES 2 (fetch (DES.REC.E2 B12.16) of X)) (fetch (REC32 BIT17) of X)) S5 _ (IPLUS (ITIMES 32 (fetch (REC32 BIT16) of X)) (fetch (DES.REC.E2 B17.21) of X)) S6.1 _ (fetch (DES.REC.E1 B20.21) of X) S6.2 _ (fetch (DES.REC.E1 B22.25) of X) S7 _ (fetch (DES.REC.E2 B24.29) of X) S8 _ (IPLUS (ITIMES 2 (fetch (DES.REC.E1 B28.32) of X)) (fetch (REC32 BIT1) of X)))) ) (DES.PERM.INITIAL (LAMBDA (X) (* jwo%: "21-Jun-85 16:40") (CONS (create REC32 BIT1 _ (fetch (REC64 BIT58) of X) BIT2 _ (fetch (REC64 BIT50) of X) BIT3 _ (fetch (REC64 BIT42) of X) BIT4 _ (fetch (REC64 BIT34) of X) BIT5 _ (fetch (REC64 BIT26) of X) BIT6 _ (fetch (REC64 BIT18) of X) BIT7 _ (fetch (REC64 BIT10) of X) BIT8 _ (fetch (REC64 BIT2) of X) BIT9 _ (fetch (REC64 BIT60) of X) BIT10 _ (fetch (REC64 BIT52) of X) BIT11 _ (fetch (REC64 BIT44) of X) BIT12 _ (fetch (REC64 BIT36) of X) BIT13 _ (fetch (REC64 BIT28) of X) BIT14 _ (fetch (REC64 BIT20) of X) BIT15 _ (fetch (REC64 BIT12) of X) BIT16 _ (fetch (REC64 BIT4) of X) BIT17 _ (fetch (REC64 BIT62) of X) BIT18 _ (fetch (REC64 BIT54) of X) BIT19 _ (fetch (REC64 BIT46) of X) BIT20 _ (fetch (REC64 BIT38) of X) BIT21 _ (fetch (REC64 BIT30) of X) BIT22 _ (fetch (REC64 BIT22) of X) BIT23 _ (fetch (REC64 BIT14) of X) BIT24 _ (fetch (REC64 BIT6) of X) BIT25 _ (fetch (REC64 BIT64) of X) BIT26 _ (fetch (REC64 BIT56) of X) BIT27 _ (fetch (REC64 BIT48) of X) BIT28 _ (fetch (REC64 BIT40) of X) BIT29 _ (fetch (REC64 BIT32) of X) BIT30 _ (fetch (REC64 BIT24) of X) BIT31 _ (fetch (REC64 BIT16) of X) BIT32 _ (fetch (REC64 BIT8) of X)) (create REC32 BIT1 _ (fetch (REC64 BIT57) of X) BIT2 _ (fetch (REC64 BIT49) of X) BIT3 _ (fetch (REC64 BIT41) of X) BIT4 _ (fetch (REC64 BIT33) of X) BIT5 _ (fetch (REC64 BIT25) of X) BIT6 _ (fetch (REC64 BIT17) of X) BIT7 _ (fetch (REC64 BIT9) of X) BIT8 _ (fetch (REC64 BIT1) of X) BIT9 _ (fetch (REC64 BIT59) of X) BIT10 _ (fetch (REC64 BIT51) of X) BIT11 _ (fetch (REC64 BIT43) of X) BIT12 _ (fetch (REC64 BIT35) of X) BIT13 _ (fetch (REC64 BIT27) of X) BIT14 _ (fetch (REC64 BIT19) of X) BIT15 _ (fetch (REC64 BIT11) of X) BIT16 _ (fetch (REC64 BIT3) of X) BIT17 _ (fetch (REC64 BIT61) of X) BIT18 _ (fetch (REC64 BIT53) of X) BIT19 _ (fetch (REC64 BIT45) of X) BIT20 _ (fetch (REC64 BIT37) of X) BIT21 _ (fetch (REC64 BIT29) of X) BIT22 _ (fetch (REC64 BIT21) of X) BIT23 _ (fetch (REC64 BIT13) of X) BIT24 _ (fetch (REC64 BIT5) of X) BIT25 _ (fetch (REC64 BIT63) of X) BIT26 _ (fetch (REC64 BIT55) of X) BIT27 _ (fetch (REC64 BIT47) of X) BIT28 _ (fetch (REC64 BIT39) of X) BIT29 _ (fetch (REC64 BIT31) of X) BIT30 _ (fetch (REC64 BIT23) of X) BIT31 _ (fetch (REC64 BIT15) of X) BIT32 _ (fetch (REC64 BIT7) of X)))) ) (DES.PERM.INV.INITIAL (LAMBDA (L R) (* jwo%: "24-Jun-85 23:27") (create REC64 BIT58 _ (fetch (REC32 BIT1) of L) BIT50 _ (fetch (REC32 BIT2) of L) BIT42 _ (fetch (REC32 BIT3) of L) BIT34 _ (fetch (REC32 BIT4) of L) BIT26 _ (fetch (REC32 BIT5) of L) BIT18 _ (fetch (REC32 BIT6) of L) BIT10 _ (fetch (REC32 BIT7) of L) BIT2 _ (fetch (REC32 BIT8) of L) BIT60 _ (fetch (REC32 BIT9) of L) BIT52 _ (fetch (REC32 BIT10) of L) BIT44 _ (fetch (REC32 BIT11) of L) BIT36 _ (fetch (REC32 BIT12) of L) BIT28 _ (fetch (REC32 BIT13) of L) BIT20 _ (fetch (REC32 BIT14) of L) BIT12 _ (fetch (REC32 BIT15) of L) BIT4 _ (fetch (REC32 BIT16) of L) BIT62 _ (fetch (REC32 BIT17) of L) BIT54 _ (fetch (REC32 BIT18) of L) BIT46 _ (fetch (REC32 BIT19) of L) BIT38 _ (fetch (REC32 BIT20) of L) BIT30 _ (fetch (REC32 BIT21) of L) BIT22 _ (fetch (REC32 BIT22) of L) BIT14 _ (fetch (REC32 BIT23) of L) BIT6 _ (fetch (REC32 BIT24) of L) BIT64 _ (fetch (REC32 BIT25) of L) BIT56 _ (fetch (REC32 BIT26) of L) BIT48 _ (fetch (REC32 BIT27) of L) BIT40 _ (fetch (REC32 BIT28) of L) BIT32 _ (fetch (REC32 BIT29) of L) BIT24 _ (fetch (REC32 BIT30) of L) BIT16 _ (fetch (REC32 BIT31) of L) BIT8 _ (fetch (REC32 BIT32) of L) BIT57 _ (fetch (REC32 BIT1) of R) BIT49 _ (fetch (REC32 BIT2) of R) BIT41 _ (fetch (REC32 BIT3) of R) BIT33 _ (fetch (REC32 BIT4) of R) BIT25 _ (fetch (REC32 BIT5) of R) BIT17 _ (fetch (REC32 BIT6) of R) BIT9 _ (fetch (REC32 BIT7) of R) BIT1 _ (fetch (REC32 BIT8) of R) BIT59 _ (fetch (REC32 BIT9) of R) BIT51 _ (fetch (REC32 BIT10) of R) BIT43 _ (fetch (REC32 BIT11) of R) BIT35 _ (fetch (REC32 BIT12) of R) BIT27 _ (fetch (REC32 BIT13) of R) BIT19 _ (fetch (REC32 BIT14) of R) BIT11 _ (fetch (REC32 BIT15) of R) BIT3 _ (fetch (REC32 BIT16) of R) BIT61 _ (fetch (REC32 BIT17) of R) BIT53 _ (fetch (REC32 BIT18) of R) BIT45 _ (fetch (REC32 BIT19) of R) BIT37 _ (fetch (REC32 BIT20) of R) BIT29 _ (fetch (REC32 BIT21) of R) BIT21 _ (fetch (REC32 BIT22) of R) BIT13 _ (fetch (REC32 BIT23) of R) BIT5 _ (fetch (REC32 BIT24) of R) BIT63 _ (fetch (REC32 BIT25) of R) BIT55 _ (fetch (REC32 BIT26) of R) BIT47 _ (fetch (REC32 BIT27) of R) BIT39 _ (fetch (REC32 BIT28) of R) BIT31 _ (fetch (REC32 BIT29) of R) BIT23 _ (fetch (REC32 BIT30) of R) BIT15 _ (fetch (REC32 BIT31) of R) BIT7 _ (fetch (REC32 BIT32) of R))) ) (DES.PERM.P (LAMBDA (X) (* jwo%: "21-Jun-85 22:45") (create REC32 BIT1 _ (fetch (REC32 BIT16) of X) BIT2 _ (fetch (REC32 BIT7) of X) BIT3 _ (fetch (REC32 BIT20) of X) BIT4 _ (fetch (REC32 BIT21) of X) BIT5 _ (fetch (REC32 BIT29) of X) BIT6 _ (fetch (REC32 BIT12) of X) BIT7 _ (fetch (REC32 BIT28) of X) BIT8 _ (fetch (REC32 BIT17) of X) BIT9 _ (fetch (REC32 BIT1) of X) BIT10 _ (fetch (REC32 BIT15) of X) BIT11 _ (fetch (REC32 BIT23) of X) BIT12 _ (fetch (REC32 BIT26) of X) BIT13 _ (fetch (REC32 BIT5) of X) BIT14 _ (fetch (REC32 BIT18) of X) BIT15 _ (fetch (REC32 BIT31) of X) BIT16 _ (fetch (REC32 BIT10) of X) BIT17 _ (fetch (REC32 BIT2) of X) BIT18 _ (fetch (REC32 BIT8) of X) BIT19 _ (fetch (REC32 BIT24) of X) BIT20 _ (fetch (REC32 BIT14) of X) BIT21 _ (fetch (REC32 BIT32) of X) BIT22 _ (fetch (REC32 BIT27) of X) BIT23 _ (fetch (REC32 BIT3) of X) BIT24 _ (fetch (REC32 BIT9) of X) BIT25 _ (fetch (REC32 BIT19) of X) BIT26 _ (fetch (REC32 BIT13) of X) BIT27 _ (fetch (REC32 BIT30) of X) BIT28 _ (fetch (REC32 BIT6) of X) BIT29 _ (fetch (REC32 BIT22) of X) BIT30 _ (fetch (REC32 BIT11) of X) BIT31 _ (fetch (REC32 BIT4) of X) BIT32 _ (fetch (REC32 BIT25) of X))) ) (DES.PERM.PC1 (LAMBDA (X) (* jwo%: "22-Jun-85 20:51") (CONS (create REC32 BIT1 _ (fetch (REC64 BIT57) of X) BIT2 _ (fetch (REC64 BIT49) of X) BIT3 _ (fetch (REC64 BIT41) of X) BIT4 _ (fetch (REC64 BIT33) of X) BIT5 _ (fetch (REC64 BIT25) of X) BIT6 _ (fetch (REC64 BIT17) of X) BIT7 _ (fetch (REC64 BIT9) of X) BIT8 _ (fetch (REC64 BIT1) of X) BIT9 _ (fetch (REC64 BIT58) of X) BIT10 _ (fetch (REC64 BIT50) of X) BIT11 _ (fetch (REC64 BIT42) of X) BIT12 _ (fetch (REC64 BIT34) of X) BIT13 _ (fetch (REC64 BIT26) of X) BIT14 _ (fetch (REC64 BIT18) of X) BIT15 _ (fetch (REC64 BIT10) of X) BIT16 _ (fetch (REC64 BIT2) of X) BIT17 _ (fetch (REC64 BIT59) of X) BIT18 _ (fetch (REC64 BIT51) of X) BIT19 _ (fetch (REC64 BIT43) of X) BIT20 _ (fetch (REC64 BIT35) of X) BIT21 _ (fetch (REC64 BIT27) of X) BIT22 _ (fetch (REC64 BIT19) of X) BIT23 _ (fetch (REC64 BIT11) of X) BIT24 _ (fetch (REC64 BIT3) of X) BIT25 _ (fetch (REC64 BIT60) of X) BIT26 _ (fetch (REC64 BIT52) of X) BIT27 _ (fetch (REC64 BIT44) of X) BIT28 _ (fetch (REC64 BIT36) of X)) (create REC32 BIT1 _ (fetch (REC64 BIT63) of X) BIT2 _ (fetch (REC64 BIT55) of X) BIT3 _ (fetch (REC64 BIT47) of X) BIT4 _ (fetch (REC64 BIT39) of X) BIT5 _ (fetch (REC64 BIT31) of X) BIT6 _ (fetch (REC64 BIT23) of X) BIT7 _ (fetch (REC64 BIT15) of X) BIT8 _ (fetch (REC64 BIT7) of X) BIT9 _ (fetch (REC64 BIT62) of X) BIT10 _ (fetch (REC64 BIT54) of X) BIT11 _ (fetch (REC64 BIT46) of X) BIT12 _ (fetch (REC64 BIT38) of X) BIT13 _ (fetch (REC64 BIT30) of X) BIT14 _ (fetch (REC64 BIT22) of X) BIT15 _ (fetch (REC64 BIT14) of X) BIT16 _ (fetch (REC64 BIT6) of X) BIT17 _ (fetch (REC64 BIT61) of X) BIT18 _ (fetch (REC64 BIT53) of X) BIT19 _ (fetch (REC64 BIT45) of X) BIT20 _ (fetch (REC64 BIT37) of X) BIT21 _ (fetch (REC64 BIT29) of X) BIT22 _ (fetch (REC64 BIT21) of X) BIT23 _ (fetch (REC64 BIT13) of X) BIT24 _ (fetch (REC64 BIT5) of X) BIT25 _ (fetch (REC64 BIT28) of X) BIT26 _ (fetch (REC64 BIT20) of X) BIT27 _ (fetch (REC64 BIT12) of X) BIT28 _ (fetch (REC64 BIT4) of X)))) ) (DES.PERM.PC2 (LAMBDA (C D) (* jwo%: "25-Jun-85 14:34") (create REC48 BIT1 _ (fetch (REC32 BIT14) of C) BIT2 _ (fetch (REC32 BIT17) of C) BIT3 _ (fetch (REC32 BIT11) of C) BIT4 _ (fetch (REC32 BIT24) of C) BIT5 _ (fetch (REC32 BIT1) of C) BIT6 _ (fetch (REC32 BIT5) of C) BIT7 _ (fetch (REC32 BIT3) of C) BIT8 _ (fetch (REC32 BIT28) of C) BIT9 _ (fetch (REC32 BIT15) of C) BIT10 _ (fetch (REC32 BIT6) of C) BIT11 _ (fetch (REC32 BIT21) of C) BIT12 _ (fetch (REC32 BIT10) of C) BIT13 _ (fetch (REC32 BIT23) of C) BIT14 _ (fetch (REC32 BIT19) of C) BIT15 _ (fetch (REC32 BIT12) of C) BIT16 _ (fetch (REC32 BIT4) of C) BIT17 _ (fetch (REC32 BIT26) of C) BIT18 _ (fetch (REC32 BIT8) of C) BIT19 _ (fetch (REC32 BIT16) of C) BIT20 _ (fetch (REC32 BIT7) of C) BIT21 _ (fetch (REC32 BIT27) of C) BIT22 _ (fetch (REC32 BIT20) of C) BIT23 _ (fetch (REC32 BIT13) of C) BIT24 _ (fetch (REC32 BIT2) of C) BIT25 _ (fetch (REC32 BIT13) of D) BIT26 _ (fetch (REC32 BIT24) of D) BIT27 _ (fetch (REC32 BIT3) of D) BIT28 _ (fetch (REC32 BIT9) of D) BIT29 _ (fetch (REC32 BIT19) of D) BIT30 _ (fetch (REC32 BIT27) of D) BIT31 _ (fetch (REC32 BIT2) of D) BIT32 _ (fetch (REC32 BIT12) of D) BIT33 _ (fetch (REC32 BIT23) of D) BIT34 _ (fetch (REC32 BIT17) of D) BIT35 _ (fetch (REC32 BIT5) of D) BIT36 _ (fetch (REC32 BIT20) of D) BIT37 _ (fetch (REC32 BIT16) of D) BIT38 _ (fetch (REC32 BIT21) of D) BIT39 _ (fetch (REC32 BIT11) of D) BIT40 _ (fetch (REC32 BIT28) of D) BIT41 _ (fetch (REC32 BIT6) of D) BIT42 _ (fetch (REC32 BIT25) of D) BIT43 _ (fetch (REC32 BIT18) of D) BIT44 _ (fetch (REC32 BIT14) of D) BIT45 _ (fetch (REC32 BIT22) of D) BIT46 _ (fetch (REC32 BIT8) of D) BIT47 _ (fetch (REC32 BIT1) of D) BIT48 _ (fetch (REC32 BIT4) of D))) ) (DES.REC32.LS28 (LAMBDA (X) (* ; "Edited 20-May-87 17:20 by bvm:") (* ;; "X points at a two-word block. Rotate bits 0-27 left one bit (low 4 bits unchanged).") (create DES.REC32.LS28.OUT B1.15 _ (fetch (DES.REC32.LS28.IN B2.16) of X) B16 _ (fetch (DES.REC32.LS28.IN B17) of X) B17.27 _ (fetch (DES.REC32.LS28.IN B18.28) of X) B28 _ (fetch (DES.REC32.LS28.IN B1) of X))) ) (DES.SMAP (LAMBDA (X) (* jwo%: "21-Jun-85 23:06") (create DES.REC32.4 NIB1 _ (ELT DES.SBOX.1 (fetch (DES.REC48.6 S1) of X)) NIB2 _ (ELT DES.SBOX.2 (fetch (DES.REC48.6 S2) of X)) NIB3 _ (ELT DES.SBOX.3 (IPLUS (ITIMES 4 (fetch (DES.REC48.6 S3.1) of X)) (fetch (DES.REC48.6 S3.2) of X))) NIB4 _ (ELT DES.SBOX.4 (fetch (DES.REC48.6 S4) of X)) NIB5 _ (ELT DES.SBOX.5 (fetch (DES.REC48.6 S5) of X)) NIB6 _ (ELT DES.SBOX.6 (IPLUS (ITIMES 16 (fetch (DES.REC48.6 S6.1) of X)) (fetch (DES.REC48.6 S6.2) of X))) NIB7 _ (ELT DES.SBOX.7 (fetch (DES.REC48.6 S7) of X)) NIB8 _ (ELT DES.SBOX.8 (fetch (DES.REC48.6 S8) of X)))) ) (REC32.XOR (LAMBDA (X Y) (* jwo%: "24-Jun-85 17:42") (create REC32.W WORD1 _ (LOGXOR (fetch (REC32.W WORD1) of X) (fetch (REC32.W WORD1) of Y)) WORD2 _ (LOGXOR (fetch (REC32.W WORD2) of X) (fetch (REC32.W WORD2) of Y)))) ) (REC48.XOR (LAMBDA (X Y) (* jwo%: "24-Jun-85 17:50") (create REC48.W WORD1 _ (LOGXOR (fetch (REC48.W WORD1) of X) (fetch (REC48.W WORD1) of Y)) WORD2 _ (LOGXOR (fetch (REC48.W WORD2) of X) (fetch (REC48.W WORD2) of Y)) WORD3 _ (LOGXOR (fetch (REC48.W WORD3) of X) (fetch (REC48.W WORD3) of Y)))) ) (REC64.XOR (LAMBDA (X Y) (* jwo%: " 3-Jul-85 17:27") (create REC64.W WORD1 _ (LOGXOR (fetch (REC64.W WORD1) of X) (fetch (REC64.W WORD1) of Y)) WORD2 _ (LOGXOR (fetch (REC64.W WORD2) of X) (fetch (REC64.W WORD2) of Y)) WORD3 _ (LOGXOR (fetch (REC64.W WORD3) of X) (fetch (REC64.W WORD3) of Y)) WORD4 _ (LOGXOR (fetch (REC64.W WORD4) of X) (fetch (REC64.W WORD4) of Y)))) ) (REC64.XOR.CHK (LAMBDA (L N) (* jwo%: " 9-Aug-85 00:58") (LET ((BLK (create REC64.W WORD1 _ 0 WORD2 _ 0 WORD3 _ 0 WORD4 _ 0))) (for I from 1 to N do (PROGN (replace (REC64.W WORD1) of BLK with (LOGXOR (fetch (REC64.W WORD1) of BLK) (fetch (REC64.W WORD1) of (CAR (NTH L I))))) (replace (REC64.W WORD2) of BLK with (LOGXOR (fetch (REC64.W WORD2) of BLK) (fetch (REC64.W WORD2) of (CAR (NTH L I))))) (replace (REC64.W WORD3) of BLK with (LOGXOR (fetch (REC64.W WORD3) of BLK) (fetch (REC64.W WORD3) of (CAR (NTH L I))))) (replace (REC64.W WORD4) of BLK with (LOGXOR (fetch (REC64.W WORD4) of BLK) (fetch (REC64.W WORD4) of (CAR (NTH L I))))))) BLK)) ) ) (RPAQ DES.PARITY.TABLE (READARRAY-FROM-LIST 128 (QUOTE BIT) 0 (QUOTE (1 0 0 1 0 1 1 0 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 1 0 0 1 0 1 1 0 0 1 1 0 1 0 0 1 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 0 1 1 0 1 0 0 1 1 0 0 1 0 1 1 0 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 1 0 0 1 0 1 1 0 NIL)))) (RPAQ DES.SBOX.1 (READARRAY-FROM-LIST 64 (QUOTE BYTE) 0 (QUOTE (14 0 4 15 13 7 1 4 2 14 15 2 11 13 8 1 3 10 10 6 6 12 12 11 5 9 9 5 0 3 7 8 4 15 1 12 14 8 8 2 13 4 6 9 2 1 11 7 15 5 12 11 9 3 7 14 3 10 10 0 5 6 0 13 NIL)))) (RPAQ DES.SBOX.2 (READARRAY-FROM-LIST 64 (QUOTE BYTE) 0 (QUOTE (15 3 1 13 8 4 14 7 6 15 11 2 3 8 4 14 9 12 7 0 2 1 13 10 12 6 0 9 5 11 10 5 0 13 14 8 7 10 11 1 10 3 4 15 13 4 1 2 5 11 8 6 12 7 6 12 9 0 3 5 2 14 15 9 NIL)))) (RPAQ DES.SBOX.3 (READARRAY-FROM-LIST 64 (QUOTE BYTE) 0 (QUOTE (10 13 0 7 9 0 14 9 6 3 3 4 15 6 5 10 1 2 13 8 12 5 7 14 11 12 4 11 2 15 8 1 13 1 6 10 4 13 9 0 8 6 15 9 3 8 0 7 11 4 1 15 2 14 12 3 5 11 10 5 14 2 7 12 NIL)))) (RPAQ DES.SBOX.4 (READARRAY-FROM-LIST 64 (QUOTE BYTE) 0 (QUOTE (7 13 13 8 14 11 3 5 0 6 6 15 9 0 10 3 1 4 2 7 8 2 5 12 11 1 12 10 4 14 15 9 10 3 6 15 9 0 0 6 12 10 11 1 7 13 13 8 15 9 1 4 3 5 14 11 5 12 2 7 8 2 4 14 NIL)))) (RPAQ DES.SBOX.5 (READARRAY-FROM-LIST 64 (QUOTE BYTE) 0 (QUOTE (2 14 12 11 4 2 1 12 7 4 10 7 11 13 6 1 8 5 5 0 3 15 15 10 13 3 0 9 14 8 9 6 4 11 2 8 1 12 11 7 10 1 13 14 7 2 8 13 15 6 9 15 12 0 5 9 6 10 3 4 0 5 14 3 NIL)))) (RPAQ DES.SBOX.6 (READARRAY-FROM-LIST 64 (QUOTE BYTE) 0 (QUOTE (12 10 1 15 10 4 15 2 9 7 2 12 6 9 8 5 0 6 13 1 3 13 4 14 14 0 7 11 5 3 11 8 9 4 14 3 15 2 5 12 2 9 8 5 12 15 3 10 7 11 0 14 4 1 10 7 1 6 13 0 11 8 6 13 NIL)))) (RPAQ DES.SBOX.7 (READARRAY-FROM-LIST 64 (QUOTE BYTE) 0 (QUOTE (4 13 11 0 2 11 14 7 15 4 0 9 8 1 13 10 3 14 12 3 9 5 7 12 5 2 10 15 6 8 1 6 1 6 4 11 11 13 13 8 12 1 3 4 7 10 14 7 10 9 15 5 6 0 8 15 0 14 5 2 9 3 2 12 NIL)))) (RPAQ DES.SBOX.8 (READARRAY-FROM-LIST 64 (QUOTE BYTE) 0 (QUOTE (13 1 2 15 8 13 4 8 6 10 15 3 11 7 1 4 10 12 9 5 3 6 14 11 5 0 0 14 12 9 7 2 7 2 11 1 4 14 1 7 9 4 12 10 14 8 2 13 0 15 6 12 10 9 13 0 15 3 3 5 5 6 8 11 NIL)))) (RPAQ DES.SHIFTS (READARRAY-FROM-LIST 16 (QUOTE BYTE) 1 (QUOTE (1 1 2 2 2 2 2 2 1 2 2 2 2 2 2 1 NIL))) ) (RPAQQ DESKEYSLST NIL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (BLOCKRECORD DES.REC.E1 ((B1.5 BITS 5) (G6.7 BITS 2) (B8.11 BITS 4) (B12.13 BITS 2) (G14.16 BITS 3) (G17.19 BITS 3) (B20.21 BITS 2) (B22.25 BITS 4) (G26.27 BITS 2) (B28.32 BITS 5)) (CREATE (\ALLOCBLOCK 1))) (BLOCKRECORD DES.REC.E2 ((G1.3 BITS 3) (B4.9 BITS 6) (G10.11 BITS 2) (B12.16 BITS 5) (B17.21 BITS 5) (G22.23 BITS 2) (B24.29 BITS 6) (G30.32 BITS 3)) (CREATE (\ALLOCBLOCK 1))) (BLOCKRECORD DES.REC32.4 ((NIB1 BITS 4) (NIB2 BITS 4) (NIB3 BITS 4) (NIB4 BITS 4) (NIB5 BITS 4) (NIB6 BITS 4) (NIB7 BITS 4) (NIB8 BITS 4)) (CREATE (\ALLOCBLOCK 1))) (BLOCKRECORD DES.REC32.LS28.IN ((B1 BITS 1) (B2.16 BITS 15) (B17 BITS 1) (B18.28 BITS 11)) (CREATE (\ALLOCBLOCK 1))) (BLOCKRECORD DES.REC32.LS28.OUT ((B1.15 BITS 15) (B16 BITS 1) (B17.27 BITS 11) (B28 BITS 1)) (CREATE (\ALLOCBLOCK 1))) (BLOCKRECORD DES.REC48.6 ((S1 BITS 6) (S2 BITS 6) (S3.1 BITS 4) (S3.2 BITS 2) (S4 BITS 6) (S5 BITS 6) (S6.1 BITS 2) (S6.2 BITS 4) (S7 BITS 6) (S8 BITS 6)) (CREATE (\ALLOCBLOCK 2))) (BLOCKRECORD DESBLOCK ((W1 BITS 16) (W2 BITS 16) (W3 BITS 16) (W4 BITS 16)) (CREATE (\ALLOCBLOCK 2))) (BLOCKRECORD DESKEY ((W1 BITS 16) (W2 BITS 16) (W3 BITS 16) (W4 BITS 16)) (CREATE (\ALLOCBLOCK 2))) (BLOCKRECORD DESKEY.P ((B1 BITS 7) (P1 BITS 1) (B2 BITS 7) (P2 BITS 1) (B3 BITS 7) (P3 BITS 1) (B4 BITS 7) (P4 BITS 1) (B5 BITS 7) (P5 BITS 1) (B6 BITS 7) (P6 BITS 1) (B7 BITS 7) (P7 BITS 1) (B8 BITS 7) (P8 BITS 1)) (CREATE (\ALLOCBLOCK 2))) (BLOCKRECORD REC32 ((BIT1 BITS 1) (BIT2 BITS 1) (BIT3 BITS 1) (BIT4 BITS 1) (BIT5 BITS 1) (BIT6 BITS 1) (BIT7 BITS 1) (BIT8 BITS 1) (BIT9 BITS 1) (BIT10 BITS 1) (BIT11 BITS 1) (BIT12 BITS 1) (BIT13 BITS 1) (BIT14 BITS 1) (BIT15 BITS 1) (BIT16 BITS 1) (BIT17 BITS 1) (BIT18 BITS 1) (BIT19 BITS 1) (BIT20 BITS 1) (BIT21 BITS 1) (BIT22 BITS 1) (BIT23 BITS 1) (BIT24 BITS 1) (BIT25 BITS 1) (BIT26 BITS 1) (BIT27 BITS 1) (BIT28 BITS 1) (BIT29 BITS 1) (BIT30 BITS 1) (BIT31 BITS 1) (BIT32 BITS 1)) (CREATE (\ALLOCBLOCK 1))) (BLOCKRECORD REC32.W ((WORD1 BITS 16) (WORD2 BITS 16)) (CREATE (\ALLOCBLOCK 1))) (BLOCKRECORD REC48 ((BIT1 BITS 1) (BIT2 BITS 1) (BIT3 BITS 1) (BIT4 BITS 1) (BIT5 BITS 1) (BIT6 BITS 1) (BIT7 BITS 1) (BIT8 BITS 1) (BIT9 BITS 1) (BIT10 BITS 1) (BIT11 BITS 1) (BIT12 BITS 1) (BIT13 BITS 1) (BIT14 BITS 1) (BIT15 BITS 1) (BIT16 BITS 1) (BIT17 BITS 1) (BIT18 BITS 1) (BIT19 BITS 1) (BIT20 BITS 1) (BIT21 BITS 1) (BIT22 BITS 1) (BIT23 BITS 1) (BIT24 BITS 1) (BIT25 BITS 1) (BIT26 BITS 1) (BIT27 BITS 1) (BIT28 BITS 1) (BIT29 BITS 1) (BIT30 BITS 1) (BIT31 BITS 1) (BIT32 BITS 1) (BIT33 BITS 1) (BIT34 BITS 1) (BIT35 BITS 1) (BIT36 BITS 1) (BIT37 BITS 1) (BIT38 BITS 1) (BIT39 BITS 1) (BIT40 BITS 1) (BIT41 BITS 1) (BIT42 BITS 1) (BIT43 BITS 1) (BIT44 BITS 1) (BIT45 BITS 1) (BIT46 BITS 1) (BIT47 BITS 1) (BIT48 BITS 1)) (CREATE (\ALLOCBLOCK 2))) (BLOCKRECORD REC48.W ((WORD1 BITS 16) (WORD2 BITS 16) (WORD3 BITS 16)) (CREATE (\ALLOCBLOCK 2))) (BLOCKRECORD REC64 ((BIT1 BITS 1) (BIT2 BITS 1) (BIT3 BITS 1) (BIT4 BITS 1) (BIT5 BITS 1) (BIT6 BITS 1) (BIT7 BITS 1) (BIT8 BITS 1) (BIT9 BITS 1) (BIT10 BITS 1) (BIT11 BITS 1) (BIT12 BITS 1) (BIT13 BITS 1) (BIT14 BITS 1) (BIT15 BITS 1) (BIT16 BITS 1) (BIT17 BITS 1) (BIT18 BITS 1) (BIT19 BITS 1) (BIT20 BITS 1) (BIT21 BITS 1) (BIT22 BITS 1) (BIT23 BITS 1) (BIT24 BITS 1) (BIT25 BITS 1) (BIT26 BITS 1) (BIT27 BITS 1) (BIT28 BITS 1) (BIT29 BITS 1) (BIT30 BITS 1) (BIT31 BITS 1) (BIT32 BITS 1) (BIT33 BITS 1) (BIT34 BITS 1) (BIT35 BITS 1) (BIT36 BITS 1) (BIT37 BITS 1) (BIT38 BITS 1) (BIT39 BITS 1) (BIT40 BITS 1) (BIT41 BITS 1) (BIT42 BITS 1) (BIT43 BITS 1) (BIT44 BITS 1) (BIT45 BITS 1) (BIT46 BITS 1) (BIT47 BITS 1) (BIT48 BITS 1) (BIT49 BITS 1) (BIT50 BITS 1) (BIT51 BITS 1) (BIT52 BITS 1) (BIT53 BITS 1) (BIT54 BITS 1) (BIT55 BITS 1) (BIT56 BITS 1) (BIT57 BITS 1) (BIT58 BITS 1) (BIT59 BITS 1) (BIT60 BITS 1) (BIT61 BITS 1) (BIT62 BITS 1) (BIT63 BITS 1) (BIT64 BITS 1)) (CREATE (\ALLOCBLOCK 2))) (BLOCKRECORD REC64.W ((WORD1 BITS 16) (WORD2 BITS 16) (WORD3 BITS 16) (WORD4 BITS 16)) (CREATE (\ALLOCBLOCK 2))) ) ) (PUTPROPS DES COPYRIGHT ("Venue & Xerox Corporation" 1985 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1614 4972 (DES.BREAKOUT.BLOCKS 1624 . 1926) (DES.MAKE.BLOCKS 1928 . 2588) ( DES.ECB.ENCRYPT 2590 . 2748) (DES.ECB.DECRYPT 2750 . 2908) (DES.CBC.ENCRYPT 2910 . 2999) ( DES.CBC.DECRYPT 3001 . 3339) (DES.CBCC.ENCRYPT 3341 . 3558) (DES.CBCC.DECRYPT 3560 . 3880) ( DES.PASSWORD.TO.KEY 3882 . 4780) (DES.MAKE.KEY 4782 . 4970)) (5004 20861 (DES.CORRECT.KEY.PARITY 5014 . 5794) (DES.CRYPT.BLOCK 5796 . 6171) (DES.KEY.COPY 6173 . 6369) (DES.KEY.EQUAL 6371 . 6660) ( DES.LOOPBODY 6662 . 6802) (DES.MAKE.INTERNAL.KEYS 6804 . 8090) (DES.PERM.E 8092 . 8739) ( DES.PERM.INITIAL 8741 . 11055) (DES.PERM.INV.INITIAL 11057 . 13355) (DES.PERM.P 13357 . 14532) ( DES.PERM.PC1 14534 . 16565) (DES.PERM.PC2 16567 . 18299) (DES.REC32.LS28 18301 . 18677) (DES.SMAP 18679 . 19295) (REC32.XOR 19297 . 19523) (REC48.XOR 19525 . 19826) (REC64.XOR 19828 . 20204) ( REC64.XOR.CHK 20206 . 20859))))) STOP \ No newline at end of file diff --git a/library/DMCHAT b/library/DMCHAT new file mode 100644 index 00000000..fad74f8b --- /dev/null +++ b/library/DMCHAT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "20-Jan-93 13:49:09" {DSK}lde>lispcore>library>DMCHAT.;2 11747 changes to%: (RECORDS DM2500.STATE) previous date%: "11-Jun-90 15:39:12" {DSK}lde>lispcore>library>DMCHAT.;1) (* ; " Copyright (c) 1984, 1985, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DMCHATCOMS) (RPAQQ DMCHATCOMS ( (* ;;  "DM2500 emulator, with some peculiar functions to handle its silly autocrlf properties") (FILES CHATTERMINAL) (FNS DMCHAT.STATE DMCHAT.HANDLECHARACTER DMCHAT.HANDLE.WRAP DMCHAT.ADDRESS DMCHAT.CLEAR DMCHAT.CLEARMODES DMCHAT.NEWLINE DMCHAT.RIGHT) (ADDVARS (CHAT.DRIVERTYPES (DM2500 DMCHAT.HANDLECHARACTER DMCHAT.STATE))) (VARIABLES CHAT.AUTOCRLF) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T) (FILES (SOURCE) CHATDECLS) (RECORDS DM2500.STATE)) (INITRECORDS DM2500.STATE) (SYSRECORDS DM2500.STATE))) (* ;; "DM2500 emulator, with some peculiar functions to handle its silly autocrlf properties") (FILESLOAD CHATTERMINAL) (DEFINEQ (DMCHAT.STATE (LAMBDA (CHAT.STATE) (* ; "Edited 15-Feb-90 18:44 by bvm") (TERM.RESET.DISPLAY.PARMS CHAT.STATE) (replace (CHAT.STATE CLEARMODEFN) of CHAT.STATE with (FUNCTION DMCHAT.CLEARMODES)) (TERM.HOME CHAT.STATE) (create DM2500.STATE)) ) (DMCHAT.HANDLECHARACTER (LAMBDA (CHAR CHAT.STATE DM2500.STATE) (* ; "Edited 11-Aug-88 16:35 by drc:") (\DTEST CHAT.STATE (QUOTE CHAT.STATE)) (\DTEST DM2500.STATE (QUOTE DM2500.STATE)) (PROG NIL (COND ((EQ CHAR (CHARCODE BELL)) (RETURN (COND ((NEQ \MACHINETYPE \DORADO) (* ; "Modern machines have audible bells") (BOUT (ffetch (CHAT.STATE DSP) of CHAT.STATE) 7)) ((NOT (ffetch (DM2500.STATE DINGED) of DM2500.STATE)) (CL:FUNCALL INVERTWINDOWFN (ffetch (CHAT.STATE WINDOW) of CHAT.STATE)) (* ; "Complement window") (freplace (DM2500.STATE DINGED) of DM2500.STATE with T)))))) (COND ((ffetch (DM2500.STATE DINGED) of DM2500.STATE) (* ; "Last character was a bell, with which we complemented screen. Now back to normal") (CL:FUNCALL INVERTWINDOWFN (ffetch (CHAT.STATE WINDOW) of CHAT.STATE)) (freplace (DM2500.STATE DINGED) of DM2500.STATE with NIL))) (COND ((AND (ffetch (DM2500.STATE AUTOLF) of DM2500.STATE) (OR (NEQ CHAR (CHARCODE CR)) (NOT (ffetch (DM2500.STATE EATTOCRLF) of DM2500.STATE)))) (* ;; "We last received a CR, so DM wants auto LF after it. However, we postpone doing so until the next char is received, so that we get scroll holding right") (TERM.DOWN CHAT.STATE) (freplace (DM2500.STATE AUTOLF) of DM2500.STATE with NIL))) (COND ((ffetch (DM2500.STATE ADDRESSING) of DM2500.STATE) (* ; "In the middle of receiving an address command") (COND ((DMCHAT.ADDRESS CHAT.STATE DM2500.STATE CHAR) (RETURN))))) (COND ((AND (>= CHAR (CHARCODE SPACE)) (< CHAR (CHARCODE DEL))) (* ; "Normal char") (freplace (DM2500.STATE EATLF) of DM2500.STATE with (freplace (DM2500.STATE EATCRLF) of DM2500.STATE with NIL)) (RETURN (COND ((NOT (ffetch (DM2500.STATE EATTOCRLF) of DM2500.STATE)) (* ; "Print the char") (COND ((ffetch (DM2500.STATE IDMODE) of DM2500.STATE) (* ; "this is discouraged by the DM manual, but apparently EMACS does it, so might as well support it") (TERM.ADDCHAR CHAT.STATE))) (TERM.PRINTCHAR CHAT.STATE CHAR (FUNCTION DMCHAT.HANDLE.WRAP))))))) (* ;; "At this point, we have a non-printing char, presumably some command (or cr, lf).") (COND ((ffetch (DM2500.STATE EATLF) of DM2500.STATE) (* ; "Previous char was CR, after which we must ignore LF.") (freplace (DM2500.STATE EATLF) of DM2500.STATE with NIL) (COND ((EQ CHAR (CHARCODE LF)) (* ; "Yes, it was a LF, so we're done.") (RETURN))))) (COND ((ffetch (DM2500.STATE EATCRLF) of DM2500.STATE) (* ; "We just wrapped around, so ignore CR and/or LF if next") (COND ((EQ CHAR (CHARCODE CR)) (* ; "There's the CR, next eat the lf") (freplace (DM2500.STATE EATLF) of DM2500.STATE with T) (freplace (DM2500.STATE EATCRLF) of DM2500.STATE with NIL) (RETURN)) (T (* ; "Intervening control characters do not stop the eating, except for a few inconsistent exceptions...") (SELCHARQ CHAR ((^B ^\ ^^ ^_) (freplace (DM2500.STATE EATCRLF) of DM2500.STATE with NIL)) NIL))))) (SELCHARQ CHAR (LF (COND ((ffetch (DM2500.STATE IDMODE) of DM2500.STATE) (TERM.ADDLINE CHAT.STATE)) (T (TERM.DOWN CHAT.STATE)))) (CR (freplace (DM2500.STATE EATTOCRLF) of DM2500.STATE with NIL) (DMCHAT.NEWLINE CHAT.STATE DM2500.STATE T)) (BS (COND ((ffetch (DM2500.STATE IDMODE) of DM2500.STATE) (TERM.DELCHAR CHAT.STATE)) (T (TERM.LEFT CHAT.STATE)))) (^W (* ; "Erase to end of line") (TERM.ERASE.TO.EOL CHAT.STATE)) (^L (* ; "Start of cursor address") (freplace (DM2500.STATE ADDRESSING) of DM2500.STATE with -1)) (^B (* ; "Homes cursor, cancels some modes") (TERM.HOME CHAT.STATE) (DMCHAT.CLEARMODES CHAT.STATE DM2500.STATE)) (^X (* ; "Cancel --resets modes") (DMCHAT.CLEARMODES CHAT.STATE DM2500.STATE) (freplace (CHAT.STATE ROLLMODE) of CHAT.STATE with NIL)) ((^^ ^_) (* ; "Master Reset -- Clears screen, modes") (DMCHAT.CLEAR CHAT.STATE DM2500.STATE)) (^\ (* ; "Forward space") (COND ((ffetch (DM2500.STATE IDMODE) of DM2500.STATE) (TERM.ADDCHAR CHAT.STATE)) (T (DMCHAT.RIGHT CHAT.STATE DM2500.STATE)))) (^Z (* ; "Up") (COND ((ffetch (DM2500.STATE IDMODE) of DM2500.STATE) (TERM.DELETELINE CHAT.STATE)) (T (TERM.UP CHAT.STATE)))) ((^N ^O) (* ; "Enter blink mode, enter protected mode. Do both as embolden") (TERM.MODIFY.ATTRIBUTES CHAT.STATE (QUOTE BRIGHT)) (freplace (DM2500.STATE BRIGHTMODE) of DM2500.STATE with T)) (^P (* ; "Enter insert/delete mode") (freplace (DM2500.STATE IDMODE) of DM2500.STATE with T)) (^%] (* ; "Set roll mode") (freplace (CHAT.STATE ROLLMODE) of CHAT.STATE with T)) NIL))) ) (DMCHAT.HANDLE.WRAP (LAMBDA (CHAT.STATE) (* ;; "Called when a character is printed in the last column of the screen") (LET ((DM2500.STATE (fetch (CHAT.STATE TERM.STATE) of CHAT.STATE))) (COND (CHAT.AUTOCRLF (* ; "This is standard behavior--do auto crlf") (DMCHAT.NEWLINE CHAT.STATE DM2500.STATE)) (T (* ; "An alternate mode some might like--flush everything til crlf.") (replace (DM2500.STATE EATTOCRLF) of DM2500.STATE with T))))) ) (DMCHAT.ADDRESS (LAMBDA (CHAT.STATE DM2500.STATE CHAR) (* ejs%: "12-May-85 15:26") (* ;; "In the middle of doing absolute address, which is {^L, xpos, ypos}. Return T (meaning we handled the character) unless CHAR implies a cancellation of the address, in which case caller must handle CHAR") (\DTEST DM2500.STATE (QUOTE DM2500.STATE)) (SELCHARQ CHAR ((^X ^^ ^_) (* ; "Cancel it, return NIL") (freplace (DM2500.STATE ADDRESSING) of DM2500.STATE with NIL) NIL) (^L (* ; "Restarting the address in the middle of the address is legal") (freplace (DM2500.STATE ADDRESSING) of DM2500.STATE with -1) T) (LET ((ADDRESSING (ffetch (DM2500.STATE ADDRESSING) of DM2500.STATE)) (NEXTPOS (LOGXOR CHAR 96))) (COND ((< ADDRESSING 0) (* ; "Accept first (x) position") (freplace (DM2500.STATE ADDRESSING) of DM2500.STATE with NEXTPOS)) (T (* ; "Accept second position and go there") (TERM.MOVETO CHAT.STATE ADDRESSING NEXTPOS) (freplace (DM2500.STATE ADDRESSING) of DM2500.STATE with NIL))) T))) ) (DMCHAT.CLEAR (LAMBDA (CHAT.STATE DM2500.STATE SETROLL) (* ejs%: "12-May-85 17:13") (CLEARW (ffetch (CHAT.STATE WINDOW) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (DMCHAT.CLEARMODES CHAT.STATE DM2500.STATE) (AND SETROLL (freplace (CHAT.STATE ROLLMODE) of CHAT.STATE with T)) (TERM.HOME CHAT.STATE)) ) (DMCHAT.CLEARMODES (LAMBDA (CHAT.STATE DM2500.STATE) (* ; "Edited 15-Feb-90 18:37 by bvm") (\DTEST CHAT.STATE (QUOTE CHAT.STATE)) (DSPFONT (ffetch (CHAT.STATE PLAINFONT) of CHAT.STATE) (ffetch (CHAT.STATE DSP) of CHAT.STATE)) (* ; "Restore normal font") (freplace (DM2500.STATE BRIGHTMODE) of DM2500.STATE with (freplace (DM2500.STATE BLINKMODE) of DM2500.STATE with (freplace (DM2500.STATE IDMODE) of DM2500.STATE with (freplace (DM2500.STATE ADDRESSING) of DM2500.STATE with NIL)))) (freplace (CHAT.STATE ROLLMODE) of CHAT.STATE with T)) ) (DMCHAT.NEWLINE (LAMBDA (CHAT.STATE DM2500.STATE EXPLICIT) (* ejs%: "12-May-85 15:12") (* ;; "Do a CRLF. EXPLICIT = T means a CR was received, NIL means we did autowraparound") (\DTEST CHAT.STATE (QUOTE CHAT.STATE)) (MOVETO (freplace (CHAT.STATE XPOS) of CHAT.STATE with 0) (ffetch (CHAT.STATE YPOS) of CHAT.STATE) (ffetch (CHAT.STATE DSP) of CHAT.STATE)) (* ; "Do only the CR part now, saving the LF for when next char arrives") (freplace (DM2500.STATE AUTOLF) of (\DTEST DM2500.STATE (QUOTE DM2500.STATE)) with T) (COND (EXPLICIT (* ; "That WAS a cr, so eat the following lf") (freplace (DM2500.STATE EATLF) of DM2500.STATE with T)) (T (* ; "Just wrapping, eat chars til crlf") (freplace (DM2500.STATE EATCRLF) of DM2500.STATE with T)))) ) (DMCHAT.RIGHT (LAMBDA (CHAT.STATE DM2500.STATE) (* ejs%: "12-May-85 15:31") (LET ((XPOS (+ (ffetch (CHAT.STATE XPOS) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE))) (ffetch (CHAT.STATE FONTWIDTH) of CHAT.STATE)))) (COND ((< XPOS (ffetch (CHAT.STATE TTYWIDTH) of CHAT.STATE)) (MOVETO (freplace (CHAT.STATE XPOS) of CHAT.STATE with XPOS) (ffetch (CHAT.STATE YPOS) of CHAT.STATE) (ffetch (CHAT.STATE DSP) of CHAT.STATE))) (T (* ; "Auto crlf") (DMCHAT.NEWLINE CHAT.STATE DM2500.STATE))))) ) ) (ADDTOVAR CHAT.DRIVERTYPES (DM2500 DMCHAT.HANDLECHARACTER DMCHAT.STATE)) (CL:DEFVAR CHAT.AUTOCRLF T "If true, dm2500 emulator performs automatic CRLF when it reaches the right edge of the display.") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (FILESLOAD (SOURCE) CHATDECLS) (DECLARE%: EVAL@COMPILE (DATATYPE DM2500.STATE ((DINGED FLAG) (EATLF FLAG) (EATCRLF FLAG) (EATTOCRLF FLAG) (AUTOLF FLAG) ADDRESSING (IDMODE FLAG) (BLINKMODE FLAG) (BRIGHTMODE FLAG))) ) (/DECLAREDATATYPE 'DM2500.STATE '(FLAG FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG) '((DM2500.STATE 0 (FLAGBITS . 0)) (DM2500.STATE 0 (FLAGBITS . 16)) (DM2500.STATE 0 (FLAGBITS . 32)) (DM2500.STATE 0 (FLAGBITS . 48)) (DM2500.STATE 0 (FLAGBITS . 64)) (DM2500.STATE 2 POINTER) (DM2500.STATE 2 (FLAGBITS . 0)) (DM2500.STATE 2 (FLAGBITS . 16)) (DM2500.STATE 2 (FLAGBITS . 32))) '4) ) (/DECLAREDATATYPE 'DM2500.STATE '(FLAG FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG) '((DM2500.STATE 0 (FLAGBITS . 0)) (DM2500.STATE 0 (FLAGBITS . 16)) (DM2500.STATE 0 (FLAGBITS . 32)) (DM2500.STATE 0 (FLAGBITS . 48)) (DM2500.STATE 0 (FLAGBITS . 64)) (DM2500.STATE 2 POINTER) (DM2500.STATE 2 (FLAGBITS . 0)) (DM2500.STATE 2 (FLAGBITS . 16)) (DM2500.STATE 2 (FLAGBITS . 32))) '4) (ADDTOVAR SYSTEMRECLST (DATATYPE DM2500.STATE ((DINGED FLAG) (EATLF FLAG) (EATCRLF FLAG) (EATTOCRLF FLAG) (AUTOLF FLAG) ADDRESSING (IDMODE FLAG) (BLINKMODE FLAG) (BRIGHTMODE FLAG))) ) (PUTPROPS DMCHAT COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1988 1990 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1425 9543 (DMCHAT.STATE 1435 . 1680) (DMCHAT.HANDLECHARACTER 1682 . 6025) ( DMCHAT.HANDLE.WRAP 6027 . 6464) (DMCHAT.ADDRESS 6466 . 7452) (DMCHAT.CLEAR 7454 . 7759) ( DMCHAT.CLEARMODES 7761 . 8306) (DMCHAT.NEWLINE 8308 . 9054) (DMCHAT.RIGHT 9056 . 9541))))) STOP \ No newline at end of file diff --git a/library/DORADOKEYBOARDS b/library/DORADOKEYBOARDS new file mode 100644 index 00000000..f8dbcc45 --- /dev/null +++ b/library/DORADOKEYBOARDS @@ -0,0 +1 @@ +((EUROPEAN ((100 (53 197 NOLOCKSHIFT)) (101 (52 196 NOLOCKSHIFT)) (102 (54 198 NOLOCKSHIFT)) (103 ( 61887 61759 LOCKSHIFT)) (104 (55 199 NOLOCKSHIFT)) (105 (61888 61760 LOCKSHIFT)) (106 (61872 61744 LOCKSHIFT)) (107 (61860 61732 LOCKSHIFT)) (108 (48 126 NOLOCKSHIFT)) (109 (61892 61764 LOCKSHIFT)) ( 110 (203 207 NOLOCKSHIFT)) (111 (61919 61791 LOCKSHIFT)) (112 (47 191 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 195 NOLOCKSHIFT)) (117 (50 194 NOLOCKSHIFT)) (118 (61873 61745 LOCKSHIFT)) (119 (61858 61730 LOCKSHIFT)) (120 (61874 61746 LOCKSHIFT)) (121 (61859 61731 LOCKSHIFT)) (122 (57 202 NOLOCKSHIFT)) (123 (61886 61758 LOCKSHIFT)) (124 (61864 61736 LOCKSHIFT)) (125 (61903 61775 LOCKSHIFT)) (126 (61908 61780 LOCKSHIFT)) (127 (241 225 LOCKSHIFT)) (128 (187 170 LOCKSHIFT)) ( 129 (249 233 LOCKSHIFT)) (132 (49 193 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61905 61777 LOCKSHIFT)) (137 (61869 61741 LOCKSHIFT)) (138 (61877 61749 LOCKSHIFT)) (139 (61906 61778 LOCKSHIFT)) (140 (251 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 ( 250 234 LOCKSHIFT)) (143 (59 58 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (171 186 LOCKSHIFT )) (148 (61904 61776 LOCKSHIFT)) (149 (61920 61792 LOCKSHIFT)) (150 (61921 61793 LOCKSHIFT)) (151 ( 61857 61729 LOCKSHIFT)) (152 (61863 61735 LOCKSHIFT)) (153 (56 200 NOLOCKSHIFT)) (154 (61900 61772 LOCKSHIFT)) (155 (239 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( 246 230 LOCKSHIFT)) (159 (207 176 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (logic ((100 ( 53 37 NOLOCKSHIFT)) (101 (52 164 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61258 61260 NOLOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (61292 61293 NOLOCKSHIFT)) (106 (61271 61270 NOLOCKSHIFT) ) (107 (61284 61285 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61307 61306 NOLOCKSHIFT)) (110 (45 177 NOLOCKSHIFT)) (111 (61269 61268 LOCKSHIFT)) (112 (172 174 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61240 61241 NOLOCKSHIFT)) (119 ( 61234 61235 NOLOCKSHIFT)) (120 (61266 61262 NOLOCKSHIFT)) (121 (61365 61365 NOLOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (61275 61274 NOLOCKSHIFT)) (124 (61300 61299 NOLOCKSHIFT)) (125 (61273 61272 NOLOCKSHIFT)) (126 (61282 61283 NOLOCKSHIFT)) (127 (61256 61257 NOLOCKSHIFT)) (128 (61356 61356 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61250 61251 NOLOCKSHIFT)) (137 (61298 61297 NOLOCKSHIFT)) (138 (61305 61303 NOLOCKSHIFT)) (139 (61265 61264 NOLOCKSHIFT)) (140 (61364 61364 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (61281 233 NOLOCKSHIFT)) (143 (61351 61351 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (61357 61357 NOLOCKSHIFT)) (148 (61279 61278 NOLOCKSHIFT)) (149 (61239 61238 NOLOCKSHIFT)) (150 (61290 61290 NOLOCKSHIFT)) (151 (61263 61261 NOLOCKSHIFT)) (152 (61295 61295 NOLOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61252 61253 NOLOCKSHIFT)) (155 (61254 61255 NOLOCKSHIFT) ) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (MATH ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61284 61285 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (174 61245 NOLOCKSHIFT)) (107 (61369 61363 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61254 61255 NOLOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (173 61246 LOCKSHIFT)) ( 112 (47 61300 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61282 61283 LOCKSHIFT)) (119 (61287 61286 NOLOCKSHIFT)) (120 (61301 61302 NOLOCKSHIFT)) (121 (61351 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (175 61247 LOCKSHIFT)) (124 ( 180 184 LOCKSHIFT)) (125 (172 61244 LOCKSHIFT)) (126 (61256 61257 LOCKSHIFT)) (127 (44 61250 NOLOCKSHIFT)) (128 (61298 61253 NOLOCKSHIFT)) (129 (93 61265 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) ( 133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 ( 61356 61362 LOCKSHIFT)) (138 (61254 61291 NOLOCKSHIFT)) (139 (98 61360 NOLOCKSHIFT)) (140 (61309 177 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 61251 NOLOCKSHIFT)) (143 (61299 61252 NOLOCKSHIFT)) ( 144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (61358 82 LOCKSHIFT)) (149 (61296 61266 NOLOCKSHIFT)) (150 (61305 61303 NOLOCKSHIFT)) (151 (61308 61267 LOCKSHIFT)) (152 (61288 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61357 61361 NOLOCKSHIFT)) (155 (61292 61293 LOCKSHIFT)) ( 156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 61264 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (OFFICE ((100 (61397 61381 NOLOCKSHIFT)) (101 ( 61396 61380 NOLOCKSHIFT)) (102 (61398 61382 NOLOCKSHIFT)) (103 (8557 8554 NOLOCKSHIFT)) (104 (61399 61383 NOLOCKSHIFT)) (105 (61232 8743 NOLOCKSHIFT)) (106 (61346 8571 NOLOCKSHIFT)) (107 (188 86 NOLOCKSHIFT)) (108 (61402 61386 NOLOCKSHIFT)) (109 (210 8738 NOLOCKSHIFT)) (110 (61437 61438 NOLOCKSHIFT)) (111 (163 8558 NOLOCKSHIFT)) (112 (61248 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (61395 61379 NOLOCKSHIFT)) (117 (61394 61378 NOLOCKSHIFT)) (118 (185 8553 NOLOCKSHIFT)) ( 119 (176 8546 NOLOCKSHIFT)) (120 (167 8744 NOLOCKSHIFT)) (121 (97 8745 NOLOCKSHIFT)) (122 (61401 61385 NOLOCKSHIFT)) (123 (162 8570 NOLOCKSHIFT)) (124 (61437 88 NOLOCKSHIFT)) (125 (111 8569 NOLOCKSHIFT)) (126 (61289 8737 NOLOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (61393 61377 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61233 8742 NOLOCKSHIFT)) (137 (61438 67 NOLOCKSHIFT)) (138 (8739 74 NOLOCKSHIFT)) (139 (190 61436 NOLOCKSHIFT)) (140 (189 90 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( 142 (61249 62 NOLOCKSHIFT)) (143 (61352 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 61280 NOLOCKSHIFT)) (148 (212 8574 NOLOCKSHIFT)) (149 (61354 8573 NOLOCKSHIFT)) (150 (61286 8741 NOLOCKSHIFT)) (151 (165 8572 NOLOCKSHIFT)) (152 (61368 8740 NOLOCKSHIFT)) (153 (61400 61384 NOLOCKSHIFT)) (154 (173 175 NOLOCKSHIFT)) (155 (172 174 NOLOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61406 61368 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (DVORAK ((100 (49 42 NOLOCKSHIFT)) (101 (51 41 NOLOCKSHIFT)) (102 (57 37 NOLOCKSHIFT)) (103 (46 62 NOLOCKSHIFT)) (104 (48 38 NOLOCKSHIFT)) (105 (101 69 LOCKSHIFT)) (106 (103 71 LOCKSHIFT)) (107 (107 75 LOCKSHIFT)) (108 (54 45 NOLOCKSHIFT)) (109 (116 84 LOCKSHIFT)) (110 (56 95 NOLOCKSHIFT)) (111 (108 76 LOCKSHIFT)) (112 (122 90 LOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (53 40 NOLOCKSHIFT)) (117 (55 35 NOLOCKSHIFT)) (118 (44 60 NOLOCKSHIFT)) (119 (63 47 NOLOCKSHIFT)) ( 120 (111 79 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (52 164 NOLOCKSHIFT)) (123 (99 67 LOCKSHIFT)) ( 124 (113 81 LOCKSHIFT)) (125 (114 82 LOCKSHIFT)) (126 (110 78 LOCKSHIFT)) (127 (119 87 LOCKSHIFT)) ( 128 (44 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (33 64 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (117 85 LOCKSHIFT)) (137 (106 74 LOCKSHIFT)) (138 (104 72 LOCKSHIFT)) (139 (120 88 LOCKSHIFT)) (140 (59 58 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (118 86 LOCKSHIFT)) (143 (115 83 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (169 170 NOLOCKSHIFT)) (148 (112 80 LOCKSHIFT)) (149 (121 89 LOCKSHIFT)) (150 (105 73 LOCKSHIFT)) (151 (102 70 LOCKSHIFT)) (152 (100 68 LOCKSHIFT)) (153 (50 162 NOLOCKSHIFT)) (154 (98 66 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( 91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (GREEK ((100 ( 53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (9830 69 LOCKSHIFT)) ( 104 (55 38 NOLOCKSHIFT)) (105 (9829 9797 LOCKSHIFT)) (106 (9849 9817 LOCKSHIFT)) (107 (115 9814 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (9837 9805 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (9843 9811 LOCKSHIFT)) (112 (47 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (9853 9821 LOCKSHIFT)) (119 (9835 9803 LOCKSHIFT)) (120 (9846 9814 LOCKSHIFT)) (121 (9825 9793 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (9836 9804 LOCKSHIFT)) (124 ( 9851 9819 LOCKSHIFT)) (125 (9842 9810 LOCKSHIFT)) (126 (9838 9806 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT) ) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (9850 9818 LOCKSHIFT)) (137 (9841 9809 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (9826 66 LOCKSHIFT)) (140 (9833 9801 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (9845 9813 LOCKSHIFT)) (149 (9848 9816 LOCKSHIFT)) (150 (9828 9796 LOCKSHIFT)) (151 (9852 9820 LOCKSHIFT)) (152 (9834 9802 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) ( 154 (9840 9808 LOCKSHIFT)) (155 (9839 9807 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT ) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (ITALIAN ((100 (53 61903 NOLOCKSHIFT)) (101 (52 61886 NOLOCKSHIFT)) (102 (54 61919 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) ( 116 (51 61872 NOLOCKSHIFT)) (117 (50 61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (39 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) ( 145 (95 170 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) ( 151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) ( 155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (SPANISH ((100 (53 61904 NOLOCKSHIFT)) (101 (52 61887 NOLOCKSHIFT)) (102 (54 61920 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 61873 NOLOCKSHIFT)) (117 (50 61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 ( 97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 ( 111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (59 58 NOLOCKSHIFT)) (129 (203 187 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) ( 143 (61900 61772 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (161 191 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61925 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (44 171 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (FRENCH ((100 (53 61905 NOLOCKSHIFT)) (101 (52 61888 NOLOCKSHIFT)) (102 (54 61921 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) ( 105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) ( 109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 61874 NOLOCKSHIFT)) (117 (50 61859 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (39 61857 NOLOCKSHIFT)) (129 (61872 61892 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (61869 61741 LOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61919 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61873 61877 LOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (GERMAN ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (251 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) ( 116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) ( 120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) ( 124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) ( 128 (39 34 NOLOCKSHIFT)) (129 (61863 61735 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT )) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 ( 121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 ( 109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61908 61780 LOCKSHIFT)) (159 (61925 61797 LOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO) (STANDARD-RUSSIAN (( 100 (34 52 NOLOCKSHIFT)) (101 (47 51 NOLOCKSHIFT)) (102 (58 53 NOLOCKSHIFT)) (103 (10085 10037 LOCKSHIFT)) (104 (44 54 NOLOCKSHIFT)) (105 (10067 10019 LOCKSHIFT)) (106 (10068 10020 LOCKSHIFT)) (107 (10078 10030 LOCKSHIFT)) (108 (63 57 NOLOCKSHIFT)) (109 (10077 10029 LOCKSHIFT)) (110 (37 48 NOLOCKSHIFT)) (111 (10073 10025 LOCKSHIFT)) (112 (10071 10023 LOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (45 50 NOLOCKSHIFT)) (117 (61352 49 NOLOCKSHIFT)) (118 (10088 10040 LOCKSHIFT)) (119 ( 10075 10027 LOCKSHIFT)) (120 (10093 10045 LOCKSHIFT)) (121 (10086 10038 LOCKSHIFT)) (122 (95 56 NOLOCKSHIFT)) (123 (10090 10042 LOCKSHIFT)) (124 (10089 10041 LOCKSHIFT)) (125 (10091 10043 LOCKSHIFT) ) (126 (10069 10021 LOCKSHIFT)) (127 (10066 10018 LOCKSHIFT)) (128 (10095 10047 LOCKSHIFT)) (129 ( 10092 10044 LOCKSHIFT)) (132 (167 43 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (10065 10017 LOCKSHIFT)) (137 (10083 10035 LOCKSHIFT)) (138 (10080 10032 LOCKSHIFT)) (139 (10074 10026 LOCKSHIFT)) (140 (10097 10049 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( 142 (10096 10048 LOCKSHIFT)) (143 (10072 10024 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (41 40 NOLOCKSHIFT)) (148 (10076 10028 LOCKSHIFT)) (149 (10070 10022 LOCKSHIFT)) (150 (10081 10033 LOCKSHIFT)) (151 (10079 10031 LOCKSHIFT)) (152 (10082 10034 LOCKSHIFT)) (153 (46 55 NOLOCKSHIFT)) (154 (10084 10036 LOCKSHIFT)) (155 (10094 10046 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (10087 10039 LOCKSHIFT)) (159 (33 61 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DORADO)) \ No newline at end of file diff --git a/library/DOSPRINT b/library/DOSPRINT new file mode 100644 index 00000000..8f1786f0 --- /dev/null +++ b/library/DOSPRINT @@ -0,0 +1,53 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") +(FILECREATED "20-Nov-95 11:34:56" {DSK}LIBRARY/DOSPRINT.\;1 2006 + + |changes| |to:| (VARS DOSPRINTCOMS) + + |previous| |date:| "26-Jul-93 14:01:26" {DSK}LIBRARY/DOSPRINT.\;1) + + +; Copyright (c) 1995 by Xerox Corporation. All rights reserved. + +(PRETTYCOMPRINT DOSPRINTCOMS) + +(RPAQQ DOSPRINTCOMS ((FNS DOSPRINT) + (INITVARS (|DosPrinterName| NIL)) + (DECLARE\: EVAL@COMPILE DONTCOPY (GLOBALVARS |DosPrinterName|)) + (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS + (NLAMA) + (NLAML) + (LAMA))))) +(DEFINEQ + +(DOSPRINT + (LAMBDA (HOST FILE PRINTOPTIONS) (* \; "Edited 26-Jul-93 13:48 by ") + (LET* ((PRINTER (OR HOST |DosPrinterName|)) + (COPIES (LISTGET PRINTOPTIONS '\#COPIES)) + (NAME (LISTGET PRINTOPTIONS 'DOCUMENT.NAME)) + (TYPE (PRINTERTYPE PRINTER))) + (CL:WITH-OPEN-STREAM (|out| (OPENSTREAM PRINTER 'OUTPUT)) + (CL:WITH-OPEN-STREAM (|in| (OPENSTREAM FILE 'INPUT)) + (CL:FORMAT PROMPTWINDOW "Spooling output to DOS printer \"~A\"..." PRINTER) + (COPYCHARS |in| |out|) + (CL:FORMAT PROMPTWINDOW "Done.")))))) +) + +(RPAQ? |DosPrinterName| NIL) +(DECLARE\: EVAL@COMPILE DONTCOPY +(DECLARE\: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS |DosPrinterName|) +) +) +(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA ) +) +(PUTPROPS DOSPRINT COPYRIGHT ("Xerox Corporation" 1995)) +(DECLARE\: DONTCOPY + (FILEMAP (NIL (958 1636 (DOSPRINT 970 . 1633))))) +STOP diff --git a/library/DOVEKEYBOARDS b/library/DOVEKEYBOARDS new file mode 100644 index 00000000..f5fba51c --- /dev/null +++ b/library/DOVEKEYBOARDS @@ -0,0 +1 @@ +((EUROPEAN ((100 (53 197 NOLOCKSHIFT)) (101 (52 196 NOLOCKSHIFT)) (102 (54 198 NOLOCKSHIFT)) (103 ( 61887 61759 LOCKSHIFT)) (104 (55 199 NOLOCKSHIFT)) (105 (61888 61760 LOCKSHIFT)) (106 (61872 61744 LOCKSHIFT)) (107 (61860 61732 LOCKSHIFT)) (108 (48 126 NOLOCKSHIFT)) (109 (61892 61764 LOCKSHIFT)) ( 110 (203 207 NOLOCKSHIFT)) (111 (61919 61791 LOCKSHIFT)) (112 (47 191 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 195 NOLOCKSHIFT)) (117 (50 194 NOLOCKSHIFT)) (118 (61873 61745 LOCKSHIFT)) (119 (61858 61730 LOCKSHIFT)) (120 (61874 61746 LOCKSHIFT)) (121 (61859 61731 LOCKSHIFT)) (122 (57 202 NOLOCKSHIFT)) (123 (61886 61758 LOCKSHIFT)) (124 (61864 61736 LOCKSHIFT)) (125 (61903 61775 LOCKSHIFT)) (126 (61908 61780 LOCKSHIFT)) (127 (241 225 LOCKSHIFT)) (171 (187 170 LOCKSHIFT)) ( 129 (249 233 LOCKSHIFT)) (132 (49 193 NOLOCKSHIFT)) (165 (27 27 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61905 61777 LOCKSHIFT)) (137 (61869 61741 LOCKSHIFT)) (138 (61877 61749 LOCKSHIFT)) (139 (61906 61778 LOCKSHIFT)) (140 (251 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 ( 250 234 LOCKSHIFT)) (143 (59 58 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (208 (171 186 LOCKSHIFT )) (148 (61904 61776 LOCKSHIFT)) (149 (61920 61792 LOCKSHIFT)) (150 (61921 61793 LOCKSHIFT)) (151 ( 61857 61729 LOCKSHIFT)) (152 (61863 61735 LOCKSHIFT)) (153 (56 200 NOLOCKSHIFT)) (154 (61900 61772 LOCKSHIFT)) (155 (239 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( 246 230 LOCKSHIFT)) (159 (207 176 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DOVE) (logic ((100 (53 37 NOLOCKSHIFT)) (101 (52 164 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61258 61260 NOLOCKSHIFT)) ( 104 (55 38 NOLOCKSHIFT)) (105 (61292 61293 NOLOCKSHIFT)) (106 (61271 61270 NOLOCKSHIFT)) (107 (61284 61285 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61307 61306 NOLOCKSHIFT)) (110 (45 177 NOLOCKSHIFT )) (111 (61269 61268 LOCKSHIFT)) (112 (172 174 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61240 61241 NOLOCKSHIFT)) (119 (61234 61235 NOLOCKSHIFT)) (120 (61266 61262 NOLOCKSHIFT)) (121 (61365 61365 NOLOCKSHIFT)) (122 (57 40 NOLOCKSHIFT) ) (123 (61275 61274 NOLOCKSHIFT)) (124 (61300 61299 NOLOCKSHIFT)) (125 (61273 61272 NOLOCKSHIFT)) (126 (61282 61283 NOLOCKSHIFT)) (127 (61256 61257 NOLOCKSHIFT)) (171 (61356 61356 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (165 (27 27 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61250 61251 NOLOCKSHIFT)) (137 (61298 61297 NOLOCKSHIFT)) (138 (61305 61303 NOLOCKSHIFT)) (139 (61265 61264 NOLOCKSHIFT)) (140 (61364 61364 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (61281 233 NOLOCKSHIFT)) (143 (61351 61351 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (208 (61357 61357 NOLOCKSHIFT)) (148 (61279 61278 NOLOCKSHIFT)) (149 (61239 61238 NOLOCKSHIFT) ) (150 (61290 61290 NOLOCKSHIFT)) (151 (61263 61261 NOLOCKSHIFT)) (152 (61295 61295 NOLOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61252 61253 NOLOCKSHIFT)) (155 (61254 61255 NOLOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DOVE) (MATH ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61284 61285 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 ( 174 61245 NOLOCKSHIFT)) (107 (61369 61363 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61254 61255 NOLOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (173 61246 LOCKSHIFT)) (112 (47 61300 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61282 61283 LOCKSHIFT)) (119 (61287 61286 NOLOCKSHIFT)) (120 (61301 61302 NOLOCKSHIFT)) (121 (61351 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (175 61247 LOCKSHIFT)) (124 (180 184 LOCKSHIFT)) (125 (172 61244 LOCKSHIFT)) (126 (61256 61257 LOCKSHIFT)) (127 (44 61250 NOLOCKSHIFT)) (171 (61298 61253 NOLOCKSHIFT)) (129 (93 61265 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (165 (27 27 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (61356 61362 LOCKSHIFT)) (138 (61254 61291 NOLOCKSHIFT)) (139 (98 61360 NOLOCKSHIFT)) (140 (61309 177 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( 142 (46 61251 NOLOCKSHIFT)) (143 (61299 61252 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (208 ( 95 94 NOLOCKSHIFT)) (148 (61358 82 LOCKSHIFT)) (149 (61296 61266 NOLOCKSHIFT)) (150 (61305 61303 NOLOCKSHIFT)) (151 (61308 61267 LOCKSHIFT)) (152 (61288 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61357 61361 NOLOCKSHIFT)) (155 (61292 61293 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 61264 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DOVE) (OFFICE ((100 (61397 61381 NOLOCKSHIFT)) (101 (61396 61380 NOLOCKSHIFT)) (102 (61398 61382 NOLOCKSHIFT)) (103 (8557 8554 NOLOCKSHIFT)) (104 (61399 61383 NOLOCKSHIFT)) (105 (61232 8743 NOLOCKSHIFT)) (106 (61346 8571 NOLOCKSHIFT)) (107 (188 86 NOLOCKSHIFT)) (108 (61402 61386 NOLOCKSHIFT) ) (109 (210 8738 NOLOCKSHIFT)) (110 (61437 61438 NOLOCKSHIFT)) (111 (163 8558 NOLOCKSHIFT)) (112 ( 61248 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (61395 61379 NOLOCKSHIFT)) (117 (61394 61378 NOLOCKSHIFT)) (118 (185 8553 NOLOCKSHIFT)) (119 (176 8546 NOLOCKSHIFT)) (120 (167 8744 NOLOCKSHIFT)) (121 (97 8745 NOLOCKSHIFT)) (122 (61401 61385 NOLOCKSHIFT)) (123 (162 8570 NOLOCKSHIFT)) (124 (61437 88 NOLOCKSHIFT)) (125 (111 8569 NOLOCKSHIFT)) (126 (61289 8737 NOLOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) (171 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (61393 61377 NOLOCKSHIFT)) ( 165 (27 27 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61233 8742 NOLOCKSHIFT)) (137 (61438 67 NOLOCKSHIFT)) (138 (8739 74 NOLOCKSHIFT)) (139 (190 61436 NOLOCKSHIFT)) (140 (189 90 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (61249 62 NOLOCKSHIFT)) (143 (61352 58 NOLOCKSHIFT)) ( 144 (13 13 NOLOCKSHIFT) . IGNORE) (208 (95 61280 NOLOCKSHIFT)) (148 (212 8574 NOLOCKSHIFT)) (149 ( 61354 8573 NOLOCKSHIFT)) (150 (61286 8741 NOLOCKSHIFT)) (151 (165 8572 NOLOCKSHIFT)) (152 (61368 8740 NOLOCKSHIFT)) (153 (61400 61384 NOLOCKSHIFT)) (154 (173 175 NOLOCKSHIFT)) (155 (172 174 NOLOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61406 61368 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DOVE) (DVORAK ((100 (49 42 NOLOCKSHIFT)) (101 (51 41 NOLOCKSHIFT)) (102 (57 37 NOLOCKSHIFT)) (103 (46 62 NOLOCKSHIFT)) (104 (48 38 NOLOCKSHIFT)) (105 (101 69 LOCKSHIFT)) (106 (103 71 LOCKSHIFT)) (107 (107 75 LOCKSHIFT)) (108 (54 45 NOLOCKSHIFT)) (109 (116 84 LOCKSHIFT)) (110 (56 95 NOLOCKSHIFT)) (111 (108 76 LOCKSHIFT)) (112 (122 90 LOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (53 40 NOLOCKSHIFT)) (117 (55 35 NOLOCKSHIFT)) (118 (44 60 NOLOCKSHIFT)) ( 119 (63 47 NOLOCKSHIFT)) (120 (111 79 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (52 164 NOLOCKSHIFT)) ( 123 (99 67 LOCKSHIFT)) (124 (113 81 LOCKSHIFT)) (125 (114 82 LOCKSHIFT)) (126 (110 78 LOCKSHIFT)) (127 (119 87 LOCKSHIFT)) (171 (44 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (33 64 NOLOCKSHIFT)) ( 165 (27 27 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (117 85 LOCKSHIFT)) (137 (106 74 LOCKSHIFT)) (138 (104 72 LOCKSHIFT)) (139 (120 88 LOCKSHIFT)) (140 (59 58 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (118 86 LOCKSHIFT)) (143 (115 83 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (208 (169 170 NOLOCKSHIFT)) (148 (112 80 LOCKSHIFT)) (149 (121 89 LOCKSHIFT)) (150 (105 73 LOCKSHIFT)) (151 (102 70 LOCKSHIFT)) (152 (100 68 LOCKSHIFT)) (153 (50 162 NOLOCKSHIFT)) (154 (98 66 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( 91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DOVE) (GREEK ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (9830 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (9829 9797 LOCKSHIFT)) (106 (9849 9817 LOCKSHIFT)) (107 (115 9814 LOCKSHIFT)) ( 108 (48 41 NOLOCKSHIFT)) (109 (9837 9805 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (9843 9811 LOCKSHIFT)) (112 (47 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (9853 9821 LOCKSHIFT)) (119 (9835 9803 LOCKSHIFT)) (120 (9846 9814 LOCKSHIFT )) (121 (9825 9793 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (9836 9804 LOCKSHIFT)) (124 (9851 9819 LOCKSHIFT)) (125 (9842 9810 LOCKSHIFT)) (126 (9838 9806 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) (171 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (165 (27 27 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (9850 9818 LOCKSHIFT)) (137 (9841 9809 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (9826 66 LOCKSHIFT)) (140 (9833 9801 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (208 (95 94 NOLOCKSHIFT)) (148 (9845 9813 LOCKSHIFT)) (149 (9848 9816 LOCKSHIFT)) (150 (9828 9796 LOCKSHIFT)) (151 (9852 9820 LOCKSHIFT)) (152 (9834 9802 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (9840 9808 LOCKSHIFT)) (155 (9839 9807 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) ( 158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DOVE) (ITALIAN ((171 (39 34 NOLOCKSHIFT)) (100 (53 61903 NOLOCKSHIFT)) (101 (52 61886 NOLOCKSHIFT)) (102 (54 61919 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (95 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 61872 NOLOCKSHIFT)) (117 (50 61857 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT) ) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (171 (39 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (165 (27 27 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT )) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (208 (95 170 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DOVE) (SPANISH ((208 (161 191 NOLOCKSHIFT)) (171 (59 58 NOLOCKSHIFT)) (100 (53 61904 NOLOCKSHIFT)) (101 (52 61887 NOLOCKSHIFT)) (102 (54 61920 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) ( 106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) ( 110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (95 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 61873 NOLOCKSHIFT)) (117 (50 61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (171 (59 58 NOLOCKSHIFT)) (129 (185 186 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (165 (27 27 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (61900 61772 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (208 (161 191 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61925 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) ( 158 (169 170 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DOVE) (FRENCH ((208 (61869 61741 NOLOCKSHIFT)) (171 (39 61857 NOLOCKSHIFT)) (100 (53 61905 NOLOCKSHIFT)) (101 (52 61888 NOLOCKSHIFT)) (102 (54 61921 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 ( 100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 ( 107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (95 63 NOLOCKSHIFT)) (115 ( 1 1 NOLOCKSHIFT) . IGNORE) (116 (51 61874 NOLOCKSHIFT)) (117 (50 61859 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (171 (39 61857 NOLOCKSHIFT)) (129 (61872 61892 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (165 (27 27 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (208 (61869 61741 LOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61919 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61873 61877 LOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DOVE) (GERMAN ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT )) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT) ) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT) ) (111 (112 80 LOCKSHIFT)) (112 (251 63 NOLOCKSHIFT)) (115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) (171 (39 34 NOLOCKSHIFT)) (129 (61863 61735 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (165 (27 27 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (208 (95 94 NOLOCKSHIFT)) ( 148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) ( 152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) ( 156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61908 61780 LOCKSHIFT)) (159 (61925 61797 LOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) DOVE) (STANDARD-RUSSIAN ((208 (41 40 NOLOCKSHIFT)) (171 (10073 10025 NOLOCKSHIFT)) (100 (34 52 NOLOCKSHIFT)) (101 (47 51 NOLOCKSHIFT)) (102 (58 53 NOLOCKSHIFT)) (103 (10085 10037 LOCKSHIFT)) (104 (44 54 NOLOCKSHIFT)) (105 (10067 10019 LOCKSHIFT)) ( 106 (10068 10020 LOCKSHIFT)) (107 (10078 10030 LOCKSHIFT)) (108 (63 57 NOLOCKSHIFT)) (109 (10077 10029 LOCKSHIFT)) (110 (37 48 NOLOCKSHIFT)) (111 (10073 10025 LOCKSHIFT)) (112 (10071 10023 LOCKSHIFT)) ( 115 (8 8 NOLOCKSHIFT) . IGNORE) (116 (45 50 NOLOCKSHIFT)) (117 (61352 49 NOLOCKSHIFT)) (118 (10088 10040 LOCKSHIFT)) (119 (10075 10027 LOCKSHIFT)) (120 (10093 10045 LOCKSHIFT)) (121 (10086 10038 LOCKSHIFT)) (122 (95 56 NOLOCKSHIFT)) (123 (10090 10042 LOCKSHIFT)) (124 (10089 10041 LOCKSHIFT)) (125 (10091 10043 LOCKSHIFT)) (126 (10069 10021 LOCKSHIFT)) (127 (10066 10018 LOCKSHIFT)) (171 (10095 10047 LOCKSHIFT)) (129 (10092 10044 LOCKSHIFT)) (132 (167 43 NOLOCKSHIFT)) (165 (27 27 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (10065 10017 LOCKSHIFT)) (137 (10083 10035 LOCKSHIFT)) ( 138 (10080 10032 LOCKSHIFT)) (139 (10074 10026 LOCKSHIFT)) (140 (10097 10049 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (10096 10048 LOCKSHIFT)) (143 (10072 10024 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (208 (41 40 NOLOCKSHIFT)) (148 (10076 10028 LOCKSHIFT)) (149 (10070 10022 LOCKSHIFT)) (150 (10081 10033 LOCKSHIFT)) (151 (10079 10031 LOCKSHIFT)) (152 (10082 10034 LOCKSHIFT)) (153 (46 55 NOLOCKSHIFT)) (154 (10084 10036 LOCKSHIFT)) (155 (10094 10046 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (10087 10039 LOCKSHIFT)) (159 (33 61 NOLOCKSHIFT)) ( 160 2SHIFTDOWN . 2SHIFTUP)) DOVE)) \ No newline at end of file diff --git a/library/DOVERS232C b/library/DOVERS232C new file mode 100644 index 00000000..959cc0d1 --- /dev/null +++ b/library/DOVERS232C @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "30-May-91 16:15:14" |{PELE:MV:ENVOS}LIBRARY>DOVERS232C.;3| 18719 changes to%: (VARS DOVERS232CCOMS) previous date%: "11-Jun-90 15:40:49" |{PELE:MV:ENVOS}LIBRARY>DOVERS232C.;2|) (* ; " Copyright (c) 1985, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DOVERS232CCOMS) (RPAQQ DOVERS232CCOMS [(COMS (* ; "Dove Rs232 Opie definitions") (DECLARE%: DONTCOPY (FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) MESATYPES (LOADCOMP) DOVEINPUTOUTPUT (SOURCE) DOVEDECLS (LOADCOMP) DOVEMISC) (EXPORT (RECORDS Dove.RSIOPSystemInputPort Dove.RSLatchedStatus Dove.RS232FlowControl) (RECORDS Dove.i8274.WR1 Dove.i8274.WR3 Dove.i8274.WR4 Dove.i8274.WR5 Dove.i8274.RR0 Dove.i8274.RR1) (RECORDS Dove.RS232DCB Dove.RS232FCB Dove.RS232HdlOnlyRecord Dove.RS232IOCB) (CONSTANTS * Dove.RS232CommandListConstants) (CONSTANTS * Dove.RS232MiscConstants) (CONSTANTS * Dove.RS232WorkListConstants) (CONSTANTS * Dove.RS232IOCBTypes) (CONSTANTS * Dove.i8274.WR1.Constants) (CONSTANTS * Dove.i8274.WR4.Constants) (CONSTANTS * Dove.i8274.WR5.Constants) (CONSTANTS * Dove.i8274.RR1.Constants) (CONSTANTS (DVRS232C.IOCB.SIZE 12]) (* ; "Dove Rs232 Opie definitions") (DECLARE%: DONTCOPY (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) MESATYPES (LOADCOMP) DOVEINPUTOUTPUT (SOURCE) DOVEDECLS (LOADCOMP) DOVEMISC) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (BLOCKRECORD Dove.RSIOPSystemInputPort ((NIL BYTE) (NIL BITS 5) (dataSetReady FLAG) (* active low) (ringIndicator FLAG) (* active low) (dataTerminalReady FLAG) (* active low) )) (BLOCKRECORD Dove.RSLatchedStatus ((NIL BITS 5) (ringHeard FLAG) (dataLost FLAG) (breakDetected FLAG))) (MESARECORD Dove.RS232FlowControl ((type WORD) (XOn WORD) (XOff WORD))) ) (DECLARE%: EVAL@COMPILE (BLOCKRECORD Dove.i8274.WR1 ((NIL BYTE) (* Padding so we can access this  with (LOCF (fetch (Dove.RS232DCB  rsWR1ofi8274) |...|))) (waitEnable FLAG) (NIL FLAG) (waitOnRxOrTx BITS 1) (interruptCondition BITS 2) (statusAffectsVector FLAG) (txIntDMAenable FLAG) (extInterruptEnable FLAG))) (BLOCKRECORD Dove.i8274.WR3 ((rxCharLength BITS 2) (autoEnable FLAG) (enterHuntMode FLAG) (rxCRCenable FLAG) (addrSearchMode FLAG) (syncCharLoadInhibit FLAG) (rxEnable FLAG))) (BLOCKRECORD Dove.i8274.WR4 ((NIL BYTE) (clockRate BITS 2) (synchCharControl BITS 2) (stopBits BITS 2) (parityOddOrEven BITS 1) (enableParity FLAG))) (BLOCKRECORD Dove.i8274.WR5 ((dtr FLAG) (txCharLength BITS 2) (sendBreak FLAG) (txEnable FLAG) (modeSDLCOrCRC16 BITS 1) (rts FLAG) (txCRCenable FLAG))) (BLOCKRECORD Dove.i8274.RR0 ((NIL BYTE) (break FLAG) (syncOnlyTxUnderrun FLAG) (cts FLAG) (synDetect FLAG) (carrierDetect FLAG) (txBufferEmpty FLAG) (chAIntPending FLAG) (rxCharAvailable FLAG)) [ACCESSFNS ((ctsReally (NOT (fetch (Dove.i8274.RR0 cts) of DATUM))) (synDetectReally (NOT (fetch (Dove.i8274.RR0 synDetect) of DATUM))) (carrierDetectReally (NOT (fetch (Dove.i8274.RR0 carrierDetect) of DATUM]) (BLOCKRECORD Dove.i8274.RR1 ((endOfFrameSDLCMode FLAG) (crcFramingError FLAG) (rxOverrunError FLAG) (parityError FLAG) (bitCharMode BITS 3) (allSent FLAG))) ) (DECLARE%: EVAL@COMPILE (MESARECORD Dove.RS232DCB ((rsIOPSystemInputPort WORD) (rsWorkList WORD) (rsCommandWorkList WORD) (rsBaudRateChA WORD) (rsWR0ofi8274 BYTE) (rsWR1ofi8274 BYTE) (rsWR3ofi8274 BYTE) (rsWR4ofi8274 BYTE) (rsWR5ofi8274 BYTE) (rsWR6ofi8274 BYTE) (rsWR7ofi8274 BYTE) (rsReadRegister0 BYTE) (rsReadRegister1 BYTE) (rsReadRegister2 BYTE) (rsLatchedStatus BYTE) (rsTTYHost BYTE) (rsClientType BYTE) (rs232Mode BYTE) (rs232FlowControl Dove.RS232FlowControl) (rsFrameTimeoutValue WORD) (rsClientConditionChA DoveIO.ClientCondition) (rs232ChAWork WORD) (txChAWork WORD) (txChAWaitXOn WORD) (rsEEpromImage 2 BYTE))) (MESARECORD Dove.RS232FCB ((rs232CMainTaskTcb DoveIO.TaskContextBlock) (txTaskChATcb DoveIO.TaskContextBlock) (specRxTaskChATcb DoveIO.TaskContextBlock) (rxTaskChATcb DoveIO.TaskContextBlock) (extStatChATcb DoveIO.TaskContextBlock) (rsQueueTxChA Dove.QueueBlock)(* Rs232 transmitter queue) (rsQueueRxChA Dove.QueueBlock)(* Rs232 receiver queue) (rs232LockMask WORD) (rs232WorkMask WORD))) (BLOCKRECORD Dove.RS232HdlOnlyRecord ((currentTxIOCBES WORD) (* Info on state of tx IOCB's) (currentTxIOCBDI WORD) (rsTxBufferES WORD) (rsTxBufferDI WORD) (rsBytesTransfered WORD) (* SIC!) (currentRxIOCBES WORD) (* Info on state of rx IOCB's) (currentRxIOCBDI WORD) (rsRxBufferES WORD) (rsRxBufferDI WORD) (rsBytesReceived WORD) (rsTxIOCBs WORD) (* error and status counters) (rsRxIOCBs WORD) (rsRxCRCErrorCnt WORD) (specErrorCount WORD) (rsOverRunErrors WORD) (badTxIntCnts WORD) (badRxIntCnts WORD) (badSpecRxIntCnts WORD) (badExtStatIntCnts WORD) (badTxIntTimeout WORD))) (BLOCKRECORD Dove.RS232IOCB ((rsLispSynchEvent POINTER) (* Notify this event when the  operation is complete) (rsUsedByMesa WORD) (* Contains a data buffer and a  length word) (rsTransferCountChA WORD) (* byte count in the buffer) (rsNextIocbChA 2 WORD) (* address of next IOCB) (currentOpStatus BYTE) (* current operation status) (rsIocbStatusByte0 BYTE) (* Read register 0 of the 8274) (rsIocbStatusByte1 BYTE) (* Read register 1 of the 8274) (rsIocbStatusByte2 BYTE) (* Read register 2 of the 8274) (rsBufferPtr 2 WORD) (* Pointer to the buffer) (rsBufferSize WORD) (* Size of buffer) (rsIOCBType BYTE) (* Tx or Rx IOCB) (rsActiveIOCB BYTE) (* Set when an IOCB is active,  cleared when not) )) ) (RPAQQ Dove.RS232CommandListConstants ((abortRx 32768) (clearAbortRx 32767) (abortTx 16384) (clearAbortTx 49151) (newTx 8192) (clearNewTx 57343) (getDeviceStatus 4096) (cleargetDevStat 61439) (rsCommandInProgress 2048) (noCommandInProgress 63487) (rtsCommand 1024) (dtrCommand 512))) (DECLARE%: EVAL@COMPILE (RPAQQ abortRx 32768) (RPAQQ clearAbortRx 32767) (RPAQQ abortTx 16384) (RPAQQ clearAbortTx 49151) (RPAQQ newTx 8192) (RPAQQ clearNewTx 57343) (RPAQQ getDeviceStatus 4096) (RPAQQ cleargetDevStat 61439) (RPAQQ rsCommandInProgress 2048) (RPAQQ noCommandInProgress 63487) (RPAQQ rtsCommand 1024) (RPAQQ dtrCommand 512) (CONSTANTS (abortRx 32768) (clearAbortRx 32767) (abortTx 16384) (clearAbortTx 49151) (newTx 8192) (clearNewTx 57343) (getDeviceStatus 4096) (cleargetDevStat 61439) (rsCommandInProgress 2048) (noCommandInProgress 63487) (rtsCommand 1024) (dtrCommand 512)) ) (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)) ) (RPAQQ Dove.RS232WorkListConstants ((workFori8274 32768) (rsWorkWR7 16384) (rsWorkWR6 8192) (rsWorkWR5 4096) (rsWorkWR4 2048) (rsWorkWR3 1024) (rsWorkWR1 512) (rsWorkWR0 256) (rsNewBaudRate 128) (rsChangeMode 64))) (DECLARE%: EVAL@COMPILE (RPAQQ workFori8274 32768) (RPAQQ rsWorkWR7 16384) (RPAQQ rsWorkWR6 8192) (RPAQQ rsWorkWR5 4096) (RPAQQ rsWorkWR4 2048) (RPAQQ rsWorkWR3 1024) (RPAQQ rsWorkWR1 512) (RPAQQ rsWorkWR0 256) (RPAQQ rsNewBaudRate 128) (RPAQQ rsChangeMode 64) (CONSTANTS (workFori8274 32768) (rsWorkWR7 16384) (rsWorkWR6 8192) (rsWorkWR5 4096) (rsWorkWR4 2048) (rsWorkWR3 1024) (rsWorkWR1 512) (rsWorkWR0 256) (rsNewBaudRate 128) (rsChangeMode 64)) ) (RPAQQ Dove.RS232IOCBTypes ((rsIOCBTypeRx 0) (rsIOCBTypeTx 1))) (DECLARE%: EVAL@COMPILE (RPAQQ rsIOCBTypeRx 0) (RPAQQ rsIOCBTypeTx 1) (CONSTANTS (rsIOCBTypeRx 0) (rsIOCBTypeTx 1)) ) (RPAQQ Dove.i8274.WR1.Constants ((waitOnTx 0) (waitOnRx 1) (rxIntDMAdisable 0) (rxIntOn1stCharOrSpecCondition 1) (intOnAllRxParityAffectsVector 2) (intOnAllRxParityNotAffectVector 3))) (DECLARE%: EVAL@COMPILE (RPAQQ waitOnTx 0) (RPAQQ waitOnRx 1) (RPAQQ rxIntDMAdisable 0) (RPAQQ rxIntOn1stCharOrSpecCondition 1) (RPAQQ intOnAllRxParityAffectsVector 2) (RPAQQ intOnAllRxParityNotAffectVector 3) (CONSTANTS (waitOnTx 0) (waitOnRx 1) (rxIntDMAdisable 0) (rxIntOn1stCharOrSpecCondition 1) (intOnAllRxParityAffectsVector 2) (intOnAllRxParityNotAffectVector 3)) ) (RPAQQ Dove.i8274.WR4.Constants ((enableSyncModes 0) (oneStopBit 1) (oneAndHalfStopBit 2) (twoStopBits 3) (parityOdd 0) (parityEven 1) (bitSync8 0) (BitSync16 1) (SdlcHdlc 2) (extSyncMode 3) (x1clk 0) (x16clk 1) (x32clk 2) (x64clk 3))) (DECLARE%: EVAL@COMPILE (RPAQQ enableSyncModes 0) (RPAQQ oneStopBit 1) (RPAQQ oneAndHalfStopBit 2) (RPAQQ twoStopBits 3) (RPAQQ parityOdd 0) (RPAQQ parityEven 1) (RPAQQ bitSync8 0) (RPAQQ BitSync16 1) (RPAQQ SdlcHdlc 2) (RPAQQ extSyncMode 3) (RPAQQ x1clk 0) (RPAQQ x16clk 1) (RPAQQ x32clk 2) (RPAQQ x64clk 3) (CONSTANTS (enableSyncModes 0) (oneStopBit 1) (oneAndHalfStopBit 2) (twoStopBits 3) (parityOdd 0) (parityEven 1) (bitSync8 0) (BitSync16 1) (SdlcHdlc 2) (extSyncMode 3) (x1clk 0) (x16clk 1) (x32clk 2) (x64clk 3)) ) (RPAQQ Dove.i8274.WR5.Constants ((ch5bits 0) (ch6bits 1) (ch7bits 2) (ch8bits 3) (SDLC 0) (CRC16 1))) (DECLARE%: EVAL@COMPILE (RPAQQ ch5bits 0) (RPAQQ ch6bits 1) (RPAQQ ch7bits 2) (RPAQQ ch8bits 3) (RPAQQ SDLC 0) (RPAQQ CRC16 1) (CONSTANTS (ch5bits 0) (ch6bits 1) (ch7bits 2) (ch8bits 3) (SDLC 0) (CRC16 1)) ) (RPAQQ Dove.i8274.RR1.Constants ((bitSyncResidue0 0) (bitSyncResidue1 1) (bitSyncResidue2 2) (bitSyncResidue3 3) (bitSyncResidue4 4) (bitSyncResidue5 5) (bitSyncResidue6 6) (bitSyncResidue7 7))) (DECLARE%: EVAL@COMPILE (RPAQQ bitSyncResidue0 0) (RPAQQ bitSyncResidue1 1) (RPAQQ bitSyncResidue2 2) (RPAQQ bitSyncResidue3 3) (RPAQQ bitSyncResidue4 4) (RPAQQ bitSyncResidue5 5) (RPAQQ bitSyncResidue6 6) (RPAQQ bitSyncResidue7 7) (CONSTANTS (bitSyncResidue0 0) (bitSyncResidue1 1) (bitSyncResidue2 2) (bitSyncResidue3 3) (bitSyncResidue4 4) (bitSyncResidue5 5) (bitSyncResidue6 6) (bitSyncResidue7 7)) ) (DECLARE%: EVAL@COMPILE (RPAQQ DVRS232C.IOCB.SIZE 12) (CONSTANTS (DVRS232C.IOCB.SIZE 12)) ) (* "END EXPORTED DEFINITIONS") ) (PUTPROPS DOVERS232C COPYRIGHT ("Venue & Xerox Corporation" 1985 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/library/EDITBITMAP b/library/EDITBITMAP new file mode 100644 index 00000000..83b6ddfc --- /dev/null +++ b/library/EDITBITMAP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "11-Jun-90 15:42:25" {DSK}local>lde>lispcore>library>EDITBITMAP.;2 19366 changes to%: (VARS EDITBITMAPCOMS) previous date%: " 7-Oct-86 15:47:41" {DSK}local>lde>lispcore>library>EDITBITMAP.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT EDITBITMAPCOMS) (RPAQQ EDITBITMAPCOMS [(FNS ADD.BORDER.TO.BITMAP BIT.IN.COLUMN BIT.IN.ROW EDIT.BITMAP EDIT.BITMAP.REAL FROM.SCREEN.BITMAP GET.EDIT.BITMAP.MENU INTERACT&SHIFT.BITMAP.LEFT INTERACT&SHIFT.BITMAP.RIGHT INTERACT&SHIFT.BITMAP.DOWN INTERACT&SHIFT.BITMAP.UP INTERACT&ADD.BORDER.TO.BITMAP INVERT.BITMAP.B/W INVERT.BITMAP.DIAGONALLY INVERT.BITMAP.HORIZONTALLY INVERT.BITMAP.VERTICALLY ROTATE.BITMAP.LEFT ROTATE.BITMAP.RIGHT SHIFT.BITMAP.DOWN SHIFT.BITMAP.LEFT SHIFT.BITMAP.RIGHT SHIFT.BITMAP.UP TRIM.BITMAP) (VARS (EDIT.BITMAP.MENU)) (GLOBALVARS EDIT.BITMAP.MENU PROMPTWINDOW BLACKSHADE) (FILES READNUMBER) (P (FONTCREATE '(GACHA 12 BOLD]) (DEFINEQ (ADD.BORDER.TO.BITMAP [LAMBDA (BITMAP NBITS TEXTURE) (* DAHJr "23-APR-83 12:23") (PROG ((WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) (REAL.NBITS (OR NBITS 2)) NEW.BITMAP) [SETQ NEW.BITMAP (BITMAPCREATE (IPLUS WIDTH (ITIMES REAL.NBITS 2)) (IPLUS HEIGHT (ITIMES REAL.NBITS 2] (BITBLT NIL NIL NIL NEW.BITMAP NIL NIL NIL NIL 'TEXTURE 'REPLACE (OR TEXTURE WHITESHADE)) (BITBLT BITMAP 0 0 NEW.BITMAP REAL.NBITS REAL.NBITS WIDTH HEIGHT 'INPUT 'REPLACE) (RETURN NEW.BITMAP]) (BIT.IN.COLUMN [LAMBDA (BITMAP COLUMN) (* AJB "11-Oct-85 16:07") (for X from 0 to (SUB1 (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) when (EQ 1 (BITMAPBIT BITMAP COLUMN X)) DO (RETURN T]) (BIT.IN.ROW [LAMBDA (BITMAP ROW) (* AJB "11-Oct-85 16:11") (for X from 0 to (SUB1 (fetch (BITMAP BITMAPWIDTH) of BITMAP)) when (EQ 1 (BITMAPBIT BITMAP X ROW)) DO (RETURN T]) (EDIT.BITMAP [LAMBDA (OBJECT) (* AJB " 7-Oct-86 15:46") (PROG (NEW.OBJECT BM) (RETURN (COND ((NULL OBJECT) (EDIT.BITMAP.REAL (BITMAPCREATE 50 50))) ((LITATOM OBJECT) (SETQ BM (EVAL OBJECT)) (SETQ NEW.OBJECT (EDIT.BITMAP BM)) (SET OBJECT NEW.OBJECT) OBJECT) ((BITMAPP OBJECT) (EDIT.BITMAP.REAL OBJECT)) ((CURSORP OBJECT) (SETQ NEW.OBJECT (EDIT.BITMAP.REAL (fetch (CURSOR CUIMAGE) of OBJECT))) (CURSORCREATE NEW.OBJECT (fetch (CURSOR CUHOTSPOTX) of OBJECT) (fetch (CURSOR CUHOTSPOTY) of OBJECT))) (T (ERROR "Object of unrecognized type: " OBJECT]) (EDIT.BITMAP.REAL [LAMBDA (BITMAP) (* rrb "11-AUG-83 13:31") (PROG (NEW.BITMAP COMMAND.MENU DONE COMMAND PREVIOUS.BITMAP NAME TEMP X Y) (SETQ NEW.BITMAP (BITMAPCOPY BITMAP)) (SETQ COMMAND.MENU (GET.EDIT.BITMAP.MENU)) [until DONE do (SETQ COMMAND (MENU COMMAND.MENU)) (CLEARW PROMPTWINDOW) (SELECTQ COMMAND (NIL NIL) (QUIT (SETQ DONE T)) (UNDO (COND (PREVIOUS.BITMAP (SETQ NEW.BITMAP (CAR PREVIOUS.BITMAP)) (SETQ PREVIOUS.BITMAP (CDR PREVIOUS.BITMAP))) (T (printout PROMPTWINDOW T "Can't: no previous bitmap saved")))) (PROGN (SETQ PREVIOUS.BITMAP (CONS NEW.BITMAP PREVIOUS.BITMAP)) (SETQ NEW.BITMAP (SELECTQ COMMAND (HAND.EDIT (EDITBM NEW.BITMAP)) (FROM.SCREEN (FROM.SCREEN.BITMAP)) (TRIM (TRIM.BITMAP NEW.BITMAP)) (INVERT.HORIZONTALLY (INVERT.BITMAP.HORIZONTALLY NEW.BITMAP)) (INVERT.VERTICALLY (INVERT.BITMAP.VERTICALLY NEW.BITMAP)) (INVERT.DIAGONALLY (INVERT.BITMAP.DIAGONALLY NEW.BITMAP)) (ROTATE.BITMAP.LEFT (ROTATE.BITMAP.LEFT NEW.BITMAP)) (ROTATE.BITMAP.RIGHT (ROTATE.BITMAP.RIGHT NEW.BITMAP)) (SHIFT.LEFT (  INTERACT&SHIFT.BITMAP.LEFT NEW.BITMAP)) (SHIFT.RIGHT (  INTERACT&SHIFT.BITMAP.RIGHT NEW.BITMAP)) (SHIFT.DOWN (  INTERACT&SHIFT.BITMAP.DOWN NEW.BITMAP)) (SHIFT.UP (INTERACT&SHIFT.BITMAP.UP NEW.BITMAP)) (INTERCHANGE.BLACK/WHITE (INVERT.BITMAP.B/W NEW.BITMAP)) (ADD.BORDER (  INTERACT&ADD.BORDER.TO.BITMAP NEW.BITMAP)) (ERROR "Unrecognized command" COMMAND ] (RETURN NEW.BITMAP]) (FROM.SCREEN.BITMAP [LAMBDA NIL (* kbr%: "26-Feb-86 00:16") (PROG (SCREENREGION SCREEN REGION NEW.BITMAP) (printout PROMPTWINDOW T "Indicate a region from which to take bits") (SETQ SCREENREGION (GETSCREENREGION)) (SETQ SCREEN (fetch (SCREENREGION SCREEN) of SCREENREGION)) (SETQ REGION (fetch (SCREENREGION REGION) of SCREENREGION)) [SETQ NEW.BITMAP (BITMAPCREATE (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) (BITSPERPIXEL (SCREENBITMAP SCREEN] (BITBLT (SCREENBITMAP SCREEN) (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) NEW.BITMAP 0 0 (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) 'INPUT 'REPLACE) (RETURN NEW.BITMAP]) (GET.EDIT.BITMAP.MENU [LAMBDA NIL (* DAHJr " 7-JUL-83 17:13") (* EVAL THIS WHEN CHANGING THE MENU  (SETQ EDIT.BITMAP.MENU)) (OR EDIT.BITMAP.MENU (SETQ EDIT.BITMAP.MENU (create MENU TITLE _ "Operations on bitmaps" ITEMS _ '(HAND.EDIT FROM.SCREEN TRIM INVERT.HORIZONTALLY INVERT.VERTICALLY INVERT.DIAGONALLY ROTATE.BITMAP.LEFT ROTATE.BITMAP.RIGHT SHIFT.LEFT SHIFT.RIGHT SHIFT.DOWN SHIFT.UP INTERCHANGE.BLACK/WHITE ADD.BORDER UNDO QUIT) CENTERFLG _ T CHANGEOFFSETFLG _ T]) (INTERACT&SHIFT.BITMAP.LEFT [LAMBDA (BITMAP) (* edited%: "17-DEC-82 08:31") (PROG (NBITS NEW.BITMAP) (SETQ NBITS (RNUMBER "Number of bits to shift the bitmap left: ")) (RETURN (SHIFT.BITMAP.LEFT BITMAP NBITS]) (INTERACT&SHIFT.BITMAP.RIGHT [LAMBDA (BITMAP) (* edited%: "17-DEC-82 08:31") (PROG (NBITS NEW.BITMAP) (SETQ NBITS (RNUMBER "Number of bits to shift the bitmap right: ")) (RETURN (SHIFT.BITMAP.RIGHT BITMAP NBITS]) (INTERACT&SHIFT.BITMAP.DOWN [LAMBDA (BITMAP) (* DAHJr "23-MAR-83 14:39") (PROG (NBITS) (SETQ NBITS (RNUMBER "Number of bits to shift the bitmap down: ")) (RETURN (SHIFT.BITMAP.DOWN BITMAP NBITS]) (INTERACT&SHIFT.BITMAP.UP [LAMBDA (BITMAP) (* edited%: "17-DEC-82 08:31") (PROG (NBITS NEW.BITMAP) (SETQ NBITS (RNUMBER "Number of bits to shift the bitmap up: ")) (RETURN (SHIFT.BITMAP.UP BITMAP NBITS]) (INTERACT&ADD.BORDER.TO.BITMAP [LAMBDA (BITMAP) (* rrb "24-Jul-84 18:12") (PROG (NBITS TEXTURE) (COND ((EQ (SETQ NBITS (RNUMBER "Number of bits in the border: ")) 0) (RETURN BITMAP)) ((GREATERP 0 NBITS) (PROMPTPRINT "Can't add a negative border.") (RETURN BITMAP)) ((GREATERP NBITS 500) (PROMPTPRINT "Can't add a border of more than 500.") (RETURN BITMAP))) (SETQ TEXTURE (EDITSHADE)) (RETURN (ADD.BORDER.TO.BITMAP BITMAP NBITS TEXTURE]) (INVERT.BITMAP.B/W [LAMBDA (BITMAP) (* HK "12-JUL-82 11:19") (PROG ((WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) (NEW.BITMAP (BITMAPCOPY BITMAP))) (BITBLT BITMAP 0 0 NEW.BITMAP 0 0 WIDTH HEIGHT 'TEXTURE 'INVERT BLACKSHADE) (RETURN NEW.BITMAP]) (INVERT.BITMAP.DIAGONALLY [LAMBDA (BITMAP) (* HK "12-JUL-82 16:02") (PROG (NEW.BITMAP (WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP))) (SETQ NEW.BITMAP (BITMAPCREATE HEIGHT WIDTH)) [for X from 0 to (SUB1 WIDTH) do (for Y from 0 to (SUB1 HEIGHT) do (BITMAPBIT NEW.BITMAP Y X (BITMAPBIT BITMAP X Y] (RETURN NEW.BITMAP]) (INVERT.BITMAP.HORIZONTALLY [LAMBDA (BITMAP) (* HK "12-JUL-82 11:28") (PROG ((WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) (NEW.BITMAP (BITMAPCOPY BITMAP))) [for X1 from 0 to (SUB1 (IQUOTIENT WIDTH 2)) do (for Y from 0 to (SUB1 HEIGHT) bind (X2 _ (IDIFFERENCE (SUB1 WIDTH) X1)) do (BITMAPBIT NEW.BITMAP X1 Y (BITMAPBIT BITMAP X2 Y)) (BITMAPBIT NEW.BITMAP X2 Y (BITMAPBIT BITMAP X1 Y] (RETURN NEW.BITMAP]) (INVERT.BITMAP.VERTICALLY [LAMBDA (BITMAP) (* HK "12-JUL-82 11:33") (PROG ((WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) (NEW.BITMAP (BITMAPCOPY BITMAP))) [for X1 from 0 to (SUB1 (IQUOTIENT HEIGHT 2)) do (for Y from 0 to (SUB1 WIDTH) bind (X2 _ (IDIFFERENCE (SUB1 HEIGHT) X1)) do (BITMAPBIT NEW.BITMAP Y X1 (BITMAPBIT BITMAP Y X2)) (BITMAPBIT NEW.BITMAP Y X2 (BITMAPBIT BITMAP Y X1] (RETURN NEW.BITMAP]) (ROTATE.BITMAP.LEFT [LAMBDA (BITMAP) (* HK "12-JUL-82 11:48") (PROG (NEW.BITMAP (WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP))) (SETQ NEW.BITMAP (BITMAPCREATE HEIGHT WIDTH)) [for Y from 0 to (SUB1 HEIGHT) do (for X from 0 to (SUB1 WIDTH) bind (Y1 _ (IDIFFERENCE (SUB1 HEIGHT) Y)) do (BITMAPBIT NEW.BITMAP Y1 X (BITMAPBIT BITMAP X Y] (RETURN NEW.BITMAP]) (ROTATE.BITMAP.RIGHT [LAMBDA (BITMAP) (* HK "12-JUL-82 11:50") (PROG (NEW.BITMAP (WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP))) (SETQ NEW.BITMAP (BITMAPCREATE HEIGHT WIDTH)) [for X from 0 to (SUB1 WIDTH) do (for Y from 0 to (SUB1 HEIGHT) bind (X1 _ (IDIFFERENCE (SUB1 WIDTH) X)) do (BITMAPBIT NEW.BITMAP Y X1 (BITMAPBIT BITMAP X Y] (RETURN NEW.BITMAP]) (SHIFT.BITMAP.DOWN [LAMBDA (BITMAP NBITS) (* edited%: "21-OCT-82 16:20") (PROG ((WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) NEW.BITMAP) (SETQ NEW.BITMAP (BITMAPCREATE WIDTH (IPLUS HEIGHT NBITS))) (BITBLT BITMAP 0 0 NEW.BITMAP 0 0 WIDTH HEIGHT 'INPUT 'REPLACE) (RETURN NEW.BITMAP]) (SHIFT.BITMAP.LEFT [LAMBDA (BITMAP NBITS) (* edited%: "21-OCT-82 16:16") (PROG ((WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) NEW.BITMAP) (SETQ NEW.BITMAP (BITMAPCREATE (IPLUS WIDTH NBITS) HEIGHT)) (BITBLT BITMAP 0 0 NEW.BITMAP 0 0 WIDTH HEIGHT 'INPUT 'REPLACE) (RETURN NEW.BITMAP]) (SHIFT.BITMAP.RIGHT [LAMBDA (BITMAP NBITS) (* edited%: "21-OCT-82 16:17") (PROG ((WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) NEW.BITMAP) (SETQ NEW.BITMAP (BITMAPCREATE (IPLUS WIDTH NBITS) HEIGHT)) (BITBLT BITMAP 0 0 NEW.BITMAP NBITS 0 WIDTH HEIGHT 'INPUT 'REPLACE) (RETURN NEW.BITMAP]) (SHIFT.BITMAP.UP [LAMBDA (BITMAP NBITS) (* edited%: "21-OCT-82 16:18") (PROG ((WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) NEW.BITMAP) (SETQ NEW.BITMAP (BITMAPCREATE WIDTH (IPLUS HEIGHT NBITS))) (BITBLT BITMAP 0 0 NEW.BITMAP 0 NBITS WIDTH HEIGHT 'INPUT 'REPLACE) (RETURN NEW.BITMAP]) (TRIM.BITMAP [LAMBDA (BITMAP) (* HK "20-JUL-82 15:59") (PROG ((WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) LEFT RIGHT BOTTOM TOP NEW.BITMAP) (SETQ LEFT (for X from 0 to (SUB1 WIDTH) thereis (BIT.IN.COLUMN BITMAP X))) (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))) (OR (AND LEFT RIGHT BOTTOM TOP) (HELP)) [SETQ NEW.BITMAP (BITMAPCREATE (ADD1 (IDIFFERENCE RIGHT LEFT)) (ADD1 (IDIFFERENCE TOP BOTTOM] (BITBLT BITMAP LEFT BOTTOM NEW.BITMAP 0 0 (ADD1 (IDIFFERENCE RIGHT LEFT)) (ADD1 (IDIFFERENCE TOP BOTTOM)) 'INPUT 'REPLACE) (RETURN NEW.BITMAP]) ) (RPAQQ EDIT.BITMAP.MENU NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS EDIT.BITMAP.MENU PROMPTWINDOW BLACKSHADE) ) (FILESLOAD READNUMBER) (FONTCREATE '(GACHA 12 BOLD)) (PUTPROPS EDITBITMAP COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1199 19075 (ADD.BORDER.TO.BITMAP 1209 . 1891) (BIT.IN.COLUMN 1893 . 2160) (BIT.IN.ROW 2162 . 2422) (EDIT.BITMAP 2424 . 3474) (EDIT.BITMAP.REAL 3476 . 8053) (FROM.SCREEN.BITMAP 8055 . 9103) (GET.EDIT.BITMAP.MENU 9105 . 9912) (INTERACT&SHIFT.BITMAP.LEFT 9914 . 10203) ( INTERACT&SHIFT.BITMAP.RIGHT 10205 . 10497) (INTERACT&SHIFT.BITMAP.DOWN 10499 . 10774) ( INTERACT&SHIFT.BITMAP.UP 10776 . 11059) (INTERACT&ADD.BORDER.TO.BITMAP 11061 . 11715) ( INVERT.BITMAP.B/W 11717 . 12125) (INVERT.BITMAP.DIAGONALLY 12127 . 12679) (INVERT.BITMAP.HORIZONTALLY 12681 . 13549) (INVERT.BITMAP.VERTICALLY 13551 . 14375) (ROTATE.BITMAP.LEFT 14377 . 15126) ( ROTATE.BITMAP.RIGHT 15128 . 15829) (SHIFT.BITMAP.DOWN 15831 . 16281) (SHIFT.BITMAP.LEFT 16283 . 16767) (SHIFT.BITMAP.RIGHT 16769 . 17258) (SHIFT.BITMAP.UP 17260 . 17712) (TRIM.BITMAP 17714 . 19073))))) STOP \ No newline at end of file diff --git a/library/ETHERRECORDS b/library/ETHERRECORDS new file mode 100644 index 00000000..5f8d497e --- /dev/null +++ b/library/ETHERRECORDS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "20-Jan-93 13:50:03" {DSK}lde>lispcore>library>ETHERRECORDS.;2 29958 changes to%: (RECORDS ETHERPACKET SYSQUEUE QABLEITEM PUP ERRORPUP PUPADDRESS XIP ERRORXIP NSHOSTNUMBER NSADDRESS NSNAME) previous date%: "17-Dec-92 14:33:27" {DSK}lde>lispcore>library>ETHERRECORDS.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1987, 1990, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ETHERRECORDSCOMS) (RPAQQ ETHERRECORDSCOMS ((RECORDS ETHERPACKET SYSQUEUE QABLEITEM) (COMS (* ; "Pup things") (RECORDS PUP ERRORPUP PUPADDRESS) (MACROS \LOCALPUPADDRESS \LOCALPUPHOSTNUMBER \LOCALPUPNETNUMBER) (CONSTANTS (\PUPOVLEN 22) (\MAX.PUPDATALENGTH 532)) (CONSTANTS * PUPERRORCODES)) (COMS (* ; "XIP things") (RECORDS XIP ERRORXIP NSHOSTNUMBER NSADDRESS NSNAME) (CONSTANTS (\XIPOVLEN 30) (\MAX.XIPDATALENGTH 546)) (CONSTANTS * XIPERRORCODES)))) (DECLARE%: EVAL@COMPILE (DATATYPE ETHERPACKET ((NIL BYTE) (EPLINK POINTER) (* ; "For queue maintenence") (EPFLAGS BYTE) (* ;  "optional flags for some applications") (EPUSERFIELD POINTER) (* ;  "Arbitrary pointer for applications") (NIL BYTE) (EPPLIST POINTER) (* ;  "Extra field for use as an A-list for properties") (EPTRANSMITTING FLAG) (* ;  "True while packet is being transmitted and hence cannot be reused") (EPRECEIVING FLAG) (* ;  "True when a packet has been seen at the head of the network's input queue at least once") (NIL BITS 6) (EPREQUEUE POINTER) (* ;  "Where to requeue this packet after transmission") (NIL BYTE) (EPSOCKET POINTER) (NIL BYTE) (EPNETWORK POINTER) (EPTYPE WORD) (* ;  "Type of packet to be encapsulated (PUP or XIP or 10TO3)") (NIL WORD) (EPTIMESTAMP FIXP) (* ;  "Gets RCLK value when transmitted/received") (EPREQUEUEFN POINTER) (* ; "FN to perform requeueing") (NIL 4 WORD) (* ; "Space for expansion") (* ;  "Note: This next field wants to be quad+2 aligned so that the 10mb packet is quad+3 aligned") (EPENCAPSULATION 8 WORD) (* ;  "10mb encapsulation, or 3mb encapsulation with padding") (EPBODY 289 WORD) (* ;  "Body of packet, header up to 16 words plus data up to 546 bytes") )) (DATATYPE SYSQUEUE ((NIL BYTE) (SYSQUEUEHEAD POINTER) (NIL BYTE) (SYSQUEUETAIL POINTER))) (BLOCKRECORD QABLEITEM ((NIL BITS 4) (QLINK POINTER) (* ;  "Link to next thing in queue always in first pointer of datum, independent of what the datum is") ) (BLOCKRECORD QABLEITEM ((NIL BITS 4) (LINK POINTER) (* ;  "Let's also be able to call it a LINK") ))) ) (/DECLAREDATATYPE 'ETHERPACKET '(BYTE POINTER BYTE POINTER BYTE POINTER FLAG FLAG (BITS 6) POINTER BYTE POINTER BYTE POINTER WORD WORD FIXP POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD) '((ETHERPACKET 0 (BITS . 7)) (ETHERPACKET 2 POINTER) (ETHERPACKET 1 (BITS . 7)) (ETHERPACKET 4 POINTER) (ETHERPACKET 1 (BITS . 135)) (ETHERPACKET 6 POINTER) (ETHERPACKET 6 (FLAGBITS . 0)) (ETHERPACKET 6 (FLAGBITS . 16)) (ETHERPACKET 0 (BITS . 133)) (ETHERPACKET 8 POINTER) (ETHERPACKET 10 (BITS . 7)) (ETHERPACKET 12 POINTER) (ETHERPACKET 11 (BITS . 7)) (ETHERPACKET 14 POINTER) (ETHERPACKET 16 (BITS . 15)) (ETHERPACKET 17 (BITS . 15)) (ETHERPACKET 18 FIXP) (ETHERPACKET 20 POINTER) (ETHERPACKET 22 (BITS . 15)) (ETHERPACKET 23 (BITS . 15)) (ETHERPACKET 24 (BITS . 15)) (ETHERPACKET 25 (BITS . 15)) (ETHERPACKET 26 (BITS . 15)) (ETHERPACKET 27 (BITS . 15)) (ETHERPACKET 28 (BITS . 15)) (ETHERPACKET 29 (BITS . 15)) (ETHERPACKET 30 (BITS . 15)) (ETHERPACKET 31 (BITS . 15)) (ETHERPACKET 32 (BITS . 15)) (ETHERPACKET 33 (BITS . 15)) (ETHERPACKET 34 (BITS . 15)) (ETHERPACKET 35 (BITS . 15)) (ETHERPACKET 36 (BITS . 15)) (ETHERPACKET 37 (BITS . 15)) (ETHERPACKET 38 (BITS . 15)) (ETHERPACKET 39 (BITS . 15)) (ETHERPACKET 40 (BITS . 15)) (ETHERPACKET 41 (BITS . 15)) (ETHERPACKET 42 (BITS . 15)) (ETHERPACKET 43 (BITS . 15)) (ETHERPACKET 44 (BITS . 15)) (ETHERPACKET 45 (BITS . 15)) (ETHERPACKET 46 (BITS . 15)) (ETHERPACKET 47 (BITS . 15)) (ETHERPACKET 48 (BITS . 15)) (ETHERPACKET 49 (BITS . 15)) (ETHERPACKET 50 (BITS . 15)) (ETHERPACKET 51 (BITS . 15)) (ETHERPACKET 52 (BITS . 15)) (ETHERPACKET 53 (BITS . 15)) (ETHERPACKET 54 (BITS . 15)) (ETHERPACKET 55 (BITS . 15)) (ETHERPACKET 56 (BITS . 15)) (ETHERPACKET 57 (BITS . 15)) (ETHERPACKET 58 (BITS . 15)) (ETHERPACKET 59 (BITS . 15)) (ETHERPACKET 60 (BITS . 15)) (ETHERPACKET 61 (BITS . 15)) (ETHERPACKET 62 (BITS . 15)) (ETHERPACKET 63 (BITS . 15)) (ETHERPACKET 64 (BITS . 15)) (ETHERPACKET 65 (BITS . 15)) (ETHERPACKET 66 (BITS . 15)) (ETHERPACKET 67 (BITS . 15)) (ETHERPACKET 68 (BITS . 15)) (ETHERPACKET 69 (BITS . 15)) (ETHERPACKET 70 (BITS . 15)) (ETHERPACKET 71 (BITS . 15)) (ETHERPACKET 72 (BITS . 15)) (ETHERPACKET 73 (BITS . 15)) (ETHERPACKET 74 (BITS . 15)) (ETHERPACKET 75 (BITS . 15)) (ETHERPACKET 76 (BITS . 15)) (ETHERPACKET 77 (BITS . 15)) (ETHERPACKET 78 (BITS . 15)) (ETHERPACKET 79 (BITS . 15)) (ETHERPACKET 80 (BITS . 15)) (ETHERPACKET 81 (BITS . 15)) (ETHERPACKET 82 (BITS . 15)) (ETHERPACKET 83 (BITS . 15)) (ETHERPACKET 84 (BITS . 15)) (ETHERPACKET 85 (BITS . 15)) (ETHERPACKET 86 (BITS . 15)) (ETHERPACKET 87 (BITS . 15)) (ETHERPACKET 88 (BITS . 15)) (ETHERPACKET 89 (BITS . 15)) (ETHERPACKET 90 (BITS . 15)) (ETHERPACKET 91 (BITS . 15)) (ETHERPACKET 92 (BITS . 15)) (ETHERPACKET 93 (BITS . 15)) (ETHERPACKET 94 (BITS . 15)) (ETHERPACKET 95 (BITS . 15)) (ETHERPACKET 96 (BITS . 15)) (ETHERPACKET 97 (BITS . 15)) (ETHERPACKET 98 (BITS . 15)) (ETHERPACKET 99 (BITS . 15)) (ETHERPACKET 100 (BITS . 15)) (ETHERPACKET 101 (BITS . 15)) (ETHERPACKET 102 (BITS . 15)) (ETHERPACKET 103 (BITS . 15)) (ETHERPACKET 104 (BITS . 15)) (ETHERPACKET 105 (BITS . 15)) (ETHERPACKET 106 (BITS . 15)) (ETHERPACKET 107 (BITS . 15)) (ETHERPACKET 108 (BITS . 15)) (ETHERPACKET 109 (BITS . 15)) (ETHERPACKET 110 (BITS . 15)) (ETHERPACKET 111 (BITS . 15)) (ETHERPACKET 112 (BITS . 15)) (ETHERPACKET 113 (BITS . 15)) (ETHERPACKET 114 (BITS . 15)) (ETHERPACKET 115 (BITS . 15)) (ETHERPACKET 116 (BITS . 15)) (ETHERPACKET 117 (BITS . 15)) (ETHERPACKET 118 (BITS . 15)) (ETHERPACKET 119 (BITS . 15)) (ETHERPACKET 120 (BITS . 15)) (ETHERPACKET 121 (BITS . 15)) (ETHERPACKET 122 (BITS . 15)) (ETHERPACKET 123 (BITS . 15)) (ETHERPACKET 124 (BITS . 15)) (ETHERPACKET 125 (BITS . 15)) (ETHERPACKET 126 (BITS . 15)) (ETHERPACKET 127 (BITS . 15)) (ETHERPACKET 128 (BITS . 15)) (ETHERPACKET 129 (BITS . 15)) (ETHERPACKET 130 (BITS . 15)) (ETHERPACKET 131 (BITS . 15)) (ETHERPACKET 132 (BITS . 15)) (ETHERPACKET 133 (BITS . 15)) (ETHERPACKET 134 (BITS . 15)) (ETHERPACKET 135 (BITS . 15)) (ETHERPACKET 136 (BITS . 15)) (ETHERPACKET 137 (BITS . 15)) (ETHERPACKET 138 (BITS . 15)) (ETHERPACKET 139 (BITS . 15)) (ETHERPACKET 140 (BITS . 15)) (ETHERPACKET 141 (BITS . 15)) (ETHERPACKET 142 (BITS . 15)) (ETHERPACKET 143 (BITS . 15)) (ETHERPACKET 144 (BITS . 15)) (ETHERPACKET 145 (BITS . 15)) (ETHERPACKET 146 (BITS . 15)) (ETHERPACKET 147 (BITS . 15)) (ETHERPACKET 148 (BITS . 15)) (ETHERPACKET 149 (BITS . 15)) (ETHERPACKET 150 (BITS . 15)) (ETHERPACKET 151 (BITS . 15)) (ETHERPACKET 152 (BITS . 15)) (ETHERPACKET 153 (BITS . 15)) (ETHERPACKET 154 (BITS . 15)) (ETHERPACKET 155 (BITS . 15)) (ETHERPACKET 156 (BITS . 15)) (ETHERPACKET 157 (BITS . 15)) (ETHERPACKET 158 (BITS . 15)) (ETHERPACKET 159 (BITS . 15)) (ETHERPACKET 160 (BITS . 15)) (ETHERPACKET 161 (BITS . 15)) (ETHERPACKET 162 (BITS . 15)) (ETHERPACKET 163 (BITS . 15)) (ETHERPACKET 164 (BITS . 15)) (ETHERPACKET 165 (BITS . 15)) (ETHERPACKET 166 (BITS . 15)) (ETHERPACKET 167 (BITS . 15)) (ETHERPACKET 168 (BITS . 15)) (ETHERPACKET 169 (BITS . 15)) (ETHERPACKET 170 (BITS . 15)) (ETHERPACKET 171 (BITS . 15)) (ETHERPACKET 172 (BITS . 15)) (ETHERPACKET 173 (BITS . 15)) (ETHERPACKET 174 (BITS . 15)) (ETHERPACKET 175 (BITS . 15)) (ETHERPACKET 176 (BITS . 15)) (ETHERPACKET 177 (BITS . 15)) (ETHERPACKET 178 (BITS . 15)) (ETHERPACKET 179 (BITS . 15)) (ETHERPACKET 180 (BITS . 15)) (ETHERPACKET 181 (BITS . 15)) (ETHERPACKET 182 (BITS . 15)) (ETHERPACKET 183 (BITS . 15)) (ETHERPACKET 184 (BITS . 15)) (ETHERPACKET 185 (BITS . 15)) (ETHERPACKET 186 (BITS . 15)) (ETHERPACKET 187 (BITS . 15)) (ETHERPACKET 188 (BITS . 15)) (ETHERPACKET 189 (BITS . 15)) (ETHERPACKET 190 (BITS . 15)) (ETHERPACKET 191 (BITS . 15)) (ETHERPACKET 192 (BITS . 15)) (ETHERPACKET 193 (BITS . 15)) (ETHERPACKET 194 (BITS . 15)) (ETHERPACKET 195 (BITS . 15)) (ETHERPACKET 196 (BITS . 15)) (ETHERPACKET 197 (BITS . 15)) (ETHERPACKET 198 (BITS . 15)) (ETHERPACKET 199 (BITS . 15)) (ETHERPACKET 200 (BITS . 15)) (ETHERPACKET 201 (BITS . 15)) (ETHERPACKET 202 (BITS . 15)) (ETHERPACKET 203 (BITS . 15)) (ETHERPACKET 204 (BITS . 15)) (ETHERPACKET 205 (BITS . 15)) (ETHERPACKET 206 (BITS . 15)) (ETHERPACKET 207 (BITS . 15)) (ETHERPACKET 208 (BITS . 15)) (ETHERPACKET 209 (BITS . 15)) (ETHERPACKET 210 (BITS . 15)) (ETHERPACKET 211 (BITS . 15)) (ETHERPACKET 212 (BITS . 15)) (ETHERPACKET 213 (BITS . 15)) (ETHERPACKET 214 (BITS . 15)) (ETHERPACKET 215 (BITS . 15)) (ETHERPACKET 216 (BITS . 15)) (ETHERPACKET 217 (BITS . 15)) (ETHERPACKET 218 (BITS . 15)) (ETHERPACKET 219 (BITS . 15)) (ETHERPACKET 220 (BITS . 15)) (ETHERPACKET 221 (BITS . 15)) (ETHERPACKET 222 (BITS . 15)) (ETHERPACKET 223 (BITS . 15)) (ETHERPACKET 224 (BITS . 15)) (ETHERPACKET 225 (BITS . 15)) (ETHERPACKET 226 (BITS . 15)) (ETHERPACKET 227 (BITS . 15)) (ETHERPACKET 228 (BITS . 15)) (ETHERPACKET 229 (BITS . 15)) (ETHERPACKET 230 (BITS . 15)) (ETHERPACKET 231 (BITS . 15)) (ETHERPACKET 232 (BITS . 15)) (ETHERPACKET 233 (BITS . 15)) (ETHERPACKET 234 (BITS . 15)) (ETHERPACKET 235 (BITS . 15)) (ETHERPACKET 236 (BITS . 15)) (ETHERPACKET 237 (BITS . 15)) (ETHERPACKET 238 (BITS . 15)) (ETHERPACKET 239 (BITS . 15)) (ETHERPACKET 240 (BITS . 15)) (ETHERPACKET 241 (BITS . 15)) (ETHERPACKET 242 (BITS . 15)) (ETHERPACKET 243 (BITS . 15)) (ETHERPACKET 244 (BITS . 15)) (ETHERPACKET 245 (BITS . 15)) (ETHERPACKET 246 (BITS . 15)) (ETHERPACKET 247 (BITS . 15)) (ETHERPACKET 248 (BITS . 15)) (ETHERPACKET 249 (BITS . 15)) (ETHERPACKET 250 (BITS . 15)) (ETHERPACKET 251 (BITS . 15)) (ETHERPACKET 252 (BITS . 15)) (ETHERPACKET 253 (BITS . 15)) (ETHERPACKET 254 (BITS . 15)) (ETHERPACKET 255 (BITS . 15)) (ETHERPACKET 256 (BITS . 15)) (ETHERPACKET 257 (BITS . 15)) (ETHERPACKET 258 (BITS . 15)) (ETHERPACKET 259 (BITS . 15)) (ETHERPACKET 260 (BITS . 15)) (ETHERPACKET 261 (BITS . 15)) (ETHERPACKET 262 (BITS . 15)) (ETHERPACKET 263 (BITS . 15)) (ETHERPACKET 264 (BITS . 15)) (ETHERPACKET 265 (BITS . 15)) (ETHERPACKET 266 (BITS . 15)) (ETHERPACKET 267 (BITS . 15)) (ETHERPACKET 268 (BITS . 15)) (ETHERPACKET 269 (BITS . 15)) (ETHERPACKET 270 (BITS . 15)) (ETHERPACKET 271 (BITS . 15)) (ETHERPACKET 272 (BITS . 15)) (ETHERPACKET 273 (BITS . 15)) (ETHERPACKET 274 (BITS . 15)) (ETHERPACKET 275 (BITS . 15)) (ETHERPACKET 276 (BITS . 15)) (ETHERPACKET 277 (BITS . 15)) (ETHERPACKET 278 (BITS . 15)) (ETHERPACKET 279 (BITS . 15)) (ETHERPACKET 280 (BITS . 15)) (ETHERPACKET 281 (BITS . 15)) (ETHERPACKET 282 (BITS . 15)) (ETHERPACKET 283 (BITS . 15)) (ETHERPACKET 284 (BITS . 15)) (ETHERPACKET 285 (BITS . 15)) (ETHERPACKET 286 (BITS . 15)) (ETHERPACKET 287 (BITS . 15)) (ETHERPACKET 288 (BITS . 15)) (ETHERPACKET 289 (BITS . 15)) (ETHERPACKET 290 (BITS . 15)) (ETHERPACKET 291 (BITS . 15)) (ETHERPACKET 292 (BITS . 15)) (ETHERPACKET 293 (BITS . 15)) (ETHERPACKET 294 (BITS . 15)) (ETHERPACKET 295 (BITS . 15)) (ETHERPACKET 296 (BITS . 15)) (ETHERPACKET 297 (BITS . 15)) (ETHERPACKET 298 (BITS . 15)) (ETHERPACKET 299 (BITS . 15)) (ETHERPACKET 300 (BITS . 15)) (ETHERPACKET 301 (BITS . 15)) (ETHERPACKET 302 (BITS . 15)) (ETHERPACKET 303 (BITS . 15)) (ETHERPACKET 304 (BITS . 15)) (ETHERPACKET 305 (BITS . 15)) (ETHERPACKET 306 (BITS . 15)) (ETHERPACKET 307 (BITS . 15)) (ETHERPACKET 308 (BITS . 15)) (ETHERPACKET 309 (BITS . 15)) (ETHERPACKET 310 (BITS . 15)) (ETHERPACKET 311 (BITS . 15)) (ETHERPACKET 312 (BITS . 15)) (ETHERPACKET 313 (BITS . 15)) (ETHERPACKET 314 (BITS . 15)) (ETHERPACKET 315 (BITS . 15)) (ETHERPACKET 316 (BITS . 15)) (ETHERPACKET 317 (BITS . 15)) (ETHERPACKET 318 (BITS . 15)) (ETHERPACKET 319 (BITS . 15)) (ETHERPACKET 320 (BITS . 15)) (ETHERPACKET 321 (BITS . 15)) (ETHERPACKET 322 (BITS . 15))) '324) (/DECLAREDATATYPE 'SYSQUEUE '(BYTE POINTER BYTE POINTER) '((SYSQUEUE 0 (BITS . 7)) (SYSQUEUE 2 POINTER) (SYSQUEUE 1 (BITS . 7)) (SYSQUEUE 4 POINTER)) '6) (* ; "Pup things") (DECLARE%: EVAL@COMPILE (ACCESSFNS PUP [(PUPBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM] [BLOCKRECORD PUPBASE ((PUPLENGTH WORD) (PUPTCONTROL BYTE) (PUPTYPE BYTE) (PUPID FIXP) (PUPDEST WORD) (PUPDESTSOCKET FIXP) (PUPSOURCE WORD) (PUPSOURCESOCKET FIXP) (PUPDATASTART 266 WORD)) (BLOCKRECORD PUPBASE ((NIL WORD) (TYPEWORD WORD) (PUPIDHI WORD) (PUPIDLO WORD) (PUPDESTNET BYTE) (PUPDESTHOST BYTE) (PUPDESTSOCKETHI WORD) (PUPDESTSOCKETLO WORD) (PUPSOURCENET BYTE) (PUPSOURCEHOST BYTE) (PUPSOURCESOCKETHI WORD) (PUPSOURCESOCKETLO WORD)) (* ; "Temporary extra synonyms") (SYNONYM PUPDESTNET (DESTNET)) (SYNONYM PUPDESTHOST (DESTHOST)) (SYNONYM PUPDESTSOCKETHI (DESTSKTHI)) (SYNONYM PUPDESTSOCKETLO (DESTSKTLO)) (SYNONYM PUPSOURCENET (SOURCENET)) (SYNONYM PUPSOURCEHOST (SOURCEHOST)) (SYNONYM PUPSOURCESOCKETHI (SOURCESKTHI)) (SYNONYM PUPSOURCESOCKETLO (SOURCESKTLO))) (SYNONYM PUPDEST (DEST)) (SYNONYM PUPDESTSOCKET (DESTSKT)) (SYNONYM PUPSOURCE (SOURCE)) (SYNONYM PUPSOURCESOCKET (SOURCESKT)) (ACCESSFNS PUPDATASTART ((PUPCONTENTS (LOCF DATUM] [ACCESSFNS PUP [(PUPCHECKSUMBASE (fetch PUPBASE of DATUM)) (PUPCHECKSUMLOC (\ADDBASE (fetch PUPBASE of DATUM) (FOLDLO (SUB1 (fetch PUPLENGTH of DATUM)) BYTESPERWORD] (BLOCKRECORD PUPCHECKSUMLOC ((PUPCHECKSUM WORD] (TYPE? (type? ETHERPACKET DATUM))) (ACCESSFNS ERRORPUP ((ERRORPUPBASE (fetch PUPCONTENTS of DATUM))) (BLOCKRECORD ERRORPUPBASE ((ERRORPUPCOPY 10 WORD) (* ; "Copy of pup header") (ERRORPUPCODE WORD) (ERRORPUPARG WORD) (* ; "Usually zero") (ERRORPUPSTRINGBASE WORD) (* ; "Human readable message") ))) (ACCESSFNS PUPADDRESS ((PUPNET# (LRSH DATUM 8)) (PUPHOST# (LOGAND DATUM 255))) (CREATE (IPLUS (LLSH PUPNET# 8) PUPHOST#))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \LOCALPUPADDRESS MACRO (NIL \LOCALPUPNETHOST)) (PUTPROPS \LOCALPUPHOSTNUMBER MACRO (NIL (fetch PUPHOST# of \LOCALPUPNETHOST))) (PUTPROPS \LOCALPUPNETNUMBER MACRO (NIL (fetch PUPNET# of \LOCALPUPNETHOST))) ) (DECLARE%: EVAL@COMPILE (RPAQQ \PUPOVLEN 22) (RPAQQ \MAX.PUPDATALENGTH 532) (CONSTANTS (\PUPOVLEN 22) (\MAX.PUPDATALENGTH 532)) ) (RPAQQ PUPERRORCODES ((\PUPE.CHECKSUM 1) (\PUPE.NOSOCKET 2) (\PUPE.SOCKETFULL 3) (\PUPE.GATEWAY.BADPUP 513) (\PUPE.NOROUTE 514) (\PUPE.NOHOST 515) (\PUPE.LOOPED 516) (\PUPE.TOOLARGE 517) (\PUPE.WRONG.GATEWAY 518) (\PUPE.GATEWAYFULL 519))) (DECLARE%: EVAL@COMPILE (RPAQQ \PUPE.CHECKSUM 1) (RPAQQ \PUPE.NOSOCKET 2) (RPAQQ \PUPE.SOCKETFULL 3) (RPAQQ \PUPE.GATEWAY.BADPUP 513) (RPAQQ \PUPE.NOROUTE 514) (RPAQQ \PUPE.NOHOST 515) (RPAQQ \PUPE.LOOPED 516) (RPAQQ \PUPE.TOOLARGE 517) (RPAQQ \PUPE.WRONG.GATEWAY 518) (RPAQQ \PUPE.GATEWAYFULL 519) (CONSTANTS (\PUPE.CHECKSUM 1) (\PUPE.NOSOCKET 2) (\PUPE.SOCKETFULL 3) (\PUPE.GATEWAY.BADPUP 513) (\PUPE.NOROUTE 514) (\PUPE.NOHOST 515) (\PUPE.LOOPED 516) (\PUPE.TOOLARGE 517) (\PUPE.WRONG.GATEWAY 518) (\PUPE.GATEWAYFULL 519)) ) (* ; "XIP things") (DECLARE%: EVAL@COMPILE (ACCESSFNS XIP [(XIPBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM] [BLOCKRECORD XIPBASE ((XIPCHECKSUM WORD) (XIPLENGTH WORD) (XIPTCONTROL BYTE) (XIPTYPE BYTE) (XIPDESTNET FIXP) (XIPDESTWORD1 3 WORD) (XIPDESTSOCKET WORD) (XIPSOURCENET FIXP) (XIPSOURCEWORD1 3 WORD) (XIPSOURCESOCKET WORD) (XIPFIRSTDATAWORD WORD) (* ; "Start of data") ) [ACCESSFNS XIPLENGTH ((XIPCHECKSUMBASE (LOCF DATUM] [ACCESSFNS XIPFIRSTDATAWORD ((XIPCONTENTS (LOCF DATUM] [ACCESSFNS XIPSOURCEWORD1 ((XIPSOURCEHOST (\LOADNSHOSTNUMBER (LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE] [ACCESSFNS XIPDESTWORD1 ((XIPDESTHOST (\LOADNSHOSTNUMBER (LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE] [ACCESSFNS XIPSOURCENET ((XIPSOURCENSADDRESS (\LOADNSADDRESS (LOCF DATUM)) (\STORENSADDRESS (LOCF DATUM) NEWVALUE] (ACCESSFNS XIPDESTNET ((XIPDESTNSADDRESS (\LOADNSADDRESS (LOCF DATUM)) (\STORENSADDRESS (LOCF DATUM) NEWVALUE] (TYPE? (type? ETHERPACKET DATUM))) (ACCESSFNS ERRORXIP ((ERRORXIPBASE (fetch XIPCONTENTS of DATUM))) (BLOCKRECORD ERRORXIPBASE ((ERRORXIPCODE WORD) (ERRORXIPARG WORD) (ERRORXIPBODY WORD) (* ;  "As many words of offending XIP as sender felt like including...") ))) (TYPERECORD NSHOSTNUMBER (NSHOST0 NSHOST1 NSHOST2)) (DATATYPE NSADDRESS ((NSNET FIXP) (NSHNM0 WORD) (NSHNM1 WORD) (NSHNM2 WORD) (NSSOCKET WORD)) (ACCESSFNS (NSHOSTNUMBER (\LOADNSHOSTNUMBER (LOCF (fetch NSHNM0 of DATUM))) (\STORENSHOSTNUMBER (LOCF (fetch NSHNM0 of DATUM)) NEWVALUE))) (BLOCKRECORD NSADDRESS ((NSNETHI WORD) (NSNETLO WORD)))) (DATATYPE NSNAME ((NSOBJECT POINTER) (NSDOMAIN POINTER) (NSORGANIZATION POINTER)) (* Canonical three-part  Clearinghouse name) ) ) (/DECLAREDATATYPE 'NSADDRESS '(FIXP WORD WORD WORD WORD) '((NSADDRESS 0 FIXP) (NSADDRESS 2 (BITS . 15)) (NSADDRESS 3 (BITS . 15)) (NSADDRESS 4 (BITS . 15)) (NSADDRESS 5 (BITS . 15))) '6) (/DECLAREDATATYPE 'NSNAME '(POINTER POINTER POINTER) '((NSNAME 0 POINTER) (NSNAME 2 POINTER) (NSNAME 4 POINTER)) '6) (DECLARE%: EVAL@COMPILE (RPAQQ \XIPOVLEN 30) (RPAQQ \MAX.XIPDATALENGTH 546) (CONSTANTS (\XIPOVLEN 30) (\MAX.XIPDATALENGTH 546)) ) (RPAQQ XIPERRORCODES ((\XIPE.CHECKSUM 1) (\XIPE.NOSOCKET 2) (\XIPE.SOCKETFULL 3) (\XIPE.GATEWAY.CHECKSUM 513) (\XIPE.NOROUTE 514) (\XIPE.LOOPED 515) (\XIPE.TOOLARGE 516))) (DECLARE%: EVAL@COMPILE (RPAQQ \XIPE.CHECKSUM 1) (RPAQQ \XIPE.NOSOCKET 2) (RPAQQ \XIPE.SOCKETFULL 3) (RPAQQ \XIPE.GATEWAY.CHECKSUM 513) (RPAQQ \XIPE.NOROUTE 514) (RPAQQ \XIPE.LOOPED 515) (RPAQQ \XIPE.TOOLARGE 516) (CONSTANTS (\XIPE.CHECKSUM 1) (\XIPE.NOSOCKET 2) (\XIPE.SOCKETFULL 3) (\XIPE.GATEWAY.CHECKSUM 513) (\XIPE.NOROUTE 514) (\XIPE.LOOPED 515) (\XIPE.TOOLARGE 516)) ) (PUTPROPS ETHERRECORDS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1987 1990 1992 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/library/EXPORTS.ALL b/library/EXPORTS.ALL new file mode 100644 index 00000000..fafe5f6d --- /dev/null +++ b/library/EXPORTS.ALL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (LISPXPRIN1 "EXPORTS GATHERED FROM {DSK}kaplan>Local>medley3.5>lispcore>sources> ON 3-May-2018 15:59:42" T) (LISPXTERPRI T) (PUTPROP (QUOTE FILESETS) (QUOTE IMPORTDATE) (IDATE "29-Jan-98 16:26:53")) (RPAQQ MODARITHMACROS (CEIL FLOOR FOLDHI FOLDLO MODUP UNFOLD MOD)) (PUTPROPS CEIL MACRO ((X N) (FLOOR (IPLUS X (CONSTANT (SUB1 N))) N))) (PUTPROPS FLOOR MACRO ((X N) (LOGAND X (CONSTANT (LOGXOR (SUB1 N) -1))))) (PUTPROPS FOLDHI MACRO (X (PROG ((FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X))))) (OR ( AND DIVISOR (POWEROFTWOP DIVISOR)) (\ILLEGAL.ARG (CADR X))) (RETURN (LIST (QUOTE LRSH) (LIST (QUOTE IPLUS) FORM (SUB1 DIVISOR)) (SUB1 (INTEGERLENGTH DIVISOR))))))) (PUTPROPS FOLDLO MACRO (X (PROG ((FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X))))) (OR ( AND DIVISOR (POWEROFTWOP DIVISOR)) (\ILLEGAL.ARG (CADR X))) (RETURN (LIST (QUOTE LRSH) FORM (SUB1 ( INTEGERLENGTH DIVISOR))))))) (PUTPROPS MODUP MACRO (OPENLAMBDA (X N) (IDIFFERENCE (SUB1 N) (IMOD (SUB1 X) N)))) (PUTPROPS UNFOLD MACRO (X (PROG ((FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X))))) (OR ( AND DIVISOR (POWEROFTWOP DIVISOR)) (\ILLEGAL.ARG (CADR X))) (RETURN (LIST (QUOTE LLSH) FORM (SUB1 ( INTEGERLENGTH DIVISOR))))))) (PUTPROPS MOD MACRO (= . IMOD)) (RPAQQ BITSPERNIBBLE 4) (RPAQQ NIBBLESPERBYTE 2) (RPAQQ BITSPERBYTE 8) (RPAQQ BITSPERCELL 32) (RPAQQ BITSPERWORD 16) (RPAQQ BYTESPERCELL 4) (RPAQQ BYTESPERPAGE 512) (RPAQQ BYTESPERWORD 2) (RPAQQ CELLSPERPAGE 128) (RPAQQ CELLSPERSEGMENT 32768) (RPAQQ PAGESPERSEGMENT 256) (RPAQQ WORDSPERCELL 2) (RPAQQ WORDSPERPAGE 256) (RPAQQ WORDSPERSEGMENT 65536) (RPAQQ WORDSPERQUAD 4) (RPAQQ CELLSPERQUAD 2) (RPAQQ BYTESPERQUAD 8) (CONSTANTS BITSPERNIBBLE NIBBLESPERBYTE BITSPERBYTE BITSPERCELL BITSPERWORD BYTESPERCELL BYTESPERPAGE BYTESPERWORD CELLSPERPAGE CELLSPERSEGMENT PAGESPERSEGMENT WORDSPERCELL WORDSPERPAGE WORDSPERSEGMENT WORDSPERQUAD CELLSPERQUAD BYTESPERQUAD) (RPAQQ INTEGERSIZECONSTANTS ((BITS.PER.SMALLP (ADD1 BITSPERWORD)) (SMALLP.LENGTH (SUB1 BITS.PER.SMALLP )) (MAX.SMALLP (LOGOR (LSH 1 (SUB1 SMALLP.LENGTH)) (SUB1 (LSH 1 (SUB1 SMALLP.LENGTH))))) (MIN.SMALLP ( IDIFFERENCE -1 MAX.SMALLP)) (BITS.PER.FIXP BITSPERCELL) (FIXP.LENGTH (SUB1 BITS.PER.FIXP)) (MAX.FIXP ( LOGOR (LSH 1 (SUB1 FIXP.LENGTH)) (SUB1 (LSH 1 (SUB1 FIXP.LENGTH))))) (MIN.FIXP (IDIFFERENCE -1 MAX.FIXP)))) (RPAQ BITS.PER.SMALLP (ADD1 BITSPERWORD)) (RPAQ SMALLP.LENGTH (SUB1 BITS.PER.SMALLP)) (RPAQ MAX.SMALLP (LOGOR (LSH 1 (SUB1 SMALLP.LENGTH)) (SUB1 (LSH 1 (SUB1 SMALLP.LENGTH))))) (RPAQ MIN.SMALLP (IDIFFERENCE -1 MAX.SMALLP)) (RPAQ BITS.PER.FIXP BITSPERCELL) (RPAQ FIXP.LENGTH (SUB1 BITS.PER.FIXP)) (RPAQ MAX.FIXP (LOGOR (LSH 1 (SUB1 FIXP.LENGTH)) (SUB1 (LSH 1 (SUB1 FIXP.LENGTH))))) (RPAQ MIN.FIXP (IDIFFERENCE -1 MAX.FIXP)) (CONSTANTS (BITS.PER.SMALLP (ADD1 BITSPERWORD)) (SMALLP.LENGTH (SUB1 BITS.PER.SMALLP)) (MAX.SMALLP ( LOGOR (LSH 1 (SUB1 SMALLP.LENGTH)) (SUB1 (LSH 1 (SUB1 SMALLP.LENGTH))))) (MIN.SMALLP (IDIFFERENCE -1 MAX.SMALLP)) (BITS.PER.FIXP BITSPERCELL) (FIXP.LENGTH (SUB1 BITS.PER.FIXP)) (MAX.FIXP (LOGOR (LSH 1 ( SUB1 FIXP.LENGTH)) (SUB1 (LSH 1 (SUB1 FIXP.LENGTH))))) (MIN.FIXP (IDIFFERENCE -1 MAX.FIXP))) (PUTPROP (QUOTE MODARITH) (QUOTE IMPORTDATE) (IDATE "16-May-90 20:46:21")) (RPAQQ WINDFLG T) (CONSTANTS (WINDFLG T)) (RPAQQ INITCONSTANTS ((* ;;; "(LISPNAME VALUE BCPLNAME UCODENAME)") (CDRCODING 1 T T) (* ; "IF CDRCODING=0, CDR CODING IS OFF, OTHERWISE ON") (* ;; "type numbers -- repeated on LLBASIC too") ( \SMALLP 1 SMALLTYPE SmallType) (\FIXP 2 INTEGERTYPE FixpType) (\FLOATP 3 FLTPTTYPE FloatpType) ( \LITATOM 4 ATOMTYPE AtomType) (\LISTP 5 LISTTYPE ListType) (\ARRAYP 6 ARRAYPTRTYPE ArrayType) ( \STRINGP 7 STRINGPTRTYPE) (\STACKP 8) (\CHARACTERP 9) (\VMEMPAGEP 10 NIL VMemPagePType) (\STREAM 11 NIL STREAMTYPE) (* ;; "TYPE TABLE CONSTANTS - - - - - - - - - - - - - - - - - - - - - -") ( \TT.TYPEMASK 2047 TTTypeMask T) (\TT.NOREF 32768 NIL T) (\TT.SYMBOLP 16384 NIL T) (\TT.FIXP 8192) ( \TT.NUMBERP 4096) (\TT.ATOM 2048) (* ;; "page map - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -") (\PMblockSize 32 PMBLOCKSIZE) (\STATSsize 8 T) (\NumPMTpages 8) (\EmptyPMTEntry 65535 T) (\FirstVmemBlock 2 T) ( \MAXVMPAGE 131069) (\MAXVMSEGMENT 255) (* ;; "interface page") (\IFPValidKey 5603 T) (* ;; "MDS") ( \FirstMDSPage 16382) (\MaxMDSPage 524285) (\DefaultSecondMDSPage 65532) (\MDSIncrement 512) ( \PagesPerMDSUnit 2) (* ; "(FOLDLO \MDSIncrement WORDSPERPAGE)") (* ;; "arrays") (\ARRAYSPACE (46 0)) ( \FirstArraySegment 46) (\FirstArrayPage 11776) (\ARRAYSPACE2 (64 0)) (\DefaultSecondArrayPage 16384) ( * ;; "stack block constants") (\StackMask 57344 T T) (\FxtnBlock 49152 T T) (\GuardBlock 57344 T T) ( \BFBlock 32768 T T) (\FreeStackBlock 40960 T T) (\NotStackBlock 0) (* ; "none of the above") ( \MinExtraStackWords 32 T T) (* ;; "backspace kludge") (ERASECHARCODE 0 T) (* ;; "GC constants") ( \HT1CNT 1024 NIL T) (\HTSTKBIT 512 NIL T) (\HTCNTMASK 64512 NIL T) (\HTMAINSIZE 65536 NIL T) ( \HTCOLLSIZE 1048576 NIL T) (* ; "HTCOLL size in words") (\HTENDFREE 1 NIL T) (\HTFREEPTR 0 NIL T) (* ;; "pointers and lengths of various data spaces") (\ATOMSPACE (0 0) (ATOMspace NIL) (atomHiVal NIL)) ( \AtomHI 0) (\CHARHI 7) (* ; "overlap character space and the atom hash table space") (\AtomHashTable ( 21 0) (AHTspace AHTbase)) (\AtomHTpages 256 AHTSIZE) (\LastAtomPage 255) (\MaxAtomFrLst 65535) ( \SMALLPOSPSPACE (14 0)) (\SmallPosHi 14 SMALLPOSspace smallpl) (\SMALLNEGSPACE (15 0)) (\SmallNegHi 15 SMALLNEGspace smallneg) (\NumSmallPages 512) (* ;; "PNAME SPACEin the old world; used for initial atoms now.") (\PNPSPACE (8 0) (PNPspace PNPbase)) ( \PNAME.HI 8) (\OLDATOMSPACE (44 0)) (* ; "NEW ATOM SPACE") (\ATOM.HI 44) (* ; "HI PART OF NEW ATOM SPACE") (* ;; "Definitions in old atom world") (\DEFSPACE (10 0) (DEFspace DEFbase) (DEFspace DEFbase)) (\DEF.HI 10) (\VALSPACE (12 0) (TOPVALspace TOPVALbase) (VALspace VALbase )) (\VAL.HI 12) (\PLISTSPACE (2 0) (PLISTspace PLISTbase)) (\PLIST.HI 2) (\PAGEMAP (5 0) (PAGEMAPspace PAGEMAPbase)) (\NumPageMapPages 256) (\PageMapTBL (20 512) (PMTspace PMTbase)) (\InterfacePage (20 0) (INTERFACEspace INTERFACEbase) (INTERFACEspace INTERFACEbase)) (\IOPAGE (0 65280)) (\DoveIORegion (0 16384)) (\IOCBPAGE (0 256)) (\FPTOVP (2 0)) (\MDSTypeTable (24 0) (MDSTYPEspace MDSTYPEbase) ( MDSTYPEspace MDSTYPEbase)) (\MDSTTsize 1024 T) (* ; "in Pages") (\MISCSTATS (20 2560) (STATSspace MISCSTATSbase)) (\UFNTable (20 3072) NIL (STATSspace UFNTablebase)) (\UFNTableSize 2) (\DTDSpaceBase ( 20 4096) (DTDspace DTDbase) (DTDspace DTDbase)) (\DTDSize 18 T) (\LISTPDTD (20 4186)) (\EndTypeNumber 2047) (\LOCKEDPAGETABLE (20 28672)) (\NumLPTPages 16) (\STACKSPACE (1 0) (STACKspace NIL) (STACKspace NIL)) (\GuardStackAddr 61440) (\LastStackAddr 65534) (\STACKHI 1 T T) (\HTMAIN (22 0) (HTMAINspace HTMAINbase) (HTMAINspace HTMAINbase)) (\HTMAINnpages 256 T) (\HTOVERFLOW (23 0) NIL (NIL HTOVERFLOWbase)) (\HTBIGCOUNT (23 32768)) (\HTCOLL (28 0) NIL (HTCOLLspace HTCOLLbase)) ( \DISPLAYREGION (18 0)) (\D1BCPLspace 0 T LEmubrHiVal) (\D0BCPLspace 0 T) (* ;; "Interface Page locations") (\CurrentFXP 0 T T) (\ResetFXP 1 T T) (\SubovFXP 2 T T) (\KbdFXP 3 T T) ( \HardReturnFXP 4 T T) (\GCFXP 5) (\FAULTFXP 6 T T) (\MiscFXP 14 T T) (\TeleRaidFXP 24 T T) (* ;; "emulator segment locations") (DCB.EM 272) (DISPINTERRUPT.EM 273) (CURSORBITMAP.EM 281) (KBDAD0.EM 65052) (KBDAD1.EM 65053) (KBDAD2.EM 65054) (KBDAD3.EM 65055) (UTILIN.EM 65048) (CURSORX.EM 278) ( CURSORY.EM 279) (MOUSEX.EM 276) (MOUSEY.EM 277) (\LispKeyMask 8192 T T) (\BcplKeyMask 4352 T T) (* ; "Machine types") (\MAIKO 3) (\DOLPHIN 4) (\DORADO 5) (\DANDELION 6) (\DAYBREAK 8) (* ;; "FOR DLION (AND DAYBREAK)") (\VP.DISPLAY 4608) (\NP.DISPLAY 202) (* ; "for Dorado display 1024x808 pixels / (16 pixels/word x 256 words/page)") (\NP.WIDEDOVEDISPLAY 243) (* ; "Wide Dove display 1152x864 pixels") (\WIDEDOVEDISPLAYWIDTH 1152) (\RP.AFTERDISPLAY 206) (* ; "Includes 4 pages for cursor") (\RP.AFTERDOVEDISPLAY 243) (* ; "if big screen") (\RP.DISPLAY 0) ( \RP.TEMPDISPLAY 2561) (\RP.MISCLOCKED 2804) (* ; "(+ \RP.TEMPDISPLAY \NP.WIDEDOVEDISPLAY)") (\RP.STACK 768) (\VP.STACK 256) (\RP.MAP 256) (\NP.MAP 256) (\RP.IOPAGE 512) (* ; "The DOVE IOCBPAGE can go anywhere, but should be under the 1mbyte range") (\RP.DOVEIOCBPAGE 543) ( \RP.DOVEIORGN 544) (\VP.DOVEIORGN 64) (\DOVEIORGNSIZE 64) (\VP.IOPAGE 255) (\VP.IFPAGE 5120) ( \VP.FPTOVP 512) (\NP.FPTOVP 4096) (\RP.FPTOVP 1024) (\RP.STARTBUFFERS 640) (\VP.TYPETABLE 6144) ( \NP.TYPETABLE 1024) (\RP.TYPETABLE 5120) (\VP.GCTABLE 5632) (\NP.GCTABLE 256) (\RP.GCTABLE 6144) ( \VP.GCOVERFLOW 5888) (\NP.GCOVERFLOW 1) (\RP.GCOVERFLOW 6400) (\FP.IFPAGE 2) (\VP.IOCBS 1) ( \VP.PRIMARYMAP 5122) (\VP.SECONDARYMAP 1280) (\VP.LPT 5232) (\VP.INITSCRATCH 8) (\VP.RPT 128) ( \VP.BUFFERS 218) (* ; "DLion processor commands") (\DL.PROCESSORBUSY 32768) (\DL.SETTOD 32769) ( \DL.READTOD 32770) (\DL.READPID 32771) (\DL.BOOTBUTTON 32772))) (RPAQQ MISCSTATSLAYOUT ((STARTTIME FIXP MSstrtTime) (TOTALTIME FIXP) (SWAPWAITTIME FIXP T) (PAGEFAULTS FIXP T) (SWAPWRITES FIXP T) (DISKIOTIME FIXP T) (DISKOPS FIXP T) (KEYBOARDWAITTIME FIXP T) (GCTIME FIXP T) (NETIOTIME FIXP T) (NETIOOPS FIXP T) (SWAPTEMP0 FIXP) (SWAPTEMP1 FIXP) (RCLKSECOND FIXP) ( SECONDSCLOCK FIXP) (MILLISECONDSCLOCK FIXP) (BASECLOCK FIXP) (RCLKTEMP0 FIXP) (SECONDSTMP FIXP) ( MILLISECONDSTMP FIXP) (BASETMP FIXP) (EXCESSTIMETMP FIXP) (CLOCKTEMP0 FIXP) (DISKTEMP0 FIXP) ( DISKTEMP1 FIXP) (TELERAIDTEMP1 FIXP) (TELERAIDTEMP2 FIXP) (TELERAIDTEMP3 FIXP) (LASTUSERACTION FIXP) ( DLMOUSETIMER FIXP) (DLMOUSETEMP FIXP))) (RPAQQ IFPAGELAYOUT ((CurrentFXP WORD) (* ; "First 7 items are FX values for user and 6 system contexts.") (ResetFXP WORD) (SubovFXP WORD) (KbdFXP WORD) (HardReturnFXP WORD) (GCFXP WORD) (FAULTFXP WORD) (EndOfStack WORD) (* ; "Stack high-water mark: address of guard block at current end of stack") (LVersion WORD) (* ; "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp") (MinRVersion WORD) (MinBVersion WORD) (RVersion WORD) (* ; "Bcpl fills in the actual microcode, Bcpl versions.") ( BVersion WORD) (MachineType WORD) (MiscFXP WORD) (* ; "FX for MISC context") (Key WORD) (* ; "= IFPValidKey if vmem consistent.") (SerialNumber WORD) (* ; "Pup host number (Dorado/Dolphin)") ( EmulatorSpace WORD) (* ; "Hiloc of bcpl space (always zero now)") (ScreenWidth WORD) (NxtPMAddr WORD) (* ; "Next page to be allocated in secondary page map table") (NActivePages WORD) (* ; "Length of vmem in use") (NDirtyPages WORD) (* ; "not used, but maintained as = NActivePages") ( filePnPMP0 WORD) (* ; "Sysout page number of first page of secondary page map table (\PAGEMAP), which is where the secondary map pages themselves live" ) (filePnPMT0 WORD) (* ; "Sysout page number of first page of primary page map table") (TELERAIDFXP WORD) (* ; "FX for TeleRaid server context") (NATIVE-START-MEM-PAGE WORD) (* ; "Unix page where native code starts") (NATIVE-LENGTH-PAGE WORD) (* ; "Unix page length of native code" ) (NATIVE-PAGE-OFFSET WORD) (* ; "Lisp Disk Page offset of native code") (UserNameAddr WORD) (* ; "Addresses in bcpl space (seg 0) of global user name and password") (UserPswdAddr WORD) (StackBase WORD) (* ; "Stack address where user stack starts") (FAULTHI WORD) (* ; "Microcode for page fault stores fault address here, then does context switch to FAULTFXP") (FAULTLO WORD) (DEVCONFIG WORD) (* ; "IT'S FOR KB,DISP TYPE") (* ; "Formerly REALPAGETABLE, back when it was always in Bcpl space.") (RPTSIZE WORD) (* ; "Number of entries in Real Page Table") (RPOFFSET WORD) (* ; "RP-RPOFFSET => index in table") ( MAXETHERBYTES WORD) (* ; "Number of bytes available in a pbi, not counting encapsulation (Dorado)") ( EMBUFVP WORD) (* ; "VP of a one-page emulator buffer") (NSHost0 WORD) (* ; "Machine's 48-bit NS host number. Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in." ) (NSHost1 WORD) (NSHost2 WORD) (MDSZone WORD) (* ; "Obsolete -- was used by Dolphin 10MB network code.") (MDSZoneLength WORD) (EMUBUFFERS WORD) (* ; "Buffer space in segment 0 for swapping/disk activity") (EMUBUFLENGTH WORD) (* ; "Number of words of said space") (LASTNUMCHARS WORD) (* ; "No longer used?") (SYSDISK WORD) (* ; "Address of sysDisk in Bcpl space -- disk obj for boot partition.") (ISFMAP WORD) (* ;; "The following 4 are for \MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!" ) (MISCSTACKFN FULLXPOINTER) (MISCSTACKARG1 FULLXPOINTER) (MISCSTACKARG2 FULLXPOINTER) ( MISCSTACKRESULT FULLXPOINTER) (NRealPages WORD) (* ; "Number pages of real memory") ( LastLockedFilePage WORD) (* ; "Last page of vmem that is locked--booting has to load at least that far.") (LastDominoFilePage WORD) (* ; "Last sysout page reserved for Dandelion microcode") (FPTOVPStart WORD) (* ; "Sysout page where FPTOVP starts") (FAKEMOUSEBITS WORD) (* ; "Used to implement fake middle button on 2-button Dandelion.") (DL24BitAddressable WORD) (* ; "non-zero if DLion capable of addressing 32MB virtual memory") (REALPAGETABLEPTR FULLXPOINTER) (* ; "Address of real page table, set up by Bcpl (but not chained together)") (DLLastVmemPage WORD) (* ; "DLion booting microcode puts length of vmem file here.") (FullSpaceUsed WORD) (* ; "Non-zero if vmem beyond initial 8MB has been allocated.") (FAKEKBDAD4 WORD) (FAKEKBDAD5 WORD) (* ;; "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with." ) (XVmemFmapBase WORD) (* ; "Bcpl stores isf map pointer to each partition here. First is redundant with ISFMAP field above.") ( NIL WORD) (NIL WORD) (XVmemFmapHighBase WORD) (* ; "Bcpl stores the highest vm page contained in this or earlier partition.") (NIL WORD) (NIL WORD) ( XVmemDiskBase FULLXPOINTER) (* ; "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).") (NIL FULLXPOINTER) (NIL FULLXPOINTER))) (RPAQQ MAIKO.IFPAGELAYOUT ((CurrentFXP WORD) (* ; "First 7 items are FX values for user and 6 system contexts.") (ResetFXP WORD) (SubovFXP WORD) (KbdFXP WORD) (HardReturnFXP WORD) (GCFXP WORD) (FAULTFXP WORD) (EndOfStack WORD) (* ; "Stack high-water mark: address of guard block at current end of stack") (LVersion WORD) (* ; "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp") (MinRVersion WORD) (MinBVersion WORD) (RVersion WORD) (* ; "Bcpl fills in the actual microcode, Bcpl versions.") ( BVersion WORD) (MachineType WORD) (MiscFXP WORD) (* ; "FX for MISC context") (Key WORD) (* ; "= IFPValidKey if vmem consistent.") (SerialNumber WORD) (* ; "Pup host number (Dorado/Dolphin)") ( EmulatorSpace WORD) (* ; "Hiloc of bcpl space (always zero now)") (ScreenWidth WORD) (NxtPMAddr WORD) (* ; "Next page to be allocated in secondary page map table") (NIL WORD) (* ; "WAS NActivePages, Length of vmem in use") (NIL WORD) (* ; "WAS NDirtyPages, not used, but maintained as = NActivePages") (filePnPMP0 WORD) (* ; "Sysout page number of first page of secondary page map table (\PAGEMAP), which is where the secondary map pages themselves live" ) (filePnPMT0 WORD) (* ; "Sysout page number of first page of primary page map table") (TELERAIDFXP WORD) (* ; "FX for TeleRaid server context") (NATIVE-START-MEM-PAGE WORD) (* ; "Unix page where native code starts") (NATIVE-LENGTH-PAGE WORD) (* ; "Unix page length of native code" ) (NATIVE-PAGE-OFFSET WORD) (* ; "Lisp Disk Page offset of native code") (UserNameAddr WORD) (* ; "Addresses in bcpl space (seg 0) of global user name and password") (UserPswdAddr WORD) (StackBase WORD) (* ; "Stack address where user stack starts") (FAULTHI WORD) (* ; "Microcode for page fault stores fault address here, then does context switch to FAULTFXP") (FAULTLO WORD) (DEVCONFIG WORD) (* ; "IT'S FOR KB,DISP TYPE") (* ; "Formerly REALPAGETABLE, back when it was always in Bcpl space.") (RPTSIZE WORD) (* ; "Number of entries in Real Page Table") (RPOFFSET WORD) (* ; "RP-RPOFFSET => index in table") ( MAXETHERBYTES WORD) (* ; "Number of bytes available in a pbi, not counting encapsulation (Dorado)") ( EMBUFVP WORD) (* ; "VP of a one-page emulator buffer") (NSHost0 WORD) (* ; "Machine's 48-bit NS host number. Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in." ) (NSHost1 WORD) (NSHost2 WORD) (MDSZone WORD) (* ; "Obsolete -- was used by Dolphin 10MB network code.") (MDSZoneLength WORD) (EMUBUFFERS WORD) (* ; "Buffer space in segment 0 for swapping/disk activity") (EMUBUFLENGTH WORD) (* ; "Number of words of said space") (* ;; "The following 2 are available if NEW_STOARGE is specified in C") (ProcessSize WORD) (* ; "Process size for which can be use as LISP space") (StorageFullState WORD) (* ; "Save last storage state") (ISFMAP WORD) (* ;; "The following 4 are for \MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!" ) (MISCSTACKFN FULLXPOINTER) (MISCSTACKARG1 FULLXPOINTER) (MISCSTACKARG2 FULLXPOINTER) ( MISCSTACKRESULT FULLXPOINTER) (NRealPages WORD) (* ; "Number pages of real memory") ( LastLockedFilePage WORD) (* ; "Last page of vmem that is locked--booting has to load at least that far.") (LastDominoFilePage WORD) (* ; "Last sysout page reserved for Dandelion microcode") (FPTOVPStart WORD) (* ; "Sysout page where FPTOVP starts") (FAKEMOUSEBITS WORD) (* ; "Used to implement fake middle button on 2-button Dandelion.") (DL24BitAddressable WORD) (* ; "non-zero if DLion capable of addressing 32MB virtual memory") (REALPAGETABLEPTR FULLXPOINTER) (* ; "Address of real page table, set up by Bcpl (but not chained together)") (SYSDISK WORD) (* ; "WAS DLLastVmemPage, DLion booting microcode puts length of vmem file here.") (FullSpaceUsed WORD) (* ; "Non-zero if vmem beyond initial 8MB has been allocated.") (FAKEKBDAD4 WORD) (FAKEKBDAD5 WORD) (* ;; "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with." ) (XVmemFmapBase WORD) (* ; "Bcpl stores isf map pointer to each partition here. First is redundant with ISFMAP field above.") ( NIL WORD) (NIL WORD) (XVmemFmapHighBase WORD) (* ; "Bcpl stores the highest vm page contained in this or earlier partition.") (NIL WORD) (NIL WORD) ( XVmemDiskBase FULLXPOINTER) (* ; "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).") (NIL FULLXPOINTER) (NIL FULLXPOINTER) (DLLastVmemPage FIXP) (* ; "DLion booting microcode puts length of vmem file here.") (NActivePages FIXP) (* ; "Length of vmem in use") (NDirtyPages FIXP) (* ; "not used, but maintained as = NActivePages"))) (RPAQQ IOPAGELAYOUT ((NIL 18 WORD) (DLMAINTPANEL WORD NIL T) (DLFLOPPYCMD WORD) (DLTTYPORTCMD WORD) ( DLPROCESSORCMD WORD) (NEWMOUSESTATE WORD) (DLBEEPCMD WORD) (DLRS232CMISCCOMMAND WORD) (DLRS232CPUTFLAG WORD) (DLRS232CGETFLAG WORD) (NIL 6 WORD) (DLFLOPPY WORD) (DLTTYOUT WORD) (NIL 1 WORD) (DLTTYIN WORD) (NIL 1 WORD) (DLPROCESSOR2 WORD) (DLPROCESSOR1 WORD) (DLPROCESSOR0 WORD) (NEWMOUSEX WORD) (NEWMOUSEY WORD) (DLBEEPFREQ WORD) (DLRS232CPARAMETERCSBLO WORD) (DLRS232CPARAMETERCSBHI WORD) ( DLRS232CSETRS366STATUS 3 WORD) (DLRS232CPUTCSBLO WORD) (DLRS232CPUTCSBHI WORD) (DLRS232CGETCSBLO WORD) (DLRS232CGETCSBHI WORD) (DLRS232CDEVICESTATUS WORD) (DLRS232CPARAMETEROUTCOME WORD) (DLTODVALID WORD) (DLTODLO WORD NIL T) (DLTODHI WORD) (DLTODLO2 WORD) (DLMOUSEX WORD NIL T) (DLMOUSEY WORD NIL T) ( DLUTILIN WORD NIL T) (DLKBDAD0 WORD NIL T) (DLKBDAD1 WORD NIL T) (DLKBDAD2 WORD NIL T) (DLKBDAD3 WORD NIL T) (DLKBDAD4 WORD NIL T) (DLKBDAD5 WORD NIL T) (DLLSEPIMAGECSB 32 WORD) (DLIOPHARDWARECONFIG WORD) (NIL 11 WORD) (DLRS232CPARAMETERCSBLO.11 WORD) (DLRS232CPARAMETERCSBHI.11 WORD) ( DLRS232CSETRS366STATUS.11 14 WORD) (NIL 60 WORD) (DLMAGTAPE 4 WORD) (DLETHERNET 12 WORD NIL T) (NIL 31 WORD) (DLDISPINTERRUPT WORD NIL T) (DLDISPCONTROL WORD) (DLDISPBORDER WORD) (DLCURSORX WORD NIL T) ( DLCURSORY WORD NIL T) (DLCURSORBITMAP 16 WORD NIL T))) (RPAQQ CDRCODING 1) (RPAQQ \SMALLP 1) (RPAQQ \FIXP 2) (RPAQQ \FLOATP 3) (RPAQQ \LITATOM 4) (RPAQQ \LISTP 5) (RPAQQ \ARRAYP 6) (RPAQQ \STRINGP 7) (RPAQQ \STACKP 8) (RPAQQ \CHARACTERP 9) (RPAQQ \VMEMPAGEP 10) (RPAQQ \STREAM 11) (RPAQQ \TT.TYPEMASK 2047) (RPAQQ \TT.NOREF 32768) (RPAQQ \TT.SYMBOLP 16384) (RPAQQ \TT.FIXP 8192) (RPAQQ \TT.NUMBERP 4096) (RPAQQ \TT.ATOM 2048) (RPAQQ \PMblockSize 32) (RPAQQ \STATSsize 8) (RPAQQ \NumPMTpages 8) (RPAQQ \EmptyPMTEntry 65535) (RPAQQ \FirstVmemBlock 2) (RPAQQ \MAXVMPAGE 131069) (RPAQQ \MAXVMSEGMENT 255) (RPAQQ \IFPValidKey 5603) (RPAQQ \FirstMDSPage 16382) (RPAQQ \MaxMDSPage 524285) (RPAQQ \DefaultSecondMDSPage 65532) (RPAQQ \MDSIncrement 512) (RPAQQ \PagesPerMDSUnit 2) (RPAQQ \FirstArraySegment 46) (RPAQQ \FirstArrayPage 11776) (RPAQQ \DefaultSecondArrayPage 16384) (RPAQQ \StackMask 57344) (RPAQQ \FxtnBlock 49152) (RPAQQ \GuardBlock 57344) (RPAQQ \BFBlock 32768) (RPAQQ \FreeStackBlock 40960) (RPAQQ \NotStackBlock 0) (RPAQQ \MinExtraStackWords 32) (RPAQQ ERASECHARCODE 0) (RPAQQ \HT1CNT 1024) (RPAQQ \HTSTKBIT 512) (RPAQQ \HTCNTMASK 64512) (RPAQQ \HTMAINSIZE 65536) (RPAQQ \HTCOLLSIZE 1048576) (RPAQQ \HTENDFREE 1) (RPAQQ \HTFREEPTR 0) (RPAQQ \AtomHI 0) (RPAQQ \CHARHI 7) (RPAQQ \AtomHTpages 256) (RPAQQ \LastAtomPage 255) (RPAQQ \MaxAtomFrLst 65535) (RPAQQ \SmallPosHi 14) (RPAQQ \SmallNegHi 15) (RPAQQ \NumSmallPages 512) (RPAQQ \PNAME.HI 8) (RPAQQ \ATOM.HI 44) (RPAQQ \DEF.HI 10) (RPAQQ \VAL.HI 12) (RPAQQ \PLIST.HI 2) (RPAQQ \NumPageMapPages 256) (RPAQQ \MDSTTsize 1024) (RPAQQ \UFNTableSize 2) (RPAQQ \DTDSize 18) (RPAQQ \EndTypeNumber 2047) (RPAQQ \NumLPTPages 16) (RPAQQ \GuardStackAddr 61440) (RPAQQ \LastStackAddr 65534) (RPAQQ \STACKHI 1) (RPAQQ \HTMAINnpages 256) (RPAQQ \D1BCPLspace 0) (RPAQQ \D0BCPLspace 0) (RPAQQ \CurrentFXP 0) (RPAQQ \ResetFXP 1) (RPAQQ \SubovFXP 2) (RPAQQ \KbdFXP 3) (RPAQQ \HardReturnFXP 4) (RPAQQ \GCFXP 5) (RPAQQ \FAULTFXP 6) (RPAQQ \MiscFXP 14) (RPAQQ \TeleRaidFXP 24) (RPAQQ DCB.EM 272) (RPAQQ DISPINTERRUPT.EM 273) (RPAQQ CURSORBITMAP.EM 281) (RPAQQ KBDAD0.EM 65052) (RPAQQ KBDAD1.EM 65053) (RPAQQ KBDAD2.EM 65054) (RPAQQ KBDAD3.EM 65055) (RPAQQ UTILIN.EM 65048) (RPAQQ CURSORX.EM 278) (RPAQQ CURSORY.EM 279) (RPAQQ MOUSEX.EM 276) (RPAQQ MOUSEY.EM 277) (RPAQQ \LispKeyMask 8192) (RPAQQ \BcplKeyMask 4352) (RPAQQ \MAIKO 3) (RPAQQ \DOLPHIN 4) (RPAQQ \DORADO 5) (RPAQQ \DANDELION 6) (RPAQQ \DAYBREAK 8) (RPAQQ \VP.DISPLAY 4608) (RPAQQ \NP.DISPLAY 202) (RPAQQ \NP.WIDEDOVEDISPLAY 243) (RPAQQ \WIDEDOVEDISPLAYWIDTH 1152) (RPAQQ \RP.AFTERDISPLAY 206) (RPAQQ \RP.AFTERDOVEDISPLAY 243) (RPAQQ \RP.DISPLAY 0) (RPAQQ \RP.TEMPDISPLAY 2561) (RPAQQ \RP.MISCLOCKED 2804) (RPAQQ \RP.STACK 768) (RPAQQ \VP.STACK 256) (RPAQQ \RP.MAP 256) (RPAQQ \NP.MAP 256) (RPAQQ \RP.IOPAGE 512) (RPAQQ \RP.DOVEIOCBPAGE 543) (RPAQQ \RP.DOVEIORGN 544) (RPAQQ \VP.DOVEIORGN 64) (RPAQQ \DOVEIORGNSIZE 64) (RPAQQ \VP.IOPAGE 255) (RPAQQ \VP.IFPAGE 5120) (RPAQQ \VP.FPTOVP 512) (RPAQQ \NP.FPTOVP 4096) (RPAQQ \RP.FPTOVP 1024) (RPAQQ \RP.STARTBUFFERS 640) (RPAQQ \VP.TYPETABLE 6144) (RPAQQ \NP.TYPETABLE 1024) (RPAQQ \RP.TYPETABLE 5120) (RPAQQ \VP.GCTABLE 5632) (RPAQQ \NP.GCTABLE 256) (RPAQQ \RP.GCTABLE 6144) (RPAQQ \VP.GCOVERFLOW 5888) (RPAQQ \NP.GCOVERFLOW 1) (RPAQQ \RP.GCOVERFLOW 6400) (RPAQQ \FP.IFPAGE 2) (RPAQQ \VP.IOCBS 1) (RPAQQ \VP.PRIMARYMAP 5122) (RPAQQ \VP.SECONDARYMAP 1280) (RPAQQ \VP.LPT 5232) (RPAQQ \VP.INITSCRATCH 8) (RPAQQ \VP.RPT 128) (RPAQQ \VP.BUFFERS 218) (RPAQQ \DL.PROCESSORBUSY 32768) (RPAQQ \DL.SETTOD 32769) (RPAQQ \DL.READTOD 32770) (RPAQQ \DL.READPID 32771) (RPAQQ \DL.BOOTBUTTON 32772) (CONSTANTS (CDRCODING 1) (\SMALLP 1) (\FIXP 2) (\FLOATP 3) (\LITATOM 4) (\LISTP 5) (\ARRAYP 6) ( \STRINGP 7) (\STACKP 8) (\CHARACTERP 9) (\VMEMPAGEP 10) (\STREAM 11) (\TT.TYPEMASK 2047) (\TT.NOREF 32768) (\TT.SYMBOLP 16384) (\TT.FIXP 8192) (\TT.NUMBERP 4096) (\TT.ATOM 2048) (\PMblockSize 32) ( \STATSsize 8) (\NumPMTpages 8) (\EmptyPMTEntry 65535) (\FirstVmemBlock 2) (\MAXVMPAGE 131069) ( \MAXVMSEGMENT 255) (\IFPValidKey 5603) (\FirstMDSPage 16382) (\MaxMDSPage 524285) ( \DefaultSecondMDSPage 65532) (\MDSIncrement 512) (\PagesPerMDSUnit 2) (\FirstArraySegment 46) ( \FirstArrayPage 11776) (\DefaultSecondArrayPage 16384) (\StackMask 57344) (\FxtnBlock 49152) ( \GuardBlock 57344) (\BFBlock 32768) (\FreeStackBlock 40960) (\NotStackBlock 0) (\MinExtraStackWords 32 ) (ERASECHARCODE 0) (\HT1CNT 1024) (\HTSTKBIT 512) (\HTCNTMASK 64512) (\HTMAINSIZE 65536) (\HTCOLLSIZE 1048576) (\HTENDFREE 1) (\HTFREEPTR 0) (\AtomHI 0) (\CHARHI 7) (\AtomHTpages 256) (\LastAtomPage 255) (\MaxAtomFrLst 65535) (\SmallPosHi 14) (\SmallNegHi 15) (\NumSmallPages 512) (\PNAME.HI 8) (\ATOM.HI 44) (\DEF.HI 10) (\VAL.HI 12) (\PLIST.HI 2) (\NumPageMapPages 256) (\MDSTTsize 1024) (\UFNTableSize 2) (\DTDSize 18) (\EndTypeNumber 2047) (\NumLPTPages 16) (\GuardStackAddr 61440) (\LastStackAddr 65534) (\STACKHI 1) (\HTMAINnpages 256) (\D1BCPLspace 0) (\D0BCPLspace 0) (\CurrentFXP 0) (\ResetFXP 1) ( \SubovFXP 2) (\KbdFXP 3) (\HardReturnFXP 4) (\GCFXP 5) (\FAULTFXP 6) (\MiscFXP 14) (\TeleRaidFXP 24) ( DCB.EM 272) (DISPINTERRUPT.EM 273) (CURSORBITMAP.EM 281) (KBDAD0.EM 65052) (KBDAD1.EM 65053) ( KBDAD2.EM 65054) (KBDAD3.EM 65055) (UTILIN.EM 65048) (CURSORX.EM 278) (CURSORY.EM 279) (MOUSEX.EM 276) (MOUSEY.EM 277) (\LispKeyMask 8192) (\BcplKeyMask 4352) (\MAIKO 3) (\DOLPHIN 4) (\DORADO 5) ( \DANDELION 6) (\DAYBREAK 8) (\VP.DISPLAY 4608) (\NP.DISPLAY 202) (\NP.WIDEDOVEDISPLAY 243) ( \WIDEDOVEDISPLAYWIDTH 1152) (\RP.AFTERDISPLAY 206) (\RP.AFTERDOVEDISPLAY 243) (\RP.DISPLAY 0) ( \RP.TEMPDISPLAY 2561) (\RP.MISCLOCKED 2804) (\RP.STACK 768) (\VP.STACK 256) (\RP.MAP 256) (\NP.MAP 256 ) (\RP.IOPAGE 512) (\RP.DOVEIOCBPAGE 543) (\RP.DOVEIORGN 544) (\VP.DOVEIORGN 64) (\DOVEIORGNSIZE 64) ( \VP.IOPAGE 255) (\VP.IFPAGE 5120) (\VP.FPTOVP 512) (\NP.FPTOVP 4096) (\RP.FPTOVP 1024) ( \RP.STARTBUFFERS 640) (\VP.TYPETABLE 6144) (\NP.TYPETABLE 1024) (\RP.TYPETABLE 5120) (\VP.GCTABLE 5632 ) (\NP.GCTABLE 256) (\RP.GCTABLE 6144) (\VP.GCOVERFLOW 5888) (\NP.GCOVERFLOW 1) (\RP.GCOVERFLOW 6400) (\FP.IFPAGE 2) (\VP.IOCBS 1) (\VP.PRIMARYMAP 5122) (\VP.SECONDARYMAP 1280) (\VP.LPT 5232) ( \VP.INITSCRATCH 8) (\VP.RPT 128) (\VP.BUFFERS 218) (\DL.PROCESSORBUSY 32768) (\DL.SETTOD 32769) ( \DL.READTOD 32770) (\DL.READPID 32771) (\DL.BOOTBUTTON 32772)) (RPAQQ \MPERRORS ((\MP.OBSOLETEVMEM 1) (\MP.INVALIDVMEM 2 "Vmem inconsistent at startup") ( \MP.IOCBPAGE 3 "No place for IOCB page at startup") (\MP.MOB 4 "Map out of bounds") (\MP.INVALIDADDR 5 ) (\MP.INVALIDVP 6) (\MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain") (\MP.SELECTLOOP 8 "Loop in \SELECTREALPAGE") (\MP.NEWPAGE 9 "Attempt to allocate already existing page") ( \MP.NEWMAPPAGE 10 "\DONEWPAGE failed to allocate new map page") (\MP.BADLOCKED 11 "Locked page occupies a file page needed to lock another") (\MP.CLOCK0 12 "Arg to CLOCK0 not an integer box") (\MP.RESIDENT 13 "Fault on resident page") (\MP.STACKFAULT 14 "Fault on stack") (\MP.VMEMTOOLONG 16 "Attempt to extend Vmem File beyond fixed limit (8mb)") ( \MP.WRITING.LOCKED.PAGE 17 "Writing a locked page with UPDATEKEY = T") (\MP.UNINTERRUPTABLE 18 "Error in uninterruptable system code") (\MP.STACKFULL 19) (\MP.MDSFULL 20) (\MP.UNKNOWN.UFN 21) ( \MP.ATOMSFULL 22) (\MP.PNAMESFULL 23) (\MP.USECOUNTOVERFLOW 24) (\MP.MDSFULLWARNING 25) ( \MP.BADMDSFREELIST 26) (\MP.BADARRAYBLOCK 27) (\MP.BADDELETEBLOCK 28) (\MP.BADARRAYRECLAIM 29) ( \MP.BIGREFCNTMISSING 30 "PTR refcnt previously overflowed, but not found in table.") ( \MP.BIGREFCNTALREADYPRESENT 31 "PTR already in overflow table") (\MP.DELREF0 32) (\MP.PROCERROR 33) ( \MP.PROCNOFRAME 34 "Failed to build frame for PROCESS use") (\MP.32MBINUSE 35) (\MP.TOPUNWOUND 36 "Unexpected (RETTO T)") (\MP.STACKRELEASED 37) (\MP.FLUSHLOCKED 38) (\MP.MAPNOTLOCKED 39) ( \MP.UNLOCKINGMAP 40) (\MP.SWAPDISKERROR 41 "Hard Disk Error in swapper") (\MP.BADRUNTABLE 42 "Malformed run table for vmem file"))) (RPAQQ \MP.OBSOLETEVMEM 1) (RPAQ \MP.INVALIDVMEM 2 "Vmem inconsistent at startup") (RPAQ \MP.IOCBPAGE 3 "No place for IOCB page at startup") (RPAQ \MP.MOB 4 "Map out of bounds") (RPAQQ \MP.INVALIDADDR 5) (RPAQQ \MP.INVALIDVP 6) (RPAQ \MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain") (RPAQ \MP.SELECTLOOP 8 "Loop in \SELECTREALPAGE") (RPAQ \MP.NEWPAGE 9 "Attempt to allocate already existing page") (RPAQ \MP.NEWMAPPAGE 10 "\DONEWPAGE failed to allocate new map page") (RPAQ \MP.BADLOCKED 11 "Locked page occupies a file page needed to lock another") (RPAQ \MP.CLOCK0 12 "Arg to CLOCK0 not an integer box") (RPAQ \MP.RESIDENT 13 "Fault on resident page") (RPAQ \MP.STACKFAULT 14 "Fault on stack") (RPAQ \MP.VMEMTOOLONG 16 "Attempt to extend Vmem File beyond fixed limit (8mb)") (RPAQ \MP.WRITING.LOCKED.PAGE 17 "Writing a locked page with UPDATEKEY = T") (RPAQ \MP.UNINTERRUPTABLE 18 "Error in uninterruptable system code") (RPAQQ \MP.STACKFULL 19) (RPAQQ \MP.MDSFULL 20) (RPAQQ \MP.UNKNOWN.UFN 21) (RPAQQ \MP.ATOMSFULL 22) (RPAQQ \MP.PNAMESFULL 23) (RPAQQ \MP.USECOUNTOVERFLOW 24) (RPAQQ \MP.MDSFULLWARNING 25) (RPAQQ \MP.BADMDSFREELIST 26) (RPAQQ \MP.BADARRAYBLOCK 27) (RPAQQ \MP.BADDELETEBLOCK 28) (RPAQQ \MP.BADARRAYRECLAIM 29) (RPAQ \MP.BIGREFCNTMISSING 30 "PTR refcnt previously overflowed, but not found in table.") (RPAQ \MP.BIGREFCNTALREADYPRESENT 31 "PTR already in overflow table") (RPAQQ \MP.DELREF0 32) (RPAQQ \MP.PROCERROR 33) (RPAQ \MP.PROCNOFRAME 34 "Failed to build frame for PROCESS use") (RPAQQ \MP.32MBINUSE 35) (RPAQ \MP.TOPUNWOUND 36 "Unexpected (RETTO T)") (RPAQQ \MP.STACKRELEASED 37) (RPAQQ \MP.FLUSHLOCKED 38) (RPAQQ \MP.MAPNOTLOCKED 39) (RPAQQ \MP.UNLOCKINGMAP 40) (RPAQ \MP.SWAPDISKERROR 41 "Hard Disk Error in swapper") (RPAQ \MP.BADRUNTABLE 42 "Malformed run table for vmem file") (CONSTANTS (\MP.OBSOLETEVMEM 1) (\MP.INVALIDVMEM 2 "Vmem inconsistent at startup") (\MP.IOCBPAGE 3 "No place for IOCB page at startup") (\MP.MOB 4 "Map out of bounds") (\MP.INVALIDADDR 5) ( \MP.INVALIDVP 6) (\MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain") (\MP.SELECTLOOP 8 "Loop in \SELECTREALPAGE") (\MP.NEWPAGE 9 "Attempt to allocate already existing page") (\MP.NEWMAPPAGE 10 "\DONEWPAGE failed to allocate new map page") (\MP.BADLOCKED 11 "Locked page occupies a file page needed to lock another") (\MP.CLOCK0 12 "Arg to CLOCK0 not an integer box") (\MP.RESIDENT 13 "Fault on resident page") (\MP.STACKFAULT 14 "Fault on stack") (\MP.VMEMTOOLONG 16 "Attempt to extend Vmem File beyond fixed limit (8mb)") ( \MP.WRITING.LOCKED.PAGE 17 "Writing a locked page with UPDATEKEY = T") (\MP.UNINTERRUPTABLE 18 "Error in uninterruptable system code") (\MP.STACKFULL 19) (\MP.MDSFULL 20) (\MP.UNKNOWN.UFN 21) ( \MP.ATOMSFULL 22) (\MP.PNAMESFULL 23) (\MP.USECOUNTOVERFLOW 24) (\MP.MDSFULLWARNING 25) ( \MP.BADMDSFREELIST 26) (\MP.BADARRAYBLOCK 27) (\MP.BADDELETEBLOCK 28) (\MP.BADARRAYRECLAIM 29) ( \MP.BIGREFCNTMISSING 30 "PTR refcnt previously overflowed, but not found in table.") ( \MP.BIGREFCNTALREADYPRESENT 31 "PTR already in overflow table") (\MP.DELREF0 32) (\MP.PROCERROR 33) ( \MP.PROCNOFRAME 34 "Failed to build frame for PROCESS use") (\MP.32MBINUSE 35) (\MP.TOPUNWOUND 36 "Unexpected (RETTO T)") (\MP.STACKRELEASED 37) (\MP.FLUSHLOCKED 38) (\MP.MAPNOTLOCKED 39) ( \MP.UNLOCKINGMAP 40) (\MP.SWAPDISKERROR 41 "Hard Disk Error in swapper") (\MP.BADRUNTABLE 42 "Malformed run table for vmem file")) (GLOBALVARS \ARRAYSPACE \ARRAYSPACE2 \ATOMSPACE \AtomHashTable \SMALLPOSPSPACE \SMALLNEGSPACE \PNPSPACE \OLDATOMSPACE \DEFSPACE \VALSPACE \PLISTSPACE \PAGEMAP \PageMapTBL \InterfacePage \IOPAGE \DoveIORegion \IOCBPAGE \FPTOVP \MDSTypeTable \MISCSTATS \UFNTable \DTDSpaceBase \LISTPDTD \LOCKEDPAGETABLE \STACKSPACE \HTMAIN \HTOVERFLOW \HTBIGCOUNT \HTCOLL \DISPLAYREGION) (BLOCKRECORD MISCSTATS ((STARTTIME FIXP) (TOTALTIME FIXP) (SWAPWAITTIME FIXP) (PAGEFAULTS FIXP) ( SWAPWRITES FIXP) (DISKIOTIME FIXP) (DISKOPS FIXP) (KEYBOARDWAITTIME FIXP) (GCTIME FIXP) (NETIOTIME FIXP) (NETIOOPS FIXP) (SWAPTEMP0 FIXP) (SWAPTEMP1 FIXP) (RCLKSECOND FIXP) (SECONDSCLOCK FIXP) ( MILLISECONDSCLOCK FIXP) (BASECLOCK FIXP) (RCLKTEMP0 FIXP) (SECONDSTMP FIXP) (MILLISECONDSTMP FIXP) ( BASETMP FIXP) (EXCESSTIMETMP FIXP) (CLOCKTEMP0 FIXP) (DISKTEMP0 FIXP) (DISKTEMP1 FIXP) (TELERAIDTEMP1 FIXP) (TELERAIDTEMP2 FIXP) (TELERAIDTEMP3 FIXP) (LASTUSERACTION FIXP) (DLMOUSETIMER FIXP) (DLMOUSETEMP FIXP)) (CREATE (\ALLOCBLOCK 31))) (BLOCKRECORD IFPAGE ((CurrentFXP WORD) (* ; "First 7 items are FX values for user and 6 system contexts.") (ResetFXP WORD) (SubovFXP WORD) (KbdFXP WORD) (HardReturnFXP WORD) (GCFXP WORD) (FAULTFXP WORD) (EndOfStack WORD) (* ; "Stack high-water mark: address of guard block at current end of stack") (LVersion WORD) (* ; "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp") (MinRVersion WORD) (MinBVersion WORD) (RVersion WORD) (* ; "Bcpl fills in the actual microcode, Bcpl versions.") ( BVersion WORD) (MachineType WORD) (MiscFXP WORD) (* ; "FX for MISC context") (Key WORD) (* ; "= IFPValidKey if vmem consistent.") (SerialNumber WORD) (* ; "Pup host number (Dorado/Dolphin)") ( EmulatorSpace WORD) (* ; "Hiloc of bcpl space (always zero now)") (ScreenWidth WORD) (NxtPMAddr WORD) (* ; "Next page to be allocated in secondary page map table") (NIL WORD) (* ; "WAS NActivePages, Length of vmem in use") (NIL WORD) (* ; "WAS NDirtyPages, not used, but maintained as = NActivePages") (filePnPMP0 WORD) (* ; "Sysout page number of first page of secondary page map table (\PAGEMAP), which is where the secondary map pages themselves live" ) (filePnPMT0 WORD) (* ; "Sysout page number of first page of primary page map table") (TELERAIDFXP WORD) (* ; "FX for TeleRaid server context") (NATIVE-START-MEM-PAGE WORD) (* ; "Unix page where native code starts") (NATIVE-LENGTH-PAGE WORD) (* ; "Unix page length of native code" ) (NATIVE-PAGE-OFFSET WORD) (* ; "Lisp Disk Page offset of native code") (UserNameAddr WORD) (* ; "Addresses in bcpl space (seg 0) of global user name and password") (UserPswdAddr WORD) (StackBase WORD) (* ; "Stack address where user stack starts") (FAULTHI WORD) (* ; "Microcode for page fault stores fault address here, then does context switch to FAULTFXP") (FAULTLO WORD) (DEVCONFIG WORD) (* ; "IT'S FOR KB,DISP TYPE") (* ; "Formerly REALPAGETABLE, back when it was always in Bcpl space.") (RPTSIZE WORD) (* ; "Number of entries in Real Page Table") (RPOFFSET WORD) (* ; "RP-RPOFFSET => index in table") ( MAXETHERBYTES WORD) (* ; "Number of bytes available in a pbi, not counting encapsulation (Dorado)") ( EMBUFVP WORD) (* ; "VP of a one-page emulator buffer") (NSHost0 WORD) (* ; "Machine's 48-bit NS host number. Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in." ) (NSHost1 WORD) (NSHost2 WORD) (MDSZone WORD) (* ; "Obsolete -- was used by Dolphin 10MB network code.") (MDSZoneLength WORD) (EMUBUFFERS WORD) (* ; "Buffer space in segment 0 for swapping/disk activity") (EMUBUFLENGTH WORD) (* ; "Number of words of said space") (* ;; "The following 2 are available if NEW_STOARGE is specified in C") (ProcessSize WORD) (* ; "Process size for which can be use as LISP space") (StorageFullState WORD) (* ; "Save last storage state") (ISFMAP WORD) (* ;; "The following 4 are for \MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!" ) (MISCSTACKFN FULLXPOINTER) (MISCSTACKARG1 FULLXPOINTER) (MISCSTACKARG2 FULLXPOINTER) ( MISCSTACKRESULT FULLXPOINTER) (NRealPages WORD) (* ; "Number pages of real memory") ( LastLockedFilePage WORD) (* ; "Last page of vmem that is locked--booting has to load at least that far.") (LastDominoFilePage WORD) (* ; "Last sysout page reserved for Dandelion microcode") (FPTOVPStart WORD) (* ; "Sysout page where FPTOVP starts") (FAKEMOUSEBITS WORD) (* ; "Used to implement fake middle button on 2-button Dandelion.") (DL24BitAddressable WORD) (* ; "non-zero if DLion capable of addressing 32MB virtual memory") (REALPAGETABLEPTR FULLXPOINTER) (* ; "Address of real page table, set up by Bcpl (but not chained together)") (SYSDISK WORD) (* ; "WAS DLLastVmemPage, DLion booting microcode puts length of vmem file here.") (FullSpaceUsed WORD) (* ; "Non-zero if vmem beyond initial 8MB has been allocated.") (FAKEKBDAD4 WORD) (FAKEKBDAD5 WORD) (* ;; "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with." ) (XVmemFmapBase WORD) (* ; "Bcpl stores isf map pointer to each partition here. First is redundant with ISFMAP field above.") ( NIL WORD) (NIL WORD) (XVmemFmapHighBase WORD) (* ; "Bcpl stores the highest vm page contained in this or earlier partition.") (NIL WORD) (NIL WORD) ( XVmemDiskBase FULLXPOINTER) (* ; "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).") (NIL FULLXPOINTER) (NIL FULLXPOINTER) (DLLastVmemPage FIXP) (* ; "DLion booting microcode puts length of vmem file here.") (NActivePages FIXP) (* ; "Length of vmem in use") (NDirtyPages FIXP) (* ; "not used, but maintained as = NActivePages")) ( CREATE (\ALLOCBLOCK 43))) (BLOCKRECORD IOPAGE ((NIL 18 WORD) (DLMAINTPANEL WORD) (DLFLOPPYCMD WORD) (DLTTYPORTCMD WORD) ( DLPROCESSORCMD WORD) (NEWMOUSESTATE WORD) (DLBEEPCMD WORD) (DLRS232CMISCCOMMAND WORD) (DLRS232CPUTFLAG WORD) (DLRS232CGETFLAG WORD) (NIL 6 WORD) (DLFLOPPY WORD) (DLTTYOUT WORD) (NIL 1 WORD) (DLTTYIN WORD) (NIL 1 WORD) (DLPROCESSOR2 WORD) (DLPROCESSOR1 WORD) (DLPROCESSOR0 WORD) (NEWMOUSEX WORD) (NEWMOUSEY WORD) (DLBEEPFREQ WORD) (DLRS232CPARAMETERCSBLO WORD) (DLRS232CPARAMETERCSBHI WORD) ( DLRS232CSETRS366STATUS 3 WORD) (DLRS232CPUTCSBLO WORD) (DLRS232CPUTCSBHI WORD) (DLRS232CGETCSBLO WORD) (DLRS232CGETCSBHI WORD) (DLRS232CDEVICESTATUS WORD) (DLRS232CPARAMETEROUTCOME WORD) (DLTODVALID WORD) (DLTODLO WORD) (DLTODHI WORD) (DLTODLO2 WORD) (DLMOUSEX WORD) (DLMOUSEY WORD) (DLUTILIN WORD) ( DLKBDAD0 WORD) (DLKBDAD1 WORD) (DLKBDAD2 WORD) (DLKBDAD3 WORD) (DLKBDAD4 WORD) (DLKBDAD5 WORD) ( DLLSEPIMAGECSB 32 WORD) (DLIOPHARDWARECONFIG WORD) (NIL 11 WORD) (DLRS232CPARAMETERCSBLO.11 WORD) ( DLRS232CPARAMETERCSBHI.11 WORD) (DLRS232CSETRS366STATUS.11 14 WORD) (NIL 60 WORD) (DLMAGTAPE 4 WORD) ( DLETHERNET 12 WORD) (NIL 31 WORD) (DLDISPINTERRUPT WORD) (DLDISPCONTROL WORD) (DLDISPBORDER WORD) ( DLCURSORX WORD) (DLCURSORY WORD) (DLCURSORBITMAP 16 WORD)) (ACCESSFNS IOPAGE ((DLCURSORBITMAPPTR ( \ADDBASE DATUM 240)) (DLCURSORYPTR (\ADDBASE DATUM 239)) (DLCURSORXPTR (\ADDBASE DATUM 238)) ( DLDISPINTERRUPTPTR (\ADDBASE DATUM 235)) (DLETHERNETPTR (\ADDBASE DATUM 192)) (DLKBDAD5PTR (\ADDBASE DATUM 67)) (DLKBDAD4PTR (\ADDBASE DATUM 66)) (DLKBDAD3PTR (\ADDBASE DATUM 65)) (DLKBDAD2PTR (\ADDBASE DATUM 64)) (DLKBDAD1PTR (\ADDBASE DATUM 63)) (DLKBDAD0PTR (\ADDBASE DATUM 62)) (DLUTILINPTR (\ADDBASE DATUM 61)) (DLMOUSEYPTR (\ADDBASE DATUM 60)) (DLMOUSEXPTR (\ADDBASE DATUM 59)) (DLTODLOPTR (\ADDBASE DATUM 56)) (DLMAINTPANELPTR (\ADDBASE DATUM 18)))) (CREATE (\ALLOCBLOCK 128))) (PUTPROPS EMADDRESS MACRO (ARGS ((LAMBDA (ADDR) (COND ((EQ \D1BCPLspace \D0BCPLspace) (LIST ( BIG-VMEM-CODE (LIST (QUOTE OPCODES) (QUOTE GCONST) 0 0 (LRSH ADDR 8) (LOGAND ADDR 255)) (LIST (QUOTE OPCODES) (QUOTE GCONST) 0 (LRSH ADDR 8) (LOGAND ADDR 255))))) (T (BQUOTE (\VAG2 (fetch EmulatorSpace of \InterfacePage) %, ADDR))))) (EVAL (CAR ARGS))))) (PUTPROPS EMGETBASE MACRO ((OFFSET) (\GETBASE (EMADDRESS OFFSET) 0))) (PUTPROPS EMPUTBASE MACRO ((OFFSET VAL) (\PUTBASE (EMADDRESS OFFSET) 0 VAL))) (PUTPROPS EMULATORSEGMENT MACRO (NIL (fetch EmulatorSpace of \InterfacePage))) (PUTPROPS EMPOINTER MACRO (X (COND ((NEQ \D1BCPLspace \D0BCPLspace) (LIST (QUOTE \VAG2) (QUOTE (fetch (IFPAGE EmulatorSpace) of \InterfacePage)) (CAR X))) ((ZEROP (CAR X)) NIL) (T (LIST (QUOTE \VAG2) \D0BCPLspace (CAR X)))))) (PUTPROPS EMADDRESSP MACRO (X (LIST (QUOTE EQ) (LIST (QUOTE \HILOC) (CAR X)) (COND ((EQ \D1BCPLspace \D0BCPLspace) \D0BCPLspace) (T (QUOTE (fetch (IFPAGE EmulatorSpace) of \InterfacePage))))))) (PUTPROP (QUOTE LLPARAMS) (QUOTE IMPORTDATE) (IDATE "31-Jan-98 09:16:51")) (DATATYPE COMPILED-CLOSURE (FNHEADER ENVIRONMENT)) (RPAQQ \COMPILED-CLOSURE 13) (CONSTANTS \COMPILED-CLOSURE) (PUTPROPS \EXTENDED.EQP MACRO (OPENLAMBDA (X Y) (COND ((EQ (NTYPX X) (NTYPX Y)) (SELECTC (NTYPX X) ( \STACKP (EQ (fetch (STACKP EDFXP) of X) (fetch (STACKP EDFXP) of Y))) (\COMPILED-CLOSURE (EQDEFP X Y)) NIL))))) (PUTPROPS DPUTCODE MACRO ((FN CA SIZE) (SELECTQ (SYSTEMTYPE) (D (DEFC FN CA)) (/PUTPROP FN (QUOTE DCODE) CA)))) (PUTPROPS MCODEP MACRO ((X) (OR (ARRAYP X) (AND (LITATOM X) (ARRAYP (SELECTQ (SYSTEMTYPE) (D (GETD X)) (GETPROP X (QUOTE DCODE)))))))) (PUTPROPS CODELT MACRO ((CA N) (\BYTELT CA N))) (PUTPROPS CODELT2 MACRO (OPENLAMBDA (DEF LC) (LOGOR (LLSH (CODELT DEF LC) BITSPERBYTE) (CODELT DEF ( ADD1 LC))))) (PUTPROPS CODESETA2 MACRO (OPENLAMBDA (DEF LC VALUE) (CODESETA DEF LC (LRSH VALUE BITSPERBYTE)) ( CODESETA DEF (ADD1 LC) (IMOD VALUE (CONSTANT (LLSH 1 BITSPERBYTE)))))) (PUTPROPS CODESETA MACRO ((CA N NV) (\BYTESETA CA N NV))) (PUTPROPS BYTESPERNAMEENTRY MACRO (NIL (UNFOLD (CONSTANT (WORDSPERNAMEENTRY)) BYTESPERWORD))) (PUTPROPS BYTESPERNTOFFSETENTRY MACRO (NIL (UNFOLD (WORDSPERNAMEENTRY) BYTESPERWORD))) (PUTPROPS GETNAMEENTRY MACRO (OPENLAMBDA (DEF LC) (LET ((NUMBER 0)) (* ;; "Must ALWAYS be called with DEF really being either a FNHEADER or a nametable pseudo-fnheader. Never use addbase to offset from it. This is because CODEBASEELT checks the BYTESWAPPED flag in the fnheader...." ) (FOR I FROM 0 TO (CONSTANT (SUB1 (BYTESPERNAMEENTRY))) DO (SETQ NUMBER (LOGOR (LLSH NUMBER BITSPERBYTE) (CODEBASELT DEF (IPLUS LC I))))) NUMBER))) (PUTPROPS GETNTFLAGS MACRO (OPENLAMBDA (DEF LC) (CODEBASELT DEF LC))) (PUTPROPS GETNTOFFSET MACRO (OPENLAMBDA (DEF LC) (NTSLOT-OFFSET (GETNTOFFSETENTRY DEF LC)))) (PUTPROPS GETNTOFFSETENTRY MACRO (OPENLAMBDA (DEF LC) (LET ((NUMBER 0)) (for I from 0 to (CONSTANT ( SUB1 (BYTESPERNTOFFSETENTRY))) do (SETQ NUMBER (LOGOR (LLSH NUMBER BITSPERBYTE) (CODEBASELT DEF (IPLUS LC I))))) NUMBER))) (PUTPROPS GETNTTAG MACRO (OPENLAMBDA (DEF LC) (CODEBASELT DEF (ADD1 LC)))) (PUTPROPS SETNAMEENTRY MACRO (OPENLAMBDA (DEF LC VALUE) (FOR I FROM (CONSTANT (SUB1 (BYTESPERNAMEENTRY ))) TO 0 BY -1 DO (CODEBASESETA DEF (IPLUS LC I) (LOGAND VALUE (CONSTANT (SUB1 (LLSH 1 BITSPERBYTE)))) ) (SETQ VALUE (LRSH VALUE BITSPERBYTE))))) (PUTPROPS WORDSPERNTOFFSETENTRY MACRO (NIL (WORDSPERNAMEENTRY))) (PUTPROPS NTSLOT-OFFSET MACRO ((X) (LOGAND 255 X))) (DEFMACRO NEW-SYMBOL-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM) (* ;; "Use one form or another, depending on whether we're compiling for new 3-byte atoms or old 2-byte atom numbers." ) (COND ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*) (* ; "NEW ATOMS") (BQUOTE (\, NEW-SYMBOL-FORM ))) (T (BQUOTE (\, OLD-SYMBOL-FORM))))) (DEFOPTIMIZER BIG-VMEM-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM &ENVIRONMENT ENV) (* ;; "Allow for differences between 4-byte pointers and 3-byte pointers..") (COND ((FMEMB :4-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\, NEW-SYMBOL-FORM))) (T (BQUOTE (\, OLD-SYMBOL-FORM) )))) (DEFOPTIMIZER SETSTKNAMEENTRY (CODEARRAY OFFSET VAL &ENVIRONMENT ENV) (* ;; "Set the name entry for a name-table entry.") (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (LET ((BASE (fetch (ARRAYP BASE) of (\, CODEARRAY))) (VALUE (\, VAL))) (COND ((FIXP VALUE) (* ; "A 20-byte atom #. Make it an atom.") (\PUTBASEPTR BASE (\, OFFSET) (\VAG2 \AtomHI VALUE) )) (T (* ; "A 3-byte atom. Just use it.") (\PUTBASEPTR BASE (\, OFFSET) VALUE)))))) (T (BQUOTE (LET ( (BASE (fetch (ARRAYP BASE) of (\, CODEARRAY)))) (\PUTBASE BASE (\, OFFSET) (\, VAL))))))) (DEFOPTIMIZER SETSTKNTOFFSETENTRY (BASE OFFSET VAL &ENVIRONMENT ENV) (* ;; "Set the offset entry for a name-table entry.") (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\PUTBASEFIXP (\, BASE) (\, OFFSET) (\, VAL)))) (T (BQUOTE (\PUTBASE (\, BASE) (\, OFFSET) (\, VAL)))))) (DEFOPTIMIZER GETSTKNAMEENTRY (BASE OFFSET &ENVIRONMENT ENV) (* ;; "Get a name entry out of a name table. BASE is the start of the name table; OFFSET is in words, not bytes or name entries." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\GETBASEPTR (\, BASE) (\, OFFSET)))) (T (BQUOTE (\GETBASE (\, BASE) (\, OFFSET)))))) (DEFOPTIMIZER GETSTKNTOFFSETENTRY (BASE OFFSET &ENVIRONMENT ENV) (COND ((FMEMB :3-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\GETBASEFIXP (\, BASE) (\, OFFSET)))) (T (BQUOTE ( \GETBASE (\, BASE) (\, OFFSET)))))) (DEFOPTIMIZER WORDSPERNAMEENTRY (&ENVIRONMENT ENV) (* ;; "Number of words in a name-table %"Name%" entry--the space for the symbol. 1 for old symbol systems, 2 for 3-byte-atom systesm." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (PROGN 2))) ((AND CROSSCOMPILING (FMEMB :3-BYTE-INIT (COMPILER::ENV-TARGET-ARCHITECTURE ENV))) (BQUOTE (PROGN 2))) (T ( BQUOTE (PROGN 1))))) (DEFOPTIMIZER SETSTKNTOFFSET (BASE OFFSET TYPE VAL &ENVIRONMENT ENV) (* ;; "Set the offset entry for a name-table entry, from the symbol to fill in plus the variable-type marker value SHIFTED LEFT 14 BITS ALREADY." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (PROGN (\FIXCODENUM (\, BASE) (IDIFFERENCE (\, OFFSET) BYTESPERWORD) (\, TYPE)) (\FIXCODENUM (\, BASE) (\, OFFSET) (\, VAL))))) (T (BQUOTE (\FIXCODENUM (\, BASE) (\, OFFSET) (IPLUS (\, TYPE) (\, VAL))))))) (DEFOPTIMIZER SETSTKNAME-RAW (BASE OFFSET VAL &ENVIRONMENT ENV) (* ;; "Set the name entry for a name-table entry. This version works with raw storage, as opposed to SETSTKNAMEENTRY, which works on an ARRAYP." ) (* ;; "If this optimizer changes, change SETSTKNAMEENTRY as well.") (COND ((FMEMB :3-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (LET ((VALUE (\, VAL))) (COND ((FIXP VALUE) (* ; "A 20-byte atom #. Make it an atom.") (\PUTBASEPTR (\, BASE) (\, OFFSET) (\VAG2 \AtomHI VALUE))) (T ( * ; "A 3-byte atom. Just use it.") (\PUTBASEPTR (\, BASE) (\, OFFSET) VALUE)))))) (T (BQUOTE ( \PUTBASE (\, BASE) (\, OFFSET) (\, VAL)))))) (DEFOPTIMIZER SETSTKNTOFFSET-RAW (BASE OFFSET TYPE VAL &ENVIRONMENT ENV) (* ;; "Set the offset entry for a name-table entry. This version works on raw storage, vs SETSTKNAMEOFFSETENTRY, which is supposed to work on codearrays. Any changes here should be made there, as well. TYPE must already be shifted left by 14 bits." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (PROGN (\PUTBASE (\, BASE) ( \, OFFSET) (\, TYPE)) (\PUTBASE (\, BASE) (IPLUS (\, OFFSET) 1) (\, VAL))))) (T (BQUOTE (\PUTBASE (\, BASE) (\, OFFSET) (IPLUS (\, TYPE) (\, VAL))))))) (DEFOPTIMIZER NEW-SYMBOL-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM &ENVIRONMENT ENV) (* ;; "Allow for differences between 3-byte atoms and 2-byte atoms.") (COND ((FMEMB :3-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\, NEW-SYMBOL-FORM))) (T (BQUOTE (\, OLD-SYMBOL-FORM) )))) (DEFOPTIMIZER MAKE-NTENTRY (TYPE OFFSET &ENVIRONMENT ENV) (COND ((FMEMB :3-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (IPLUS (CONSTANT (LLSH (\, TYPE) 16)) (\, OFFSET)))) ( T (BQUOTE (IPLUS (CONSTANT (\, TYPE)) (\, OFFSET)))))) (DEFOPTIMIZER NULL-NTENTRY (VALUE &ENVIRONMENT ENV) (* ;; "Predicate: Is VALUE a null entry in a name table? I.e., does it result from fetching the entry at the end that`s all zeros? For 2-byte atoms, that's the same as being zero. For 3-byte atoms, it's the same as being NIL." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (NULL (\, VALUE)))) (T ( BQUOTE (EQ (\, VALUE) 0))))) (DEFOPTIMIZER NTSLOT-VARTYPE (X &ENVIRONMENT ENV) (* ;; "Given the contents of a name-table Offset entry, return the variable-type bits at the top of the entry. THE RESULT IS RETURNED SHEFTED LEFT 14 BITS, THE USUAL REPRESENTATION." ) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (LOGAND 49153 (LRSH (\, X) 16 )))) (T (BQUOTE (LOGAND (\, X) 49152))))) (ACCESSFNS CODEARRAY ((STKMIN (CODELT2 DATUM 0) (CODESETA2 DATUM 0 NEWVALUE)) (NA (SIGNED (CODELT2 DATUM 2) BITSPERWORD) (CODESETA2 DATUM 2 (UNSIGNED NEWVALUE BITSPERWORD))) (PV (SIGNED (CODELT2 DATUM 4) BITSPERWORD) (CODESETA2 DATUM 4 (UNSIGNED NEWVALUE BITSPERWORD))) (STARTPC (CODELT2 DATUM 6) ( CODESETA2 DATUM 6 NEWVALUE)) (ARGTYPE (LOGAND (LRSH (CODELT DATUM 8) 4) 3) (CODESETA DATUM 8 (LOGOR ( LOGAND (CODELT DATUM 8) 207) (LLSH (LOGAND NEWVALUE 3) 4)))) (FRAMENAME (\VAG2 (LOGAND (CODELT2 DATUM 8) 4095) (CODELT2 DATUM 10)) (\FIXCODEPTR DATUM 11 (EVQ NEWVALUE))) (NTSIZE (CODELT2 DATUM 12) ( CODESETA2 DATUM 12 NEWVALUE)) (NLOCALS (CODELT DATUM 14) (CODESETA DATUM 14 NEWVALUE)) (FVAROFFSET ( CODELT DATUM 15) (CODESETA DATUM 15 NEWVALUE))) (ACCESSFNS CODEARRAY ((LSTARP (ILESSP (fetch ( CODEARRAY NA) of DATUM) 0)) (OVERHEADWORDS (PROGN 8)) (ALIGNED (IPLUS (fetch (CODEARRAY NTSIZE) of DATUM) (fetch (CODEARRAY OVERHEADWORDS) of T))) (FIXED NIL (replace (CODEARRAY STKMIN) of DATUM with ( \STKMIN DATUM))) (FRAMENAME# (PROGN 8))))) (RECORD OPCODE (OP# OPCODENAME OPNARGS OPPRINT LEVADJ UFNFN UNIMPL)) (GLOBALVARS \OPCODES) (RPAQQ PVARCODE 32768) (RPAQQ FVARCODE 49152) (RPAQQ IVARCODE 0) (RPAQQ VARCODEMASK 49152) (CONSTANTS PVARCODE FVARCODE IVARCODE VARCODEMASK) (RPAQQ \NT.IVARCODE 0) (RPAQQ \NT.PVARCODE 2) (RPAQQ \NT.FVARCODE 3) (CONSTANTS \NT.IVARCODE \NT.PVARCODE \NT.FVARCODE) (PUTPROP (QUOTE LLCODE) (QUOTE IMPORTDATE) (IDATE "19-Jan-93 10:45:33")) (RPAQQ \ERRORMESSAGELIST ("SYSTEM ERROR" " " "STACK OVERFLOW" "ILLEGAL RETURN" "ARG NOT LIST" "HARD DISK ERROR" "ATTEMPT TO SET NIL OR T" "ATTEMPT TO RPLAC NIL" "UNDEFINED OR ILLEGAL GO" "FILE WON'T OPEN" "NON-NUMERIC ARG" "ATOM TOO LONG" "ATOM HASH TABLE FULL" "FILE NOT OPEN" "ARG NOT LITATOM" "! too many files open" "END OF FILE" "ERROR" "BREAK" "ILLEGAL STACK ARG" "FAULT IN EVAL" "ARRAYS FULL" "FILE SYSTEM RESOURCES EXCEEDED" "FILE NOT FOUND" "BAD SYSOUT FILE" "UNUSUAL CDR ARG LIST" "HASH TABLE FULL" "ILLEGAL ARG" "ARG NOT ARRAY" "ILLEGAL OR IMPOSSIBLE BLOCK" "STACK PTR HAS BEEN RELEASED" "STORAGE FULL" "ATTEMPT TO USE ITEM OF INCORRECT TYPE" "ILLEGAL DATA TYPE NUMBER" "DATA TYPES FULL" "ATTEMPT TO BIND NIL OR T" "! too many user interrupt characters" "! read-macro context error" "ILLEGAL READTABLE" "ILLEGAL TERMINAL TABLE" "! swapblock too big for buffer" "PROTECTION VIOLATION" "BAD FILE NAME" "USER BREAK" "UNBOUND ATOM" "UNDEFINED CAR OF FORM" "UNDEFINED FUNCTION" "CONTROL-E" "FLOATING UNDERFLOW" "FLOATING OVERFLOW" "OVERFLOW" "ARG NOT HARRAY" "TOO MANY ARGUMENTS")) (DEFOPTIMIZER LISPERROR (MESSAGE ARG) (BQUOTE (\LISPERROR (\, ARG) (\, (CL:IF (CL:STRINGP MESSAGE) ( FOR X IN \ERRORMESSAGELIST AS I FROM 0 WHEN (CL:EQUAL X MESSAGE) DO (RETURN I) FINALLY (RETURN (HELP "Unknown error message" (LIST MESSAGE ARG)))) MESSAGE))))) (PUTPROP (QUOTE AERROR) (QUOTE IMPORTDATE) (IDATE "16-May-90 11:58:35")) (RECORD BASEBYTESTREAM STREAM (SUBRECORD STREAM) (ACCESSFNS ((BIASOFFST (fetch (STREAM FW6) of DATUM) (replace (STREAM FW6) of DATUM with NEWVALUE)) (BBSNCHARS (fetch (STREAM FW7) of DATUM) (replace ( STREAM FW7) of DATUM with NEWVALUE)) (WRITEXTENSIONFN (fetch (STREAM F1) of DATUM) (replace (STREAM F1 ) of DATUM with NEWVALUE))))) (PUTPROPS \INSTREAMARG MACRO ((STRM NOERRORFLG) (\GETSTREAM STRM (QUOTE INPUT) NOERRORFLG))) (PUTPROPS \OUTSTREAMARG MACRO ((STRM NOERRORFLG) (\GETSTREAM STRM (QUOTE OUTPUT) NOERRORFLG))) (PUTPROPS \STREAMARG MACRO (OPENLAMBDA (STRM NOERRORFLG) (COND (NOERRORFLG (\GETSTREAM STRM NIL T)) (T (\DTEST STRM (QUOTE STREAM)))))) (PUTPROP (QUOTE AOFD) (QUOTE IMPORTDATE) (IDATE "13-Sep-90 16:39:58")) (PUTPROPS .SPACECHECK. MACRO ((STRM N) (AND \THISFILELINELENGTH (IGREATERP (IPLUS N (fetch CHARPOSITION of STRM)) \THISFILELINELENGTH) (FRESHLINE STRM)))) (PUTPROPS \CHECKRADIX MACRO (LAMBDA (R) (COND ((OR (NOT (SMALLP R)) (ILESSP R 1) (IGREATERP R 36)) ( \INVALID.RADIX R)) (T R)))) (PUTPROPS \XCCSFILEOUTCHARFN MACRO ((OUTSTREAM CHARCODE) (* ;;; "Encoder for XCCS format. Default decoder.") (COND ((EQ CHARCODE (CHARCODE EOL)) (COND ((NOT ( \RUNCODED OUTSTREAM)) (* ; "Charset is a constant 0") (\BOUT OUTSTREAM (\CHARSET (CHARCODE EOL)))) (( EQ (\CHARSET (CHARCODE EOL)) (ffetch (STREAM CHARSET) of OUTSTREAM))) (T (\BOUT OUTSTREAM NSCHARSETSHIFT) (\BOUT OUTSTREAM (freplace (STREAM CHARSET) of OUTSTREAM with (\CHARSET (CHARCODE EOL) ))))) (\BOUT OUTSTREAM (SELECTC (ffetch EOLCONVENTION of OUTSTREAM) (CR.EOLC (CHARCODE CR)) (LF.EOLC ( CHARCODE LF)) (CRLF.EOLC (\BOUT OUTSTREAM (CHARCODE CR)) (* ;; "Don't put out high-order byte preceding LF. The CRLF is EOL only if the bytes are immediately adjacent in the stream, with no additional encoding bytes" ) (CHARCODE LF)) (SHOULDNT))) (freplace CHARPOSITION of OUTSTREAM with 0)) (T (COND ((NOT (\RUNCODED OUTSTREAM)) (\BOUT OUTSTREAM (\CHARSET CHARCODE)) (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE))) ((EQ ( \CHARSET CHARCODE) (ffetch (STREAM CHARSET) of OUTSTREAM)) (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE))) (T (\BOUT OUTSTREAM NSCHARSETSHIFT) (\BOUT OUTSTREAM (freplace (STREAM CHARSET) of OUTSTREAM with ( \CHARSET CHARCODE))) (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE)))) (freplace CHARPOSITION of OUTSTREAM with (PROGN (* ; "Ugh. Don't overflow") (IPLUS16 (ffetch CHARPOSITION of OUTSTREAM) 1))))))) (PUTPROP (QUOTE APRINT) (QUOTE IMPORTDATE) (IDATE " 6-Dec-91 11:43:22")) (GLOBALVARS \BCPLDISPLAY) (ACCESSFNS LINEBUFFER ((LPARCOUNT (fetch FW6 of DATUM) (replace FW6 of DATUM with NEWVALUE)) ( LBRKCOUNT (fetch FW7 of DATUM) (replace FW7 of DATUM with NEWVALUE)) (LINEBUFSTATE (fetch F5 of DATUM) (replace F5 of DATUM with NEWVALUE)) (* ; "F4 is free. EJS, 7/8/85") (KEYBOARDSTREAM (fetch F2 of DATUM) (replace F2 of DATUM with NEWVALUE)) (PEEKEDCHAR (fetch F3 of DATUM) (replace F3 of DATUM with NEWVALUE)) (* ; "Character read by PEEKC") (LBFLAGS (fetch FW9 of DATUM) (replace FW9 of DATUM with NEWVALUE)) (* ;; "True if peeked char was echoed when peeked. Could use this to determine whether to echo later or not, but that would be incompatible with Interlisp-10, so this field not used" )) (ACCESSFNS LINEBUFFER ((LBFLAGBASE (LOCF (fetch LBFLAGS of DATUM)))) (BLOCKRECORD LBFLAGBASE (( PEEKEDECHOFLG FLAG) (INSTRINGP FLAG))))) (RPAQQ LINEBUFFERSTATES (FILLING.LBS READING.LBS RETYPING.LBS)) (RPAQQ FILLING.LBS 0) (RPAQQ READING.LBS 1) (RPAQQ RETYPING.LBS 2) (CONSTANTS FILLING.LBS READING.LBS RETYPING.LBS) (PUTPROPS \INTERMP MACRO ((OFD) (EQ OFD \LINEBUF.OFD))) (PUTPROPS \OUTTERMP MACRO ((OFD) (EQ OFD \TERM.OFD))) (GLOBALVARS \DEFAULTLINEBUF) (PUTPROP (QUOTE ATERM) (QUOTE IMPORTDATE) (IDATE "16-May-90 12:08:04")) (DATATYPE HARRAYP ((NULLSLOTS WORD) (* ; "Number of NIL-NIL slots, which break chains") (LASTINDEX WORD) (* ; "Slot offset of last slot. Used in probe computations computations. Microcode support for \ADDBASE4 would help" ) (HARRAYPBASE POINTER) (RECLAIMABLE FLAG) (* ; "True if keys can go away when no other refs") ( OVERFLOWACTION POINTER) (NUMSLOTS WORD) (* ; "The maximum number of logical slots--returned by HARRAYSIZE") (NUMKEYS WORD) (* ; "The number of distinct keys in the array") (HASHBITSFN POINTER) (EQUIVFN POINTER) (HASHUSERDATA POINTER))) (PUTPROPS \EQHASHINGBITS MACRO (OPENLAMBDA (X) (* ; "Spread out objects whose low bits are in small arithmetic progression, esp atoms") (LOGXOR (\HILOC X) (LOGXOR (LLSH (LOGAND (\LOLOC X) 8191) 3) (LRSH (\LOLOC X) 9))))) (PUTPROPS \ADDBASE2 MACRO (OPENLAMBDA (BASE N) (\ADDBASE (\ADDBASE BASE N) N))) (PUTPROPS \ADDBASE4 MACRO (OPENLAMBDA (BASE N) (\ADDBASE2 (\ADDBASE2 BASE N) N))) (PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX) (FOLDLO (fetch DTDSIZE of (\GETDTD NTYPX)) WORDSPERCELL))) (PUTPROPS \BYTELT DMACRO (OPENLAMBDA (A J) (\GETBASEBYTE (fetch (ARRAYP BASE) of A) (IPLUS (fetch ( ARRAYP OFFST) of A) J)))) (PUTPROPS \BYTESETA DMACRO (OPENLAMBDA (A J V) (\PUTBASEBYTE (fetch (ARRAYP BASE) of A) (IPLUS (fetch (ARRAYP OFFST) of A) J) V))) (PUTPROPS \WORDELT DMACRO (OPENLAMBDA (A J) (CHECK (AND (ARRAYP A) (EQ 0 (fetch (ARRAYP ORIG) of A)) ( EQ \ST.POS16 (fetch (ARRAYP TYP) of A)))) (CHECK (IGREATERP (fetch (ARRAYP LENGTH) of A) J)) (\GETBASE (fetch (ARRAYP BASE) of A) (IPLUS (fetch (ARRAYP OFFST) of A) J)))) (RPAQQ BLOCKGCTYPECONSTANTS ((CODEBLOCK.GCT 2) (PTRBLOCK.GCT 1) (UNBOXEDBLOCK.GCT 0))) (RPAQQ CODEBLOCK.GCT 2) (RPAQQ PTRBLOCK.GCT 1) (RPAQQ UNBOXEDBLOCK.GCT 0) (CONSTANTS (CODEBLOCK.GCT 2) (PTRBLOCK.GCT 1) (UNBOXEDBLOCK.GCT 0)) (RPAQQ ARRAYCONSTANTS (\ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells \ArrayBlockTrailerWords (\ArrayBlockOverheadCells (IPLUS \ArrayBlockHeaderCells \ArrayBlockTrailerCells)) (\ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords \ArrayBlockTrailerWords)) \ArrayBlockLinkingCells (\MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells \ArrayBlockLinkingCells)) (\MaxArrayBlockSize 65535) (\MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize \ArrayBlockOverheadCells)) \MaxArrayLen (\ABPASSWORDSHIFT 3) (\ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT)) (\FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT) (LLSH UNBOXEDBLOCK.GCT 1))) (\UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT) 1)) ( \CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT) (LLSH CODEBLOCK.GCT 1) 1)))) (RPAQQ \ArrayBlockHeaderCells 1) (RPAQQ \ArrayBlockHeaderWords 2) (RPAQQ \ArrayBlockTrailerCells 1) (RPAQQ \ArrayBlockTrailerWords 2) (RPAQ \ArrayBlockOverheadCells (IPLUS \ArrayBlockHeaderCells \ArrayBlockTrailerCells)) (RPAQ \ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords \ArrayBlockTrailerWords)) (RPAQQ \ArrayBlockLinkingCells 2) (RPAQ \MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells \ArrayBlockLinkingCells)) (RPAQQ \MaxArrayBlockSize 65535) (RPAQ \MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize \ArrayBlockOverheadCells)) (RPAQQ \MaxArrayLen 65535) (RPAQQ \ABPASSWORDSHIFT 3) (RPAQ \ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT)) (RPAQ \FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT) (LLSH UNBOXEDBLOCK.GCT 1)) ) (RPAQ \UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT) 1)) (RPAQ \CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT) (LLSH CODEBLOCK.GCT 1) 1)) (CONSTANTS \ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells \ArrayBlockTrailerWords (\ArrayBlockOverheadCells (IPLUS \ArrayBlockHeaderCells \ArrayBlockTrailerCells)) (\ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords \ArrayBlockTrailerWords)) \ArrayBlockLinkingCells (\MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells \ArrayBlockLinkingCells)) (\MaxArrayBlockSize 65535) (\MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize \ArrayBlockOverheadCells)) \MaxArrayLen (\ABPASSWORDSHIFT 3) (\ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT)) (\FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT) (LLSH UNBOXEDBLOCK.GCT 1))) (\UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT) 1)) ( \CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT) (LLSH CODEBLOCK.GCT 1) 1))) (RPAQQ ARRAYTYPES ((\ST.BYTE 0) (\ST.POS16 1) (\ST.INT32 2) (\ST.CODE 4) (\ST.PTR 6) (\ST.FLOAT 7) ( \ST.BIT 8) (\ST.PTR2 11))) (RPAQQ \ST.BYTE 0) (RPAQQ \ST.POS16 1) (RPAQQ \ST.INT32 2) (RPAQQ \ST.CODE 4) (RPAQQ \ST.PTR 6) (RPAQQ \ST.FLOAT 7) (RPAQQ \ST.BIT 8) (RPAQQ \ST.PTR2 11) (CONSTANTS (\ST.BYTE 0) (\ST.POS16 1) (\ST.INT32 2) (\ST.CODE 4) (\ST.PTR 6) (\ST.FLOAT 7) (\ST.BIT 8) (\ST.PTR2 11)) (RPAQQ \MAX.CELLSPERHUNK 64) (CONSTANTS \MAX.CELLSPERHUNK) (RPAQQ \IN.MAKEINIT NIL) (CONSTANTS (\IN.MAKEINIT)) (BLOCKRECORD SEQUENCEDESCRIPTOR ((ORIG BITS 1) (NIL BITS 1) (READONLY FLAG) (NIL BITS 1) (BASE POINTER ) (TYP BITS 4) (NIL BITS 4) (LENGTH BITS 24) (OFFST FIXP))) (DATATYPE ARRAYP ((* ;; "Describes an INTERLISP ARRAYP, as opposed to a CL array.") (ORIG BITS 1) (* ; "Origin, 0 or 1") (NIL BITS 1) (READONLY FLAG) (* ; "probably no READONLY arrays now") (NIL BITS 1) ( BASE POINTER) (TYP BITS 4) (* ; "Type of the contents") (NIL BITS 4) (LENGTH BITS 24) (* ; "Array's length") (OFFST FIXP) (* ; "Offset from BASE where the data really starts.")) (* ;; "note that while ARRAYP is a DATATYPE, the allocation of it actually happens at MAKEINIT time under INITDATATYPE{NAMES}" )) (BLOCKRECORD ARRAYBLOCK ((PASSWORD BITS 13) (GCTYPE BITS 2) (* ; "Unboxed, Pointers, or Code") (INUSE FLAG) (ARLEN WORD) (FWD FULLXPOINTER) (* ; "Only when on free list") (BKWD FULLXPOINTER)) (BLOCKRECORD ARRAYBLOCK ((ABFLAGS WORD) (* ; "Used for header and trailer"))) (ACCESSFNS ARRAYBLOCK ((DAT ( \ADDBASE DATUM \ArrayBlockHeaderWords)) (TRAILER (\ADDBASE2 DATUM (IDIFFERENCE (fetch (ARRAYBLOCK ARLEN) of DATUM) \ArrayBlockTrailerCells))))) (TYPE? (AND (EQ 0 (NTYPX DATUM)) (IGEQ (\HILOC DATUM) \FirstArraySegment)))) (GLOBALVARS \NxtArrayPage \FREEBLOCKBUCKETS \HUNKING?) (PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX) (FOLDLO (fetch DTDSIZE of (\GETDTD NTYPX)) WORDSPERCELL))) (PUTPROP (QUOTE LLARRAYELT) (QUOTE IMPORTDATE) (IDATE "15-Sep-94 11:08:59")) (DEFOPTIMIZER PUTBASEPTRX (&REST ARGS) (CONS (QUOTE (OPENLAMBDA (DATUM OFFSET NEWVALUE) ( UNINTERRUPTABLY (\PUTBASE DATUM OFFSET (LOGOR (LOGAND 61440 (\GETBASE DATUM OFFSET)) (LOGAND (\HILOC NEWVALUE) 4095))) (\PUTBASE DATUM (ADD1 OFFSET) (\LOLOC NEWVALUE)) NEWVALUE))) ARGS)) (RPAQQ \SMALLP 1) (RPAQQ \FIXP 2) (RPAQQ \FLOATP 3) (RPAQQ \LITATOM 4) (RPAQQ \LISTP 5) (RPAQQ \ARRAYP 6) (RPAQQ \STACKP 8) (RPAQQ \VMEMPAGEP 10) (RPAQQ \STREAM 11) (RPAQQ \NEW-ATOM 21) (CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STACKP \VMEMPAGEP \STREAM \NEW-ATOM) (RPAQQ \BUILT-IN-SYSTEM-TYPES ((SMALLP) (FIXP 2) (FLOATP 2) (LITATOM) (LISTP 4 (0 2)) (ARRAYP 6 (0)) ( STRINGP 6 (0)) (STACKP 2 NIL \RECLAIMSTACKP) (CHARACTER) (VMEMPAGEP 256 NIL RELEASINGVMEMPAGE) (STREAM ) (BITMAP) (COMPILED-CLOSURE 4 (0 2)) (ONED-ARRAY 8 (0)) (TWOD-ARRAY 10 (0)) (GENERAL-ARRAY 10 (0 8)) (BIGNUM) (RATIO) (COMPLEX) (PATHNAME) (NEW-ATOM 10 (2 4 6)) (FILLER22) (FILLER23) (FILLER24) (FILLER25 ) (FILLER26) (FILLER27) (FILLER28) (FILLER29) (FILLER30))) (BLOCKRECORD DTD ((NIL BITS 2) (DTDOBSOLETE FLAG) (* ; "True for type of a redeclared datatype--not allowed to allocate more of these") (DTDFINALIZABLE FLAG) (* ; "True if finalization exists for this type") (DTDNAME POINTER) (* ; "Type name -- a symbol ") ( DTDCNT0 WORD) (* ; "Incremental box count -- this plus DTDOLDCNT is the true box count") (DTDSIZE WORD ) (* ; "Length of datum in words") (DTDFREE FULLXPOINTER) (* ; "Pointer to first object on free chain, or NIL. Not used for LISTP") (DTDLOCKEDP FLAG) (* ; "True if objects of this type must be locked down (not pagefault)") (DTDHUNKP FLAG) (* ; "True if this type is used as an array hunk type") (DTDGCTYPE BITS 2) (* ; "For hunk datatypes, is analogous to arrayblock's GCTYPE") (DTDDESCRS POINTER) (DTDTYPESPECS POINTER) (DTDPTRS POINTER) (* ; "List of word offsets inside datum where reference-counted pointers are stored -- used by GC") ( DTDOLDCNT FIXP) (* ; "'Box count' -- number of objects of this type ever allocated") (DTDNEXTPAGE FIXP ) (* ; "Currently only for LISTP pages -- page number of next page on chain of non-full cons pages") ( DTDTYPEENTRY WORD) (* ;; "The word stored in the type table for objects of this type. Hi bits have numberp tags, ref countable, etc." ) (DTDSUPERTYPE WORD) (* ; "Type number of immediate supertype, or zero if none")) (ACCESSFNS DTD (( DTDCNTLOC (\ADDBASE DATUM 4)) (DTDCNT (IPLUS (fetch DTDOLDCNT DATUM) (fetch DTDCNT0 DATUM)) ( UNINTERRUPTABLY (replace DTDOLDCNT of DATUM with NEWVALUE) (replace DTDCNT0 of DATUM with 0)))))) (PUTPROPS \GETDTD MACRO ((typeNum) (ADDBASE \DTDSpaceBase (ITIMES typeNum 18)))) (DEFOPTIMIZER \TYPEMASK.UFN (&REST X) (LET ((CE (CONSTANTEXPRESSIONP (CADR X)))) (if CE then (BQUOTE ( (OPCODES TYPEMASK.N (\, (CAR CE))) (\, (CAR X)))) else (QUOTE IGNOREMACRO)))) (RPAQQ \GUARDSTORAGEFULL 128) (RPAQQ \GUARD1STORAGEFULL 64) (CONSTANTS \GUARDSTORAGEFULL \GUARD1STORAGEFULL) (GLOBALVARS \NxtMDSPage \LeastMDSPage \SecondArrayPage \SecondMDSPage \MDSFREELISTPAGE \MaxSysTypeNum \MaxTypeNumber \STORAGEFULL \INTERRUPTSTATE \PENDINGINTERRUPT) (PUTPROP (QUOTE LLDATATYPE) (QUOTE IMPORTDATE) (IDATE "28-Jun-99 16:57:50")) (ACCESSFNS POINTER ((PAGE# (IPLUS (LLSH (\HILOC DATUM) 8) (LRSH (\LOLOC DATUM) 8))) (WORDINPAGE ( LOGAND (\LOLOC DATUM) 255)) (CELLINPAGE (LRSH (fetch WORDINPAGE of DATUM) 1)) (BYTEINPAGE (LLSH (fetch WORDINPAGE of DATUM) 1)) (SEGMENT# (\HILOC DATUM)) (WORDINSEGMENT (\LOLOC DATUM)) (CELLINSEGMENT ( LRSH (fetch WORDINSEGMENT of DATUM) 1)) (WORD# (fetch WORDINPAGE of DATUM)) (DBLWORD# (fetch CELLINPAGE of DATUM)) (PAGEBASE (\VAG2 (\HILOC DATUM) (LOGAND (\LOLOC DATUM) 65280)))) (CREATE (\VAG2 (LRSH PAGE# 8) (LLSH (LOGAND PAGE# 255) 8)))) (ACCESSFNS WORD ((HIBYTE (LRSH DATUM 8)) (LOBYTE (LOGAND DATUM 255))) (CREATE (IPLUS (LLSH HIBYTE 8) LOBYTE))) (PUTPROPS PTRGTP MACRO (OPENLAMBDA (X Y) (OR (IGREATERP (\HILOC X) (\HILOC Y)) (AND (EQ (\HILOC X) ( \HILOC Y)) (IGREATERP (\LOLOC X) (\LOLOC Y)))))) (PUTPROPS .COERCE.TO.SMALLPOSP. DMACRO (OPENLAMBDA (X) (COND ((SMALLPOSP X) X) (T (\ILLEGAL.ARG X))))) (PUTPROPS .COERCE.TO.BYTE. DMACRO (OPENLAMBDA (X) (COND ((AND (SMALLPOSP X) (ILESSP X (CONSTANT (LLSH 1 BITSPERBYTE)))) X) (T (\ILLEGAL.ARG X))))) (BLOCKRECORD LISTP ((* ;; "Describes a CONS cell.") (CAR POINTER) (CDR POINTER)) (CREATE (CREATECELL \LISTP)) (* ;; "FOLLOWING ARE CDR-CODE FIELDS") (BLOCKRECORD LISTP ((CDRCODE BITS 4) (CARFIELD XPOINTER))) (* ;; "For chaining together free cells on a page:") (BLOCKRECORD LISTP ((NEXTFREE BYTE) ( NIL BITS 24))) (ACCESSFNS LISTP ((FULLCARFIELD NIL (\PUTBASEPTR DATUM 0 NEWVALUE)))) (* ;; "because replace of XPOINTER is slow, the CAR field is stored with PUTBASEPTR, even though that smashes the hi byte" )) (BLOCKRECORD CONSPAGE ((* ;; "Describes a page of CONS cells, which (when free) are chained together thru the top byte.") (NIL 2 FIXP) (* ; "Empty cells, space for another 2 CONS cells if we can figure out how.") (CNT BYTE) (* ; "# of cells free on this page") (NEXTCELL BYTE) (* ; "WORD offset of next free cell (not guaranteed to be 0 if no free cells)") (NIL WORD) (* ; "Padding") (NEXTPAGE FIXP) (* ; "Next CONS page on the DTD's free list, for searching for cells."))) (RPAQQ CONSCONSTANTS (\CDR.ONPAGE \CDR.NIL \CDR.INDIRECT \CDR.MAXINDIRECT \CONSPAGE.LAST)) (RPAQQ \CDR.ONPAGE 8) (RPAQQ \CDR.NIL 8) (RPAQQ \CDR.INDIRECT 0) (RPAQQ \CDR.MAXINDIRECT 7) (RPAQQ \CONSPAGE.LAST 65535) (CONSTANTS \CDR.ONPAGE \CDR.NIL \CDR.INDIRECT \CDR.MAXINDIRECT \CONSPAGE.LAST) (PUTPROPS LOCAL MACRO ((X) X)) (PUTPROPS ALLOCAL MACRO ((X) X)) (PUTPROP (QUOTE LLNEW) (QUOTE IMPORTDATE) (IDATE " 2-Feb-95 16:21:44")) (PUTPROPS CHECK MACRO (ARGS (COND ((AND (BOUNDP (QUOTE CHECK)) CHECK) (CONS (QUOTE PROGN) (for I in ARGS collect (LIST (QUOTE OR) I (LIST (QUOTE RAID) (KWOTE (LIST (QUOTE Check-failure%:) I))))))) (T ( CONS COMMENTFLG ARGS))))) (PUTPROPS \StatsZero BYTEMACRO (OPENLAMBDA (N) (\PUTBASE N 0 0) (\PUTBASE N 1 0))) (PUTPROPS \StatsAdd1 DMACRO (OPENLAMBDA (A) (PROG ((LO (IPLUS16 (\GETBASE A 1) 1))) (DECLARE ( LOCALVARS LO)) (* ; "Increment double word at A by 1") (\PUTBASE A 1 LO) (COND ((EQ LO 0) (\PUTBASE A 0 (ADD1 (\GETBASE A 0)))))))) (PUTPROPS IPLUS16 MACRO ((X Y) (* ; "Kludge to do 16-bit plus") (\LOLOC (\ADDBASE X Y)))) (PUTPROPS SMALLPOSP MACRO (OPENLAMBDA (X) (AND (SMALLP X) (IGEQ X 0)))) (PROGN (PUTPROPS SETXVAR MACRO (X (BQUOTE (SETQ.NOREF %, (CADAR X) %, (CADR X))))) (PUTPROPS SETXVAR DMACRO (X (OR (AND (EQ (CAAR X) (QUOTE QUOTE)) (LITATOM (CADAR X))) (SHOULDNT)) (GLOBALVARS \VALSPACE) (LIST (QUOTE SETQ.NOREF) (CADAR X) (CADR X))))) (PUTPROPS SETQ.NOREF DMACRO ((VAR VAL) (\PUTBASEPTR (LOCF (fetch (LITATOM VALUE) of (QUOTE VAR))) 0 VAL))) (PROGN (PUTPROPS IEQ MACRO ((X Y) (IEQP X Y))) (PUTPROPS IEQ DMACRO (= . EQ))) (RPAQQ WordsPerPage 256) (CONSTANTS WordsPerPage) (ACCESSFNS LITATOM ((DEFINITIONCELL (\DEFCELL DATUM)) (PROPCELL (\PROPCELL DATUM)) (VCELL (\VALCELL DATUM)) (PNAMECELL (\PNAMECELL DATUM))) (* ;; "VCELL can also be accessed directly from a value index via the record VALINDEX (as in \SETGLOBALVAL.UFN) --- Similarly, PNAMEINDEX accesses PNAMECELL for use by \MKATOM and UNCOPYATOM" ) (TYPE? (LITATOM DATUM)) (BLOCKRECORD PROPCELL ((NIL BITS 4) (* ; "former flags locations") (PROPLIST POINTER) (NIL BITS 8) (* ; "Package byte") (NIL BITS 8) (* ; "Flags from defcell") (* ;; "PROPCell flags:") (NIL BITS 1) (GENSYMP FLAG) (FATPNAMEP FLAG) (NIL BITS 5) (* ;; "Filler for final cell:") (NIL BITS 8)))) (SYNONYM CL:SYMBOL (LITATOM)) (ACCESSFNS VALINDEX ((VCELL (COND ((AND (FIXP DATUM) (ILESSP DATUM 65535)) (* ; "Xerox Lisp traditional symbol") (\ADDBASE2 \PNPSPACE (IPLUS \NEWATOM-VALOFFSET (ITIMES 10 DATUM)))) ( T (* ; "New symbol") (* ; "'90/07/19 ON") (\ADDBASE DATUM \NEWATOM-VALOFFSET)))))) (BLOCKRECORD VCELL ((VALUE FULLPOINTER))) (BLOCKRECORD DEFINITIONCELL ((CCODEP FLAG) (FASTP FLAG) (ARGTYPE BITS 2) (* ; "Former flag location") (DEFPOINTER POINTER) (NIL POINTER) (* ; "Proplist cell") (NIL BITS 8) (* ; "package") (* ;; "DEFCELL flags overflow from top 4 bits of the real cell:") (NIL BITS 4) (PSEUDOCODEP FLAG) (NIL BITS 3) (* ;; "proplist falgs and filler:") (NIL BITS 16)) (BLOCKRECORD DEFINITIONCELL ((DEFCELLFLAGS BITS 4) (NIL POINTER) (* ; "defn ptr") (NIL BITS 4) (NIL POINTER) (* ; "filler for proplist ptr") (NIL BITS 8) (AUXDEFCELLFLAGS BYTE) (NIL BITS 16)))) (BLOCKRECORD FNHEADER ((STKMIN WORD) (NA SIGNEDWORD) (PV SIGNEDWORD) (STARTPC WORD) (CLOSUREP FLAG) (* ; "T if this is a %"compiled closure%"") (BYTESWAPPED FLAG) (* ; "T if, on 386, we reswapped the code section of this function for faster access.") (ARGTYPE BITS 2) (* ; "0 = LAMBDA") (* ; "2 = LAMBDA nospread") (* ; "1 = NLAMBDA") (* ; "3 = NLAMBDA nospread") (* ;; "4 NIL BITS USED TO BE HERE.") (%#FRAMENAME XPOINTER) (NTSIZE WORD) (* ; "Size of the Name Table, IN WORDS. This value is always rounded up to the next Quad-word in size, and there' guaranteed to be one entry of zeros in the length." ) (NLOCALS BYTE) (FVAROFFSET BYTE)) (ACCESSFNS FNHEADER ((LSTARP (ILESSP (fetch (FNHEADER NA) of DATUM ) 0)) (OVERHEADWORDS (PROGN 8)) (NATIVE (PROGN NIL)) (* ; "T if this is a NATIVE-code function (never true!)") (ALIGNED (IPLUS (fetch (FNHEADER NTSIZE) of DATUM ) (fetch (FNHEADER OVERHEADWORDS) of T))) (FIXED NIL (replace (FNHEADER STKMIN) of DATUM with (\STKMIN DATUM T))) (NPVARWORDS (UNFOLD (ADD1 (fetch (FNHEADER PV) of DATUM)) WORDSPERQUAD)) (FRAMENAME (fetch (FNHEADER %#FRAMENAME) of DATUM) (UNINTERRUPTABLY (CHECK (NEQ (\HILOC DATUM) \STACKHI)) (\DELREF ( fetch (FNHEADER %#FRAMENAME) of DATUM)) (\ADDREF NEWVALUE) (replace (FNHEADER %#FRAMENAME) of DATUM with NEWVALUE)))))) (BLOCKRECORD PNAMECELL ((NIL BITS 4) (PNAMEBASE XPOINTER) (NIL POINTER) (* ; "val, def, prop cells") ( NIL POINTER) (NIL POINTER) (PACKAGEINDEX BYTE) (NIL BITS 24) (* ; "filler for other flags")) ( BLOCKRECORD PNAMECELL ((FULLPNAMEBASE FULLXPOINTER) (* ; "Replacing this smashes PACKAGEINDEX to 0"))) (ACCESSFNS PNAMECELL ((PACKAGE (LET ((I (FETCH (PNAMECELL PACKAGEINDEX) OF DATUM))) (* ; "This ugly construct allows cl:symbol-package to run in the init, where *PACKAGE-FROM-INDEX* is not yet bound." ) (COND ((EQ 0 I) NIL) (T (CL:AREF *PACKAGE-FROM-INDEX* I)))) (REPLACE (PNAMECELL PACKAGEINDEX) OF DATUM WITH (IF (NULL NEWVALUE) THEN *UNINTERNED-PACKAGE-INDEX* ELSE (CL::%%PACKAGE-INDEX NEWVALUE))))) )) (ACCESSFNS PACKAGEINDEX ((PACKAGE (IF (EQ 0 DATUM) (* ; "This ugly construct allows cl:symbol-package to run in the init, where *PACKAGE-FROM-INDEX* is not yet bound." ) THEN NIL ELSE (CL:AREF *PACKAGE-FROM-INDEX* DATUM))))) (BLOCKRECORD PNAMEBASE ((PNAMELENGTH BYTE) (* ; "Length is always here, be the pname thin or fat") ( PNAMEFATPADDINGBYTE BYTE) (* ; "This byte is zero for fat pnames so that the pname chars are word-aligned"))) (ACCESSFNS PNAMEINDEX ((PNAMECELL (COND ((AND (FIXP DATUM) (ILESSP DATUM 65535)) (* ; "Xerox Lisp traditional symbol") (\ADDBASE \OLDATOMSPACE (IPLUS \NEWATOM-PNAMEOFFSET (ITIMES 10 DATUM) ))) (T (* ; "New symbol") (* ; "'90/07/19 ON") (\ADDBASE DATUM \NEWATOM-PNAMEOFFSET)))))) (BLOCKRECORD NEW-ATOM ((* ;; "An extended symbol, for expanding atom space. Kept in its own datatype.") (PNAME XPOINTER) (* ; "PNAME, same as litatom.") (VALUE POINTER) (DEF POINTER) (PROPLIST POINTER) (* ;; "Flags that used to be above the pointers, e.g. package, ccodep, gensymp:") (NIL BITS 32))) (PUTPROPS \DEFCELL MACRO ((ATOM) (\ATOMCELL ATOM \DEF.HI))) (PUTPROPS \VALCELL MACRO ((ATOM) (\ATOMCELL ATOM \VAL.HI))) (PUTPROPS \PNAMECELL MACRO ((ATOM) (\ATOMCELL ATOM \PNAME.HI))) (PUTPROPS \ATOMVALINDEX DMACRO (OPENLAMBDA (X) (COND ((EQ (NTYPX X) \LITATOM) (* ; "Original litatoms" ) (\LOLOC X)) ((EQ (NTYPX X) \NEW-ATOM) (* ; "new 3-byte symbols") X) (T (SHOULDNT))))) (PUTPROPS \ATOMDEFINDEX DMACRO (OPENLAMBDA (X) (COND ((EQ (NTYPX X) \LITATOM) (* ; "Original litatoms" ) (\LOLOC X)) ((EQ (NTYPX X) \NEW-ATOM) (* ; "new 3-byte symbols") X) (T (SHOULDNT))))) (PUTPROPS \ATOMPNAMEINDEX DMACRO (OPENLAMBDA (X) (COND ((EQ (NTYPX X) \LITATOM) (* ; "Original litatoms") (\LOLOC X)) ((EQ (NTYPX X) \NEW-ATOM) (* ; "new 3-byte symbols") X) (T (SHOULDNT) )))) (PUTPROPS \ATOMPROPINDEX DMACRO ((X) (COND ((EQ (NTYPX X) \LITATOM) (* ; "Original litatoms") (\LOLOC X)) ((EQ (NTYPX X) \NEW-ATOM) (* ; "new 3-byte symbols") X) (T (SHOULDNT))))) (PUTPROPS \INDEXATOMPNAME DMACRO (OPENLAMBDA (X) (COND ((FIXP X) (* ; "Xerox Lisp traditional symbol") (COND ((SMALLP X) (\VAG2 \AtomHI X)) (T (\VAG2 (LRSH X 16) (LOGAND X 65535))))) (T (* ; "New symbol") X)))) (PUTPROPS \INDEXATOMVAL DMACRO (OPENLAMBDA (X) (COND ((FIXP X) (* ; "Xerox Lisp traditional symbol") ( COND ((SMALLP X) (\VAG2 \AtomHI X)) (T (\VAG2 (LRSH X 16) (LOGAND X 65535))))) (T (* ; "New symbol") X )))) (PUTPROPS \INDEXATOMDEF DMACRO (OPENLAMBDA (X) (COND ((FIXP X) (* ; "Xerox Lisp traditional symbol") ( COND ((SMALLP X) (\VAG2 \AtomHI X)) (T (\VAG2 (LRSH X 16) (LOGAND X 65535))))) (T (* ; "New symbol") X )))) (PUTPROPS \ATOMNUMBER DMACRO (= . \LOLOC)) (GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage \AtomFrLst \OneCharAtomBase \PNAMES.IN.BLOCKS? \SCRATCHSTRING COMPILEATPUTDFLG) (RPAQQ \PNAMELIMIT 255) (RPAQQ \CharsPerPnPage 512) (CONSTANTS (\PNAMELIMIT 255) (\CharsPerPnPage 512)) (RPAQQ \NEWATOM-PNAMEOFFSET 0) (RPAQQ \NEWATOM-VALOFFSET 2) (RPAQQ \NEWATOM-DEFOFFSET 4) (RPAQQ \NEWATOM-PLISTOFFSET 6) (RPAQQ \NEWATOM-TYPE# 21) (CONSTANTS (\NEWATOM-PNAMEOFFSET 0) (\NEWATOM-VALOFFSET 2) (\NEWATOM-DEFOFFSET 4) ( \NEWATOM-PLISTOFFSET 6) (\NEWATOM-TYPE# 21)) (PUTPROPS \MOVEWORDS MACRO (OPENLAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS) (\BLT (\ADDBASE DBASE DOFFSET) (\ADDBASE SBASE SOFFSET) NWORDS))) (PUTPROP (QUOTE LLBASIC) (QUOTE IMPORTDATE) (IDATE "31-Jan-98 09:55:50")) (ACCESSFNS STRINGP ((XREADONLY (fetch (ARRAY-HEADER READ-ONLY-P) of DATUM) (replace (ARRAY-HEADER READ-ONLY-P) of DATUM with NEWVALUE)) (XBASE ((OPENLAMBDA (STRING) (COND ((fetch (ARRAY-HEADER INDIRECT-P) of STRING) (%%ARRAY-BASE STRING)) (T (fetch (ARRAY-HEADER BASE) of STRING)))) DATUM) (( OPENLAMBDA (STRING NV) (replace (ARRAY-HEADER INDIRECT-P) of STRING with NIL) (replace (ARRAY-HEADER BASE) of STRING with NV) NV) DATUM NEWVALUE)) (TYP ((OPENLAMBDA (STRING) (SELECTC (COND ((fetch ( ARRAY-HEADER INDIRECT-P) of STRING) (%%ARRAY-TYPE-NUMBER STRING)) (T (fetch (ARRAY-HEADER TYPE-NUMBER) of STRING))) (%%THIN-CHAR-TYPENUMBER \ST.BYTE) (%%FAT-CHAR-TYPENUMBER \ST.POS16) (SHOULDNT "Unknown type-number"))) DATUM) ((OPENLAMBDA (STRING NV) (LET ((%%NEW-TYPE-NUMBER (SELECTC NV ( \ST.BYTE %%THIN-CHAR-TYPENUMBER) (\ST.POS16 %%FAT-CHAR-TYPENUMBER) (SHOULDNT "Unknown typ value")))) ( COND ((fetch (ARRAY-HEADER INDIRECT-P) of STRING) (%%SET-ARRAY-TYPE-NUMBER STRING %%NEW-TYPE-NUMBER)) (T (replace (ARRAY-HEADER TYPE-NUMBER) of STRING with %%NEW-TYPE-NUMBER))))) DATUM NEWVALUE)) (LENGTH (fetch (ARRAY-HEADER FILL-POINTER) of DATUM) ((OPENLAMBDA (STRING NV) (replace (ARRAY-HEADER FILL-POINTER) of STRING with NV) (replace (ARRAY-HEADER TOTAL-SIZE) of STRING with NV) (COND (( %%GENERAL-ARRAY-P STRING) (freplace (GENERAL-ARRAY DIMS) of STRING with (LIST NV)))) NV) DATUM NEWVALUE)) (OFFST ((OPENLAMBDA (STRING) (COND ((fetch (ARRAY-HEADER INDIRECT-P) of STRING) ( %%ARRAY-OFFSET STRING)) (T (fetch (ARRAY-HEADER OFFSET) of STRING)))) DATUM) ((OPENLAMBDA (STRING NV) (COND ((NOT (EQ 0 NV)) (replace (ARRAY-HEADER DISPLACED-P) of STRING with T))) (COND ((fetch ( ARRAY-HEADER INDIRECT-P) of STRING) (%%SET-ARRAY-OFFSET STRING NV)) (T (replace (ARRAY-HEADER OFFSET) of STRING with NV)))) DATUM NEWVALUE)) (* ;; "The rest of these fields only appear when smashing") ( XFLAGS (LOGAND (fetch (ARRAY-HEADER FLAGS) of DATUM) 15) ((OPENLAMBDA (STRING) (replace (ARRAY-HEADER ADJUSTABLE-P) of STRING with NIL) (replace (ARRAY-HEADER DISPLACED-P) of STRING with NIL) (replace ( ARRAY-HEADER FILL-POINTER-P) of STRING with NIL) (replace (ARRAY-HEADER EXTENDABLE-P) of STRING with NIL)) DATUM))) (ACCESSFNS STRINGP ((ORIG ((OPENLAMBDA (STRING) 1) DATUM) ((OPENLAMBDA (STRING NV) ( COND ((NOT (EQ NV 1)) (ERROR "Il:stringp's are always origin 1"))) NV) DATUM NEWVALUE)) (* ; "An inoperative field") (SUBSTRINGED ((OPENLAMBDA (STRING) NIL) DATUM) ((OPENLAMBDA (STRING NV) (OR ( NULL NV) (ERROR "Substringed field not supported"))) DATUM NEWVALUE)) (READONLY (ffetch (STRINGP XREADONLY) of DATUM) (freplace (STRINGP XREADONLY) of DATUM with NEWVALUE)) (FATSTRINGP ((OPENLAMBDA ( STRING) (EQ (COND ((fetch (ARRAY-HEADER INDIRECT-P) of STRING) (%%ARRAY-TYPE-NUMBER STRING)) (T (fetch (ARRAY-HEADER TYPE-NUMBER) of STRING))) %%FAT-CHAR-TYPENUMBER)) DATUM) ((OPENLAMBDA (STRING NV) (LET ((%%NEW-TYPE-NUMBER (COND (NV %%FAT-CHAR-TYPENUMBER) (T %%THIN-CHAR-TYPENUMBER)))) (COND ((fetch ( ARRAY-HEADER INDIRECT-P) of STRING) (%%SET-ARRAY-TYPE-NUMBER STRING %%NEW-TYPE-NUMBER)) (T (replace ( ARRAY-HEADER TYPE-NUMBER) of STRING with %%NEW-TYPE-NUMBER))))) DATUM NEWVALUE)) (BASE (ffetch ( STRINGP XBASE) of DATUM) (freplace (STRINGP XBASE) of DATUM with NEWVALUE)))) (CREATE (create ONED-ARRAY BASE _ XBASE READ-ONLY-P _ XREADONLY STRING-P _ T DISPLACED-P _ (NOT (EQ OFFST 0)) TYPE-NUMBER _ (COND ((EQ TYP \ST.POS16) %%FAT-CHAR-TYPENUMBER) (T %%THIN-CHAR-TYPENUMBER)) OFFSET _ OFFST FILL-POINTER _ LENGTH TOTAL-SIZE _ LENGTH)) (TYPE? (CL:STRINGP DATUM)) OFFST _ 0 TYP _ \ST.BYTE LENGTH _ 0) (GLOBALVARS \OneCharAtomBase) (PUTDEF (QUOTE \NUMSTR) (QUOTE RESOURCES) (QUOTE (NEW (ALLOCSTRING 128)))) (PUTDEF (QUOTE \NUMSTR1) (QUOTE RESOURCES) (QUOTE (NEW (CONCAT)))) (PUTDEF (QUOTE \PNAMESTRING) (QUOTE RESOURCES) (QUOTE (NEW (ALLOCSTRING \PNAMELIMIT NIL NIL \FATPNAMESTRINGP)))) (RPAQQ \FATPNAMESTRINGP T) (CONSTANTS (\FATPNAMESTRINGP T)) (PUTPROPS \PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE) (* ; "For stuffing chars into resource \PNAMESTRING") (\PUTBASECHAR \FATPNAMESTRINGP BASE OFFSET CODE))) (DEFOPTIMIZER FCHARACTER (NUM) (BQUOTE ((OPENLAMBDA (N) (COND ((IGREATERP N \MAXTHINCHAR) (* ; "The character we're getting is NOT a thin character -- do it the hard way") (CHARACTER N)) (( IGREATERP N (CHARCODE 9)) (\ADDBASE \OneCharAtomBase (IDIFFERENCE N 10))) ((IGEQ N (CHARCODE 0)) ( IDIFFERENCE N (CHARCODE 0))) (T (* ; "The common case -- just add on the one-atom base.") (\ADDBASE \OneCharAtomBase N)))) (\, NUM)))) (I.S.OPR (QUOTE inpname) NIL (QUOTE (SUBPAIR (QUOTE ($$END $$BODY $$FATP $$BASE $$OFFSET)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (BQUOTE (bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP declare (LOCALVARS $$END $$BODY $$FATP $$BASE $$OFFSET) first (PROG NIL $$RETRY (COND ((STRINGP $$BODY) (SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY)) (SETQ $$OFFSET ( SUB1 (ffetch (STRINGP OFFST) of $$BODY))) (SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH) of $$BODY))) (SETQ $$FATP (ffetch (STRINGP FATSTRINGP) of $$BODY))) ((LITATOM $$BODY) (SETQ $$BASE ( ffetch (LITATOM PNAMEBASE) of $$BODY)) (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE)) (SETQ $$FATP (ffetch (LITATOM FATPNAMEP) of $$BODY))) (T (SETQ $$BODY (MKSTRING $$BODY)) (GO $$RETRY)))) eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (COND ($$FATP (\GETBASEFAT $$BASE $$OFFSET)) (T (\GETBASETHIN $$BASE $$OFFSET)))))))) T) (I.S.OPR (QUOTE inatom) NIL (QUOTE (SUBPAIR (QUOTE ($$OFFSET $$BODY $$BASE $$END $$FATP)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END $$FATP) first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY)) (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE)) (SETQ $$FATP (ffetch (LITATOM FATPNAMEP) of $$BODY)) eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND ( IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (COND ($$FATP (\GETBASEFAT $$BASE $$OFFSET)) (T ( \GETBASETHIN $$BASE $$OFFSET)))))))) T) (I.S.OPR (QUOTE instring) NIL (QUOTE (SUBPAIR (QUOTE ($$BODY $$END $$OFFSET $$BASE $$FATP)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (bind $$BODY _ BODY $$END $$OFFSET $$BASE $$FATP declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE $$FATP) first (SETQ $$OFFSET ( SUB1 (ffetch (STRINGP OFFST) of $$BODY))) (SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY)) (SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH) of $$BODY))) (SETQ $$FATP (ffetch (STRINGP FATSTRINGP) of $$BODY)) eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (COND ($$FATP (\GETBASEFAT $$BASE $$OFFSET)) (T (\GETBASETHIN $$BASE $$OFFSET)))))))) T) (I.S.OPR (QUOTE infatatom) NIL (QUOTE (SUBPAIR (QUOTE ($$OFFSET $$BODY $$BASE $$END)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END) first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY)) (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE)) eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (\GETBASEFAT $$BASE $$OFFSET)))))) T ) (I.S.OPR (QUOTE inthinatom) NIL (QUOTE (SUBPAIR (QUOTE ($$OFFSET $$BODY $$BASE $$END)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END) first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY)) (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE)) eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (\GETBASETHIN $$BASE $$OFFSET)))))) T) (I.S.OPR (QUOTE infatstring) NIL (QUOTE (SUBPAIR (QUOTE ($$BODY $$END $$OFFSET $$BASE)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (bind $$BODY _ BODY $$END $$OFFSET $$BASE declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE) first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) of $$BODY))) (SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY)) (SETQ $$END (IPLUS $$OFFSET ( ffetch (STRINGP LENGTH) of $$BODY))) eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (\GETBASEFAT $$BASE $$OFFSET)))))) T) (I.S.OPR (QUOTE inthinstring) NIL (QUOTE (SUBPAIR (QUOTE ($$BODY $$END $$OFFSET $$BASE)) (LIST ( GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (bind $$BODY _ BODY $$END $$OFFSET $$BASE declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE) first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) of $$BODY))) (SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY)) (SETQ $$END (IPLUS $$OFFSET ( ffetch (STRINGP LENGTH) of $$BODY))) eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (\GETBASETHIN $$BASE $$OFFSET)))))) T) (PUTPROPS \CHARCODEP DMACRO (OPENLAMBDA (X) (* ; "used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses") (AND (SMALLP X) (IGEQ X 0)))) (PUTPROPS \FATCHARCODEP DMACRO (OPENLAMBDA (X) (* ; "Used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses") (AND (SMALLP X) (IGREATERP X \MAXTHINCHAR)))) (PUTPROPS \THINCHARCODEP DMACRO (OPENLAMBDA (X) (AND (SMALLP X) (IGEQ X 0) (ILEQ X \MAXTHINCHAR)))) (PUTPROPS \GETBASEFAT MACRO (= . \GETBASE)) (PUTPROPS \GETBASETHIN MACRO (= . \GETBASEBYTE)) (PUTPROPS \PUTBASEFAT MACRO (= . \PUTBASE)) (PUTPROPS \PUTBASETHIN MACRO (= . \PUTBASEBYTE)) (PUTPROPS \PUTBASECHAR MACRO (OPENLAMBDA (FATP BASE OFFSET CODE) (COND (FATP (\PUTBASEFAT BASE OFFSET CODE)) (T (\PUTBASETHIN BASE OFFSET CODE))))) (PUTPROPS \GETBASECHAR MACRO ((FATP BASE N) (COND (FATP (\GETBASEFAT BASE N)) (T (\GETBASETHIN BASE N) )))) (PUTPROPS \CHARSET MACRO ((CHARCODE) (LRSH CHARCODE 8))) (PUTPROPS \CHAR8CODE MACRO ((CHARCODE) (LOGAND CHARCODE 255))) (RPAQQ \CHARMASK 255) (RPAQQ \MAXCHAR 255) (RPAQQ \MAXTHINCHAR 255) (RPAQQ \MAXFATCHAR 65535) (RPAQQ \MAXCHARSET 255) (RPAQQ NSCHARSETSHIFT 255) (RPAQQ %#STRINGPWORDS 4) (CONSTANTS (\CHARMASK 255) (\MAXCHAR 255) (\MAXTHINCHAR 255) (\MAXFATCHAR 65535) (\MAXCHARSET 255) ( NSCHARSETSHIFT 255) (%#STRINGPWORDS 4)) (PUTPROPS \NATOMCHARS DMACRO ((AT) (fetch (LITATOM PNAMELENGTH) of AT))) (PUTPROPS \NSTRINGCHARS DMACRO ((S) (fetch (STRINGP LENGTH) of S))) (PUTPROP (QUOTE LLCHAR) (QUOTE IMPORTDATE) (IDATE "12-Jan-94 10:12:34")) (ACCESSFNS BF ((BFBLOCK (ADDSTACKBASE DATUM))) (* ; "basic frame pointer") (BLOCKRECORD BFBLOCK (( FLAGS BITS 3) (NIL BITS 3) (RESIDUAL FLAG) (* ; "true if this is not a full BF") (PADDING BITS 1) ( USECNT BITS 8) (IVAR WORD))) (TYPE? (IEQ (fetch (BF FLAGS) of DATUM) \STK.BF)) (ACCESSFNS BF ((NARGS ( IDIFFERENCE (FOLDLO (IDIFFERENCE DATUM (fetch (BF IVAR) of DATUM)) WORDSPERCELL) (fetch (BF PADDING) of DATUM))) (SIZE (IPLUS 2 (IDIFFERENCE DATUM (fetch (BF IVAR) of DATUM)))) (CHECKED (AND (type? BF DATUM) (for I from (fetch (BF IVAR) of DATUM) to (IDIFFERENCE DATUM 2) by 2 always (IEQ \STK.NOTFLAG ( fetch (BF FLAGS) of I)))))))) (ACCESSFNS FX ((FXBLOCK (ADDSTACKBASE DATUM))) (* ; "frame extension index") (BLOCKRECORD FXBLOCK (( FLAGS BITS 3) (* ; "= \STK.FX") (FAST FLAG) (NIL FLAG) (INCALL FLAG) (* ; "set when fncall microcode has to punt") (VALIDNAMETABLE FLAG) (* ; "if on, NAMETABLE field is filled in. If off, is same as FNHEADER") (NOPUSH FLAG) (* ; "when returning to this frame, don't push a value. Set by interrupt code") (USECNT BITS 8) (%#ALINK WORD) (* ; "low bit is SLOWP") (FNHEADER FULLXPOINTER) (NEXTBLOCK WORD) (PC WORD) (NAMETABLE# FULLXPOINTER) (%#BLINK WORD) (%#CLINK WORD))) (BLOCKRECORD FXBLOCK ((FLAGBYTE BYTE) (NIL BYTE) (NIL BITS 15) (* ; "most of the bits of #ALINK") (SLOWP FLAG) (* ; "if on, then BLINK and CLINK fields are valid. If off, they are implicit") (NIL FULLXPOINTER 2) ( NAMETABHI WORD) (NAMETABLO WORD))) (TYPE? (IEQ (fetch (FX FLAGS) of DATUM) \STK.FX)) (ACCESSFNS FX (( NAMETABLE (COND ((fetch (FX VALIDNAMETABLE) of DATUM) (fetch (FX NAMETABLE#) of DATUM)) (T (fetch (FX FNHEADER) of DATUM))) (PROGN (replace (FX FAST) of DATUM with NIL) (replace (FX NAMETABLE#) of DATUM with NEWVALUE) (replace (FX VALIDNAMETABLE) of DATUM with T))) (FRAMENAME (fetch (FNHEADER FRAMENAME) of (fetch (FX NAMETABLE) of DATUM))) (INVALIDP (EQ DATUM 0)) (* ; "true when A/CLink points at nobody, i.e. FX is bottom of stack") (FASTP (NOT (fetch (FX SLOWP) of DATUM)) (PROGN (CHECK (NULL NEWVALUE)) (COND ((fetch (FX FASTP) of DATUM) (replace (FX %#BLINK) of DATUM with (fetch (FX DUMMYBF) of DATUM)) (replace (FX %#CLINK) of DATUM with (fetch (FX %#ALINK) of DATUM)) (replace (FX SLOWP) of DATUM with T))))) (BLINK (COND ((fetch (FX FASTP) of DATUM) (fetch (FX DUMMYBF) of DATUM)) (T (fetch (FX %#BLINK) of DATUM))) (PROGN (replace (FX %#BLINK) of DATUM with NEWVALUE) (COND ((fetch (FX FASTP) of DATUM) (replace (FX %#CLINK) of DATUM with (fetch (FX %#ALINK) of DATUM)) (replace (FX SLOWP) of DATUM with T))))) (CLINK (IDIFFERENCE (COND ((fetch (FX FASTP) of DATUM) (fetch (FX %#ALINK) of DATUM)) (T (fetch (FX %#CLINK) of DATUM))) \#ALINK.OFFSET) (PROGN ( replace (FX %#CLINK) of DATUM with (IPLUS NEWVALUE \#ALINK.OFFSET)) (COND ((fetch (FX FASTP) of DATUM) (replace (FX %#BLINK) of DATUM with (fetch (FX DUMMYBF) of DATUM)) (replace (FX SLOWP) of DATUM with T))))) (ALINK (IDIFFERENCE (FLOOR (fetch (FX %#ALINK) of DATUM) WORDSPERCELL) \#ALINK.OFFSET) (PROGN ( COND ((fetch (FX FASTP) of DATUM) (replace (FX %#BLINK) of DATUM with (fetch (FX DUMMYBF) of DATUM)) ( replace (FX %#CLINK) of DATUM with (fetch (FX %#ALINK) of DATUM)))) (replace (FX %#ALINK) of DATUM with (IPLUS NEWVALUE \#ALINK.OFFSET (SUB1 WORDSPERCELL))))) (ACLINK (SHOULDNT) (PROGN (COND ((fetch ( FX FASTP) of DATUM) (replace (FX %#BLINK) of DATUM with (fetch (FX DUMMYBF) of DATUM)))) (replace (FX %#CLINK) of DATUM with (IPLUS NEWVALUE \#ALINK.OFFSET)) (replace (FX %#ALINK) of DATUM with (IPLUS NEWVALUE \#ALINK.OFFSET (SUB1 WORDSPERCELL))))) (* ; "replaces A & C Links at once more efficiently than separately") (DUMMYBF (IDIFFERENCE DATUM WORDSPERCELL)) (* ;; "This is either an actual BF or %"residual%" BF that provides enough BF to find its IVAR slot. This means that when a FX is copied, the cell preceding the FX is copied too." ) (IVAR (fetch (BF IVAR) of (fetch (FX DUMMYBF) of DATUM))) (CHECKED (AND (type? FX DATUM) (OR (IEQ ( fetch (FX DUMMYBF) of DATUM) (fetch (FX BLINK) of DATUM)) (AND (fetch (BF RESIDUAL) of (fetch (FX DUMMYBF) of DATUM)) (IEQ (fetch (BF IVAR) of (fetch (FX DUMMYBF) of DATUM)) (fetch (BF IVAR) of (fetch (FX BLINK) of DATUM))))))) (FIRSTPVAR (IPLUS DATUM (fetch (FX FXSIZE) of T))) (* ; "stack offset of PVAR0") (FXSIZE (PROGN 10)) (* ; "fixed overhead from flags thru clink") (PADDING ( PROGN 4)) (* ; "doublecell of garbage for microcode use") (FIRSTTEMP (IPLUS (fetch (FX FIRSTPVAR) of DATUM) (fetch (FX NPVARWORDS) of DATUM) (fetch (FX PADDING) of DATUM))) (* ; "note that NPVARWORDS is obtained from the FNHEADER") (SIZE (IDIFFERENCE (fetch (FX NEXTBLOCK) of DATUM) DATUM))))) (ACCESSFNS FSB (* ;; "FREE STACK BLOCK -- ") (* ;; " A piece of stack space that's free.") (* ;; "The first word contains 120000Q") (* ;; "The 2nd word is the size of the block, in words.") (( FSBBLOCK (ADDSTACKBASE DATUM)) (CHECKED (IEQ (fetch (FSB FLAGWORD) of DATUM) \STK.FSB.WORD))) ( BLOCKRECORD FSBBLOCK ((FLAGS BITS 3) (DUMMY BITS 13) (SIZE WORD))) (BLOCKRECORD FSBBLOCK ((FLAGWORD WORD) (SIZE WORD))) (* ; "free stack block") (TYPE? (IEQ (fetch (FSB FLAGS) of DATUM) \STK.FSB))) (ACCESSFNS STK ((STKBLOCK (ADDSTACKBASE DATUM))) (* ; "unspecified stack block") (BLOCKRECORD STKBLOCK ((FLAGS BITS 3))) (BLOCKRECORD STKBLOCK ((FLAGWORD WORD)))) (RPAQQ \#ALINK.OFFSET 10) (CONSTANTS \#ALINK.OFFSET) (GLOBALVARS \PENDINGINTERRUPT \KBDSTACKBASE \MISCSTACKBASE \STACKOVERFLOW) (PUTPROPS \MYALINK DMACRO (NIL ((OPCODES MYALINK)))) (PUTPROPS ADDSTACKBASE DMACRO (= . STACKADDBASE)) (PUTPROPS STACKADDBASE DMACRO ((N) (VAG2 \STACKHI N))) (PUTPROPS STACKGETBASE DMACRO ((N) (\GETBASE (STACKADDBASE N) 0))) (PUTPROPS STACKGETBASEPTR DMACRO ((N) (\GETBASEPTR (STACKADDBASE N) 0))) (PUTPROPS STACKPUTBASE DMACRO ((N V) (\PUTBASE (STACKADDBASE N) 0 V))) (PUTPROPS STACKPUTBASEPTR DMACRO ((N V) (\PUTBASEPTR (STACKADDBASE N) 0 V))) (PUTPROPS \MISCAPPLY* MACRO ((FN ARG1 ARG2) (UNINTERRUPTABLY (replace (IFPAGE MISCSTACKFN) of \InterfacePage with FN) (replace (IFPAGE MISCSTACKARG1) of \InterfacePage with ARG1) (replace (IFPAGE MISCSTACKARG2) of \InterfacePage with ARG2) (\CONTEXTSWITCH \MiscFXP) (fetch (IFPAGE MISCSTACKRESULT) of \InterfacePage)))) (BLOCKRECORD STACKP ((STACKP0 WORD) (EDFXP WORD)) (BLOCKRECORD STACKP ((STACKPOINTER FULLXPOINTER))) ( TYPE? (STACKP DATUM))) (RPAQQ STACKTYPES (\STK.GUARD \STK.FX \STK.BF \STK.NOTFLAG \STK.FSB \STK.FLAGS.SHIFT (\STK.FSB.WORD ( LLSH \STK.FSB \STK.FLAGS.SHIFT)) (\STK.GUARD.WORD (LLSH \STK.GUARD \STK.FLAGS.SHIFT)) (\STK.BF.WORD ( LLSH \STK.BF \STK.FLAGS.SHIFT)))) (RPAQQ \STK.GUARD 7) (RPAQQ \STK.FX 6) (RPAQQ \STK.BF 4) (RPAQQ \STK.NOTFLAG 0) (RPAQQ \STK.FSB 5) (RPAQQ \STK.FLAGS.SHIFT 13) (RPAQ \STK.FSB.WORD (LLSH \STK.FSB \STK.FLAGS.SHIFT)) (RPAQ \STK.GUARD.WORD (LLSH \STK.GUARD \STK.FLAGS.SHIFT)) (RPAQ \STK.BF.WORD (LLSH \STK.BF \STK.FLAGS.SHIFT)) (CONSTANTS \STK.GUARD \STK.FX \STK.BF \STK.NOTFLAG \STK.FSB \STK.FLAGS.SHIFT (\STK.FSB.WORD (LLSH \STK.FSB \STK.FLAGS.SHIFT)) (\STK.GUARD.WORD (LLSH \STK.GUARD \STK.FLAGS.SHIFT)) (\STK.BF.WORD (LLSH \STK.BF \STK.FLAGS.SHIFT))) (RPAQQ \StackAreaSize 768) (RPAQ \InitStackSize (ITIMES \StackAreaSize 12)) (CONSTANTS \StackAreaSize (\InitStackSize (ITIMES \StackAreaSize 12))) (RPAQQ \MAXSAFEUSECOUNT 200) (CONSTANTS \MAXSAFEUSECOUNT) (BLOCKRECORD NAMETABLESLOT ((VARTYPE BYTE) (VAROFFSET BYTE))) (BLOCKRECORD FVARSLOT ((BINDLO WORD) (BINDHI WORD)) (ACCESSFNS FVARSLOT ((LOOKEDUP (EVENP (fetch BINDLO of DATUM))) (BINDINGPTR (\VAG2 (fetch BINDHI of DATUM) (fetch BINDLO of DATUM)) (PROGN (replace BINDLO of DATUM with (\LOLOC NEWVALUE)) (replace BINDHI of DATUM with (\HILOC NEWVALUE))))))) (BLOCKRECORD PVARSLOT ((PVHI BITS 4) (PVVALUE XPOINTER)) (ACCESSFNS PVARSLOT ((BOUND (EQ (fetch ( PVARSLOT PVHI) of DATUM) 0) (if (NULL NEWVALUE) then (replace (PVARSLOT PVHI) of DATUM with 255) else (ERROR "Illegal replace" NEWVALUE)))))) (BLOCKRECORD STKTEMPSLOT ((STKTMPHI BITS 4) (VALUE XPOINTER)) (ACCESSFNS STKTEMPSLOT ((BINDINGPTRP ( NEQ (fetch STKTMPHI of DATUM) 0))))) (BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) (NIL BITS 15)) (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES WORD) (BINDLASTPVAR WORD))) (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN (* ; "Value stored in high half is one's complement of number of values bound") (LOGXOR (fetch BINDNEGVALUES of DATUM) 65535)))))) (RPAQQ \NT.IVAR 0) (RPAQQ \NT.PVAR 128) (RPAQQ \NT.FVAR 192) (CONSTANTS \NT.IVAR \NT.PVAR \NT.FVAR) (PUTPROP (QUOTE LLSTK) (QUOTE IMPORTDATE) (IDATE " 6-Jan-93 18:07:37")) (PUTPROPS WORDCONTENTS BYTEMACRO ((PTR) (\GETBASE PTR 0))) (PUTPROPS SETWORDCONTENTS BYTEMACRO ((PTR N) (\PUTBASE PTR 0 N))) (PUTPROPS WORDOFFSET BYTEMACRO ((PTR N) (\ADDBASE PTR N))) (PUTPROPS \RELEASECPAGE MACRO ((STREAM) (PROGN (* ; "Must be under an UNINTERRUPTABLY !") (COND (( fetch CBUFDIRTY of STREAM) (\SETIODIRTY STREAM (fetch CPAGE of STREAM)) (replace CBUFDIRTY of STREAM with NIL))) (replace CBUFSIZE of STREAM with 0) (replace CBUFPTR of STREAM with NIL)))) (PUTPROP (QUOTE PMAP) (QUOTE IMPORTDATE) (IDATE " 3-Feb-2002 14:11:02")) (PUTPROPS ADDREF MACRO (OPENLAMBDA (PTR) (PROG1 PTR (\ADDREF PTR)))) (PUTPROPS \ADDREF DMACRO ((X) ((OPCODES GCREF 0) X))) (PUTPROPS DELETEREF MACRO (OPENLAMBDA (PTR) (PROG1 PTR (\DELREF PTR)))) (PUTPROPS \DELREF DMACRO ((X) ((OPCODES GCREF 1) X))) (PUTPROPS SCANREF MACRO (= . \STKREF)) (PUTPROPS \STKREF DMACRO ((X) ((OPCODES GCREF 2) X))) (PUTPROPS UNSCANREF MACRO ((PTR) (\HTFIND PTR 3))) (PUTPROPS CREATEREF MACRO (= . \CREATEREF)) (PUTPROPS \CREATEREF MACRO (OPENLAMBDA (PTR) (PROG1 (\DELREF PTR) (.INCREMENT.ALLOCATION.COUNT. 1)))) (PUTPROPS .INCREMENT.ALLOCATION.COUNT. MACRO (OPENLAMBDA (N) (DECLARE (GLOBALVARS \RECLAIM.COUNTDOWN)) (AND \RECLAIM.COUNTDOWN (COND ((IGREATERP \RECLAIM.COUNTDOWN N) (SETQ \RECLAIM.COUNTDOWN (IDIFFERENCE \RECLAIM.COUNTDOWN N))) (T (SETQ \RECLAIM.COUNTDOWN) (\DORECLAIM)))))) (PUTPROPS .CHECK.ALLOCATION.COUNT. MACRO (OPENLAMBDA (N) (DECLARE (GLOBALVARS \RECLAIM.COUNTDOWN)) ( AND \RECLAIM.COUNTDOWN (COND ((NOT (IGREATERP \RECLAIM.COUNTDOWN N)) (SETQ \RECLAIM.COUNTDOWN) ( \DORECLAIM)))))) (PUTPROPS \GCDISABLED MACRO (NIL (PROGN (DECLARE (GLOBALVARS \GCDISABLED)) \GCDISABLED))) (BLOCKRECORD HTOVERFLOW ((CASE BITS 4) (PTR XPOINTER)) (ACCESSFNS HTOVERFLOW ((CLEAR NIL (\PUTBASEPTR DATUM 0 NIL))))) (BLOCKRECORD GC ((CNT BITS 15) (STKBIT FLAG) (HIBITS BITS 15) (LINKP FLAG) (NXTPTR FIXP)) (BLOCKRECORD GC ((STKCNT WORD))) (ACCESSFNS GC ((EMPTY (EQ 0 (\GETBASEFIXP DATUM 0)) (\PUTBASEFIXP DATUM 0 0)) ( CONTENTS (\GETBASEFIXP DATUM 0) (\PUTBASEFIXP DATUM 0 NEWVALUE)) (LINKPTR (LOGAND (\GETBASEFIXP DATUM 0) -2) (\PUTBASEFIXP DATUM 0 (LOGOR NEWVALUE 1)))))) (BLOCKRECORD HTCOLL ((* ;; "An entry in the GC collision table. NEXTFREE is initialized to 2 by INITGC, as part of the MAKEINIT." ) (FREEPTR FIXP) (* ; "The GC table entry") (NEXTFREE FIXP) (* ; "If the entry is in use, points to the next entry in this collision chain. If not, offset (in 1/2-entries) of the next free one on the chain." ))) (PUTPROP (QUOTE LLGC) (QUOTE IMPORTDATE) (IDATE "19-Oct-94 12:30:11")) (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 \SETSYNCODE DMACRO (LAMBDA (TABLE CHAR CODE) (CHECK (type? CHARTABLE TABLE)) (* ; "0 is REAL.CCE, NONE.TC, OTHER.RC") (COND ((ILEQ CHAR \MAXTHINCHAR) (\PUTBASEBYTE TABLE CHAR CODE)) (T (\SETFATSYNCODE TABLE CHAR CODE))))) (DATATYPE CHARTABLE ((CHARSET0 256 BYTE) (NSCHARHASH FULLPOINTER))) (RPAQQ CCECHOMODES (REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE)) (RPAQQ REAL.CCE 0) (RPAQQ IGNORE.CCE 8) (RPAQQ SIMULATE.CCE 16) (RPAQQ INDICATE.CCE 24) (CONSTANTS REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE) (RPAQQ TERMCLASSES (NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC CTRLV.TC)) (RPAQQ NONE.TC 0) (RPAQQ EOL.TC 1) (RPAQQ CHARDELETE.TC 2) (RPAQQ WORDDELETE.TC 6) (RPAQQ WORDSEPR.TC 7) (RPAQQ LINEDELETE.TC 3) (RPAQQ RETYPE.TC 4) (RPAQQ CTRLV.TC 5) (CONSTANTS NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC CTRLV.TC) (ACCESSFNS TERMCODE ((CCECHO (LOGAND DATUM 24)) (TERMCLASS (LOGAND DATUM 7))) (* ; "We assume that values are appropriately shifted") (CREATE (LOGOR CCECHO TERMCLASS))) (DATATYPE TERMTABLEP (TERMSA RAISEFLG DELCHARECHO LINEDELETE 1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL ( CONTROLFLG FLAG) (ECHOFLG FLAG)) TERMSA _ (create CHARTABLE)) (PUTPROPS \GETREADMACRODEF MACRO ((C TBL) (GETHASH C (fetch READMACRODEFS of TBL)))) (PUTPROPS \GTREADTABLE MACRO (ARGS (COND ((LITATOM (CAR ARGS)) (SUBPAIR (QUOTE (X . FLG)) ARGS (QUOTE (SELECTQ X ((NIL T) (\DTEST *READTABLE* (QUOTE READTABLEP))) (\GTREADTABLE1 X . FLG))))) (T (QUOTE IGNOREMACRO))))) (PUTPROPS \GTREADTABLE1 DMACRO (ARGS (COND ((NULL (CDR ARGS)) (LIST (QUOTE \DTEST) (CAR ARGS) (QUOTE ( QUOTE READTABLEP)))) (T (QUOTE IGNOREMACRO))))) (RPAQQ MACROBIT 8) (RPAQQ BREAKBIT 16) (RPAQQ STOPATOMBIT 32) (RPAQQ ESCAPEBIT 64) (RPAQQ INNERESCAPEBIT 4) (CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT) (RPAQQ READCODEMASKS ((CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (WAKEUPMASK (LOGOR MACROBIT 2)))) (RPAQ CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (RPAQ WAKEUPMASK (LOGOR MACROBIT 2)) (CONSTANTS (CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (WAKEUPMASK (LOGOR MACROBIT 2))) (RPAQQ READMACROCONTEXTS ((ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0)) (FIRST.RMC (LOGOR MACROBIT 0)) (ALONE.RMC (LOGOR MACROBIT 1)))) (RPAQ ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0)) (RPAQ FIRST.RMC (LOGOR MACROBIT 0)) (RPAQ ALONE.RMC (LOGOR MACROBIT 1)) (CONSTANTS (ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0)) (FIRST.RMC (LOGOR MACROBIT 0)) ( ALONE.RMC (LOGOR MACROBIT 1))) (RPAQQ READCLASSES ((OTHER.RC 0) (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0)) (BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0)) (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) ( LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3)) (LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5)) (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7)) (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1)))) (RPAQQ OTHER.RC 0) (RPAQ SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0)) (RPAQ BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0)) (RPAQ STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) (RPAQ LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RPAQ RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3)) (RPAQ LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RPAQ RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5)) (RPAQ ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (RPAQ MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7)) (RPAQ PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1)) (CONSTANTS (OTHER.RC 0) (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0)) (BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0)) (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) (LEFTPAREN.RC ( LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3)) ( LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5)) (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7)) (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1))) (RPAQQ READMACROWAKEUPS ((IMMEDIATE.RMW (LOGOR MACROBIT 2)) (NONIMMEDIATE.RMW (LOGOR MACROBIT 0)))) (RPAQ IMMEDIATE.RMW (LOGOR MACROBIT 2)) (RPAQ NONIMMEDIATE.RMW (LOGOR MACROBIT 0)) (CONSTANTS (IMMEDIATE.RMW (LOGOR MACROBIT 2)) (NONIMMEDIATE.RMW (LOGOR MACROBIT 0))) (RPAQQ READMACROESCAPES ((ESC.RME ESCAPEBIT) (NOESC.RME 0))) (RPAQ ESC.RME ESCAPEBIT) (RPAQQ NOESC.RME 0) (CONSTANTS (ESC.RME ESCAPEBIT) (NOESC.RME 0)) (ACCESSFNS READCODE ((ESCAPE (LOGAND DATUM ESCAPEBIT)) (ESCQUOTE (BITTEST DATUM ESCAPEBIT)) (STOPATOM (BITTEST DATUM STOPATOMBIT)) (INNERESCQUOTE (BITTEST DATUM (LOGOR STOPATOMBIT INNERESCAPEBIT))) ( MACROCONTEXT (LOGAND DATUM CONTEXTMASK)) (MACROP (BITTEST DATUM MACROBIT)) (WAKEUP (LOGAND DATUM WAKEUPMASK)) (BREAK (BITTEST DATUM BREAKBIT)))) (RECORD READMACRODEF (MACROTYPE . MACROFN)) (DATATYPE READTABLEP ((READSA POINTER) (* ; "A CHARTABLE defining syntax of each char") (READMACRODEFS POINTER) (* ; "A hash table associating macro chars with macro definitions") (READMACROFLG FLAG) (* ; "True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)") (ESCAPEFLG FLAG) (* ; "True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)" ) (COMMONLISP FLAG) (* ; "True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules") (NUMBERBASE BITS 5) (* ; "Not used") (CASEINSENSITIVE FLAG) (* ; "If true, unescaped lowercase chars are converted to uppercase in symbols") (COMMONNUMSYNTAX FLAG) (* ; "True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers" ) (USESILPACKAGE FLAG) (* ; "If true, IL:READ ignores *PACKAGE* and reads in the IL package") (NIL 5 FLAG) (DISPATCHMACRODEFS POINTER) (* ; "An a-list of dispatching macro char and its dispatch definitions") (HASHMACROCHAR BYTE) (* ; "The character code used in this read table for the # dispatch macro") (ESCAPECHAR BYTE) (* ; "The character code used in this read table for single escape") (MULTESCAPECHAR BYTE) (* ; "The character code used in this read table for multiple escape") (PACKAGECHAR BYTE) (* ; "The character code used in this read table for package delimiter") (READTBLNAME POINTER) (* ; "The canonical 'name' of this read table")) READSA _ (create CHARTABLE)) (PUTPROP (QUOTE ATBL) (QUOTE IMPORTDATE) (IDATE "20-Apr-2018 17:35:56")) (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") (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...") (FULLFILENAME POINTER) (* ; "Name by which file is known to user") (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") (DEVICE POINTER) (* ; "FDEV of this guy") (USERVISIBLE FLAG) (* ; "Listed by OPENP; NIL for terminal, dribble ...") (EOLCONVENTION BITS 2) (* ; "End-of-line convention") (NOTXCCS FLAG) (* ; "True if the character encoding format is not XCCS.") ( 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----" ) (* ;; "Available for device-specific uses, NOT for application use.") (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) (* ; "Called by \OUTCHAR, the normal character printer.") (ENDOFSTREAMOP POINTER) (* ; "Called if EOF and we try to read.") (OTHERPROPS POINTER) (* ; "PROP LIST for holding other info.") ( IMAGEOPS POINTER) (* ; "Image operations vector") (IMAGEDATA POINTER) (* ; "Image instance variables--format depends on IMAGEOPS value") (BUFFS POINTER) (* ; "Buffer chain for pmapped streams") (MAXBUFFERS WORD) (* ; "Max # of buffers the system will allocate.") (LASTCCODE WORD) (* ; "After READ, RATOM, etc, the charcode that will be returned (as a character) by LASTC. If there is none, this field is 65535." ) (EXTRASTREAMOP POINTER) (* ; "For use of applications programs, not devices")) (BLOCKRECORD STREAM ( (NIL 2 WORD) (UCODEFLAGS1 BITS 1) (* ;; "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))) (BLOCKRECORD STREAM ((NIL 4 WORD) (NIL BITS 14) ( * ;; "JIS character encoding format specific, overrides CHARSET field.") (IN.KANJIIN FLAG) (* ; "True if input stream is in Kanji-in mode.") (OUT.KANJIIN FLAG) (* ; "True if output stream is in Kanji-in mode."))) (ACCESSFNS STREAM ((ACCESS \GETACCESS \SETACCESS) ( FULLNAME (OR (fetch (STREAM FULLFILENAME) of DATUM) DATUM)) (NAMEDP (AND (fetch (STREAM FULLFILENAME) of DATUM) T)))) (ACCESSFNS STREAM (EXTERNALFORMAT (LISTGET (ffetch (STREAM OTHERPROPS) of DATUM) ( QUOTE EXTERNALFORMAT)) (LET ((PROPS (ffetch (STREAM OTHERPROPS) of DATUM))) (freplace (STREAM NOTXCCS) of DATUM with T) (COND (PROPS (LISTPUT PROPS (QUOTE EXTERNALFORMAT) NEWVALUE)) (T (freplace (STREAM OTHERPROPS) of DATUM with (LIST (QUOTE EXTERNALFORMAT) NEWVALUE)))) (freplace (STREAM OUTCHARFN) of DATUM with (ffetch (EXTERNALFORMAT FILEOUTCHARFN) of NEWVALUE)) (AND (ffetch (EXTERNALFORMAT EOLVALID) of NEWVALUE) (freplace (STREAM EOLCONVENTION) of DATUM with (ffetch (EXTERNALFORMAT EOL) of NEWVALUE) ))))) (ACCESSFNS STREAM (EXTERNALFORMAT.NAME (LISTGET (ffetch (STREAM OTHERPROPS) of DATUM) (QUOTE EXTERNALFORMAT.NAME)) (LET ((PROPS (ffetch (STREAM OTHERPROPS) of DATUM)) (NAME (COND ((LITATOM NEWVALUE) NEWVALUE) (T (MKATOM NEWVALUE))))) (freplace (STREAM NOTXCCS) of DATUM with T) (COND (PROPS (LISTPUT PROPS (QUOTE EXTERNALFORMAT.NAME) NAME)) (T (freplace (STREAM OTHERPROPS) of DATUM with (LIST (QUOTE EXTERNALFORMAT.NAME) NAME))))))) (ACCESSFNS STREAM (INCCODEFN (LET ((XFMT (LISTGET (ffetch ( STREAM OTHERPROPS) of DATUM) (QUOTE EXTERNALFORMAT)))) (AND (type? EXTERNALFORMAT XFMT) (fetch ( EXTERNALFORMAT INCCODEFN) of XFMT))))) (ACCESSFNS STREAM (PEEKCCODEFN (LET ((XFMT (LISTGET (ffetch ( STREAM OTHERPROPS) of DATUM) (QUOTE EXTERNALFORMAT)))) (AND (type? EXTERNALFORMAT XFMT) (fetch ( EXTERNALFORMAT PEEKCCODEFN) of XFMT))))) (ACCESSFNS STREAM (BACKCHARFN (LET ((XFMT (LISTGET (ffetch ( STREAM OTHERPROPS) of DATUM) (QUOTE EXTERNALFORMAT)))) (AND (type? EXTERNALFORMAT XFMT) (fetch ( EXTERNALFORMAT BACKCHARFN) of XFMT))))) (ACCESSFNS STREAM (FILEOUTCHARFN (ffetch (STREAM OUTCHARFN) of DATUM))) (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) LASTCCODE _ 65535 NOTXCCS _ NIL) (PUTPROPS STREAMOP MACRO (ARGS (CONS (QUOTE SPREADAPPLY*) (CONS (COND ((EQ (CAR (LISTP (CAR ARGS))) ( QUOTE QUOTE)) (LIST (QUOTE fetch) (CADAR ARGS) (QUOTE of) (CADR ARGS))) (T (HELP "STREAMOP - OPNAME not quoted:" ARGS))) (CDDR ARGS))))) (RPAQQ AppendBit 2) (RPAQQ NoBits 0) (RPAQQ ReadBit 1) (RPAQQ WriteBit 4) (RPAQ OutputBits (LOGOR AppendBit WriteBit)) (RPAQ BothBits (LOGOR ReadBit OutputBits)) (RPAQQ \NORUNCODE 255) (CONSTANTS AppendBit NoBits ReadBit WriteBit (OutputBits (LOGOR AppendBit WriteBit)) (BothBits (LOGOR ReadBit OutputBits)) \NORUNCODE) (PUTPROPS TestMasked MACRO ((BITS MASK) (NEQ (LOGAND BITS MASK) 0))) (PUTPROPS APPENDABLE MACRO ((STREAM) (TestMasked (fetch ACCESSBITS of STREAM) AppendBit))) (PUTPROPS APPENDONLY MACRO ((STREAM) (EQ (fetch ACCESSBITS of STREAM) AppendBit))) (PUTPROPS DIRTYABLE MACRO ((STREAM) (TestMasked (fetch ACCESSBITS of STREAM) (CONSTANT (LOGOR AppendBit WriteBit))))) (PUTPROPS OPENED MACRO ((STREAM) (NEQ (fetch ACCESSBITS of STREAM) NoBits))) (PUTPROPS OVERWRITEABLE MACRO ((STREAM) (TestMasked (fetch ACCESSBITS of STREAM) WriteBit))) (PUTPROPS READABLE MACRO ((STREAM) (TestMasked (fetch ACCESSBITS of STREAM) ReadBit))) (PUTPROPS READONLY MACRO ((STREAM) (EQ (fetch ACCESSBITS of STREAM) ReadBit))) (PUTPROPS WRITEABLE MACRO ((STREAM) (OR (OVERWRITEABLE STREAM) (AND (APPENDABLE STREAM) (\EOFP STREAM) )))) (PUTPROPS \RUNCODED MACRO (OPENLAMBDA (STREAM) (* ;; "returns NIL is the stream is not runcoded, that is, if the stream has 16 bit bytes explicitly represented" ) (* ; "note that neq is ok since charsets are known to be SMALLP's") (NEQ (fetch CHARSET of STREAM) \NORUNCODE))) (RPAQQ EOLCONVENTIONS ((CR.EOLC 0) (LF.EOLC 1) (CRLF.EOLC 2))) (RPAQQ CR.EOLC 0) (RPAQQ LF.EOLC 1) (RPAQQ CRLF.EOLC 2) (CONSTANTS (CR.EOLC 0) (LF.EOLC 1) (CRLF.EOLC 2)) (PUTPROPS FDEVOP DMACRO (ARGS (LET ((OPNAME (CAR ARGS)) (METHOD-DEVICE (CADR ARGS)) (TAIL (CDDR ARGS)) ) (COND ((AND (LISTP OPNAME) (EQ (CAR OPNAME) (QUOTE QUOTE))) (BQUOTE (SPREADAPPLY* (fetch (FDEV (\, ( CADR OPNAME))) of (\, METHOD-DEVICE)) (\,@ TAIL)))) (T (ERROR "OPNAME not quoted: " OPNAME)))))) (PUTPROPS \RECOGNIZE-HACK DMACRO (ARGS (LET ((NAME (CAR ARGS)) (RECOG (CADR ARGS)) (DEVICE (CADDR ARGS ))) (BQUOTE (if (type? STREAM (\, NAME)) then (\, NAME) else (FDEVOP (QUOTE GETFILENAME) (\, DEVICE) ( \, NAME) (\, RECOG) (\, DEVICE))))))) (DATATYPE FDEV ((RESETABLE FLAG) (* ; "Obsolete") (RANDOMACCESSP FLAG) (NODIRECTORIES FLAG) ( PAGEMAPPED FLAG) (* ; "True if i/o handled by pmap routines") (FDBINABLE FLAG) (* ; "Copied as a microcode flag for INPUT streams formed on this device") (FDBOUTABLE FLAG) (FDEXTENDABLE FLAG) (BUFFERED FLAG) (* ; "True implies that the device supports the BIN & BOUT uCode conventions, and implements the GETNEXTBUFFER method" ) (DEVICENAME POINTER) (* ; "Identifying name somehow") (REMOTEP FLAG) (* ; "true if device not local to machine") (SUBDIRECTORIES FLAG) (* ; "true if device has real subdirectories") (INPUT-INDIRECTED FLAG) (* ; "True for devices that indirect their input stream. Method INPUTSTREAM fetches it") ( OUTPUT-INDIRECTED FLAG) (* ; "True for devices that indirect their output stream. Method OUTPUTSTREAM fetches it") (DEVICEINFO POINTER) (* ; "arbitrary device-specific info stored here") (OPENFILELST POINTER) (* ; "Default place to keep list of streams open on this device") (* ;; "-----Rest of record consists of device %"methods%"-----") (* ;; "-----Following fields required of all devices-----") (HOSTNAMEP POINTER) (* ; "(hostname {device}) => T if hostname is valid. If device is given, return a FDEV for this {new} host, or T to use existing device" ) (EVENTFN POINTER) (* ; "(device event), called before/after logout, sysout, makesys") (* ;; "-----Following fields required of all named devices, e.g., ones that open files-----") ( DIRECTORYNAMEP POINTER) (* ; "(host/dir) => true if directory exists on host") (OPENFILE POINTER) (* ; "(name access recog otherinfo device) => new stream open on this device, or NIL if name not found") ( CLOSEFILE POINTER) (* ; "(stream) => closes stream, returns it") (REOPENFILE POINTER) (* ; "(name access recog otherinfo device stream) like openfile, but called after logout to revalidate file, so optionally uses info in old stream to keep this opening like the previous" ) (GETFILENAME POINTER) (* ; "(name recog device) => full file name") (DELETEFILE POINTER) (* ; "(name) => deletes file so named, returning name, or NIL on failure. RECOG=OLDEST") (GENERATEFILES POINTER) (* ; "(device pattern) => generator object for files matching pattern. Car of object is generator function, cdr is arbitrary state. Generator fn returns next file, or NIL when finished" ) (RENAMEFILE POINTER) (* ; "(olddevice oldfile newdevice newfile) to rename file on this (olddevice) to a potentially different device." ) (OPENP POINTER) (* ; "(name access dev) => stream if name is open for access, or all open streams if name = NIL") ( REGISTERFILE POINTER) (* ; "(stream dev) => registers stream on its device") (UNREGISTERFILE POINTER) (* ; "(stream dev) => unregisters a stream from its device") (FREEPAGECOUNT POINTER) (* ; "(host/dir dev) => # of free pages on host/dir") (MAKEDIRECTORY POINTER) (* ; "(host/dir dev)") ( CHECKFILENAME POINTER) (* ; "(name dev) => name if it is well-formed file name for dev") (HOSTALIVEP POINTER) (* ; "(host dev) => true if host is alive, i.e., responsive; only defined if REMOTEP is true") ( BREAKCONNECTION POINTER) (* ; "(host fastp dev) => closes connections to host") (* ;; "-----The following are required methods for operating on open streams-----") (BIN POINTER) (* ; "(stream) => next byte of input") (BOUT POINTER) (* ; "(stream byte) output byte to stream") (PEEKBIN POINTER) (* ; "(stream) => next byte without advancing position in stream") (READCHAR POINTER) (* ; "(stream) => next input char") (WRITECHAR POINTER) (* ; "(stream char) => writes char to stream") ( PEEKCHAR POINTER) (UNREADCHAR POINTER) (READP POINTER) (* ; "(stream flag) => T if there is input available from stream right now") (EOFP POINTER) (* ; "(stream) => T if BIN would signal eof.") (BLOCKIN POINTER) (* ; "(stream buffer byteoffset nbytes)") (BLOCKOUT POINTER) (* ; "(stream buffer byteoffset nbytes)") (FORCEOUTPUT POINTER) (* ; "(stream waitForFinish) flushes out to device anything that is buffered awaiting transmission") ( GETFILEINFO POINTER) (* ; "(stream/name attribute device) => value of attribute for open stream or name of closed file") ( SETFILEINFO POINTER) (* ; "(stream/name attribute newvalue device) sets attribute of open stream or closed file of given name") (CHARSETFN POINTER) (* ; "(stream charset) => access function for the charset slot, for benefit of indirect streams. See IMCHARSET for changing it on a file." ) (INPUTSTREAM POINTER) (* ; "(stream) => indirected input stream") (OUTPUTSTREAM POINTER) (* ; "(stream) => indirected output stream") (* ;; "-----Following are required of random-access streams-----") (GETFILEPTR POINTER) (GETEOFPTR POINTER) (SETFILEPTR POINTER) (BACKFILEPTR POINTER) (* ; "(stream) backs up `fileptr' by one. Stream is only required to be able to do this once, i.e. one-character buffer suffices" ) (SETEOFPTR POINTER) (* ; "(stream length) => truncates or lengthens stream to indicated length") ( LASTC POINTER) (* ; "Should be possible only if RANDOMACCESSP") (* ;; "-----Following used for buffered streams-----") (GETNEXTBUFFER POINTER) (* ; "(stream whatfor noerrorflg) => Disposes of current buffer and optionally reads next. whatfor is READ or WRITE. Can cause EOF error unless noerrorflg" ) (RELEASEBUFFER POINTER) (* ; "(stream) => Does whatever appropriate when CBUFPTR is released") (* ;; "-----Following used for pagemapped streams-----") (READPAGES POINTER) (* ; "(stream firstpage# buflist) => # of bytes read, starting at firstpage#, reading into buflist, a list of buffers or a single buffer (the usual case)" ) (WRITEPAGES POINTER) (* ; "(stream firstpage# buflist) writes from buflist to stream starting at firstpage# of stream") ( TRUNCATEFILE POINTER) (* ; "(stream page offset) make stream's eof be at page,offset, discarding anything after it") (* ;; "-----For window system, argh-----") (WINDOWOPS POINTER) (* ; "window system operations") (WINDOWDATA POINTER) (* ; "data for window systems") (* ;; "-----For any stream (here to not recompile everything)-----") (READCHARCODE POINTER) (* ; "Read a character code from the stream (cf BIN for bytes).")) DIRECTORYNAMEP _ (FUNCTION NILL) HOSTNAMEP _ (FUNCTION NILL) READP _ (FUNCTION \GENERIC.READP) SETFILEPTR _ (FUNCTION \IS.NOT.RANDACCESSP) GETFILEPTR _ (FUNCTION \ILLEGAL.DEVICEOP) GETEOFPTR _ (FUNCTION \IS.NOT.RANDACCESSP) EOFP _ (FUNCTION \ILLEGAL.DEVICEOP) BLOCKIN _ (FUNCTION \GENERIC.BINS) BLOCKOUT _ (FUNCTION \GENERIC.BOUTS) RENAMEFILE _ (FUNCTION \GENERIC.RENAMEFILE) FORCEOUTPUT _ (FUNCTION NILL) REGISTERFILE _ (FUNCTION NILL) OPENP _ (FUNCTION NILL) UNREGISTERFILE _ (FUNCTION NILL) READCHAR _ ( FUNCTION \GENERIC.READCHAR) WRITECHAR _ (FUNCTION \GENERIC.WRITECHAR) PEEKCHAR _ (FUNCTION \GENERIC.PEEKCHAR) UNREADCHAR _ (FUNCTION \GENERIC.UNREADCHAR) CHARSETFN _ (FUNCTION \GENERIC.CHARSET) BREAKCONNECTION _ (FUNCTION NILL) READCHARCODE _ (FUNCTION \GENERIC.READCCODE)) (RECORD FILEGENOBJ (NEXTFILEFN FILEINFOFN . GENFILESTATE)) (DATATYPE EXTERNALFORMAT ((EOLVALID FLAG) (* ; "If true, the value of EOL field will replace the EOLCONVENTION field of the resulted stream.") (EOL BITS 2) (NIL BITS 1) (INCCODEFN POINTER) (* ; "Called with two arguments -- STREAM and COUNTP") ( PEEKCCODEFN POINTER) (* ; "Called with three arguments -- STREAM, NOERROR and COUNTP") (BACKCHARFN POINTER) (* ; "Called with two arguments -- STREAM and COUNTP") (FILEOUTCHARFN POINTER) (* ; "Called with two arguments -- STREAM and CHARCODE")) EOLVALID _ NIL) (PUTPROPS \OUTCHAR DMACRO (OPENLAMBDA (STREAM CHARCODE) (STREAMOP (QUOTE OUTCHARFN) STREAM STREAM CHARCODE))) (PUTPROPS \DEVICE-OPEN-STREAMS MACRO (ARGS (LET ((DEVICE (CAR ARGS))) (BQUOTE (FDEVOP (QUOTE OPENP) ( \, DEVICE) NIL NIL (\, DEVICE)))))) (PUTPROPS \CONVERT-PATHNAME DMACRO (OPENLAMBDA (PATHNAME?) (* ;; "Coerce pathnames to Interlisp strings, for the benefit of antediluvian Interlisp-D file fns") ( CL:TYPECASE PATHNAME? (PATHNAME (INTERLISP-NAMESTRING PATHNAME?)) (T PATHNAME?)))) (DEFOPTIMIZER ACCESS-CHARSET (STREAM &OPTIONAL NEWVALUE) (BQUOTE ((OPENLAMBDA (STRM) (FDEVOP (QUOTE CHARSETFN) (fetch (STREAM DEVICE) of STRM) STRM (\, NEWVALUE))) (\, STREAM)))) (PUTPROPS \DECFILEPTR MACRO ((STREAM X) (\INCFILEPTR STREAM (IMINUS X)))) (PUTPROPS \GETFILEPTR MACRO (OPENLAMBDA (STRM) (FDEVOP (QUOTE GETFILEPTR) (fetch DEVICE of STRM) STRM) )) (PUTPROPS \SIGNEDWIN MACRO ((STREAM) (SIGNED (\WIN STREAM) BITSPERWORD))) (PUTPROPS \SIGNEDWOUT MACRO ((STREAM N) (\WOUT STREAM (UNSIGNED N BITSPERWORD)))) (PUTPROPS \WIN MACRO (OPENLAMBDA (STREAM) (create WORD HIBYTE _ (\BIN STREAM) LOBYTE _ (\BIN STREAM))) ) (PUTPROPS \WOUT MACRO (OPENLAMBDA (STREAM W) (\BOUT STREAM (fetch HIBYTE of W)) (\BOUT STREAM (fetch LOBYTE of W)))) (PUTPROPS \BINS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES) (FDEVOP (QUOTE BLOCKIN) (fetch (STREAM DEVICE) of STRM) STRM BASE OFF NBYTES))) (PUTPROPS \BOUTS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES) (FDEVOP (QUOTE BLOCKOUT) (fetch (STREAM DEVICE) of STRM) STRM BASE OFF NBYTES))) (PUTPROPS \EOFP BYTEMACRO (OPENLAMBDA (STRM) (FDEVOP (QUOTE EOFP) (fetch (STREAM DEVICE) of STRM) STRM ))) (PUTPROPS SIZE.FROM.LENGTH MACRO (LAMBDA (LEN) (DECLARE (LOCALVARS LEN)) (AND LEN (FOLDHI LEN BYTESPERPAGE)))) (RPAQQ BitsPerByte 8) (RPAQ ByteOffsetSize (SELECTQ (SYSTEMTYPE) (VAX 10) 9)) (RPAQQ WordsPerPage 256) (CONSTANTS BitsPerByte (ByteOffsetSize (SELECTQ (SYSTEMTYPE) (VAX 10) 9)) WordsPerPage) (RPAQ \MAXFILEPTR (SUB1 (LLSH 1 30))) (CONSTANTS (\MAXFILEPTR (SUB1 (LLSH 1 30)))) (ACCESSFNS BYTEPTR ((PAGE (FOLDLO DATUM BYTESPERPAGE)) (OFFSET (MOD DATUM BYTESPERPAGE))) (TYPE? (AND (FIXP DATUM) (IGEQ DATUM 0) (ILEQ DATUM \MAXFILEPTR))) (CREATE (IPLUS (UNFOLD PAGE BYTESPERPAGE) OFFSET))) (PUTPROP (QUOTE FILEIO) (QUOTE IMPORTDATE) (IDATE "26-Mar-99 12:25:05")) (BLOCKRECORD FIXP ((HINUM WORD) (LONUM WORD)) (CREATE (CREATECELL \FIXP)) (TYPE? (EQ (NTYPX DATUM) \FIXP))) (RPAQQ MAX.SMALL.INTEGER 65535) (RPAQQ MAX.POS.HINUM 32767) (CONSTANTS (MAX.SMALL.INTEGER 65535) (MAX.POS.HINUM 32767)) (PUTPROPS .UNBOX. MACRO (ARGS (LET ((ARG-FORM (CAR ARGS)) (HIGH-VAR (CADR ARGS)) (LOW-VAR (CADDR ARGS) ) (BIGNUM-FORM (CADDDR ARGS))) (BQUOTE (PROG NIL UBLP (SELECTC (NTYPX (\, ARG-FORM)) (\FIXP (SETQ (\, HIGH-VAR) (ffetch (FIXP HINUM) of (\, ARG-FORM))) (SETQ (\, LOW-VAR) (ffetch (FIXP LONUM) of (\, ARG-FORM)))) (\SMALLP (COND ((ILEQ 0 (\, ARG-FORM)) (SETQ (\, HIGH-VAR) 0) (SETQ (\, LOW-VAR) (\, ARG-FORM))) (T (SETQ (\, HIGH-VAR) 65535) (SETQ (\, LOW-VAR) (\LOLOC (\, ARG-FORM)))))) (\FLOATP (SETQ (\, ARG-FORM) (\FIXP.FROM.FLOATP (\, ARG-FORM))) (GO UBLP)) (COND ((TYPENAMEP (\, ARG-FORM) (QUOTE RATIO)) (SETQ (\, ARG-FORM) (IQUOTIENT (CL::RATIO-NUMERATOR (\, ARG-FORM)) (CL::RATIO-DENOMINATOR (\, ARG-FORM)))) (GO UBLP)) (\,@ (COND (BIGNUM-FORM (BQUOTE (((CL:INTEGERP (\, ARG-FORM)) (\, BIGNUM-FORM) )))) (T (BQUOTE (((CL:INTEGERP (\, ARG-FORM)) (\ILLEGAL.ARG (\, ARG-FORM)))))))) (T ( CL::%%NOT-NONCOMPLEX-NUMBER-ERROR (\, ARG-FORM)))))))))) (PUTPROPS .NEGATE. MACRO ((HY LY) (COND ((EQ 0 LY) (AND (NEQ HY 0) (SETQ HY (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY))))) (T (SETQ HY (IDIFFERENCE MAX.SMALL.INTEGER HY)) (SETQ LY (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY))))))) (PUTPROPS .LLSH1. MACRO ((HI LO) (* ; "shift the pair left one, assuming no overflow") (SETQ HI (LLSH HI 1)) (SETQ LO (LLSH (COND ((IGREATERP LO MAX.POS.HINUM) (add HI 1) (LOGAND LO MAX.POS.HINUM)) (T LO) ) 1)))) (PUTPROPS .LRSH1. MACRO ((HI LO) (SETQ LO (LRSH LO 1)) (COND ((NEQ (LOGAND HI 1) 0) (SETQ LO (IPLUS LO \SIGNBIT)))) (SETQ HI (LRSH HI 1)))) (PUTPROPS .BOXIPLUS. MACRO (OPENLAMBDA (X Y) (PROG ((HX (\GETBASE X 0)) (LX (\GETBASE X 1)) HY LY) ( .UNBOX. Y HY LY) (SETQ HX (COND ((IGREATERP HX (IDIFFERENCE MAX.SMALL.INTEGER HY)) (IDIFFERENCE HX ( ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY)))) (T (IPLUS HX HY)))) (* Add high parts) (\PUTBASE X 1 (COND ((IGREATERP LX (IDIFFERENCE MAX.SMALL.INTEGER LY)) (* Carry into high part.) (SETQ HX (COND ((EQ HX MAX.SMALL.INTEGER) 0) (T (ADD1 HX)))) (IDIFFERENCE LX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY)))) (T ( IPLUS LX LY)))) (\PUTBASE X 0 HX) (RETURN X)))) (PUTPROPS PutUnboxed DMACRO (= . \PUTFIXP)) (PUTPROP (QUOTE LLARITH) (QUOTE IMPORTDATE) (IDATE "16-May-90 18:47:56")) (PUTPROPS POLYEVAL DMACRO ((X COEFFS DEGREE) (* ; "execute the POLYEVAL opcode on the value X, the array COEFFS with degree DEGREE") (\FLOATBOX (( OPCODES UBFLOAT3 0) (\FLOATUNBOX X) (fetch (ARRAYP BASE) of COEFFS) DEGREE)))) (BLOCKRECORD FLOATP ((SIGNBIT BITS 1) (EXPONENT BITS 8) (HIFRACTION BITS 7) (LOFRACTION BITS 16)) ( BLOCKRECORD FLOATP ((HIWORD WORD) (LOWORD WORD))) (BLOCKRECORD FLOATP ((NIL BITS 9) (LONGFRACTION BITS 23))) (BLOCKRECORD FLOATP ((FLOATCONTENTS BITS 32))) (BLOCKRECORD FLOATP ((NIL BITS 1) ( HIWORDNOSIGNBIT BITS 15))) (CREATE (\FLOATBOX (\VAG2 (LOGOR (LLSH SIGNBIT (PLUS 7 8)) (LLSH EXPONENT 7 ) HIFRACTION) LOFRACTION))) LOFRACTION _ 0 HIFRACTION _ 0 EXPONENT _ 0 SIGNBIT _ 0 (ACCESSFNS FLOATP ( (EXP (LOGAND (LRSH (\HILOC (\FLOATUNBOX DATUM)) 7) 255)) (HIFRAC (LOGAND (\HILOC (\FLOATUNBOX DATUM)) 127))))) (RPAQQ MAX.DIGITS.ACCURACY 9) (CONSTANTS (MAX.DIGITS.ACCURACY 9)) (PUTPROPS \CALLER.ARGS MACRO (X (LET ((ARGS (CAR X)) (FORMS (CDR X))) (BQUOTE (PROGN (\SLOWRETURN) ( LET ((AL (\MYALINK)) NEXT (\,@ (for VAR in ARGS collect (COND ((LISTP VAR) (LIST (CAR VAR) 0)) (T VAR) )))) (DECLARE (\,@ (for VAR in ARGS when (LISTP VAR) collect (BQUOTE (TYPE (\, (SELECTQ (CADR VAR) (( FLOATING FLOATP) (CADR VAR)) (HELP))) (\, (CAR VAR))))))) (SETQ NEXT (fetch (FX NEXTBLOCK) of AL)) ( \,@ (for X in (REVERSE ARGS) collect (LET ((FORMS (BQUOTE (\.GETBASE32 \STACKSPACE (SETQ NEXT ( IDIFFERENCE NEXT WORDSPERCELL)))))) (COND ((LISTP X) (BQUOTE (SETQ (\, (CAR X)) (\FLOATBOX (\, FORMS)) ))) (T (BQUOTE (SETQ (\, X) (\, FORMS)))))))) (\MAKEFREEBLOCK NEXT (TIMES (\, (LENGTH ARGS)) WORDSPERCELL)) (replace (FX NEXTBLOCK) of AL with NEXT) (PROGN (\,@ FORMS)))))))) (PUTPROP (QUOTE LLFLOAT) (QUOTE IMPORTDATE) (IDATE "16-May-90 19:26:51")) (DEFOPTIMIZER FONTPROP (&REST ARGS) (SELECTQ (AND (EQ (CAADR ARGS) (QUOTE QUOTE)) (CADADR ARGS)) ( ASCENT (LIST (QUOTE FONTASCENT) (CAR ARGS))) (DESCENT (LIST (QUOTE FONTDESCENT) (CAR ARGS))) (HEIGHT ( LIST (QUOTE FONTHEIGHT) (CAR ARGS))) (QUOTE IGNOREMACRO))) (DATATYPE FONTCLASS ((PRETTYFONT# BYTE) DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME)) (DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER) (FONTFAMILY POINTER) (FONTSIZE POINTER) (FONTFACE POINTER) (\SFAscent WORD) (\SFDescent WORD) (\SFHeight WORD) (ROTATION WORD) (FBBOX SIGNEDWORD) (FBBOY SIGNEDWORD) (FBBDX SIGNEDWORD) (FBBDY SIGNEDWORD) (\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) (\SFFACECODE BITS 8) (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)) (RECORD FONTFACE (WEIGHT SLOPE EXPANSION) (ACCESSFNS ((COLOR (CDDDR DATUM) (RPLACD (CDDR DATUM) NEWVALUE)) (BACKCOLOR (COND ((CDDDR DATUM) (CAR (CDDDR DATUM)))) (PROGN (COND ((NULL (CDDDR DATUM)) ( RPLACD (CDDR DATUM) (LIST NIL NIL)))) (RPLACA (CDDDR DATUM) NEWVALUE))) (FORECOLOR (COND ((CDDDR DATUM ) (CADR (CDDDR DATUM)))) (PROGN (COND ((NULL (CDDDR DATUM)) (RPLACD (CDDR DATUM) (LIST NIL NIL)))) ( RPLACA (CDR (CDDDR DATUM)) NEWVALUE))))) WEIGHT _ (QUOTE MEDIUM) SLOPE _ (QUOTE REGULAR) EXPANSION _ ( QUOTE REGULAR) (TYPE? LISTP)) (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") LEFTKERN) WIDTHS _ (\CREATECSINFOELEMENT) OFFSETS _ (\CREATECSINFOELEMENT)) (PUTPROPS FONTASCENT MACRO ((FONTSPEC) (ffetch \SFAscent of (\GETFONTDESC FONTSPEC)))) (PUTPROPS FONTDESCENT MACRO ((FONTSPEC) (ffetch \SFDescent of (\GETFONTDESC FONTSPEC)))) (PUTPROPS FONTHEIGHT MACRO ((FONTSPEC) (ffetch \SFHeight of (\GETFONTDESC FONTSPEC)))) (PUTPROPS \FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE) (\GETBASE OFFSETSBLOCK CHAR8CODE))) (PUTPROPS \FSETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE OFFSET) (\PUTBASE OFFSETSBLOCK CHAR8CODE OFFSET) )) (PUTPROPS \FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE) (\GETBASE WIDTHSBLOCK CHAR8CODE))) (PUTPROPS \FSETWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) (\PUTBASE WIDTHSBLOCK INDEX WIDTH))) (PUTPROPS \FGETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE) (\FGETWIDTH (ffetch (CHARSETINFO WIDTHS ) of (\GETCHARSETINFO (\CHARSET CHARCODE) FONTDESC)) (\CHAR8CODE CHARCODE)))) (PUTPROPS \FSETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE WIDTH) (\FSETWIDTH (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE) FONTDESC)) (\CHAR8CODE CHARCODE) WIDTH))) (PUTPROPS \FGETIMAGEWIDTH MACRO ((IMAGEWIDTHSBLOCK CHAR8CODE) (\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE))) (PUTPROPS \FSETIMAGEWIDTH 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 \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))) (DEFMACRO \CREATEKERNELEMENT NIL (BQUOTE (CL:MAKE-ARRAY (IPLUS \MAXTHINCHAR 3) :ELEMENT-TYPE (QUOTE ( SIGNED-BYTE 16)) :INITIAL-ELEMENT 0))) (DEFMACRO \FSETLEFTKERN (LEFTKERNBLOCK INDEX KERNVALUE) (BQUOTE (CL:SETF (CL:AREF (\, LEFTKERNBLOCK) ( \, INDEX)) (\, KERNVALUE)))) (DEFMACRO \FGETLEFTKERN (LEFTKERNBLOCK CHAR8CODE) (BQUOTE (CL:AREF (\, LEFTKERNBLOCK) (\, CHAR8CODE))) ) (RPAQQ \MAXNSCHAR 65535) (CONSTANTS (\MAXNSCHAR 65535)) (PUTPROP (QUOTE FONT) (QUOTE IMPORTDATE) (IDATE "28-Jun-99 16:29:49")) (BLOCKRECORD KEYACTION ((* ;; "KEYACTION Table: For interpreting keystrokes. Stored as a 8-cell block of untyped pointer hunk storage." ) FLAGS (* ; "Flag byte per key# (one for down-transtion, 1 for up-.) to describe whether lockshifting occrrs, you ignore the transition, etc." ) CODES (* ; "Table of character codes generated by each key when no shift key is pressed.") SHIFTCODES (* ; "Table of character codes generated by each key when the shift key is pressed.") ARMED (* ; "Not sure...") INTERRUPTLIST (* ; "List of armed interrupts?") ALTGRAPHCODES (* ; "Table of codes to be generated when the ALT-GRAPH key is pressed.") DEADKEYLIST (* ; "Block of dead-key handlers, with the nominal up-transition fields filled by the shifted-case tables. Each %"table%" is an ALIST of orignal code => accented code. no entry means punt the accent.." )) FLAGS _ (\ALLOCBLOCK (FOLDHI (IPLUS \NKEYS \NKEYS) BYTESPERCELL)) CODES _ (\ALLOCBLOCK (FOLDHI ( PLUS \NKEYS \NKEYS) WORDSPERCELL)) SHIFTCODES _ (\ALLOCBLOCK (FOLDHI (PLUS \NKEYS \NKEYS) WORDSPERCELL )) ARMED _ (\ALLOCBLOCK (FOLDHI (ADD1 \MAXTHINCHAR) BITSPERCELL)) ALTGRAPHCODES _ (\ALLOCBLOCK (FOLDHI (PLUS \NKEYS \NKEYS) WORDSPERCELL)) DEADKEYLIST _ (\ALLOCBLOCK (PLUS \NKEYS \NKEYS \NKEYS \NKEYS) T) (CREATE (\ALLOCBLOCK 7 PTRBLOCK.GCT)) (TYPE? (AND (\BLOCKDATAP DATUM) (IGEQ (\#BLOCKDATACELLS DATUM) 5 ) (OR (NULL (FETCH (KEYACTION INTERRUPTLIST) OF DATUM)) (LISTP (FETCH INTERRUPTLIST OF DATUM))) ( \BLOCKDATAP (FETCH (KEYACTION FLAGS) DATUM)) (\BLOCKDATAP (FETCH (KEYACTION CODES) DATUM)) ( \BLOCKDATAP (FETCH (KEYACTION ARMED) DATUM))))) (RPAQQ \NKEYS 112) (CONSTANTS \NKEYS) (DEFOPTIMIZER KEYDOWNP (KEYNAME) (BQUOTE (\NEWKEYDOWNP (\KEYNAMETONUMBER (\, KEYNAME))))) (PUTPROPS XKEYDOWNP MACRO ((KEYNAME) (KEYDOWNP1 (\KEYNAMETONUMBER KEYNAME)))) (PUTPROPS KEYDOWNP1 MACRO (OPENLAMBDA (KEYNUMBER) (DECLARE (GLOBALVARS \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.UTILIN \EM.KBDAD4 \EM.KBDAD5)) (PROG NIL (RETURN (EQ 0 (LOGAND (LRSH (LLSH 1 15) (PROGN (* (IMOD KEYNUMBER BITSPERWORD) - GETD cause IMOD and BITSPERWORD not exported to user) ( LOGAND KEYNUMBER 15))) (\GETBASE (SELECTQ (PROGN (* (FOLDLO KEYNUMBER BITSPERWORD) GETD follows since FOLDLO and BITSPERWORD not exported to user) (LRSH KEYNUMBER 4)) (0 \EM.KBDAD0) (1 \EM.KBDAD1) (2 \EM.KBDAD2) (3 \EM.KBDAD3) (4 \EM.UTILIN) (5 (OR \EM.KBDAD4 (RETURN))) (6 (OR \EM.KBDAD5 (RETURN))) ( RETURN)) 0))))))) (PUTPROPS \NEWKEYDOWNP MACRO ((KEYNUMBER) (EQ 0 (\GETBASEBIT \LASTKEYSTATE KEYNUMBER)))) (GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM) (RPAQQ HARDCURSORHEIGHT 16) (RPAQQ HARDCURSORWIDTH 16) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTSCREEN LASTMOUSEBUTTONS LASTMOUSETIME LASTKEYBOARD) (PUTPROPS \SETMOUSEXY MACRO ((XPOS YPOS) (PROGN (SELECTC \MACHINETYPE (\DAYBREAK ( \DoveMisc.SetMousePosition XPOS YPOS)) (\MAIKO (SUBRCALL SETMOUSEXY XPOS YPOS)) (\DANDELION (do (PROGN (replace (IOPAGE NEWMOUSEX) of \IOPAGE with XPOS) (replace (IOPAGE NEWMOUSEY) of \IOPAGE with YPOS)) repeatuntil (ILESSP (fetch (IOPAGE NEWMOUSESTATE) of \IOPAGE) 32768)) (* ; "smash position until mouse says it is not busy") (replace (IOPAGE NEWMOUSEX) of \IOPAGE with XPOS) ( replace (IOPAGE NEWMOUSEY) of \IOPAGE with YPOS) (replace (IOPAGE NEWMOUSESTATE) of \IOPAGE with 32768 )) NIL) (PROGN (\PUTBASE \EM.MOUSEX 0 XPOS) (\PUTBASE \EM.MOUSEY 0 YPOS))))) (GLOBALVARS \EM.MOUSEX \EM.MOUSEY \EM.CURSORX \EM.CURSORY \EM.UTILIN \EM.REALUTILIN \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.KBDAD4 \EM.KBDAD5 \EM.DISPINTERRUPT \EM.DISPLAYHEAD \EM.CURSORBITMAP \MACHINETYPE \DEFAULTKEYACTION \COMMANDKEYACTION \CURRENTKEYACTION \PERIODIC.INTERRUPT \PERIODIC.INTERRUPT.FREQUENCY) (PUTPROP (QUOTE LLKEY) (QUOTE IMPORTDATE) (IDATE " 9-Apr-2000 16:28:23")) (DATATYPE PILOTBBT ((PBTDESTLO WORD) (PBTDESTHI WORD) (PBTDESTBIT WORD) (PBTDESTBPL SIGNEDWORD) ( PBTSOURCELO WORD) (PBTSOURCEHI WORD) (PBTSOURCEBIT WORD) (PBTSOURCEBPL SIGNEDWORD) (PBTWIDTH WORD) ( PBTHEIGHT WORD) (PBTFLAGS WORD) (NIL 5 WORD)) (BLOCKRECORD PILOTBBT ((NIL 7 WORD) (NIL BITS 4) ( PBTGRAYOFFSET BITS 4) (PBTGRAYWIDTHLESSONE BITS 4) (PBTGRAYHEIGHTLESSONE BITS 4) (NIL 2 WORD) ( PBTBACKWARD FLAG) (PBTDISJOINT FLAG) (PBTDISJOINTITEMS FLAG) (PBTUSEGRAY FLAG) (PBTSOURCETYPE BITS 1) (PBTOPERATION BITS 2) (NIL BITS 9))) (ACCESSFNS PILOTBBT ((PBTSOURCE (\VAG2 (fetch PBTSOURCEHI of DATUM) (fetch PBTSOURCELO of DATUM)) (PROGN (replace PBTSOURCEHI of DATUM with (\HILOC NEWVALUE)) ( replace PBTSOURCELO of DATUM with (\LOLOC NEWVALUE)))) (PBTDEST (\VAG2 (fetch PBTDESTHI of DATUM) ( fetch PBTDESTLO of DATUM)) (PROGN (replace PBTDESTHI of DATUM with (\HILOC NEWVALUE)) (replace PBTDESTLO of DATUM with (\LOLOC NEWVALUE)))))) (SYSTEM)) (DATATYPE \DISPLAYDATA (DDXPOSITION DDYPOSITION DDXOFFSET DDYOFFSET DDDestination DDClippingRegion DDFONT DDSlowPrintingCase DDWIDTHSCACHE DDOFFSETSCACHE DDCOLOR DDLINEFEED DDRightMargin DDLeftMargin DDScroll DDOPERATION DDSOURCETYPE (DDClippingLeft WORD) (DDClippingRight WORD) (DDClippingBottom WORD) (DDClippingTop WORD) (NIL WORD) (DDHELDFLG FLAG) (XWINDOWHINT XPOINTER) (DDPILOTBBT POINTER) DDXSCALE DDYSCALE DDCHARIMAGEWIDTHS DDEOLFN DDPAGEFULLFN DDTexture DDMICAXPOS DDMICAYPOS DDMICARIGHTMARGIN DDCHARSET (DDCHARSETASCENT WORD) (DDCHARSETDESCENT WORD) DDCHARHEIGHTDELTA (DDSPACEWIDTH WORD)) DDPILOTBBT _ (create PILOTBBT PBTDISJOINT _ T) DDLeftMargin _ 0 DDRightMargin _ SCREENWIDTH DDXPOSITION _ 0 DDYPOSITION _ 0 DDXOFFSET _ 0 DDYOFFSET _ 0 DDClippingRegion _ (create REGION) DDDestination _ ScreenBitMap DDXSCALE _ 1 DDYSCALE _ 1 DDTexture _ 0 (ACCESSFNS ((DDFOREGROUNDCOLOR ( PROG ((VAL (fetch (\DISPLAYDATA DDCOLOR) of DATUM))) (OR (FIXP VAL) (BITMAPP VAL) (AND (NULL VAL) 1) ( CAR VAL) (MAXIMUMCOLOR (BITSPERPIXEL (fetch (\DISPLAYDATA DDDestination) of DATUM)))))) ( DDBACKGROUNDCOLOR (OR (fetch (\DISPLAYDATA DDTexture) of DATUM) 0)))) (SYSTEM)) (RECORD DISPLAYSTATE (ONOFF)) (RECORD DISPLAYINFO (DITYPE DIWIDTH DIHEIGHT DIBITSPERPIXEL DIWSOPS)) (PUTPROPS \GETDISPLAYDATA MACRO (ARGS (COND ((CADR ARGS) (SUBPAIR (QUOTE (STRM STRMVAR)) ARGS (QUOTE ( \DTEST (fetch (STREAM IMAGEDATA) of (SETQ STRMVAR (\OUTSTREAMARG STRM))) (QUOTE \DISPLAYDATA))))) (T ( SUBST (CAR ARGS) (QUOTE STRM) (QUOTE (\DTEST (fetch (STREAM IMAGEDATA) of (\OUTSTREAMARG STRM)) (QUOTE \DISPLAYDATA)))))))) (PUTPROPS \BITMASK MACRO ((N) (\WORDELT BITMASKARRAY (LOGAND N 15)))) (PUTPROPS \4BITMASK MACRO ((N) (\WORDELT 4BITMASKARRAY (LOGAND N 3)))) (PUTPROPS \NOTBITMASK MACRO ((N) (DECLARE (GLOBALVARS NOTBITMASKARRAY)) (\WORDELT NOTBITMASKARRAY ( LOGAND N 15)))) (PUTPROPS \NOT4BITMASK MACRO ((N) (\WORDELT NOT4BITMASKARRAY (LOGAND N 3)))) (GLOBALVARS BITMASKARRAY NOTBITMASKARRAY 4BITMASKARRAY NOT4BITMASKARRAY) (RPAQQ WORDMASK 65535) (CONSTANTS (WORDMASK 65535)) (PUTPROPS \INVALIDATEDISPLAYCACHE MACRO ((DISPLAYDATA) (* This marks the character-printing caches of the displaystream as invalid. Needed when the font or Y position changes) (freplace (\DISPLAYDATA DDCHARSET) of DISPLAYDATA with MAX.SMALLP) (freplace (\DISPLAYDATA DDCHARSETASCENT) of DISPLAYDATA with MAX.SMALLP))) (PUTPROPS \DSPGETCHARWIDTH MACRO ((CHARCODE DD) (\FGETWIDTH (ffetch (\DISPLAYDATA DDWIDTHSCACHE) of DD ) CHARCODE))) (PUTPROPS \DSPGETCHARIMAGEWIDTH MACRO ((CHARCODE DD) (\FGETIMAGEWIDTH (ffetch (\DISPLAYDATA DDCHARIMAGEWIDTHS) of DD) CHARCODE))) (PUTPROPS \DSPGETCHAROFFSET MACRO ((CHARCODE DD) (\GETBASE (ffetch (\DISPLAYDATA DDOFFSETSCACHE) of DD ) CHARCODE))) (PUTPROPS \CONVERTOP MACRO ((OP) (* rrb "14-NOV-80 11:14") (* Only for alto bitblt !!) (SELECTQ OP ( replace 0 of NIL with NIL) (PAINT 1) (INVERT 2) (ERASE 3) 0))) (PUTPROPS \SFInvert MACRO ((BitMap y) (* corrects for the fact that alto bitmaps are stored with 0,0 as upper left while lisp bitmaps have 0,0 as lower left. The correction is actually off by one ( greater) because a majority of the places that it is called actually need one more than corrected Y value.) (IDIFFERENCE (fetch (BITMAP BITMAPHEIGHT) of BitMap) y))) (PUTPROPS \SFReplicate MACRO (LAMBDA (pattern) (LOGOR pattern (LLSH pattern 8) (SETQ pattern (LLSH pattern 4)) (LLSH pattern 8)))) (PUTPROPS \SETPBTFUNCTION MACRO (OPENLAMBDA (BBT SourceType Operation) (PROGN (replace (PILOTBBT PBTOPERATION) of BBT with (SELECTQ Operation (ERASE 1) (PAINT 2) (INVERT 3) 0)) (replace (PILOTBBT PBTSOURCETYPE) of BBT with (COND ((EQ (EQ SourceType (QUOTE INVERT)) (EQ Operation (QUOTE ERASE))) 0) (T 1)))))) (PUTPROPS \BITBLT1 MACRO ((bbt) (BitBltSUBR bbt))) (PUTPROP (QUOTE BITBLT) (QUOTE MACRO) (QUOTE (= . BKBITBLT))) (PROGN (PUTPROPS \INSURETOPWDS DMACRO (OPENLAMBDA (DS) (OR (EQ DS \TOPWDS) (COND ((FMEMB ( DSPDESTINATION NIL DS) \SCREENBITMAPS) (\TOTOPWDS DS)))))) (PUTPROPS \INSURETOPWDS MACRO ((DS) (* For non-window implementations) (PROGN)))) (PUTPROPS .WHILE.TOP.DS. MACRO ((FIRST . REST) (PROG (DISPINTERRUPT SOFTCURSORUP) (* FIRST should be a displaystream and a variable. This macro may also take a soft cursor down, similar to the way .WHILE.CURSOR.DOWN. does, but only if FIRST's destination is the same as the soft cursor's destination. *) (COND (\SOFTCURSORP (SETQ SOFTCURSORUP (AND \SOFTCURSORUPP (EQ (DSPDESTINATION NIL FIRST) \CURSORDESTINATION))) (COND (SOFTCURSORUP (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0)) ( \PUTBASE \EM.DISPINTERRUPT 0 0) (\SOFTCURSORDOWN))))) (\INSURETOPWDS FIRST) (PROGN . REST) (COND ( SOFTCURSORUP (\SOFTCURSORUPCURRENT) (\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT)))))) (PUTPROPS .WHILE.CURSOR.DOWN. MACRO ((FIRST . REST) (PROG (DISPINTERRUPT SOFTCURSORUP) (* This macro should wrap around any code that draws or bitblts directly from or to a screen bitmap. E.g. DRAWGRAYBOX in HLDISPLAY which puts up a shadow box during GETREGION. The purpose of this macro is that a soft (e.g. color) cursor's bits not be taken to be screen bits while FIRST & REST are done. *) (COND (\SOFTCURSORP (SETQ SOFTCURSORUP \SOFTCURSORUPP) (COND (SOFTCURSORUP (SETQ DISPINTERRUPT ( \GETBASE \EM.DISPINTERRUPT 0)) (\PUTBASE \EM.DISPINTERRUPT 0 0) (\SOFTCURSORDOWN))))) (PROGN FIRST . REST) (COND (SOFTCURSORUP (\SOFTCURSORUPCURRENT) (\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT)))))) (ADDTOVAR GLOBALVARS \TOPWDS) (DEFOPTIMIZER TTYDISPLAYSTREAM (&REST X) (COND ((NULL (CAR X)) (QUOTE \TERM.OFD)) (T (QUOTE IGNOREMACRO)))) (GLOBALVARS BELLCNT BELLRATE TTYBACKGROUNDFNS \DisplayStoppedForLogout \CARET.UP) (PUTPROPS \CHECKCARET MACRO ((X) (AND \CARET.UP (\CARET.DOWN X)))) (PUTPROPS \DSPTRANSFORMX MACRO ((X DD) (* transforms an x coordinate into the destination coordinate.) (IPLUS X (fetch (\DISPLAYDATA DDXOFFSET) of DD)))) (PUTPROPS \DSPTRANSFORMY MACRO ((Y DD) (* transforms an y coordinate into the destination coordinate.) (IPLUS Y (fetch (\DISPLAYDATA DDYOFFSET) of DD)))) (PUTPROPS \OFFSETBOTTOM MACRO ((X) (* gives the destination coordinate address of the origin.) (fetch (\DISPLAYDATA DDYOFFSET) of X))) (PUTPROPS \OFFSETLEFT MACRO ((DD) (* returns the x origin of display data destination coordinates.) ( fetch (\DISPLAYDATA DDXOFFSET) of DD))) (PUTPROPS DISPLAYINITIALIZEDP MACRO (NIL (* always initialized now) T)) (PUTPROPS DISPLAYSTARTEDP MACRO (NIL \DisplayStarted)) (GLOBALVARS \DisplayStarted \DisplayStreamsInitialized \DisplayInitialed WHOLEDISPLAY WHOLESCREEN SCREENWIDTH SCREENHEIGHT) (PUTPROP (QUOTE LLDISPLAY) (QUOTE IMPORTDATE) (IDATE "18-Apr-94 00:20:42")) (RECORD REGION (LEFT BOTTOM WIDTH HEIGHT) LEFT _ -16383 BOTTOM _ -16383 WIDTH _ 32767 HEIGHT _ 32767 ( ACCESSFNS ((TOP (IPLUS (fetch (REGION BOTTOM) of DATUM) (fetch (REGION HEIGHT) of DATUM) -1)) (PTOP ( IPLUS (fetch (REGION BOTTOM) of DATUM) (fetch (REGION HEIGHT) of DATUM))) (RIGHT (IPLUS (fetch (REGION LEFT) of DATUM) (fetch (REGION WIDTH) of DATUM) -1)) (PRIGHT (IPLUS (fetch (REGION LEFT) of DATUM) ( fetch (REGION WIDTH) of DATUM))))) (TYPE? (AND (EQLENGTH DATUM 4) (EVERY DATUM (FUNCTION NUMBERP)))) ( SYSTEM)) (DATATYPE BITMAP ((BITMAPBASE POINTER) (BITMAPRASTERWIDTH WORD) (BITMAPHEIGHT WORD) (BITMAPWIDTH WORD) (BITMAPBITSPERPIXEL WORD)) BITMAPBITSPERPIXEL _ 1 (BLOCKRECORD BITMAP ((BitMapHiLoc WORD) ( BitMapLoLoc WORD)) (* ; "overlay initial pointer")) (SYSTEM)) (BLOCKRECORD BITMAPWORD ((BITS WORD)) (SYSTEM)) (RECORD POSITION (XCOORD . YCOORD) (TYPE? (AND (LISTP DATUM) (NUMBERP (CAR DATUM)) (NUMBERP (CDR DATUM )))) (SYSTEM)) (DATATYPE CURSOR (CUIMAGE CUMASK CUHOTSPOTX CUHOTSPOTY CUDATA) (ACCESSFNS ((CUBITSPERPIXEL (fetch ( BITMAP BITMAPBITSPERPIXEL) of (fetch (CURSOR CUIMAGE) of DATUM))))) (SYSTEM)) (RECORD MOUSEEVENT (MOUSEX MOUSEY MOUSEBUTTONS KEYBOARD MOUSETIME) (SYSTEM)) (RECORD SCREENREGION (SCREEN . REGION) (SUBRECORD REGION) (TYPE? (AND (LISTP DATUM) (type? SCREEN (CAR DATUM)) (type? REGION (CDR DATUM)))) (SYSTEM)) (RECORD SCREENPOSITION (SCREEN . POSITION) (SUBRECORD POSITION) (TYPE? (AND (LISTP DATUM) (type? SCREEN (CAR DATUM)) (type? POSITION (CDR DATUM)))) (SYSTEM)) (PUTPROPS CURSORBITMAP MACRO (NIL CursorBitMap)) (RPAQQ HARDCURSORHEIGHT 16) (RPAQQ HARDCURSORWIDTH 16) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (ADDTOVAR GLOBALVARS CursorBitMap) (ARRAYRECORD POLYNOMIAL (A B C D) (CREATE (ARRAY 4 (QUOTE FLOATP))) (SYSTEM)) (RECORD SPLINE (%#KNOTS SPLINEX SPLINEY SPLINEDX SPLINEDY SPLINEDDX SPLINEDDY SPLINEDDDX SPLINEDDDY)) (PUTPROPS HALF MACRO ((X) (LRSH X 1))) (PUTPROPS \FILLCIRCLEBLT MACRO (OPENLAMBDA (CX CY X Y) (* ; "calls bitblt twice to fill in one line of the circle.") (\LINEBLT FCBBT (IDIFFERENCE CX X) (IPLUS CY Y) (IPLUS CX X) DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS) (\LINEBLT FCBBT (IDIFFERENCE CX X) (IDIFFERENCE CY Y) (IPLUS CX X) DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS))) (PUTDEF (QUOTE BITMAPS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (VARS . X)))))) (PUTDEF (QUOTE CURSORS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (E (MAPC (QUOTE X) (QUOTE PRINTCURSOR)))))))) (ADDTOVAR GLOBALVARS SCREENHEIGHT SCREENWIDTH ScreenBitMap) (RPAQQ BLACKSHADE 65535) (RPAQQ WHITESHADE 0) (CONSTANTS (BLACKSHADE 65535) (WHITESHADE 0)) (RPAQQ GRAYSHADE 43605) (ADDTOVAR GLOBALVARS GRAYSHADE) (RECORD HLS (HUE LIGHTNESS SATURATION)) (RECORD RGB (RED GREEN BLUE)) (PUTPROP (QUOTE ADISPLAY) (QUOTE IMPORTDATE) (IDATE "15-Sep-94 17:07:04")) (ADDTOVAR SYSSPECVARS \INTERRUPTABLE) (PUTPROPS UNINTERRUPTABLY INFO EVAL) (PUTPROPS UNINTERRUPTABLY DMACRO ((X . Y) ((LAMBDA (\INTERRUPTABLE) (PROGN X . Y)) NIL))) (ADDTOVAR PRETTYPRINTMACROS (UNINTERRUPTABLY LAMBDA (FORM) (PROG ((POS (IPLUS 4 (POSITION)))) (PRIN1 "(") (PRIN2 (CAR FORM)) (OR (EQ COMMENTFLG (CAAR (SETQ FORM (CDR FORM)))) (TAB POS 0)) (PRINTDEF FORM POS T T FNSLST) (PRIN1 ")")))) (BLOCKRECORD INTERRUPTSTATE ((* ;; "This is the structure used to communicate between the emulator and Lisp re interrupts. There is a bit per interrupt type, plus space for the character code that caused a keyboard interrupt." ) (* ;; "This must match the INTSTAT definition in lispemul.h") (* ;; "PENDING-INTERRUPT FLAGS:") ( LOGMSGSPENDING FLAG) (* ; " Log/Console msgs need printing.") (ETHERINTERRUPT FLAG) (* ; "Ether packet read finished.") (IOINTERRUPT FLAG) (GCDISABLED FLAG) (* ; "No mroe room in GC tables.") (VMEMFULL FLAG) (* ; "VMEM is full!!") (STACKOVERFLOW FLAG) (* ; "Stack overflowed.") (STORAGEFULL FLAG) (* ; "Ran out of storage, atoms, etc.") (WAITINGINTERRUPT FLAG) (* ;; "INTERRUPTS-IN-PROCESS MASK:") (P-LOGMSGSPENDING FLAG) (* ; " Log/Console msgs need printing.") ( P-ETHERINTERRUPT FLAG) (* ; "Ether packet read finished.") (P-IOINTERRUPT FLAG) (P-GCDISABLED FLAG) (* ; "No mroe room in GC tables.") (P-VMEMFULL FLAG) (* ; "VMEM is full!!") (P-STACKOVERFLOW FLAG) (* ; "Stack overflowed.") (P-STORAGEFULL FLAG) (* ; "Ran out of storage, atoms, etc.") (P-WAITINGINTERRUPT FLAG) (INTCHARCODE WORD)) (BLOCKRECORD INTERRUPTSTATE ((* ;; "Alternative view of the structure:") ( PENDING BITS 8) (* ; "Pending-interrupt flags") (IN-PROGRESS BITS 8) (* ; "Mask to prevent re-interrupt for an interrupt in progress") (NIL WORD)))) (PUTPROPS \TAKEINTERRUPT DMACRO ((PREFORM POSTFORM) (DECLARE (GLOBALVARS \PENDINGINTERRUPT)) (COND (( AND \PENDINGINTERRUPT (INTERRUPTABLE~=NILUPTHESTACK)) PREFORM ((LAMBDA (\INTERRUPTABLE) ( \CALLINTERRUPTED)) T) POSTFORM)))) (PUTPROP (QUOTE AINTERRUPT) (QUOTE IMPORTDATE) (IDATE "17-Sep-92 10:42:38")) (ACCESSFNS PUP ((PUPBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM)))) (BLOCKRECORD PUPBASE (( PUPLENGTH WORD) (PUPTCONTROL BYTE) (PUPTYPE BYTE) (PUPID FIXP) (PUPDEST WORD) (PUPDESTSOCKET FIXP) ( PUPSOURCE WORD) (PUPSOURCESOCKET FIXP) (PUPDATASTART 266 WORD)) (BLOCKRECORD PUPBASE ((NIL WORD) ( TYPEWORD WORD) (PUPIDHI WORD) (PUPIDLO WORD) (PUPDESTNET BYTE) (PUPDESTHOST BYTE) (PUPDESTSOCKETHI WORD) (PUPDESTSOCKETLO WORD) (PUPSOURCENET BYTE) (PUPSOURCEHOST BYTE) (PUPSOURCESOCKETHI WORD) ( PUPSOURCESOCKETLO WORD)) (* ; "Temporary extra synonyms") (SYNONYM PUPDESTNET (DESTNET)) (SYNONYM PUPDESTHOST (DESTHOST)) (SYNONYM PUPDESTSOCKETHI (DESTSKTHI)) (SYNONYM PUPDESTSOCKETLO (DESTSKTLO)) ( SYNONYM PUPSOURCENET (SOURCENET)) (SYNONYM PUPSOURCEHOST (SOURCEHOST)) (SYNONYM PUPSOURCESOCKETHI ( SOURCESKTHI)) (SYNONYM PUPSOURCESOCKETLO (SOURCESKTLO))) (SYNONYM PUPDEST (DEST)) (SYNONYM PUPDESTSOCKET (DESTSKT)) (SYNONYM PUPSOURCE (SOURCE)) (SYNONYM PUPSOURCESOCKET (SOURCESKT)) (ACCESSFNS PUPDATASTART ((PUPCONTENTS (LOCF DATUM))))) (ACCESSFNS PUP ((PUPCHECKSUMBASE (fetch PUPBASE of DATUM) ) (PUPCHECKSUMLOC (\ADDBASE (fetch PUPBASE of DATUM) (FOLDLO (SUB1 (fetch PUPLENGTH of DATUM)) BYTESPERWORD)))) (BLOCKRECORD PUPCHECKSUMLOC ((PUPCHECKSUM WORD)))) (TYPE? (type? ETHERPACKET DATUM))) (ACCESSFNS PUPADDRESS ((PUPNET# (LRSH DATUM 8)) (PUPHOST# (LOGAND DATUM 255))) (CREATE (IPLUS (LLSH PUPNET# 8) PUPHOST#))) (PUTPROPS \LOCALPUPADDRESS MACRO (NIL \LOCALPUPNETHOST)) (PUTPROPS \LOCALPUPHOSTNUMBER MACRO (NIL (fetch PUPHOST# of \LOCALPUPNETHOST))) (PUTPROPS \LOCALPUPNETNUMBER MACRO (NIL (fetch PUPNET# of \LOCALPUPNETHOST))) (ACCESSFNS ERRORPUP ((ERRORPUPBASE (fetch PUPCONTENTS of DATUM))) (BLOCKRECORD ERRORPUPBASE (( ERRORPUPCOPY 10 WORD) (* ; "Copy of pup header") (ERRORPUPCODE WORD) (ERRORPUPARG WORD) (* ; "Usually zero") (ERRORPUPSTRINGBASE WORD) (* ; "Human readable message")))) (RPAQQ PUPERRORCODES ((\PUPE.CHECKSUM 1) (\PUPE.NOSOCKET 2) (\PUPE.SOCKETFULL 3) (\PUPE.GATEWAY.BADPUP 513) (\PUPE.NOROUTE 514) (\PUPE.NOHOST 515) (\PUPE.LOOPED 516) (\PUPE.TOOLARGE 517) ( \PUPE.WRONG.GATEWAY 518) (\PUPE.GATEWAYFULL 519))) (RPAQQ \PUPE.CHECKSUM 1) (RPAQQ \PUPE.NOSOCKET 2) (RPAQQ \PUPE.SOCKETFULL 3) (RPAQQ \PUPE.GATEWAY.BADPUP 513) (RPAQQ \PUPE.NOROUTE 514) (RPAQQ \PUPE.NOHOST 515) (RPAQQ \PUPE.LOOPED 516) (RPAQQ \PUPE.TOOLARGE 517) (RPAQQ \PUPE.WRONG.GATEWAY 518) (RPAQQ \PUPE.GATEWAYFULL 519) (CONSTANTS (\PUPE.CHECKSUM 1) (\PUPE.NOSOCKET 2) (\PUPE.SOCKETFULL 3) (\PUPE.GATEWAY.BADPUP 513) ( \PUPE.NOROUTE 514) (\PUPE.NOHOST 515) (\PUPE.LOOPED 516) (\PUPE.TOOLARGE 517) (\PUPE.WRONG.GATEWAY 518 ) (\PUPE.GATEWAYFULL 519)) (PUTPROPS BINDPUPS MACRO (X (CONS (LIST (QUOTE LAMBDA) (CAR X) (CONS (QUOTE PROGN) (CDR X))) (in (CAR X) collect (LIST (QUOTE ALLOCATE.PUP)))))) (PUTPROPS BINDPUPS INFO BINDS) (ADDTOVAR PRETTYPRINTMACROS (BINDPUPS LAMBDA (FORM) (PROG ((POS (IPLUS 2 (POSITION)))) (PRIN1 "(") ( PRIN2 (CAR FORM)) (SPACES 1) (PRINTDEF (CADR FORM) (POSITION)) (OR (EQ COMMENTFLG (CAAR (SETQ FORM ( CDDR FORM)))) (TAB POS 0)) (PRINTDEF FORM POS T T FNSLST) (PRIN1 ")")))) (BLOCKRECORD PORT ((NETHOST WORD) (SOCKET FIXP)) (BLOCKRECORD PORT ((NET BYTE) (HOST BYTE) (SOCKETHI WORD) (SOCKETLO WORD)))) (ACCESSFNS ERRORPUP ((ERRORPUPBASE (fetch PUPCONTENTS of DATUM))) (BLOCKRECORD ERRORPUPBASE (( ERRORPUPCOPY 10 WORD) (* ; "Copy of pup header") (ERRORPUPCODE WORD) (ERRORPUPARG WORD) (* ; "Usually zero") (ERRORPUPSTRINGBASE WORD) (* ; "Human readable message")))) (GLOBALVARS \ETHERWAIT1 \ETHERTIMEOUT \MAXETHERTRIES PUPTRACEFLG LOGINPASSWORDS) (GLOBALVARS PUPTRACEFILE PUPONLYTYPES PUPIGNORETYPES PUPPRINTMACROS) (RPAQQ \PUPOVLEN 22) (RPAQQ \MAX.PUPLENGTH 532) (RPAQQ \TIME.GETPUP 5) (CONSTANTS (\PUPOVLEN 22) (\MAX.PUPLENGTH 532) (\TIME.GETPUP 5)) (PUTPROPS PUPPRINTMACROS VARTYPE ALIST) (PUTPROPS \GETPUPWORD DMACRO ((PUP WORD#) (\GETBASE (fetch PUPCONTENTS of PUP) WORD#))) (PUTPROPS \PUTPUPWORD DMACRO ((PUP WORD# VALUE) (\PUTBASE (fetch PUPCONTENTS of PUP) WORD# VALUE))) (PUTPROPS \GETPUPBYTE DMACRO ((PUP BYTE#) (\GETBASEBYTE (fetch PUPCONTENTS of PUP) BYTE#))) (PUTPROPS \PUTPUPBYTE DMACRO ((PUP BYTE# VALUE) (\PUTBASEBYTE (fetch PUPCONTENTS of PUP) BYTE# VALUE)) ) (RPAQQ RAWPUPTYPES ((\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))) (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) (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)) (RPAQ? PUPTYPES RAWPUPTYPES) (RPAQQ WELLKNOWNPUPSOCKETS ((\PUPSOCKET.TELNET 1) (\PUPSOCKET.ROUTING 2) (\PUPSOCKET.FTP 3) ( \PUPSOCKET.MISCSERVICES 4) (\PUPSOCKET.ECHO 5) (\PUPSOCKET.EFTP 16) (\PUPSOCKET.PRINTERSTATUS 17) ( \PUPSOCKET.LEAF 35))) (RPAQQ \PUPSOCKET.TELNET 1) (RPAQQ \PUPSOCKET.ROUTING 2) (RPAQQ \PUPSOCKET.FTP 3) (RPAQQ \PUPSOCKET.MISCSERVICES 4) (RPAQQ \PUPSOCKET.ECHO 5) (RPAQQ \PUPSOCKET.EFTP 16) (RPAQQ \PUPSOCKET.PRINTERSTATUS 17) (RPAQQ \PUPSOCKET.LEAF 35) (CONSTANTS (\PUPSOCKET.TELNET 1) (\PUPSOCKET.ROUTING 2) (\PUPSOCKET.FTP 3) (\PUPSOCKET.MISCSERVICES 4) (\PUPSOCKET.ECHO 5) (\PUPSOCKET.EFTP 16) (\PUPSOCKET.PRINTERSTATUS 17) (\PUPSOCKET.LEAF 35)) (PUTPROP (QUOTE PUP) (QUOTE IMPORTDATE) (IDATE "19-Jan-93 11:14:09")) (PUTPROPS UNLESSRDSYS MACRO ((NORMAL RDSYS) NORMAL)) (PUTPROPS UNLESSINEW MACRO ((NORMAL I-NEW) NORMAL)) (PUTPROPS 1ST MACRO ((A . B) A)) (PUTPROPS 2ND MACRO ((A B . C) B)) (PUTPROPS LOCAL MACRO ((X) X)) (PUTPROPS ALLOCAL MACRO ((X) X)) (PUTPROPS ADDBASE DMACRO (= . \ADDBASE)) (PUTPROPS GETBASE DMACRO (= . \GETBASE)) (PUTPROPS GETBASEBYTE DMACRO (= . \GETBASEBYTE)) (PUTPROPS GETBASEPTR DMACRO (= . \GETBASEPTR)) (PUTPROPS HILOC DMACRO (= . \HILOC)) (PUTPROPS LOLOC DMACRO (= . \LOLOC)) (PUTPROPS PUTBASE DMACRO (= . \PUTBASE)) (PUTPROPS PUTBASEBYTE DMACRO (= . \PUTBASEBYTE)) (PUTPROPS PUTBASEPTR DMACRO (= . \PUTBASEPTR)) (PUTPROPS REPLACEPTRFIELD DMACRO (= . \RPLPTR)) (PUTPROPS VAG2 DMACRO (= . \VAG2)) (PUTPROPS PAGEBASE MACRO ((PTR) (fetch (POINTER PAGEBASE) of PTR))) (PUTPROPS PAGELOC MACRO (OPENLAMBDA (PTR) (IPLUS (LLSH (\HILOC PTR) 8) (LRSH (\LOLOC PTR) 8)))) (PUTPROP (QUOTE RENAMEMACROS) (QUOTE IMPORTDATE) (IDATE "27-Apr-94 15:43:27")) (PUTPROPS MOUSESTATE MACRO (ARGS (LIST (QUOTE PROGN) (QUOTE (GETMOUSESTATE)) (MOUSESTATE-EXPR (CAR ARGS) T)))) (PUTPROPS LASTMOUSESTATE MACRO (ARGS (MOUSESTATE-EXPR (CAR ARGS) T))) (PUTPROPS UNTILMOUSESTATE MACRO (ARGS (COND ((AND (CDR ARGS) (CADR ARGS) (NEQ (CADR ARGS) T)) (* time argument is given and is not T or NIL; compile in time keeping loop.) (LIST (QUOTE PROG) (LIST (LIST ( QUOTE TIMEOUT) (LIST (QUOTE IPLUS) (QUOTE (CLOCK 0)) (LIST (QUOTE OR) (LIST (QUOTE NUMBERP) (CADR ARGS )) 100))) (QUOTE (NOWTIME (CLOCK 0)))) (QUOTE LP) (LIST (QUOTE COND) (LIST (CONS (QUOTE MOUSESTATE) ( LIST (CAR ARGS) T)) (QUOTE (RETURN T)))) (QUOTE (COND ((IGREATERP (CLOCK0 NOWTIME) TIMEOUT) (RETURN NIL)) (T (\BACKGROUND)))) (QUOTE (GO LP)))) (T (LIST (QUOTE PROG) NIL (QUOTE LP) (LIST (QUOTE COND) ( LIST (CONS (QUOTE MOUSESTATE) (LIST (CAR ARGS) T)) (QUOTE (RETURN T)))) (QUOTE (\BACKGROUND)) (QUOTE ( GO LP))))))) (PUTPROPS KEYSETSTATE MACRO (ARGS (LIST (QUOTE PROGN) (QUOTE (GETMOUSESTATE)) (MOUSESTATE-EXPR (CAR ARGS))))) (PUTPROPS LASTKEYSETSTATE MACRO (ARGS (MOUSESTATE-EXPR (CAR ARGS)))) (PUTPROPS WITHIN MACRO ((A B C) (AND (IGEQ A B) (ILESSP A (IPLUS B C))))) (ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTMOUSEBUTTONS) (PUTPROPS IABS MACRO (OPENLAMBDA (A) (COND ((IGEQ A 0) A) (T (IMINUS A))))) (PUTPROP (QUOTE HLDISPLAY) (QUOTE IMPORTDATE) (IDATE "15-Mar-94 10:48:02")) (PUTPROPS .COPYKEYDOWNP. MACRO (NIL (OR (KEYDOWNP (QUOTE LSHIFT)) (KEYDOWNP (QUOTE RSHIFT)) (KEYDOWNP (QUOTE COPY))))) (PUTPROPS WSOP MACRO (ARGS (LET ((METHOD (CADR (CAR ARGS))) (DISPLAY (CADR ARGS)) (OTHERARGS (CDDR ARGS))) (BQUOTE (SPREADAPPLY* (fetch (WSOPS (\, METHOD)) of (fetch (FDEV WINDOWOPS) of (\, DISPLAY))) (\, DISPLAY) (\,@ OTHERARGS)))))) (PUTPROPS \COERCETODS MACRO (OPENLAMBDA (X) (COND ((type? WINDOW X) (fetch (WINDOW DSP) of X)) (T ( \ILLEGAL.ARG X))))) (PUTPROPS .WHILE.ON.TOP. MACRO ((FIRST . REST) (UNINTERRUPTABLY (\INTERNALTOTOPW FIRST) . REST))) (PUTPROPS WINDOWOP DMACRO (ARGS (LET ((OPNAME (CAR ARGS)) (METHOD-DEVICE (CADR ARGS)) (TAIL (CDDR ARGS ))) (COND ((AND (LISTP OPNAME) (EQ (CAR OPNAME) (QUOTE QUOTE))) (BQUOTE (SPREADAPPLY* (fetch (SCREEN ( \, (CADR OPNAME))) of (\, METHOD-DEVICE)) (\, METHOD-DEVICE) (\,@ TAIL)))) (T (ERROR "OPNAME not quoted: " OPNAME)))))) (RPAQQ MinWindowWidth 26) (RPAQQ MinWindowHeight 16) (CONSTANTS (MinWindowWidth 26) (MinWindowHeight 16)) (DATATYPE WINDOW (DSP (* ; "The display stream you use to actually printto the window.") NEXTW (* ; "Next window in the open-window list") SAVE (* ; "Saved image from anything this window's on top of") REG (* ; "Screen region this window occupies") BUTTONEVENTFN (* ; "FN called when left/middle mouse button goes up/down") RIGHTBUTTONFN (* ; "FN called when right mouse button goes up/down") CURSORINFN (* ; "Fn called when mouse enters window" ) CURSOROUTFN (* ; "Called when mouse leaves window") CURSORMOVEDFN (* ; "Called when mouse moves in window") REPAINTFN (* ; "Redisplay part of thie window") RESHAPEFN (* ; "Called when window is reshaped") EXTENT (* ; "Scrolling limits") USERDATA (* ; "Proplist to hold other window properites") VERTSCROLLREG (* ; "Region of vert scroll bar") HORIZSCROLLREG (* ; "Tegion of horiz scroll bar") SCROLLFN (* ; "Fn to scroll this window") VERTSCROLLWINDOW (* ; "Vert scroll bar") HORIZSCROLLWINDOW (* ; "Horiz scroll bar") CLOSEFN (* ; "Called at close time") MOVEFN (* ; "Called when window is moved") WTITLE (* ; "Window's title string, if any") NEWREGIONFN (* ; "Called to get new window shape") WBORDER (* ; "Window border-width, in pixels") PROCESS (* ; "Medley process associated with this window") WINDOWENTRYFN (* ; "Fn to call when kbd focus is switched here") SCREEN (* ; "Screen this window appears on") (NATIVE-HANDLE FIXP) (* ; "Uniterpreted place for native window to store a C pointer to its private info") (NATIVE-INFO1 FIXP) ( * ; "Reserved in case the pointer must be 64 bits") (NATIVE-W1 WORD) (* ; "Word for use by native handler") (NATIVE-W2 WORD) (* ; "Word for use by native handler") (NATIVE-P1 POINTER) (* ; "Lisp pointer for use by native handler")) BUTTONEVENTFN _ (FUNCTION TOTOPW) WBORDER _ WBorder WINDOWENTRYFN _ (FUNCTION GIVE.TTY.PROCESS) (SYSTEM)) (DATATYPE SCREEN (SCONOFF SCDESTINATION SCWIDTH SCHEIGHT SCTOPW SCTOPWDS SCTITLEDS SCFDEV SCDS SCDATA (* ;; "Space for native window manager interface to use.") (HANDLE FIXP) (* ; "Handle for emulator to store info about display for C code use.") (HANDLE2 FIXP) (* ; "Reserved in case HANDLE needs to be 64 bits on the C side.") (NATIVE-INFO POINTER) (* ; "POINTER for the private use of the emulator window code") NATIVETYPE (* ; "Symbol to tell what kind of native window system we're using.") (* ;; "- - - Functional interface to screen management - - -") WINIMAGEOPS (* ; "IMAGEOPS to be used in display streas on this kind of screen") WINFDEV (* ; "FDEV for display streams on this screen") CREATEWFN (* ; "Create a window") OPENWFN (* ; "Open a window") CLOSEWFN (* ; "Close a window") MOVEWFN (* ; "Move a window") RELMOVEWFN (* ; "Move window, relative") SHRINKWFN (* ; "Shrink window to icon") EXPANDWFN (* ; "Expand icon to window") SHAPEWFN (* ; "Reshape a window") REDISPLAYFN (* ; "Redisplay (part of) a window") GETWINDOWPROPFN (* ; "Get window property value") PUTWINDOWPROPFN (* ; "Set window property value") BURYWFN (* ; "Move window behind all others") TOTOPWFN (* ; "Move iwindow in front of all others") IMPORTWFN (* ; "Take a native window and save its state internally") EXPORTWFN (* ; "Take a saved window state and open it on this screen, filling in screen and methods as needed.") DESTROYFN (* ; "Destroy this window, for GC finaliszation") SETCURSORFN (* ; "Set the cursor for this window.") PROMPTW (* ; "The prompt window for this screen") SHOWGCFN (* ; "Show GC indication; called with ON/OFF arg, t=>show gcing status, NIL=>turn off GC indicator.") DSPCREATEFN (* ; "Create a displaystream on this screen.") BBTTOWIN (* ; "BITBLT from a lisp bitmap to a window") BBTFROMWIN (* ; "BITBLT from a window to a lisp bitmap") BBTWINWIN (* ; "BITBLT from a window to another window.") SCCURSOR (* ; "CURSOR that's in effect for this screen by default.") SCKEYBOARD (* ; "Something about which keyboard we're receiving from.") SCDEPTH (* ; "# of bits per pixel on the screen. THIS WILL REPLACE SCBITSPERPIXEL ASAP.") SCCLOSEDOWN (* ; "Close down this screen cleanly, saving window state.") SCCLOSESCREEN (* ; "Close down thie screen cleanly, no state saving.") SCREOPEN (* ; "Reopen this screen?") SCCARETFLASH (* ; "Function to flash thecaret.") SCGETSCREENPOSITION (* ; "GETSCREENPOSITION") SCGETBOXSCREENPOSITION (* ; "GETBOXPOSITION") SCGETSCREENREGION (* ; "GETREGION") SCMOVEPOINTER (* ; "\CURSORPOSITION")) SCONOFF _ (QUOTE OFF) (ACCESSFNS ((SCBITSPERPIXEL (COND ((fetch (SCREEN SCDESTINATION) of DATUM) (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (SCREEN SCDESTINATION) of DATUM) )) (T 1))) (SCREGION (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (fetch (SCREEN SCWIDTH) of DATUM) HEIGHT _ (fetch (SCREEN SCHEIGHT) of DATUM))))) (SYSTEM)) (GLOBALVARS WINDOWUSERFORMS ENDOFWINDOWUSERFORMS PROMPTWINDOW) (PUTPROP (QUOTE WINDOW) (QUOTE IMPORTDATE) (IDATE " 9-Apr-2000 17:36:29")) (PUTPROPS NNLITATOM MACRO (OPENLAMBDA (X) (AND X (LITATOM X)))) (PUTPROPS \NULL.OR.FIXP MACRO (OPENLAMBDA (X) (OR (NULL X) (FIXP X)))) (PUTPROPS \CHECKTYPE MACRO (X (PROG ((VAR (CAR X)) (PRED (CADR X))) (if (AND (LISTP PRED) (MEMB (CAR PRED) (QUOTE (QUOTE FUNCTION)))) then (SETQ PRED (LIST (CADR PRED) VAR))) (RETURN (SUBPAIR (QUOTE (MSG VAR PRED)) (LIST (CONCAT " is not a suitable value for the variable: " VAR) VAR PRED) (QUOTE (until PRED do (SETQ VAR (ERROR VAR MSG))))))))) (PUTPROPS CANONICAL.TIMERUNITS MACRO (OPENLAMBDA (X) (* Checks for common abbreviations before calling \CanonicalizeTimerUnits) (SELECTQ X ((TICKS MILLISECONDS SECONDS) (* These are the canonical forms) X ) (NIL (QUOTE MILLISECONDS)) (\CanonicalizeTimerUnits X)))) (PUTPROPS \MACRO.EVAL DMACRO (Z (PROG ((X (EXPANDMACRO (CAR Z) T))) (if (EQ X (CAR Z)) then (ERROR "No macro property -- \MACRO.EVAL" X) else (RETURN (EVAL X)))))) (DEFOPTIMIZER \MACRO.MX (FORM) FORM) (PUTPROP (QUOTE MACROAUX) (QUOTE IMPORTDATE) (IDATE "16-May-90 20:26:31")) (RPAQQ MASK0WORD1'S 32767) (RPAQQ MASK1WORD0'S 32768) (RPAQQ MASKWORD1'S 65535) (RPAQQ MASKHALFWORD1'S 255) (RPAQQ BITSPERHALFWORD 8) (CONSTANTS MASK0WORD1'S MASK1WORD0'S MASKWORD1'S MASKHALFWORD1'S BITSPERHALFWORD) (PUTPROPS EQZEROP MACRO ((X) (EQ 0 X))) (PUTPROPS \MOVETOBOX DMACRO (OPENLAMBDA (N D) (SELECTC (NTYPX N) (\SMALLP (replace (FIXP HINUM) of D with 0) (replace (FIXP LONUM) of D with N)) (\FIXP (replace (FIXP HINUM) of D with (fetch (FIXP HINUM) of N)) (replace (FIXP LONUM) of D with (fetch (FIXP LONUM) of N))) (\ILLEGAL.ARG N)))) (PUTPROPS .XUNBOX. MACRO ((X HX LX) (until (SETQ LX (SELECTC (NTYPX X) (\SMALLP (COND ((IGEQ X 0) ( SETQ HX 0) X) (T (SETQ HX MASKWORD1'S) (\LOLOC X)))) (\FIXP (SETQ HX (fetch (FIXP HINUM) of X)) (fetch (FIXP LONUM) of X)) NIL)) do (SETQ X (LISPERROR "ILLEGAL ARG" X T))))) (PUTPROPS .XLLSH. MACRO ((HI LO N) (if (IGEQ N BITSPERWORD) then (* ; "Jump 16 bits in a single bound!") (SETQ HI LO) (SETQ LO 0) (SETQ N (IDIFFERENCE N BITSPERWORD))) (if (IGEQ N BITSPERHALFWORD) then (* ; "Jump 8 bits in a single bound!") (SETQ HI (LOGOR (.LOHALFWORDHI. HI) (.HIHALFWORDLO. LO))) (SETQ LO (.LOHALFWORDHI. LO)) (SETQ N (IDIFFERENCE N BITSPERHALFWORD))) (if (IGEQ N 4) then (* ; "Jump 4 bits in a single bound!") (SETQ HI (LOGOR (LRSH LO (CONSTANT (IDIFFERENCE BITSPERWORD 4))) (LLSH (LOGAND HI (CONSTANT (MASK.1'S 0 (IDIFFERENCE BITSPERWORD 4)))) 4))) (SETQ LO (LLSH (LOGAND LO (CONSTANT (MASK.1'S 0 (IDIFFERENCE BITSPERWORD 4)))) 4)) (SETQ N (IDIFFERENCE N 4))) (* ; "MASK0WORD1'S should be same as (SUB1 (LSH 1 (SUB1 BITSPERWORD)))") (FRPTQ N (SETQ HI (LLSH ( LOGAND HI MASK0WORD1'S) 1)) (SETQ LO (LLSH (if (IGEQ LO MASK1WORD0'S) then (add HI 1) (LOGAND LO MASK0WORD1'S) else LO) 1))))) (PUTPROPS .XLLSH1. MACRO ((HI LO) (SETQ HI (LLSH (LOGAND HI MASK0WORD1'S) 1)) (SETQ LO (LSH (COND (( IGEQ LO MASK1WORD0'S) (SETQ HI (LOGOR HI 1)) (LOGAND LO MASK0WORD1'S)) (T LO)) 1)))) (PUTPROPS .XLRSH. MACRO ((HI LO N) (if (IGEQ N BITSPERWORD) then (* ; "Jump 10 bits in a single bound!") (SETQ LO HI) (SETQ HI 0) (SETQ N (IDIFFERENCE N BITSPERWORD))) (if (IGEQ N BITSPERHALFWORD) then (* ; "Jump 8 bits in a single bound!") (SETQ LO (LOGOR (.HIHALFWORDLO. LO) (.LOHALFWORDHI. HI))) (SETQ HI (.HIHALFWORDLO. HI)) (SETQ N (IDIFFERENCE N BITSPERHALFWORD))) (if (IGEQ N 4) then (* ; "Jump 4 bits in a single bound!") (SETQ LO (LOGOR (LLSH (LOGAND HI (CONSTANT ( MASK.1'S 0 4))) (CONSTANT (IDIFFERENCE BITSPERWORD 4))) (LRSH LO 4))) (SETQ HI (LRSH HI 4)) (SETQ N ( IDIFFERENCE N 4))) (* ; "MASK1WORD0'S should be same as \SIGNBIT") (FRPTQ N (SETQ LO (if (ODDP HI) then (LOGOR (LRSH LO 1) MASK1WORD0'S) else (LRSH LO 1))) (SETQ HI (LRSH HI 1))))) (PUTPROPS .ADD.2WORD.INTEGERS. MACRO ((HX LX HY LY) (* ; "Ignores carry out of high-order word") (SETQ HX (.SUMSMALLMOD. HX HY)) (SETQ LX (.SUMSMALLMOD. LX LY (SETQ HX (if (EQ HX MAX.SMALL.INTEGER) then 0 else (ADD1 HX))))))) (PUTPROPS .SUB.2WORD.INTEGERS. MACRO ((HX LX HY LY) (* ; "Ignores carry out of high-order word") (SETQ HX (.DIFFERENCESMALLMOD. HX HY)) (SETQ LX (.DIFFERENCESMALLMOD. LX LY (SETQ HX (if (EQ HX 0) then MAX.SMALL.INTEGER else (SUB1 HX))))))) (PUTPROPS .32BITMUL. MACRO ((HR LR X Y) (PROG (HX LX HY LY) (if (ILESSP X Y) then (swap X Y)) (* ; "Y is the lesser of the two now") (.XUNBOX. X HX LX) (.XUNBOX. Y HY LY) LP (if (ODDP LY) then ( .ADD.2WORD.INTEGERS. HR LR HX LX)) (if (EQ HY 0) then (SETQ LY (LRSH LY 1)) (if (EQ LY 0) then (RETURN )) else (.LRSH1. HY LY)) (* ; "Trim off highest bits, so that left-shifting doesn't generate FIXPs") ( SETQ HX (LOGAND HX MASK0WORD1'S)) (.LLSH1. HX LX) (GO LP)))) (PUTPROPS .SUMSMALLMOD. MACRO ((X Y OVERFLOWFORM) ((LAMBDA (\SumSmallModVar) (DECLARE (LOCALVARS \SumSmallModVar)) (IF (ILEQ X \SumSmallModVar) THEN (IPLUS X Y) ELSE OVERFLOWFORM (IDIFFERENCE X (ADD1 \SumSmallModVar)))) (IDIFFERENCE MAX.SMALL.INTEGER Y)))) (PUTPROPS .DIFFERENCESMALLMOD. MACRO ((X Y BORROWFORM) (IF (NOT (IGREATERP Y X)) THEN (IDIFFERENCE X Y ) ELSE BORROWFORM (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER (IDIFFERENCE Y X)))))) (PUTPROPS \GETBASENIBBLE DMACRO (OPENLAMBDA (BASE OFFST) ((LAMBDA (\Byte) (DECLARE (LOCALVARS \Byte)) (if (ODDP OFFST) then (LOGAND \Byte (CONSTANT (MASK.1'S 0 BITSPERNIBBLE))) else (LRSH \Byte BITSPERNIBBLE))) (\GETBASEBYTE BASE (FOLDLO OFFST NIBBLESPERBYTE))))) (PUTPROPS \PUTBASENIBBLE DMACRO (OPENLAMBDA (BASE OFFST VAL) ((LAMBDA (\ByteNo) (DECLARE (LOCALVARS \ByteNo)) ((LAMBDA (\Byte) (DECLARE (LOCALVARS \Byte)) (\PUTBASEBYTE BASE \ByteNo (if (ODDP OFFST) then (LOGOR (LOGAND \Byte (CONSTANT (MASK.1'S BITSPERNIBBLE BITSPERNIBBLE))) VAL) else (LOGOR (LOGAND \Byte (CONSTANT (MASK.1'S 0 BITSPERNIBBLE))) (LLSH VAL BITSPERNIBBLE))))) (\GETBASEBYTE BASE \ByteNo)) ) (FOLDLO OFFST NIBBLESPERBYTE)))) (PUTPROPS \GETBASEBIT DMACRO (OPENLAMBDA (BASE OFFST) ((LAMBDA (\ByteNo \BitMask) (DECLARE (LOCALVARS \ByteNo \BitMask)) (if (EQ 0 (LOGAND \BitMask (\GETBASEBYTE BASE \ByteNo))) then 0 else 1)) (FOLDLO OFFST BITSPERBYTE) (MASK.1'S (IDIFFERENCE (CONSTANT (SUB1 BITSPERBYTE)) (IMOD OFFST BITSPERBYTE)) 1))) ) (PUTPROPS \PUTBASEBIT DMACRO (OPENLAMBDA (BASE OFFST VAL) ((LAMBDA (\ByteNo \BitMask \Byte) (DECLARE ( LOCALVARS \ByteNo \BitMask \Byte)) (SETQ \Byte (\GETBASEBYTE BASE \ByteNo)) (if (if (EQ 0 (LOGAND \BitMask \Byte)) then (NOT (EQ 0 VAL)) else (EQ 0 VAL)) then (\PUTBASEBYTE BASE \ByteNo (LOGXOR \BitMask \Byte))) VAL) (FOLDLO OFFST BITSPERBYTE) (MASK.1'S (IDIFFERENCE (CONSTANT (SUB1 BITSPERBYTE)) (IMOD OFFST BITSPERBYTE)) 1)))) (PUTPROP (QUOTE ADDARITH) (QUOTE IMPORTDATE) (IDATE "16-May-90 11:46:37")) (RPAQQ \MAXFILEPAGE 65534) (CONSTANTS \MAXFILEPAGE) (PUTPROP (QUOTE LLFAULT) (QUOTE IMPORTDATE) (IDATE " 2-Jan-93 12:26:58")) (PUTPROPS \UPDATETIMERS MACRO (NIL (* * Moves excess time from the processor clock to our software clocks. Needs to be run often, uninterruptably, preferably from the vertical retrace interrupt) (* Get processor clock) (PROG ((EXCESS (\BOXIDIFFERENCE (\RCLK (LOCF (fetch RCLKTEMP0 of \MISCSTATS))) (LOCF (fetch BASECLOCK of \MISCSTATS))))) (RETURN (COND ((OR (IGEQ EXCESS \RCLKSECOND) (ILESSP EXCESS 0)) ( * More than one second has elapsed since we updated clocks) (\BOXIPLUS (LOCF (fetch BASECLOCK of \MISCSTATS)) \RCLKSECOND) (* Increment base by one second) (\BOXIPLUS (LOCF (fetch MILLISECONDSCLOCK of \MISCSTATS)) 1000) (* Increment clocks by 1 second) (\BOXIPLUS (LOCF (fetch SECONDSCLOCK of \MISCSTATS)) 1) T)))))) (RPAQQ \RTCSECONDS 378) (RPAQQ \RTCMILLISECONDS 380) (RPAQQ \RTCBASE 382) (RPAQQ \OFFSET.SECONDS 0) (RPAQQ \OFFSET.MILLISECONDS 2) (RPAQQ \OFFSET.BASE 4) (RPAQQ \ALTO.RCLKSECOND 1680000) (RPAQQ \ALTO.RCLKMILLISECOND 1680) (RPAQQ \DLION.RCLKMILLISECOND 35) (RPAQQ \DLION.RCLKSECOND 34746) (RPAQQ \DOVE.RCLKMILLISECOND 63) (RPAQQ \DOVE.RCLKSECOND 62500) (CONSTANTS (\RTCSECONDS 378) (\RTCMILLISECONDS 380) (\RTCBASE 382) (\OFFSET.SECONDS 0) ( \OFFSET.MILLISECONDS 2) (\OFFSET.BASE 4) (\ALTO.RCLKSECOND 1680000) (\ALTO.RCLKMILLISECOND 1680) ( \DLION.RCLKMILLISECOND 35) (\DLION.RCLKSECOND 34746) (\DOVE.RCLKMILLISECOND 63) (\DOVE.RCLKSECOND 62500)) (PUTPROPS ALTO.TO.LISP.DATE MACRO ((DATE) (LOGXOR DATE -2147483648))) (PUTPROPS LISP.TO.ALTO.DATE MACRO ((DATE) (LOGXOR DATE -2147483648))) (PUTPROP (QUOTE LLTIMER) (QUOTE IMPORTDATE) (IDATE "16-May-90 20:13:11")) (DATATYPE SYSQUEUE ((NIL BYTE) (SYSQUEUEHEAD POINTER) (NIL BYTE) (SYSQUEUETAIL POINTER))) (BLOCKRECORD QABLEITEM ((NIL BITS 4) (QLINK POINTER) (* ; "Link to next thing in queue always in first pointer of datum, independent of what the datum is")) ( BLOCKRECORD QABLEITEM ((NIL BITS 4) (LINK POINTER) (* ; "Let's also be able to call it a LINK")))) (PUTPROPS \QUEUEHEAD MACRO ((Q) (fetch (SYSQUEUE SYSQUEUEHEAD) of Q))) (PUTPROPS \DETCONC MACRO (OPENLAMBDA (TQ) (PROG1 (\PEEKTCONC TQ) (if (NULL (CAR (RPLACA TQ (CDAR TQ))) ) then (RPLACD TQ))))) (PUTPROPS \ENTCONC MACRO (= . TCONC)) (PUTPROPS \PEEKTCONC MACRO (= . CAAR)) (DATATYPE ETHERPACKET ((NIL BYTE) (EPLINK POINTER) (* ; "For queue maintenence") (EPFLAGS BYTE) (* ; "optional flags for some applications") (EPUSERFIELD POINTER) (* ; "Arbitrary pointer for applications") (NIL BYTE) (EPPLIST POINTER) (* ; "Extra field for use as an A-list for properties") (EPTRANSMITTING FLAG) (* ; "True while packet is being transmitted and hence cannot be reused") (EPRECEIVING FLAG) (* ; "True when a packet has been seen at the head of the network's input queue at least once") (NIL BITS 6 ) (EPREQUEUE POINTER) (* ; "Where to requeue this packet after transmission") (NIL BYTE) (EPSOCKET POINTER) (NIL BYTE) (EPNETWORK POINTER) (EPTYPE WORD) (* ; "Type of packet to be encapsulated (PUP or XIP or 10TO3)") (NIL WORD) (EPTIMESTAMP FIXP) (* ; "Gets RCLK value when transmitted/received") (EPREQUEUEFN POINTER) (* ; "FN to perform requeueing") ( NIL 4 WORD) (* ; "Space for expansion") (* ; "Note: This next field wants to be quad+2 aligned so that the 10mb packet is quad+3 aligned") ( EPENCAPSULATION 8 WORD) (* ; "10mb encapsulation, or 3mb encapsulation with padding") (EPBODY 289 WORD ) (* ; "Body of packet, header up to 16 words plus data up to 546 bytes"))) (ACCESSFNS ETHERAUX ((AUXPTR (CDR (ASSOC (QUOTE AUXPTR) (fetch EPPLIST of DATUM))) (\EP.PUT.AUX DATUM (QUOTE AUXPTR) NEWVALUE)) (AUXWORD (OR (CDR (ASSOC (QUOTE AUXWORD) (fetch EPPLIST of DATUM))) 0) ( \EP.PUT.AUX DATUM (QUOTE AUXWORD) NEWVALUE)) (AUXBYTE (OR (CDR (ASSOC (QUOTE AUXBYTE) (fetch EPPLIST of DATUM))) 0) (\EP.PUT.AUX DATUM (QUOTE AUXBYTE) NEWVALUE)))) (RPAQQ \EPT.PUP 512) (RPAQQ \EPT.XIP 1536) (RPAQQ \3MBTYPE.XIP 1536) (RPAQQ \10MBTYPE.XIP 1536) (RPAQQ \EPT.10TO3 1537) (RPAQQ \3MBTYPE.10TO3 1537) (RPAQQ \EPT.UNKNOWN 255) (CONSTANTS \EPT.PUP \EPT.XIP \3MBTYPE.XIP \10MBTYPE.XIP \EPT.10TO3 \3MBTYPE.10TO3 \EPT.UNKNOWN) (RPAQQ \NULLCHECKSUM 65535) (CONSTANTS (\NULLCHECKSUM 65535)) (DATATYPE NDB ((NETTYPE BYTE) (* ; "10 or 3 for now") (NDBNEXT POINTER) (* ; "Link to next NDB") ( NDBPUPNET# BYTE) (* ; "Pup number of this net. May be different from NS net number, though not in Xerox world") (NDBNSNET# POINTER) (* ; "Can be 32-bits, so might as well leave its box around") (NDBTASK# BYTE) (* ; "Task # of this network") (NDBBROADCASTP POINTER) (* ; "Function that returns true if packet is of broadcast type") (NDBPUPHOST# BYTE) (* ; "My pup address on this net. NS address is global to all nets, so not needed here") (NDBTRANSMITTER POINTER) (* ; "(NDB PACKET) -- fn to send a raw packet on this net. returns NIL on failure") (NIL BYTE) (NDBENCAPSULATOR POINTER) (* ; "(NDB PACKET HOST LENGTH TYPE) -- fn to encapsulate and send a higher-level packet on this net ") ( NDBCSB POINTER) (* ; "Pointer to CSB for this network") (NDBIQLENGTH BYTE) (NDBIQ POINTER) (* ; "Queue of empty packets for receiver") (NDBTQ POINTER) (* ; "Queue of packets to transmit") ( NDBTRANSLATIONS POINTER) (* ; "Cache of translations, 3:10 or 10:3 according to network") ( NDBETHERFLUSHER POINTER) (* ; "Turns off this ether. Args NDB") (NDBWATCHER POINTER) (NDBCANHEARSELF POINTER) (* ; "True if receiver can hear packets sent by transmitter") (NDBIPNET# POINTER) (NDBIPHOST# POINTER) (NDBPUPTYPE WORD) (* ; "The packet encapsulation of PUP on this net") (NIL WORD) (NIL POINTER) (* ; "Spares"))) (RECORD ROUTING (RTNET# RTHOPCOUNT RTGATEWAY# RTNDB RTTIMER RTRECENT)) (PUTPROPS \SERIALNUMBER MACRO (NIL (fetch (IFPAGE SerialNumber) of \InterfacePage))) (PUTPROPS \DEVICE.INPUT DOPVAL (1 MISC1 1)) (PUTPROPS \DEVICE.OUTPUT DOPVAL (2 MISC2 2)) (PUTPROPS \D0.STARTIO DOPVAL (1 MISC1 0)) (PUTPROP (QUOTE LLETHER) (QUOTE IMPORTDATE) (IDATE "19-Jan-93 10:49:30")) (RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR) BRUSHSHAPE _ (QUOTE ROUND) BRUSHSIZE _ 1) (PUTPROPS IMAGEOP MACRO (ARGS (CONS (QUOTE SPREADAPPLY*) (CONS (COND ((EQ (CAR (LISTP (CAR ARGS))) ( QUOTE QUOTE)) (LIST (QUOTE fetch) (LIST (QUOTE IMAGEOPS) (CADAR ARGS)) (QUOTE of) (LIST (QUOTE fetch) (QUOTE (STREAM IMAGEOPS)) (QUOTE of) (CADR ARGS)))) (T (HELP "IMAGEOP - OPNAME not quoted:" ARGS))) ( CDDR ARGS))))) (DATATYPE IMAGEOPS (IMAGETYPE IMCLOSEFN IMXPOSITION IMYPOSITION IMFONT IMLEFTMARGIN IMRIGHTMARGIN IMLINEFEED IMDRAWLINE IMDRAWCURVE IMDRAWCIRCLE IMDRAWELLIPSE IMFILLCIRCLE IMBLTSHADE IMBITBLT IMNEWPAGE IMMOVETO IMSCALE IMTERPRI IMTOPMARGIN IMBOTTOMMARGIN IMSPACEFACTOR IMFONTCREATE IMOPERATION IMCOLOR IMSTRINGWIDTH IMCHARWIDTH IMCHARWIDTHY IMBACKCOLOR IMBITMAPSIZE IMCLIPPINGREGION IMRESET IMDRAWPOLYGON IMFILLPOLYGON IMSCALEDBITBLT IMWRITEPIXEL IMCHARSET IMROTATE IMDRAWARC IMTRANSLATE IMSCALE2 IMPUSHSTATE IMPOPSTATE IMDEFAULTSTATE IMDRAWPOINT IMBLTCHAR IMXOFFSET IMYOFFSET) IMCLOSEFN _ (FUNCTION NILL) IMTERPRI _ (FUNCTION (LAMBDA (STREAM) (\OUTCHAR STREAM (CHARCODE EOL)))) IMNEWPAGE _ ( FUNCTION (LAMBDA (STREAM) (\OUTCHAR STREAM (CHARCODE ^L)))) IMOPERATION _ (FUNCTION NILL) IMCOLOR _ ( FUNCTION NILL) IMCLIPPINGREGION _ (FUNCTION NILL) IMRESET _ (FUNCTION NILL) IMBACKCOLOR _ (FUNCTION NILL) IMSTRINGWIDTH _ (FUNCTION (LAMBDA (STREAM STR RDTBL) (STRINGWIDTH STR (DSPFONT NIL STREAM) RDTBL RDTBL))) IMCHARWIDTH _ (FUNCTION (LAMBDA (STREAM CHARCODE) (CHARWIDTH CHARCODE (DSPFONT NIL STREAM))) ) IMMOVETO _ (FUNCTION (LAMBDA (STREAM X Y) (IMAGEOP (QUOTE IMXPOSITION) STREAM STREAM X) (IMAGEOP ( QUOTE IMYPOSITION) STREAM STREAM Y))) IMBITMAPSIZE _ (FUNCTION (LAMBDA (STREAM BITMAP DIMENSION) ( SELECTQ DIMENSION (WIDTH (TIMES (DSPSCALE NIL STREAM) (BITMAPWIDTH BITMAP))) (HEIGHT (TIMES (DSPSCALE NIL STREAM) (BITMAPHEIGHT BITMAP))) (NIL (CONS (TIMES (DSPSCALE NIL STREAM) (BITMAPWIDTH BITMAP)) ( TIMES (DSPSCALE NIL STREAM) (BITMAPHEIGHT BITMAP)))) (\ILLEGAL.ARG DIMENSION)))) IMWRITEPIXEL _ ( FUNCTION NILL) IMCHARSET _ (FUNCTION NILL) IMXPOSITION _ (FUNCTION NILL) IMYPOSITION _ (FUNCTION NILL) IMFONT _ (FUNCTION NILL) IMLEFTMARGIN _ (FUNCTION NILL) IMRIGHTMARGIN _ (FUNCTION NILL) IMLINEFEED _ (FUNCTION NILL) IMDRAWLINE _ (FUNCTION NILL) IMDRAWCURVE _ (FUNCTION NILL) IMDRAWCIRCLE _ (FUNCTION NILL) IMDRAWELLIPSE _ (FUNCTION NILL) IMFILLCIRCLE _ (FUNCTION NILL) IMBLTSHADE _ (FUNCTION NILL) IMBITBLT _ (FUNCTION NILL) IMSCALE _ (FUNCTION NILL) IMTOPMARGIN _ (FUNCTION NILL) IMBOTTOMMARGIN _ ( FUNCTION NILL) IMSPACEFACTOR _ (FUNCTION NILL) IMFONTCREATE _ (FUNCTION NILL) IMCHARWIDTHY _ (FUNCTION NILL) IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.GENERIC) IMDRAWPOINT _ (FUNCTION \DRAWPOINT.GENERIC) IMFILLPOLYGON _ (FUNCTION NILL) IMSCALEDBITBLT _ (FUNCTION NILL) IMROTATE _ (FUNCTION NILL) IMDRAWARC _ (FUNCTION NILL) IMTRANSLATE _ (FUNCTION NILL) IMPUSHSTATE _ (FUNCTION NILL) IMPOPSTATE _ (FUNCTION NILL) IMSCALE2 _ (FUNCTION NILL) IMDEFAULTSTATE _ (FUNCTION NILL) IMBLTCHAR _ (FUNCTION \MEDW.BLTCHAR) IMXOFFSET _ (FUNCTION \MEDW.XOFFSET) IMYOFFSET _ (FUNCTION \MEDW.YOFFSET)) (GLOBALVARS \NOIMAGEOPS) (PUTPROP (QUOTE IMAGEIO) (QUOTE IMPORTDATE) (IDATE "28-Jun-99 16:33:59")) (DATATYPE PROCESS ((PROCFX0 WORD) (* ; "= \STACKHI to make this look like a STACKP") (PROCFX WORD) (* ; "Stack pointer to this context when it is asleep") (PROCSTATUS BYTE) (* ; "Running or waiting") ( PROCNAME POINTER) (* ; "Name for convenience in type-in reference") (PROCPRIORITY BYTE) (* ; "Priority level, 0-4. Not currently used.") (PROCQUEUE POINTER) (* ; "Queue of processes at the same priority") (NIL BYTE) (NEXTPROCHANDLE POINTER) (* ; "Pointer to next one") (PROCTIMERSET FLAG) (* ; "True if PROCWAKEUPTIMER has an interesting value") ( PROCBEINGDELETED FLAG) (* ; "True if proc was deleted, but hasn't been removed from \PROCESSES yet") ( PROCDELETED FLAG) (PROCSYSTEMP FLAG) (PROCNEVERSTARTED FLAG) (NIL FLAG) (NIL FLAG) (NIL FLAG) ( PROCWAKEUPTIMER POINTER) (* ; "a largep recording the time this proc last went to sleep") ( PROCTIMERLINK POINTER) (* ; "For linking proc in timer queue") (PROCTIMERBOX POINTER) (* ; "Scratch box to use for PROCWAKEUPTIMER when user does not give one explicitly") (WAKEREASON POINTER) (* ; "Reason process is being run. From WAKE.PROCESS or timer or event wakeup; T from simple BLOCK") (PROCEVENTORLOCK POINTER) (* ; "EVENT or MONITOR lock that this proc is waiting for") (PROCFORM POINTER) (* ; "Form to EVAL to start it going") (RESTARTABLE POINTER) (* ; "T = autorestart on error, HARDRESET = restart only on hard reset, NIL = never restart") (PROCWINDOW POINTER) (* ; "Window this process lives in, if any") (PROCFINISHED POINTER) (* ; "True if proc finished. Value is indication of how: NORMAL, DELETED, ERROR") (PROCRESULT POINTER) (* ; "Value it returned if it finished normally") (PROCFINISHEVENT POINTER) (* ; "Optional EVENT to be notified when proc finishes") (PROCMAILBOX POINTER) (* ; "Message queue") ( PROCDRIBBLEOUTPUT POINTER) (* ; "Binding for *DRIBBLE-OUTPUT* in this process") (PROCINFOHOOK POINTER) (* ; "Optional user fn that displays info about process") (PROCTYPEAHEAD POINTER) (* ; "Buffer of typeahead destined for this proc") (PROCREMOTEINFO POINTER) (* ; "For Enterprise") ( PROCUSERDATA POINTER) (* ; "For PROCESSPROP") (PROCEVENTLINK POINTER) (* ; "Used to maintain EVENT queues") (PROCAFTEREXIT POINTER) (* ; "What to do with this process when coming back from a LOGOUT, etc") (PROCBEFOREEXIT POINTER) (* ; "If DON'T, can't logout") (PROCOWNEDLOCKS POINTER) (* ; "Pointer to first lock I currently own") ( PROCEVAPPLYRESULT POINTER) (* ; "For PROCESS.EVAL and PROCESS.APPLY when WAITFORRESULT is true") ( PROCTTYENTRYFN POINTER) (* ; "Is applied to a process when it becomes the tty process") (PROCTTYEXITFN POINTER) (* ; "Is applied to a process when it ceases to be the tty process") (PROCHARDRESETINFO POINTER) (* ; "HARDRESET stores info about unwind-protect cleanups here") (PROCRESTARTFORM POINTER) (* ; "use this instead of PROCFORM when restarting") (PROCOLDTTYPROC POINTER) (* ; "Process that had the tty when we got it") (NIL POINTER) (* ; "For expansion")) PROCTIMERBOX _ ( CREATECELL \FIXP) PROCFX0 _ \STACKHI) (PUTPROPS THIS.PROCESS MACRO (NIL \RUNNING.PROCESS)) (PUTPROPS TTY.PROCESS MACRO (X (COND ((CAR X) (QUOTE IGNOREMACRO)) (T (QUOTE \TTY.PROCESS))))) (PUTPROPS TTY.PROCESSP MACRO (X (COND ((CAR X) (QUOTE IGNOREMACRO)) (T (QUOTE (OR (NULL (THIS.PROCESS) ) (EQ (THIS.PROCESS) (TTY.PROCESS)))))))) (GLOBALVARS \RUNNING.PROCESS \TTY.PROCESS \PROC.RESTARTME \PROC.RESETME \PROC.ABORTME) (PUTPROP (QUOTE PROC) (QUOTE IMPORTDATE) (IDATE "17-Jun-99 21:58:52")) (PUTPROPS \BACKCHAR MACRO (OPENLAMBDA (STREAM) (* ; "Backs up over an NS character") (\BACKNSCHAR STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256)))) (PUTPROPS \BACKNSCHAR MACRO ((ST SHIFTEDCHARSET COUNTERVAR) (COND ((\XCCSP ST) (\BACKXCCSCHAR ST SHIFTEDCHARSET COUNTERVAR)) (T (COND ((QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR ( CL:FUNCALL (ffetch (STREAM BACKCHARFN) of ST) ST T)))) (T (CL:FUNCALL (ffetch (STREAM BACKCHARFN) of ST) ST NIL))))))) (PUTPROPS \CHECKEOLC MACRO (OPENLAMBDA (CH EOLC STREAM PEEKBINFLG COUNTERVAR) (* ;; "Subtracts number of bytes read from COUNTERVAR, which may be NIL. In fact, should be NIL if PEEKBINFLG is T." ) (SELCHARQ CH (CR (SELECTC EOLC (CR.EOLC (CHARCODE EOL)) (CRLF.EOLC (COND (PEEKBINFLG (* ;; "T from PEEKC, compile-time constant. In this case, must leave the fileptr where it was, except for possibly advancing over character set shifts" ) (COND ((EQ (CHARCODE LF) (UNINTERRUPTABLY (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256)) (* ;; "Read the NS CR. We know that there aren't any font-shift characters in front of the CR, because they would have already been read by the \NSPEEK that got the CR character. Since we are going to NS back the CR character, we don't need to update the counter variable" ) (PROG1 (\PEEKBIN STREAM T) (* ;; "LF must be in next BYTE after NS CR, regardless of coding. Character-set shifting bytes can't intervene. Then we back up over the CR that was \NSINed above." ) (\BACKNSCHAR STREAM)))) (CHARCODE EOL)) (T (CHARCODE CR)))) ((EQ (CHARCODE LF) (\PEEKBIN STREAM T)) (\BIN STREAM) (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (SUB1 COUNTERVAR))) (CHARCODE EOL)) (T ( CHARCODE CR)))) (CHARCODE CR))) (LF (COND ((EQ EOLC LF.EOLC) (CHARCODE EOL)) (T (CHARCODE LF)))) CH))) (PUTPROPS \INCHAR MACRO (OPENLAMBDA (STREAM COUNTERVAR) (* ; "returns a 16 bit character code") ( \CHECKEOLC (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL COUNTERVAR) (FFETCH EOLCONVENTION OF STREAM) STREAM NIL COUNTERVAR))) (PUTPROPS \INCCODE MACRO (OPENLAMBDA (STREAM COUNTERVAR) (* ; "returns a 16 bit character code") ( \CHECKEOLC (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL COUNTERVAR) (ffetch EOLCONVENTION of STREAM) STREAM NIL COUNTERVAR))) (PUTPROPS \PEEKCCODE MACRO (OPENLAMBDA (STREAM NOERROR) (\CHECKEOLC (\NSPEEK STREAM (UNFOLD ( ACCESS-CHARSET STREAM) 256) NIL NOERROR) (ffetch EOLCONVENTION of STREAM) STREAM T))) (PUTPROPS \NSIN MACRO ((ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR) (* ;;; "Dispatches to the appropriate character code decoder. If you want to support a new character encoding format, you have to write a decoder and add it here." ) (COND ((\XCCSP ST) (\XCCSIN ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR)) (T (COND ((QUOTE COUNTERVAR) (CL:MULTIPLE-VALUE-BIND (CODE NUM) (CL:FUNCALL (ffetch (STREAM INCCODEFN) of ST) ST T) (AND NUM (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR NUM))) CODE)) (T (CL:FUNCALL (ffetch (STREAM INCCODEFN) of ST) ST NIL))))))) (PUTPROPS \NSPEEK MACRO ((ST SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR) (* ;;; "Dispatches to the appropriate character code decoder. If you want to support a new character encoding format, you have to write a decoder and add it here." ) (COND ((\XCCSP ST) (\XCCSPEEK ST (UNFOLD (ACCESS-CHARSET ST) 256) NIL NOERROR)) (T (COND ((QUOTE COUNTERVAR) (CL:MULTIPLE-VALUE-BIND (CODE NUM) (CL:FUNCALL (ffetch (STREAM PEEKCCODEFN) of ST) ST NOERROR T) (AND NUM (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR NUM))) CODE)) (T (CL:FUNCALL (ffetch ( STREAM PEEKCCODEFN) of ST) ST NOERROR NIL))))))) (PUTPROPS NUMERIC-CHARSET MACRO (= . ACCESS-CHARSET)) (PUTPROPS \CONV.JIS.TO.XCCS MACRO (OPENLAMBDA (KU TEN) (* ;;; "Some character code is not equivalent between JIS and XCCS. In such case, we have to convert the character to corresponding XCCS." ) (COND ((\NOT.EQUIVALENT.TO.XCCS KU) (\DO.CONV.JIS.TO.XCCS KU TEN)) (T (LOGOR (UNFOLD KU 256) TEN)))) ) (PUTPROPS \DO.CONV.JIS.TO.XCCS MACRO ((KU TEN) (* ;;; " Convert a JIS code divided into KU (high 8 bit) and TEN (low 8 bit) to an corresponding XCCS code.") (COND ((\INVALID.TENP TEN) *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (SELECTQ KU ((33 34 38) (* ; "1, 2 and 6 KU") (LET* ((CONVTABLE (\EXTARACT.CONV.TABLE KU)) (SET (\EXTRACT.SET TEN CONVTABLE)) (CODE (\EXTRACT.CODE TEN CONVTABLE))) (COND ((NEQ SET 255) (LOGOR (UNFOLD SET 256) CODE)) (T (COND ((EQ CODE 255) (* ; "Not defined in JIS.") *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (* ; "Defined in JIS but the displayable font is not assigned in the corresponding code in XCCS.") (COND ( *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (\EXTRACT.NO.FONT.CODE (LOGOR (UNFOLD KU 256) TEN)))))))))) (35 (* ; "3 KU") (* ; "Alpha numeric codes are all defined as single byte codes in XCCS.") TEN) (40 (* ; "8 KU") (COND ((< 0 TEN 33) (COND (*REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (\EXTRACT.NO.FONT.CODE ( LOGOR KU TEN))))) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) (116 (* ; "84 KU") (COND ((< 0 TEN 5) (LOGOR 29952 TEN)) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) (117 (* ; "85 KU") (COND ((< 0 TEN 28) (LOGOR 29696 TEN)) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) *DEFAULT-NOT-CONVERTED-FAT-CODE*))))) (PUTPROPS \CONV.XCCS.TO.JIS MACRO (OPENLAMBDA (OUTSTREAM CC) (* ;;; "Returns JIS code corresponding to XCCS charcode. Handle HANKAKU as well as ZENKAKU. If OUTSTREAM wants to convert ZENKAKUKANA to HANKAKUKANA, do so. Never returns two byte charcode for alpha-numeric character, they are all treated as single byte characode." ) (OR (COND ((\ASCIIP CC) CC) ((\NOT.EQUIVALENT.TO.JIS CC) (\DO.CONV.XCCS.TO.JIS CC)) (( \CONV.HANKAKU.TO.ZENKAKUP OUTSTREAM) (* ; "ZENKAKUKANA comes here, because their charcodes are equiavalent to JIS.") (\CONV.ZENKAKU.KANA CC)) (T CC)) CC))) (PUTPROPS \DO.CONV.XCCS.TO.JIS MACRO ((CC) (GETHASH CC *XCCS-TO-JIS-CONV-TABLE*))) (PUTPROPS \ASCIIP MACRO (OPENLAMBDA (CC) (AND (EQ (FOLDLO CC 256) 0) (< (LOGAND CC 255) 128)))) (PUTPROPS \NOT.EQUIVALENT.TO.JIS MACRO (OPENLAMBDA (CC) (OR (EQ (FOLDLO CC 256) 0) (EQ (FOLDLO CC 256) 33) (EQ (FOLDLO CC 256) 34) (EQ (FOLDLO CC 256) 38) (EQ (FOLDLO CC 256) 40) (EQ (FOLDLO CC 256) 239) (EQ (FOLDLO CC 256) 241)))) (PUTPROPS \CONV.HANKAKU.TO.ZENKAKUP MACRO ((OUTSTREAM) (STREAMPROP OUTSTREAM :HTOZP))) (PUTPROPS \CONV.ZENKAKU.KANA MACRO ((CHAR) (GETHASH CHAR *ZENKAKU-TO-HANKAKU-CONV-TABLE*))) (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 (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2))) CHAR) ((PROGN (* ; "2 shift-bytes means not run-encoded") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 3))) (EQ 0 (\BIN STREAM))) \NORUNCODE) (T (\NSIN.24BITENCODING.ERROR STREAM))))) (SETQ CHAR (\BIN STREAM)) (SETQ SCSET (COND ((QUOTE 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 (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2))) (LOGOR (UNFOLD CHAR 256) (\BIN STREAM ))) (CHAR (AND (QUOTE 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 ( QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2))) CHAR) ((PROGN (* ; "2 shift-bytes means not run-encoded") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 3))) (EQ 0 (\BIN STREAM))) \NORUNCODE) (T (\NSIN.24BITENCODING.ERROR STREAM))))) (SETQ SCSET (COND ((QUOTE 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 (QUOTE COUNTERVAR) (add COUNTERVAR 2)) T) ((QUOTE COUNTERVAR) (add COUNTERVAR 1)))) ((QUOTE COUNTERVAR) (add COUNTERVAR 1)))))) (PUTPROPS \XCCSP MACRO (OPENLAMBDA (ST) (NOT (ffetch (STREAM NOTXCCS) of (\DTEST ST (QUOTE STREAM))))) ) (PUTPROPS \EXTRACT.NO.FONT.CODE MACRO ((JISCODE) (CDR (ASSOC JISCODE *JIS-TO-XCCS-CONV-NO-FONT-TABLE*) ))) (PUTPROPS \EXTARACT.CONV.TABLE MACRO ((KU) (CDR (ASSOC KU *JIS-TO-XCCS-CONV-TABLE-LIST*)))) (PUTPROPS \NOT.EQUIVALENT.TO.XCCS MACRO ((KU) (* ;;; " The JIS codes which are not equiavelent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU. Although from 84-5 to 94-94 inclusive are not defined in JIS, that is they are GAIJI, they are also handled here." ) (OR (EQ KU 33) (EQ KU 34) (EQ KU 35) (EQ KU 38) (EQ KU 40) (EQ KU 116) (EQ KU 117)))) (PUTPROPS \EXTRACT.SET MACRO ((TEN TABLE) (ELT TABLE (IDIFFERENCE (UNFOLD (IDIFFERENCE TEN 32) 2) 1))) ) (PUTPROPS \EXTRACT.CODE MACRO ((TEN TABLE) (ELT TABLE (UNFOLD (IDIFFERENCE TEN 32) 2)))) (PUTPROPS \CHNAGE.KI.MODE MACRO (OPENLAMBDA (ST INPUTFLG ENTERP) (* ;;; "INPUTFLG is true if \CHNAGE.KI.MODE is called in the context in which ST is an input stream.") (COND (INPUTFLG (COND (ENTERP (freplace (STREAM IN.KANJIIN) of (\DTEST ST (QUOTE STREAM)) with T)) (T ( freplace (STREAM IN.KANJIIN) of (\DTEST ST (QUOTE STREAM)) with NIL)))) (T (COND (ENTERP (freplace ( STREAM OUT.KANJIIN) of (\DTEST ST (QUOTE STREAM)) with T)) (T (freplace (STREAM OUT.KANJIIN) of ( \DTEST ST (QUOTE STREAM)) with NIL))))))) (PUTPROPS \KIMODEP MACRO (OPENLAMBDA (ST INPUTFLG) (* ;;; "INPUTFLG is true if \KIMODEP is called in the context in which ST is an input stream.") (COND ( INPUTFLG (ffetch (STREAM IN.KANJIIN) of (\DTEST ST (QUOTE STREAM)))) (T (ffetch (STREAM OUT.KANJIIN) of (\DTEST ST (QUOTE STREAM))))))) (PUTPROPS \HANKAKUP MACRO ((CHAR) (< 160 CHAR 224))) (PUTPROPS \KANJIP MACRO ((CHAR) (< 12158 CHAR 29733))) (PUTPROPS \NOTGAIJIP MACRO ((CHAR) (OR (< 8480 CHAR 10305) (< 12158 CHAR 29733)))) (PUTPROPS \INVALID.TENP MACRO (OPENLAMBDA (TEN) (OR (< TEN 33) (< 126 TEN)))) (PUTPROPS \CONV.HANKAKU.KANA MACRO ((CHAR) (GETHASH CHAR *HANKAKU-TO-ZENKAKU-CONV-TABLE*))) (PUTPROPS \OUTKI MACRO ((STREAM) (\BOUT OUTSTREAM (CHARCODE ESC)) (\BOUT OUTSTREAM (CHARCODE $)) ( \BOUT OUTSTREAM (CHARCODE B)))) (PUTPROPS \OUTKO MACRO ((STREAM) (\BOUT OUTSTREAM (CHARCODE ESC)) (\BOUT OUTSTREAM (CHARCODE %()) ( \BOUT OUTSTREAM (CHARCODE J)))) (PUTPROPS \CONV.SJIS.TO.JIS MACRO (OPENLAMBDA (HI LO) (* ;;; "Convert Shift-JIS to JIS. The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of JIS code respectively." ) (SETQ CH1 (IDIFFERENCE HI (COND ((> HI 159) 177) (T 113)))) (SETQ CH1 (IPLUS (UNFOLD CH1 2) 1)) ( SETQ CH2 (COND ((> LO 158) (PROG1 (IDIFFERENCE LO 126) (SETQ CH1 (IPLUS CH1 1)))) (T (IDIFFERENCE LO ( COND ((> LO 126) (IPLUS 31 1)) (T 31)))))))) (PUTPROPS \CONV.JIS.TO.SJIS MACRO (OPENLAMBDA (HI LO) (* ;;; "Convert JIS to Shift-JIS. The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of Shift-JIS code respectively." ) (SETQ CH2 (COND ((ODDP HI) (SETQ CH2 (IPLUS LO 31)) (COND ((>= CH2 127) (IPLUS CH2 1)) (T CH2))) (T (IPLUS LO 126)))) (SETQ CH1 (IPLUS (FOLDLO (IDIFFERENCE HI 33) 2) 129)) (AND (> CH1 159) (SETQ CH1 ( IPLUS CH1 64))))) (PUTPROPS \SJIS.KANJI.FIRST.BYTEP MACRO (OPENLAMBDA (CHAR) (OR (< 127 CHAR 160) (< 223 CHAR 256)))) (PUTPROPS \EUC.KANJI.FIRST.BYTEP MACRO ((CHAR) (< 160 CHAR 255))) (PUTPROPS \GAIJIP MACRO ((CHAR) (EQ CHAR 143))) (PUTPROPS \EUC.HANKAKUP MACRO ((CHAR) (EQ CHAR 142))) (PUTPROP (QUOTE LLREAD) (QUOTE IMPORTDATE) (IDATE " 4-Aug-93 14:43:07")) (PUTPROPS EMPASSWORDLOC DMACRO (LAMBDA NIL (* lmm "24-MAR-83 06:46") (fetch (IFPAGE UserPswdAddr) of \InterfacePage))) (PUTPROPS \DECRYPT.PWD.CHAR MACRO ((CHAR) (LOGXOR CHAR 73))) (PUTPROP (QUOTE PASSWORDS) (QUOTE IMPORTDATE) (IDATE "16-May-90 21:02:21")) (RPAQQ MICASPERINCH 2540) (RPAQQ MICASPERMILLIMETER 100) (CONSTANTS (MICASPERINCH 2540) (MICASPERMILLIMETER 100)) (PUTPROP (QUOTE INTERPRESS) (QUOTE IMPORTDATE) (IDATE "16-Apr-2018 21:56:38")) (RPAQ MICASPERPT (FQUOTIENT 2540 72)) (RPAQQ IHALFMICASPERPT 17) (RPAQQ IMICASPERPT 35) (CONSTANTS (MICASPERPT (FQUOTIENT 2540 72)) (IHALFMICASPERPT 17) (IMICASPERPT 35)) (DEFMACRO \MICASTOPTS (MICAS) (COND ((NUMBERP MICAS) (QUOTIENT MICAS MICASPERPT)) (T (BQUOTE (QUOTIENT (\, MICAS) MICASPERPT))))) (PUTPROP (QUOTE HARDCOPY) (QUOTE IMPORTDATE) (IDATE "16-Apr-2018 22:15:08")) (FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES) CMLARRAY-SUPPORT) (PUTPROP (QUOTE CMLARRAY) (QUOTE IMPORTDATE) (IDATE " 6-Jan-93 12:21:21")) (RPAQQ \MISCN-TABLE-LIST ((USER-SUBR 0 \USER-SUBR-UFN T) (CL:VALUES 1 CL::VALUES-UFN NIL) (CL:SXHASH 2 CL::SXHASH-UFN NIL) (CL::EQLHASHBITSFN 3 CL::EQLHASHBITSFN-UFN NIL) (STRINGHASHBITS 4 \STRINGHASHBITS-UFN NIL) (STRING-EQUAL-HASHBITS 5 \STRING-EQUAL-HASHBITS-UFN NIL) (CL:VALUES-LIST 6 CL::VALUES-LIST-UFN NIL) (LCFetchMethod 7 LCFetchMethod NIL) (LCFetchMethodOrHelp 8 NIL NIL) ( LCFindVarIndex 9 NIL NIL) (LCGetIVValue 10 NIL NIL) (LCPutIVValue 11 NIL NIL))) (RPAQQ \USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN) (SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN))) (RPAQQ \INITSUBRS ((BACKGROUNDSUBR 6) (CHECKBCPLPASSWORD 7) (DISKPARTITION 8) (DSPBOUT 9) (DSPRATE 10) (GATHERSTATS 11) (GETPACKETBUFFER 12) (LISPFINISH 13) (MOREVMEMFILE 14) (RAID 15) (READRAWPBI 16) ( WRITERAWPBI 17) (SETSCREENCOLOR 18) (SHOWDISPLAY 19) (PUPLEVEL1STATE 20) (WRITESTATS 21) ( CONTEXTSWITCH 22) (COPYSYS0SUBR 23) (WRITEMAP 24) (UFS-GETFILENAME 34) (UFS-DELETEFILE 35) ( UFS-RENAMEFILE 36) (COM-READPAGES 37) (COM-WRITEPAGES 38) (COM-TRUNCATEFILE 39) (UFS-DIRECTORYNAMEP 41 ) (COM-GETFREEBLOCK 45) (SETUNIXTIME 48) (GETUNIXTIME 49) (COPYTIMESTATS 50) (UNIX-USERNAME 51) ( UNIX-FULLNAME 52) (UNIX-GETENV 53) (UNIX-GETPARM 54) (CHECK-SUM 55) (ETHER-SUSPEND 56) (ETHER-RESUME 57) (ETHER-AVAILABLE 58) (ETHER-RESET 59) (ETHER-GET 60) (ETHER-SEND 61) (ETHER-SETFILTER 62) ( ETHER-CHECK 63) (DSPCURSOR 64) (SETMOUSEXY 65) (DSP-VIDEOCOLOR 66) (DSP-SCREENWIDTH 67) ( DSP-SCREENHEIGHT 68) (BITBLTSUB 69) (BLTCHAR 70) (TEDIT.BLTCHAR 71) (BITBLT.BITMAP 72) ( BLTSHADE.BITMAP 73) (RS232C-CMD 74) (RS232C-READ-INIT 75) (RS232C-WRITE 76) (KEYBOARDBEEP 80) ( KEYBOARDMAP 81) (KEYBOARDSTATE 82) (VMEMSAVE 89) (LISP-FINISH 90) (NEWPAGE 91) (DORECLAIM 92) ( DUMMY-135Q 93) (NATIVE-MEMORY-REFERENCE 94) (OLD-COMPILE-LOAD-NATIVE 95) (DISABLEGC 96) ( COM-SETFILEINFO 103) (COM-OPENFILE 104) (COM-CLOSEFILE 105) (DSK-GETFILENAME 106) (DSK-DELETEFILE 107) (DSK-RENAMEFILE 108) (COM-NEXT-FILE 110) (COM-FINISH-FINFO 111) (COM-GEN-FILES 112) ( DSK-DIRECTORYNAMEP 113) (COM-GETFILEINFO 114) (COM-CHANGEDIR 116) (UNIX-HANDLECOMM 117) (RPC-CALL 119) (MESSAGE-READP 120) (MESSAGE-READ 121) (MONITOR-CONTROL 128) (GET-NATIVE-ADDR-FROM-LISP-PTR 131) ( GET-LISP-PTR-FROM-NATIVE-ADDR 132) (LOAD-NATIVE-FILE 133) (SUSPEND-LISP 134) (NEW-BLTCHAR 135) ( COLOR-INIT 136) (COLOR-SCREENMODE 137) (COLOR-MAP 138) (COLOR-BASE 139) (C-SlowBltChar 140) ( UNCOLORIZE-BITMAP 141) (COLORIZE-BITMAP 142) (COLOR-8BPPDRAWLINE 143) (TCP-OP 144) (WITH-SYMBOL 145) ( CAUSE-INTERRUPT 146) (OPEN-SOCKET 160) (CLOSE-SOCKET 161) (READ-SOCKET 162) (WRITE-SOCKET 163) ( CALL-C-FUNCTION 167) (DLD-LINK 168) (DLD-UNLINK-BY-FILE 169) (DLD-UNLINK-BY-SYMBOL 170) ( DLD-GET-SYMBOL 171) (DLD-GET-FUNC 172) (DLD-FUNCTION-EXECUTABLE-P 173) (DLD-LIST-UNDEFINED-SYMBOLS 174 ) (C-MALLOC 175) (C-FREE 176) (C-PUTBASEBYTE 177) (C-GETBASEBYTE 178) (CHAR-OPENFILE 200) (CHAR-BIN 201) (CHAR-BOUT 202) (CHAR-IOCTL 203) (CHAR-CLOSEFILE 204) (CHAR-EOFP 205) (CHAR-READP 206) (CHAR-BINS 207) (CHAR-BOUTS 208) (CHAR-FILLBUFFER 209))) (PUTPROP (QUOTE LLSUBRS) (QUOTE IMPORTDATE) (IDATE "17-Dec-92 14:28:41")) STOP \ No newline at end of file diff --git a/library/FILE-UPDATE b/library/FILE-UPDATE new file mode 100644 index 00000000..ff5d4d4e --- /dev/null +++ b/library/FILE-UPDATE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "23-Aug-95 13:01:43" |{DSK}library>FILE-UPDATE.;3| 2268 |changes| |to:| (FNS FIX-FILE) |previous| |date:| "23-Aug-95 10:54:34" |{DSK}library>FILE-UPDATE.;2|) ; Copyright (c) 1995 by Venue. All rights reserved. (PRETTYCOMPRINT FILE-UPDATECOMS) (RPAQQ FILE-UPDATECOMS ( (* |;;| "==================================") (* |;;| " M E D L E Y 3 . 0 F I L E - U P D A T E U T I L I T Y") (* |;;| "") (* |;;| "Use the function FIX-FILE to make updated copies of any source files that have DATATYPE declarations in them.") (* |;;| "") (* |;;| "You will need to fix any BLOCKRECORD declarations by hand.") (* |;;| "==================================") (FNS FIX-FILE))) (* |;;| "==================================") (* |;;| " M E D L E Y 3 . 0 F I L E - U P D A T E U T I L I T Y") (* |;;| "") (* |;;| "Use the function FIX-FILE to make updated copies of any source files that have DATATYPE declarations in them." ) (* |;;| "") (* |;;| "You will need to fix any BLOCKRECORD declarations by hand.") (* |;;| "==================================") (DEFINEQ (FIX-FILE (LAMBDA (FILE) (* \; "Edited 23-Aug-95 13:01 by jds") (* |;;| "Take a lisp source file, and re-dump it with aall record declarations (NOT including BLOCKRECORDS) changed so they're compatible with Medley 3.0.") (* |;;| "This really only involves marking each record as changed, so the file manager re-dumps the pre-parsed version of the record declaration.") (LOAD FILE 'PROP) (LOADCOMP FILE 'PROP) (AND (FILEFNSLST FILE) (|for| RECNAME |in| (FILECOMSLST FILE 'RECORDS) |do| (MARKASCHANGED RECNAME 'RECORDS))) (MARKASCHANGED FILE 'FILES) (MAKEFILE FILE))) ) (PUTPROPS FILE-UPDATE COPYRIGHT ("Venue" 1995)) (DECLARE\: DONTCOPY (FILEMAP (NIL (1424 2197 (FIX-FILE 1434 . 2195))))) STOP \ No newline at end of file diff --git a/library/FILEBROWSER b/library/FILEBROWSER new file mode 100644 index 00000000..5cc6690e --- /dev/null +++ b/library/FILEBROWSER @@ -0,0 +1,226 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "11-Sep-2001 09:26:14" |{DSK}medley3.5>library>FILEBROWSER.;8| 152759 |changes| |to:| (FNS FB.PROMPTFORINPUT) |previous| |date:| "20-Nov-2000 14:25:02" |{DSK}medley3.5>library>FILEBROWSER.;7|) ; Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994, 1999, 2000, 2001 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT FILEBROWSERCOMS) (RPAQQ FILEBROWSERCOMS ((COMS (FILES ATTACHEDWINDOW ICONW TABLEBROWSER) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops.") (INITVARS (FB.EXPUNGE?MENU) (FB.BROWSERFONT DEFAULTFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT) (FB.PROMPTFONT LITTLEFONT) (FB.HARDCOPY.FONT) (FB.HARDCOPY.DIRECTORY.FONT) (FB.PROMPTLINES 3) (FB.MENUFONT MENUFONT) (FB.OVERFLOW.MAXABSOLUTE 30) (FB.OVERFLOW.MAXFRAC 0.06) (FB.DEFAULT.EDITOR 'TEDIT) (FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR)) (FB.ICONSPEC '(#*(83 70)OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@LOOOOOOOOOOOOOOOOOONF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DCOOOHD@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DOOOOND@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@B@@@@@H@@@@@BF@@@LH@@@@@A@@@@A@@@@@@BF@@@LH@@@@@@OOOON@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LOOOOOOOOOOOOOOOOOONF@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@ NIL (5 5 73 40)))) (APPENDVARS (FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT))) (P (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET))) (ADDVARS (CACHEDMENUS FB.EXPUNGE?MENU)) (VARS FB.MENU.ITEMS FB.VERSION.MENU.ITEMS FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.INFO.MENU.ITEMS FB.DEFAULT.NAME.WIDTH FB.INFO.FIELDS FB.INFOSHADE FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE)) (COMS (* \; "Entries") (COMMANDS "fb") (FNS FB FB.COPYBINARYCOMMAND FB.COPYTEXTCOMMAND FILEBROWSER FB.TABLEBROWSER FB.SELECTEDFILES FB.FETCHFILENAME FB.PROMPTWPRINT FB.PROMPTW.FORMAT FB.PROMPTFORINPUT FB.YES-OR-NO-P FB.ALLOW.ABORT \\FB.HARDCOPY.TOFILE.EXTENSION) (* \; "Setup") (FNS FB.STARTUP FB.MAKERIGIDWINDOW) (FNS FB.PRINTFN FB.COPYFN)) (COMS (* \;  "commands and major subfunctions") (FNS FB.MENU.WHENSELECTEDFN FB.COMMANDSELECTEDFN FB.SUBITEMP FB.MAKE.BROWSER.BUSY FB.FINISH.COMMAND FB.HANDLE.ABORT.BUTTON) (FNS FB.DELETECOMMAND FB.DELVERCOMMAND FB.IS.NOT.SUBDIRECTORY.ITEM FB.DELVER.FILES FB.DELETE.FILE) (FNS FB.UNDELETECOMMAND FB.UNDELETEALLCOMMAND FB.UNDELETE.FILE) (FNS FB.COPYCOMMAND FB.RENAMECOMMAND FB.COPY/RENAME.COMMAND FB.COPY/RENAME.ONE FB.COPY/RENAME.MANY FB.MERGE.DIRECTORIES FB.GREATEST.PREFIX FB.MAYBE.INSERT.FILE FB.GET.NEW.FILE.SPEC FB.CANONICAL.DIRECTORY) (FNS FB.HARDCOPYCOMMAND FB.HARDCOPY.TOFILE) (FNS FB.EDITCOMMAND FB.EDITLISPFILE FB.BROWSECOMMAND) (FNS FB.FASTSEECOMMAND FB.FASTSEE.ONEFILE FB.SEEFULLFN FB.SEEBUTTONFN) (FNS FB.LOADCOMMAND FB.COMPILECOMMAND FB.OPERATE.ON.FILES) (FNS FB.UPDATECOMMAND FB.MAYBE.EXPUNGE FB.UPDATEBROWSERITEMS FB.DATE FB.ADJUST.DATE.WIDTH FB.SET.BROWSER.TITLE FB.MAYBE.WIDEN.NAMES FB.SET.DEFAULT.NAME.WIDTH FB.CREATE.FILEBUCKET FB.CHECK.NAME.LENGTH FB.ADD.FILEGROUP FB.INSERT.DIRECTORY FB.MAKE.SUBDIRECTORY.ITEM FB.ADD.FILE FB.INSERT.FILE FB.ANALYZE.PATTERN FB.CANONICALIZE.PATTERN FB.GETALLFILEINFO) (FNS FB.SORT.VERSIONS FB.DECREASING.VERSION FB.INCREASING.VERSION FB.NAMES.DECREASING.VERSION FB.NAMES.INCREASING.VERSION FB.DECREASING.NUMERIC.ATTR FB.INCREASING.NUMERIC.ATTR FB.ALPHABETIC.ATTR) (FNS FB.SORTCOMMAND FB.INSERT.SUBDIRECTORIES FB.GET.SORT.MENU) (FNS FB.EXPUNGECOMMAND FB.NEWPATTERNCOMMAND FB.NEWINFOCOMMAND FB.DEPTHCOMMAND FB.SHAPECOMMAND FB.REMOVE.FILE FB.COUNT.FILE.CHANGE FB.SETNEWPATTERN FB.GET.NEWPATTERN FB.OPTIONSCOMMAND)) (COMS (* \; "window functions") (FNS FB.INFOMENU.SHADEINITIALSELECTIONS FB.INFO.ITEM.NAMED) (FNS FB.MAKECOUNTERWINDOW FB.COUNTERW.REDISPLAYFN FB.UPDATE.COUNTERS FB.DISPLAY.COUNTERS FB.COUNTER.STRING) (FNS FB.MAKEHEADINGWINDOW FB.HEADINGW.REDISPLAYFN FB.HEADINGW.RESHAPEFN FB.HEADINGW.DISPLAY) (FNS FB.ICONFN FB.INFOMENU.WHENSELECTEDFN FB.CLOSEFN FB.EXPUNGE?.MENU FB.AFTERCLOSEFN FB.CLOSE&EXPUNGE) (FNS FB.HARDCOPY.DIRECTORY FB.HARDCOPY.PRINT.TITLE FB.HARDCOPY.MAXWIDTH)) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TABLEBROWSERDECLS) (RECORDS INFOFIELD FBFILEDATA FILEBROWSER) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) (MACROS NULL.VERSIONP NULL.DIRECTORYP EQ.DIRECTORYP NULL.FIELDP) (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) (LOCALVARS . T)) (INITRECORDS FILEBROWSER FBFILEDATA) (SYSRECORDS FILEBROWSER FBFILEDATA) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T)) (ADDVARS (*ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (|BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern" ))) (VARS (|BackgroundMenu|))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA FB) (NLAML) (LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT))) )) (FILESLOAD ATTACHEDWINDOW ICONW TABLEBROWSER) (* |;;| "JDS 11/94 FB.ICONSPEC is now an INITVAR so we can create smaller ones in profiles for, e.g., laptops." ) (RPAQ? FB.EXPUNGE?MENU ) (RPAQ? FB.BROWSERFONT DEFAULTFONT) (RPAQ? FB.BROWSER.DIRECTORY.FONT BOLDFONT) (RPAQ? FB.PROMPTFONT LITTLEFONT) (RPAQ? FB.HARDCOPY.FONT ) (RPAQ? FB.HARDCOPY.DIRECTORY.FONT ) (RPAQ? FB.PROMPTLINES 3) (RPAQ? FB.MENUFONT MENUFONT) (RPAQ? FB.OVERFLOW.MAXABSOLUTE 30) (RPAQ? FB.OVERFLOW.MAXFRAC 0.06) (RPAQ? FB.DEFAULT.EDITOR 'TEDIT) (RPAQ? FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR)) (RPAQ? FB.ICONSPEC '(#*(83 70)OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@LOOOOOOOOOOOOOOOOOONF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DCOOOHD@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@DOOOOND@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@D@@@@@D@@@@@BF@@@LH@@@@@GOOOOOL@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@COOOOOH@@@@@BF@@@LH@@@@@B@@@@@H@@@@@BF@@@LH@@@@@A@@@@A@@@@@@BF@@@LH@@@@@@OOOON@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LH@@@@@@@@@@@@@@@@@BF@@@LOOOOOOOOOOOOOOOOOONF@@@L@@@@@@@@@@@@@@@@@@@F@@@L@@@@@@@@@@@@@@@@@@@F@@@OOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOON@@@ NIL (5 5 73 40))) (APPENDTOVAR FONTVARS (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT LITTLEFONT) (FB.BROWSER.DIRECTORY.FONT BOLDFONT)) (* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.") (FONTSET (FONTSET)) (ADDTOVAR CACHEDMENUS FB.EXPUNGE?MENU) (RPAQQ FB.MENU.ITEMS ((|Delete| FB.DELETECOMMAND "Marks selected files for deletion. \ + (Use EXPUNGE to remove files from system)" (SUBITEMS ("Delete Selected Files" FB.DELETECOMMAND "Marks the selected files for deletion.") ("Delete Old Versions" FB.DELVERCOMMAND "Marks for deletion old versions of all files in the browser.\ +You specify how many versions to keep." ))) (|Undelete| FB.UNDELETECOMMAND "Removes deletion mark for selected files" (SUBITEMS ("Undelete ALL Files" FB.UNDELETEALLCOMMAND "Removes deletion mark from all files in the browser"))) (|Copy| FB.COPYCOMMAND "Copies selected files (prompts for new file name/directory)" (SUBITEMS ("Copy using TEXT FileType" FB.COPYTEXTCOMMAND "Forces the copying of selected files to be done as TEXT-files") ("Copy using BINARY FileType" FB.COPYBINARYCOMMAND "Forces the copying of selected files to be done as BINARY-files"))) (|Rename| FB.RENAMECOMMAND "Renames (moves) selected files (prompts for new name/directory)") (|Hardcopy| FB.HARDCOPYCOMMAND "Produces hardcopy of selected files on your default printer" (SUBITEMS ("To a file" (FB.HARDCOPYCOMMAND FILE) "Generates a hardcopy master of selected file; prompts for filename and format" ) ("To a printer" (FB.HARDCOPYCOMMAND PRINTER) "Sends hardcopy of selected files to a printer of your choosing"))) (|See| FB.FASTSEECOMMAND "Displays selected files one at a time in a separate window" (SUBITEMS ("Fast SEE Pretty" FB.FASTSEECOMMAND "Views file quickly, uses font information, no scrolling backwards") ("Fast SEE Unformatted" (FB.FASTSEECOMMAND T) "Views file quickly, shows raw characters, no scrolling backwards") ("Scrollable & Pretty" (FB.EDITCOMMAND READONLY) "Views file with font information in a fully scrollable window") ("FileBrowse" FB.BROWSECOMMAND "Recursively call FileBrowser on the selected subdirectory"))) (|Edit| FB.EDITCOMMAND "Calls an editor on the selected files (use submenu to specify editor)" (SUBITEMS ("TEdit" (FB.EDITCOMMAND TEDIT) "Calls TEdit (text editor) on selected files") ("Lisp Edit" (FB.EDITCOMMAND LISP) "Calls Lisp editor on selected files"))) (|Load| FB.LOADCOMMAND "LOADs selected files" (SUBITEMS ("IL:LOAD" FB.LOADCOMMAND "LOADs selected files") ("CL:LOAD" (FB.LOADCOMMAND CL:LOAD) "Performs CL:LOAD on selected files" ) ("Load PROP" (FB.LOADCOMMAND PROP) "Loads the selected files with LDFLG = PROP" ) ("Load SYSLOAD" (FB.LOADCOMMAND SYSLOAD) "System-loads the files (fast but not undoable)" ) (LOADFROM (FB.LOADCOMMAND LOADFROM) "Performs LOADFROM on selected files" ) (LOADCOMP (FB.LOADCOMMAND LOADCOMP) "Performs LOADCOMP on selected files" ))) (|Compile| FB.COMPILECOMMAND "Compiles selected LISP source files using default compiler" (SUBITEMS (TCOMPL (FB.COMPILECOMMAND TCOMPL) "Calls TCOMPL on selected files") (BCOMPL (FB.COMPILECOMMAND BCOMPL) "Calls BCOMPL on selected files") (COMPILE-FILE (FB.COMPILECOMMAND CL:COMPILE-FILE) "COMPILE-FILE's selected files"))) (|Expunge| FB.EXPUNGECOMMAND "Permanently removes from the file system all files marked for deletion") (|Recompute| FB.UPDATECOMMAND "Recomputes set of files satisfying selection pattern" (SUBITEMS ("Same Pattern" FB.UPDATECOMMAND "Recomputes set of files satisfying current pattern") ("New Pattern" FB.NEWPATTERNCOMMAND "Prompts for a new selection pattern and updates browser") ("New Info" FB.NEWINFOCOMMAND "Change the set of file attributes that are displayed") ("Set Depth" FB.DEPTHCOMMAND "Change the depth to which future Recomputes will enumerate the directory (NS servers only)" ) ("Shape to Fit" FB.SHAPECOMMAND "Widen or narrow the browser so that all information is visible"))) (|Sort| FB.SORTCOMMAND "Sorts all the files in the browser by the attribute of your choice"))) (RPAQQ FB.VERSION.MENU.ITEMS (("1" 1 "Keep only one version of the files") ("2" 2 "Keep two versions of the files") ("3" 3 "Keep three versions of the files") ("4" 4 "Keep four versions of the files") ("Other" :NUMBER "Select number of versions to keep"))) (RPAQQ FB.CLOSE.MENU.ITEMS (("Expunge deleted files" 'EXPUNGE "Erases all files still marked 'deleted'") ("Don't expunge" 'NOEXPUNGE "Proceeds (closes or updates browser) without expunging deleted files.\ +Your deletions are thus ignored." ))) (RPAQQ FB.DEPTH.MENU.ITEMS (("Global default" :GLOBAL "Set depth using the global default (FILING.ENUMERATION.DEPTH)" ) ("Infinite" T "Set depth to infinity, i.e., enumerate all levels of directory" ) ("1" 1 "Set depth to 1, i.e., enumerate just the top level of the directory" ) ("2" 2 "Set depth to 2") ("Other" :NUMBER "Set depth to some other finite depth"))) (RPAQQ FB.INFO.MENU.ITEMS ((|Length| LENGTH "Toggles Length display") (|ByteSize| BYTESIZE "Toggles ByteSize display") (|Pages| SIZE "Toggles Pages display") (|Type| TYPE "Toggles Type display") (|Created| CREATIONDATE "Toggles Created display") (|Written| WRITEDATE "Toggles Written display") (|Read| READDATE "Toggles Read display") (|Author| AUTHOR "Toggles Author display"))) (RPAQQ FB.DEFAULT.NAME.WIDTH 140) (RPAQQ FB.INFO.FIELDS ((LENGTH " Length" 70 (FIX 56) "99999999") (SIZE "Pages" 50 (FIX 35) "99999") (BYTESIZE "Byt" 28 (FIX 14) "99") (TYPE "Type" 55 NIL "INTERPRESS") (CREATIONDATE "Created" 170 DATE) (READDATE "Read" 170 DATE) (WRITEDATE "Written" 170 DATE) (AUTHOR "Author" 120))) (RPAQQ FB.INFOSHADE 32800) (RPAQQ FB.ITEMUNSELECTEDSHADE 0) (RPAQQ FB.ITEMSELECTEDSHADE 4672) (* \; "Entries") (DEFCOMMAND "fb" (&REST PAT&PROPS) (APPLY 'FB PAT&PROPS)) (DEFINEQ (FB +(NLAMBDA PATTERN (* \; "Edited 26-Feb-88 13:50 by bvm") (* |;;;| "FILEBROWSER entry from top-level exec: FB PATTERN ... PROPS ...") (DESTRUCTURING-BIND (PAT . PROPS) (NLAMBDA.ARGS PATTERN) (LET (OPTIONS) (|for| TAIL |on| PROPS |when| (AND (CL:KEYWORDP (CAR TAIL)) (CDR TAIL)) |do| (* \; "Interpret keyword tail of attributes as OPTIONS.") (RETURN (SETQ PROPS (LDIFF PROPS (SETQ OPTIONS TAIL))))) (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FILEBROWSER)) (QUOTE (\\\, PAT)) (QUOTE (\\\, PROPS)) (QUOTE (\\\, OPTIONS)))) (QUOTE NAME) (QUOTE FB)))) NIL) +) (FB.COPYBINARYCOMMAND +(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 18:18 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Copy|) (CONS (FUNCTION COPYFILE) (QUOTE ((TYPE BINARY)))))) +) (FB.COPYTEXTCOMMAND +(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 18:55 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Copy|) (CONS (FUNCTION COPYFILE) (QUOTE ((TYPE TEXT)))))) +) (FILEBROWSER +(LAMBDA (FILESPEC ATTRIBUTES OPTIONS) (* \; "Edited 30-Aug-94 19:45 by jds") (PROG ((TITLEFONT (DSPFONT NIL |WindowTitleDisplayStream|)) (BROWSERFONTHEIGHT (FONTPROP FB.BROWSERFONT (QUOTE HEIGHT))) (MENU-ITEMS FB.MENU.ITEMS) (MENU-TITLE "FB Commands") BROWSER PROMPTWHEIGHT COUNTERHEIGHT BROWSERWINDOW BROWSERWIDTH COMMANDMENU COMMANDMENUWIDTH COMMANDMENUWINDOW HEADINGWINDOW REGION TITLE DEPTH) (COND ((AND (LISTP OPTIONS) (SMALLP (CAR OPTIONS)) (AND (EQLENGTH OPTIONS 4) (EVERY OPTIONS (FUNCTION NUMBERP)))) (* \; "Old style") (SETQ REGION OPTIONS) (SETQ OPTIONS)) (T (|for| TAIL |on| OPTIONS |by| (CDDR TAIL) |do| (PROG ((KEY (CAR TAIL)) (VALUE (CADR TAIL))) RETRY (SELECTQ KEY (:REGION (SETQ REGION VALUE)) (:TITLE (SETQ TITLE VALUE)) ((:MENU-TITLE MENU.TITLE) (SETQ MENU-TITLE VALUE)) ((:MENU-ITEMS MENU.ITEMS) (SETQ MENU-ITEMS VALUE)) (:DEPTH (SETQ DEPTH VALUE)) (|if| (AND (NOT (CL:KEYWORDP KEY)) (SETQ KEY (CL:FIND-SYMBOL (STRING KEY) *KEYWORD-PACKAGE*))) |then| (* \; "for backward compatibility, coerce other symbols to keywords") (GO RETRY))))))) (SETQ ATTRIBUTES (COND (ATTRIBUTES (* \; "Caller specifies which attributes to use") (|for| X |in| ATTRIBUTES |collect| (OR (CADR (FB.INFO.ITEM.NAMED X FB.INFO.MENU.ITEMS)) (AND (LISTP DIRCOMMANDS) (OR (|for| PAIR |in| DIRCOMMANDS |when| (AND (LISTP PAIR) (STRING-EQUAL X (CAR PAIR))) |do| (* \; "Found synonym in dircommands. This also takes care of attribute being in different packages") (RETURN (CDR PAIR))) (PROGN (* \; "Try spelling correction. Wanted to get synonyms this way, but MISSPELLED? seems to be package-sensitive.") (MISSPELLED? X 90 DIRCOMMANDS)))) (\\ILLEGAL.ARG X)))) (T FB.DEFAULT.INFO))) (PROGN (* \; "Figure out the size of the fixed pieces before prompting for a region") (SETQ COMMANDMENU (|create| MENU MENUFONT _ FB.MENUFONT ITEMS _ MENU-ITEMS CENTERFLG _ T MENUCOLUMNS _ 1 WHENSELECTEDFN _ (FUNCTION FB.MENU.WHENSELECTEDFN) TITLE _ MENU-TITLE)) (SETQ COMMANDMENUWIDTH (|fetch| (MENU IMAGEWIDTH) |of| COMMANDMENU)) (SETQ PROMPTWHEIGHT (HEIGHTIFWINDOW (TIMES FB.PROMPTLINES (FONTPROP FB.PROMPTFONT (QUOTE HEIGHT))))) (SETQ COUNTERHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEFONT (QUOTE HEIGHT)) T))) (PROGN (* |;;| "First make the main window, carved out of the space in REGION leftover after the fixed parts are accounted for") (COND ((NOT REGION) (PROMPTPRINT (CL:FORMAT NIL "Specify region for FileBrowser~@[ on ~A~]" FILESPEC)) (SETQ REGION (GETREGION (PROGN (* \; "Min width is menu plus enough space to print a name") (+ COMMANDMENUWIDTH FB.DEFAULT.NAME.WIDTH TB.LEFT.MARGIN)) (PROGN (* \; "Min height is prompt window plus counter window plus heading plus 5 lines of files") (+ PROMPTWHEIGHT COUNTERHEIGHT (TIMES 6 BROWSERFONTHEIGHT))))) (CLRPROMPT))) (|if| (AND (NULL FILESPEC) (NOT (TTY.PROCESSP))) |then| (* \; "Grab the tty now, so that user can start typing ahead") (TTY.PROCESS (THIS.PROCESS)) (ALLOW.BUTTON.EVENTS)) (SETQ BROWSERWINDOW (CREATEW (|create| REGION |using| REGION WIDTH _ (SETQ BROWSERWIDTH (- (|fetch| (REGION WIDTH) |of| REGION) COMMANDMENUWIDTH)) HEIGHT _ (- (|fetch| (REGION HEIGHT) |of| REGION) (+ COUNTERHEIGHT PROMPTWHEIGHT BROWSERFONTHEIGHT))))) (DSPFONT FB.BROWSERFONT BROWSERWINDOW) (WINDOWPROP BROWSERWINDOW (QUOTE FILEBROWSER) (SETQ BROWSER (|create| FILEBROWSER BROWSERWINDOW _ BROWSERWINDOW BROWSERFONT _ FB.BROWSERFONT OVERFLOWSPACING _ (TIMES 3 (CHARWIDTH (CHARCODE \a) FB.BROWSERFONT)) SORTBY _ (FUNCTION FB.NAMES.DECREASING.VERSION) FIXEDTITLE _ TITLE INFOMENUCHOICES _ ATTRIBUTES FBLOCK _ (CREATE.MONITORLOCK) FBDEPTH _ DEPTH)))) (PROGN (* \; "Atop this sits the black heading window, with labels for each column in browser") (|replace| (FILEBROWSER HEADINGWINDOW) |of| BROWSER |with| (SETQ HEADINGWINDOW (FB.MAKEHEADINGWINDOW BROWSERWINDOW BROWSERWIDTH BROWSERFONTHEIGHT FB.BROWSERFONT)))) (PROGN (* \; "Atop that is the counter window, whose title contains the file pattern") (FB.MAKECOUNTERWINDOW BROWSERWINDOW TITLEFONT BROWSERWIDTH COUNTERHEIGHT TITLE)) (PROGN (* \; "Main command menu sits on the right side") (SETQ COMMANDMENUWINDOW (MENUWINDOW COMMANDMENU)) (ATTACHWINDOW COMMANDMENUWINDOW BROWSERWINDOW (QUOTE RIGHT) (QUOTE TOP))) (PROGN (* \; "Finally the prompt window atop it all") (|replace| (FILEBROWSER PROMPTWINDOW) |of| BROWSER |with| (FB.MAKERIGIDWINDOW (GETPROMPTWINDOW BROWSERWINDOW FB.PROMPTLINES FB.PROMPTFONT)))) (PROGN (* \; "Now make them all open. For some reason, attaching the menu didn't open it") (TOTOPW BROWSERWINDOW)) (|replace| (FILEBROWSER ABORTWINDOW) |of| BROWSER |with| (CONS (MENUWINDOW (|create| MENU ITEMS _ (QUOTE (("--Abort--" NIL "Abort the current FileBrowser operation"))) CENTERFLG _ T MENUOUTLINESIZE _ 2 MENUFONT _ (FONTCOPY FB.MENUFONT (QUOTE WEIGHT) (QUOTE BOLD)) WHENSELECTEDFN _ (FUNCTION FB.HANDLE.ABORT.BUTTON))) COMMANDMENUWINDOW)) (|for| W |in| (LIST COMMANDMENUWINDOW (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER)) (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) |bind| OLDCOMS |when| (LISTP (SETQ OLDCOMS (WINDOWPROP W (QUOTE PASSTOMAINCOMS)))) |do| (* \; "Make all these subwindows pass hardcopy on to the main window") (WINDOWPROP W (QUOTE PASSTOMAINCOMS) (UNION (QUOTE (HARDCOPYIMAGEW)) OLDCOMS))) (|replace| (FILEBROWSER TABLEBROWSER) |of| BROWSER |with| (TB.MAKE.BROWSER NIL BROWSERWINDOW (LIST (QUOTE PRINTFN) (FUNCTION FB.PRINTFN) (QUOTE COPYFN) (FUNCTION FB.COPYFN) (QUOTE USERDATA) BROWSER (QUOTE CLOSEFN) (FUNCTION FB.CLOSEFN) (QUOTE AFTERCLOSEFN) (FUNCTION FB.AFTERCLOSEFN) (QUOTE HEADINGWINDOW) HEADINGWINDOW))) (WINDOWPROP BROWSERWINDOW (QUOTE HARDCOPYFN) (FUNCTION FB.HARDCOPY.DIRECTORY)) (WINDOWPROP BROWSERWINDOW (QUOTE ICONFN) (FUNCTION FB.ICONFN)) (|if| (SETQ FILESPEC (|if| FILESPEC |then| (DIRECTORY.FILL.PATTERN FILESPEC) |else| (FB.STARTUP BROWSER COMMANDMENU (FUNCTION FB.GET.NEWPATTERN)))) |then| (* \; "Have a pattern to work with. Now enumerate it in a new process.") (FB.SETNEWPATTERN BROWSER FILESPEC) (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FB.STARTUP)) (QUOTE (\\\, BROWSER)) (QUOTE (\\\, COMMANDMENU)) (QUOTE (\\\, (FUNCTION FB.UPDATEBROWSERITEMS))))) (QUOTE NAME) (QUOTE |FB-Update|) (QUOTE BEFOREEXIT) (QUOTE DON\'T))) (RETURN BROWSERWINDOW))) +) (FB.TABLEBROWSER +(LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:13 by bvm:") (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER)))) +) (FB.SELECTEDFILES +(LAMBDA (BROWSER NOERRORFLG) (* \; "Edited 29-Jan-88 12:38 by bvm") (* |;;| "User entry to get the set of selected files, as tableitems, from a filebrowser. If NOERRORFLG is NIL, will print a message if no files are selected.") (COND ((TB.COLLECT.ITEMS (|ffetch| (FILEBROWSER TABLEBROWSER) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER))) (QUOTE SELECTED))) ((NOT NOERRORFLG) (FB.PROMPTWPRINT BROWSER T "No files are selected") NIL))) +) (FB.FETCHFILENAME +(LAMBDA (ITEM) (* \; "Edited 29-Jan-88 12:37 by bvm") (* |;;| "User entry to get filename from a browser tableitem.") (|fetch| (FBFILEDATA FILENAME) |of| (|ffetch| TIDATA |of| (\\DTEST ITEM (QUOTE TABLEITEM))))) +) (FB.PROMPTWPRINT +(LAMBDA U (* \; "Edited 4-Feb-88 23:08 by bvm:") (COND ((< U 2) (ERROR "not enough args to PROMPTWPRINT")) (T (LET ((WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST (ARG U 1) (QUOTE FILEBROWSER)))) THING) (* \; "CAR is window, CDR is height in lines") (|for| ITEM |from| 2 |to| U |do| (SELECTQ (SETQ THING (ARG U ITEM)) (T (TERPRI WINDOW)) (CLEAR (CLEARW WINDOW)) (FRESH (FRESHLINE WINDOW)) (PRIN1 THING WINDOW))))))) +) (FB.PROMPTW.FORMAT +(CL:LAMBDA (BROWSER FORMAT-STRING &REST ARGS) (* \; "Edited 4-Feb-88 23:15 by bvm:") (* |;;| "Outputs to FOLDER's prompt window using FORMAT.") (LET ((*PRINT-CASE* :UPCASE) (*PRINT-BASE* 10) (WINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER))))) (* |;;| "*PRINT-CASE* is bound so symbols get printed in \"expected\" case. *PRINT-BASE* is 10 for benefit of printing numbers in the non-format case.") (CL:APPLY (FUNCTION CL:FORMAT) WINDOW FORMAT-STRING ARGS))) +) (FB.PROMPTFORINPUT (LAMBDA (PROMPT DEFAULT BROWSER ABORTFLG DONTCLEAR) (* \; "Edited 22-Nov-88 15:33 by bvm") (* |;;;| "Prompt for input for browser BROWSER with question PROMPT offering default answer DEFAULT. If ABORTFLG is true and response is NIL, prints '... aborted'") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST BROWSER 'FILEBROWSER))) (PROMPTWIDTH (STRINGWIDTH PROMPT PWINDOW)) (WINDOWWIDTH (WINDOWPROP PWINDOW 'WIDTH)) RESULT) (COND (DONTCLEAR (FRESHLINE PWINDOW)) (T (CLEARW PWINDOW))) (COND ((> (+ PROMPTWIDTH (STRINGWIDTH (OR DEFAULT "XXX") PWINDOW)) WINDOWWIDTH) (* |;;| "Prompt plus default response will overflow the width of the window, so be a nice guy and break it up") (|for| I |from| (- (NCHARS PROMPT) 4) |to| 10 |by| -1 |bind| (EXCESSWIDTH _ (- PROMPTWIDTH WINDOWWIDTH)) |when| (AND (EQ (NTHCHARCODE PROMPT I) (CHARCODE SPACE)) (> (STRINGWIDTH (SUBSTRING PROMPT I) PWINDOW) EXCESSWIDTH)) |do| (RETURN (SETQ PROMPT (CONCAT (SUBSTRING PROMPT 1 (SUB1 I)) (CONSTANT (CHARACTER (CHARCODE CR))) (SUBSTRING PROMPT (ADD1 I)))))))) (SETQ RESULT (CAR (NLSETQ (TTYINPROMPTFORWORD PROMPT DEFAULT NIL PWINDOW NIL 'TTY (CHARCODE (CR)))))) (WINDOWPROP PWINDOW 'PROCESS NIL) (* \;  "Get rid of process from prompt window") (COND ((AND (NULL RESULT) ABORTFLG) (PRINTOUT PWINDOW "... aborted"))) (TERPRI PWINDOW) RESULT))) (FB.YES-OR-NO-P +(LAMBDA (PROMPT FBROWSER DEFAULT) (* \; "Edited 22-Nov-88 15:30 by bvm") (* |;;| "Return Y, N or NIL, indicating whether response to question is Yes, No or some kind of abort") (LET ((ANSWER (FB.PROMPTFORINPUT PROMPT (SELECTQ DEFAULT (Y "Yes") (N "No") NIL) FBROWSER T T))) (COND ((NULL ANSWER) (* \; "Aborted") NIL) ((OR (STRING-EQUAL ANSWER "YES") (STRING-EQUAL ANSWER "Y")) (QUOTE Y)) ((OR (STRING-EQUAL ANSWER "NO") (STRING-EQUAL ANSWER "N")) (QUOTE N)) (T (FB.PROMPTWPRINT FBROWSER "?? ...Aborted.") (* \; "Confused somehow") NIL)))) +) (FB.ALLOW.ABORT +(LAMBDA (BROWSER) (* \; "Edited 4-Feb-88 23:11 by bvm:") (* |;;| "Arranges that this browser have an abort button armed. Must be called underneath a FileBrowser command, so that the cleanup in fb.make.browser.busy is enabled.") (|freplace| (FILEBROWSER UPDATEPROC) |of| (\\DTEST BROWSER (QUOTE FILEBROWSER)) |with| (THIS.PROCESS)) (LET ((W (|ffetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) (|if| (NOT (OPENWP (CAR W))) |then| (ATTACHWINDOW (CAR W) (CDR W) (QUOTE BOTTOM)) (* \; "And repaint it in case it was used last time") (REDISPLAYW (CAR W))))) +) (\\FB.HARDCOPY.TOFILE.EXTENSION +(LAMBDA NIL (* \; "Edited 25-Feb-91 15:15 by gadener") (LET ((TYPE (PRINTERTYPE))) (CASE TYPE (INTERPRESS (QUOTE IP)) (POSTSCRIPT (QUOTE PS)) (DEFAULT TYPE)))) +) ) (* \; "Setup") (DEFINEQ (FB.STARTUP +(LAMBDA (BROWSER COMMANDMENU FN) (* \; "Edited 21-Jan-88 17:53 by bvm") (* |;;| "Apply FN to browser with Recompute grayed out.") (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER (FASSOC (QUOTE |Recompute|) (|fetch| (MENU ITEMS) |of| COMMANDMENU)) COMMANDMENU) (CL:FUNCALL FN BROWSER))) +) (FB.MAKERIGIDWINDOW +(LAMBDA (WINDOW) (* |bvm:| "22-Jul-85 16:14") (* |;;;| "make the argument window immutable w/r/to attachedwindow package") (LET ((HEIGHT (|fetch| (REGION HEIGHT) |of| (WINDOWPROP WINDOW (QUOTE REGION))))) (WINDOWPROP WINDOW (QUOTE MINSIZE) (CONS 0 HEIGHT)) (WINDOWPROP WINDOW (QUOTE MAXSIZE) (CONS SCREENWIDTH HEIGHT)) WINDOW)) +) ) (DEFINEQ (FB.PRINTFN +(LAMBDA (TBROWSER ITEM WINDOW) (* \; "Edited 30-Aug-94 19:12 by jds") (LET ((FBROWSER (TB.USERDATA TBROWSER)) (FDATA (|fetch| TIDATA |of| ITEM)) (STREAM (WINDOWPROP WINDOW (QUOTE DSP))) NEXTPOS INFO OLDFONT) (COND ((|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) (PRIN3 " " STREAM) (|if| FB.BROWSER.DIRECTORY.FONT |then| (SETQ OLDFONT (DSPFONT FB.BROWSER.DIRECTORY.FONT STREAM))))) (LET* ((FILENAME (|fetch| (FBFILEDATA FILENAME) |of| FDATA)) (OFF (|ffetch| (STRINGP OFFST) |of| FILENAME)) (BASE (|ffetch| (STRINGP BASE) |of| FILENAME)) (FATP (|ffetch| (STRINGP FATSTRINGP) |of| FILENAME)) (END (+ OFF (|ffetch| (STRINGP LENGTH) |of| FILENAME))) C) (* |;;| "This loop is a performance optimization so I don't have to cons up a substring in the display loop. This is essentially (for c instring (fetch (fbfiledata filename) of fdata) do (\\outchar stream c)), except that I want to start at STARTOFPNAME rather than 1.") (* |;;| "Slow version: (prin3 (fetch (fbfiledata printname) of fdata) stream), except it doesn't let me intercept cr's.") (|add| OFF (- (|fetch| (FBFILEDATA STARTOFPNAME) |of| FDATA) 2)) (* \; "Skip to start of name to print") (|while| (< (|add| OFF 1) END) |do| (SETQ C (COND (FATP (\\GETBASEFAT BASE OFF)) (T (\\GETBASETHIN BASE OFF)))) (\\OUTCHAR STREAM (|if| (EQ C (CHARCODE CR)) |then| (* \; "make it a blotch instead of new line #o377 is in char set 0, but is an illegal char, so can't have a glyph") 255 |else| C)))) (SETQ NEXTPOS (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER)) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INFO |in| (|fetch| (FBFILEDATA FILEINFO) |of| FDATA) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| FBROWSER)) FORMAT ACTUALNEXT XPOS |do| (COND (INFO (* \; "Make sure there's always some space before next item") (PRIN3 " " STREAM))) (SETQ XPOS (DSPXPOSITION NIL STREAM)) (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) (SETQ ACTUALNEXT (COND ((AND (LISTP FORMAT) (FIXP INFO)) (* \; "Get numbers to line up right justified") (IMAX (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH INFO FONT)) XPOS)) (T (* \; "All other fields are left-justified") NEXTPOS))) (COND ((< XPOS ACTUALNEXT) (* \; "Clear any previous junk between last position and start of field") (|if| (AND INFO (EQ FORMAT (QUOTE DATE)) (EQ (CHCON1 INFO) (CHARCODE SPACE))) |then| (* \; "Small nicety for variable-width font: account for the difference between a space and a digit, so that dates line up a little better") (|add| ACTUALNEXT (- (CHARWIDTH (CHARCODE 9) FONT) (CHARWIDTH (CHARCODE SPACE) FONT)))) (TB.CLEAR.LINE TBROWSER ITEM XPOS (- ACTUALNEXT XPOS)) (DSPXPOSITION ACTUALNEXT STREAM))) (COND (INFO (PRIN3 INFO STREAM))) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC))) (TB.CLEAR.LINE TBROWSER ITEM (DSPXPOSITION NIL STREAM)) (AND OLDFONT (DSPFONT OLDFONT STREAM)))) +) (FB.COPYFN +(LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (BKSYSBUF (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM)))) +) ) (* \; "commands and major subfunctions") (DEFINEQ (FB.MENU.WHENSELECTEDFN +(LAMBDA (ITEM MENU KEY) (* \; "Edited 21-Jan-88 11:40 by bvm") (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FB.COMMANDSELECTEDFN)) (QUOTE (\\\, ITEM)) (QUOTE (\\\, MENU)) (QUOTE (\\\, KEY)))) (QUOTE NAME) (PACK* (QUOTE FB-) (CAR ITEM)) (QUOTE BEFOREEXIT) (QUOTE DON\'T))) +) (FB.COMMANDSELECTEDFN +(LAMBDA (ITEM MENU KEY) (* \; "Edited 12-Jan-87 12:57 by bvm:") (RESETLST (LET* ((REALITEM ITEM) (WINDOW (WINDOWPROP (WFROMMENU MENU) (QUOTE MAINWINDOW))) (FBROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER)))) (COND ((NOT (MEMBER ITEM (|fetch| (MENU ITEMS) |of| MENU))) (* \; "A subitem -- fetch main item") (SETQ ITEM (|for| I |in| (|fetch| (MENU ITEMS) |of| MENU) |thereis| (FB.SUBITEMP ITEM I))))) (COND ((FB.MAKE.BROWSER.BUSY FBROWSER ITEM MENU) (LET ((FN (CADR REALITEM)) (PWINDOW (|fetch| (FILEBROWSER PROMPTWINDOW) |of| FBROWSER)) EXTRA) (COND ((OPENWP PWINDOW) (CLEARW PWINDOW))) (COND ((LISTP FN) (SETQ EXTRA (CADR FN)) (SETQ FN (CAR FN)))) (CL:FUNCALL FN FBROWSER KEY REALITEM MENU EXTRA))) (T (* \; "Used to be (FB.PROMPTWPRINT WINDOW 'This filebrowser is busy') but that trashes the prompt window") (FLASHWINDOW WINDOW)))))) +) (FB.SUBITEMP +(LAMBDA (SUBITEM ITEM) (* |bvm:| "22-Jul-85 15:08") (* |;;;| "True if SUBITEM appears among the subitems of ITEM or descendents") (LET ((SUB (CADDDR ITEM))) (AND SUB (EQ (CAR (LISTP SUB)) (QUOTE SUBITEMS)) (OR (MEMBER SUBITEM SUB) (|for| I |in| (CDR SUB) |thereis| (FB.SUBITEMP SUBITEM I)))))) +) (FB.MAKE.BROWSER.BUSY +(LAMBDA (BROWSER ITEM MENU DONTWAIT) (* \; "Edited 1-Feb-88 16:43 by bvm:") (* |;;;| "Makes browser 'busy' doing ITEM of MENU. Must be called under RESETLST") (COND ((OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| BROWSER) DONTWAIT T) (RESETSAVE NIL (LIST (FUNCTION FB.FINISH.COMMAND) BROWSER ITEM MENU)) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE)) T))) +) (FB.FINISH.COMMAND +(LAMBDA (BROWSER ITEM MENU) (* \; "Edited 1-Feb-88 16:34 by bvm:") (* |;;| "Cleanup after generic command on BROWSER. ITEM and MENU (optional) specify the shaded item. This is called under a RESETLST by anyone calling FB.MAKE.BROWSER.BUSY, but needs to be called explicitly by anyone who closes/shrinks the window before that cleanup would happen.") (|replace| (FILEBROWSER UPDATEPROC) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| NIL) (LET ((W (CAR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER))) M) (|if| (OPENWP W) |then| (* \; "Take down the abort button if there was one") (SHADEITEM (CAR (|fetch| (MENU ITEMS) |of| (SETQ M (CAR (WINDOWPROP W (QUOTE MENU)))))) M FB.ITEMUNSELECTEDSHADE) (DETACHWINDOW W) (CLOSEW W))) (|if| ITEM |then| (SHADEITEM ITEM MENU FB.ITEMUNSELECTEDSHADE)) (COND (RESETSTATE (FB.PROMPTWPRINT BROWSER "...command aborted.")))) +) (FB.HANDLE.ABORT.BUTTON +(LAMBDA (ITEM MENU) (* \; "Edited 27-Jan-88 23:38 by bvm") (* |;;| "Called when the ABORT button on a Filebrowser is pressed.") (LET ((BROWSER (WINDOWPROP (MAINWINDOW (WFROMMENU MENU) T) (QUOTE FILEBROWSER))) PROC) (|if| (AND BROWSER (SETQ PROC (|fetch| (FILEBROWSER UPDATEPROC) |of| BROWSER)) (NOT (|fetch| (FILEBROWSER ABORTING) |of| BROWSER))) |then| (* \; "We're connected to a browser, there's a process running, and it's not already aborting") (SHADEITEM ITEM MENU FB.ITEMSELECTEDSHADE) (|replace| (FILEBROWSER ABORTING) |of| BROWSER |with| T) (DEL.PROCESS PROC)))) +) ) (DEFINEQ (FB.DELETECOMMAND +(LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.DELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER)) +) (FB.DELVERCOMMAND +(LAMBDA (FBROWSER) (* \; "Edited 15-Feb-91 17:19 by gadener") (LET (NVERSIONS TBROWSER NDELETED FILES) (|if| (EQ (SETQ NVERSIONS (MENU (|create| MENU TITLE _ "Versions to keep ?" ITEMS _ FB.VERSION.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NVERSIONS (RNUMBER "Number of versions to keep ?" NIL NIL NIL T NIL T))) (COND ((NOT NVERSIONS) NIL) ((NOT (FIXP (SETQ NVERSIONS (MKATOM NVERSIONS)))) (FB.PROMPTW.FORMAT FBROWSER "~%?? ~A not an integer." NVERSIONS)) ((EQ NVERSIONS 0) NIL) (T (SETQ FILES (TB.COLLECT.ITEMS (SETQ TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (FUNCTION (LAMBDA (BROWSER ITEM) (* \; "Collect everything that is not a directory item and that has an actual version (to avoid unix lossage)") (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (NOT (NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| ITEM))))))))) (SETQ NDELETED (FB.DELVER.FILES TBROWSER (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))) NVERSIONS)) (FB.UPDATE.COUNTERS FBROWSER (QUOTE DELETED)) (FB.PROMPTW.FORMAT FBROWSER "~%Done, ~D files marked for deletion." NDELETED))))) +) (FB.IS.NOT.SUBDIRECTORY.ITEM +(LAMBDA (BROWSER ITEM) (* |bvm:| "13-Oct-85 16:51") (NOT (|fetch| TIUNSELECTABLE |of| ITEM)))) (FB.DELVER.FILES +(LAMBDA (TBROWSER FILES NVERSIONS) (* |bvm:| "15-Oct-85 00:20") (|for| FILE |in| FILES |bind| (\#DELETED _ 0) (\#SEENSOFAR _ 0) THISNAME LASTNAME |do| (* \; "Files now all lined up, decreasing version. Just pass by NVERSIONS of each file") (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| FILE))) LASTNAME) (COND ((GREATERP (|add| \#SEENSOFAR 1) NVERSIONS) (COND ((FB.DELETE.FILE TBROWSER FILE) (|add| \#DELETED 1)))))) (T (SETQ LASTNAME THISNAME) (SETQ \#SEENSOFAR 1))) |finally| (RETURN \#DELETED))) +) (FB.DELETE.FILE +(LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((NOT (|fetch| TIDELETED |of| ITEM)) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.DELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) 1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE))) T)))) +) ) (DEFINEQ (FB.UNDELETECOMMAND +(LAMBDA (BROWSER) (* |bvm:| "12-Sep-85 15:44") (TB.MAP.SELECTED.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER)) +) (FB.UNDELETEALLCOMMAND +(LAMBDA (BROWSER) (* |bvm:| "18-Sep-85 12:20") (TB.MAP.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION FB.UNDELETE.FILE)) (FB.UPDATE.COUNTERS BROWSER)) +) (FB.UNDELETE.FILE +(LAMBDA (TBROWSER ITEM) (* |bvm:| "13-Oct-85 17:44") (COND ((|fetch| TIDELETED |of| ITEM) (LET ((FBROWSER (TB.USERDATA TBROWSER)) SIZE) (TB.UNDELETE.ITEM TBROWSER ITEM) (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) -1) (COND ((SETQ SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) (IMINUS SIZE)))))))) +) ) (DEFINEQ (FB.COPYCOMMAND +(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 17:44 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Copy|) (CONS (FUNCTION COPYFILE)))) +) (FB.RENAMECOMMAND +(LAMBDA (BROWSER) (* \; "Edited 19-Oct-90 18:57 by gadener") (FB.COPY/RENAME.COMMAND BROWSER (QUOTE |Rename|) (CONS (FUNCTION RENAMEFILE)))) +) (FB.COPY/RENAME.COMMAND +(LAMBDA (FBROWSER CMD MOVEFN) (* \; "Edited 28-Jan-88 00:27 by bvm") (LET ((*UPPER-CASE-FILE-NAMES* NIL) (FILELIST (FB.SELECTEDFILES FBROWSER))) (|if| FILELIST |then| (FB.ALLOW.ABORT FBROWSER) (COND ((CDR FILELIST) (FB.COPY/RENAME.MANY FBROWSER FILELIST CMD MOVEFN)) (T (* \; "Just one file") (LET* ((OLDNAME (FB.FETCHFILENAME (CAR FILELIST))) (NEWNAME (FB.GET.NEW.FILE.SPEC OLDNAME FBROWSER CMD))) (COND (NEWNAME (FB.COPY/RENAME.ONE FBROWSER (CAR FILELIST) OLDNAME NEWNAME CMD MOVEFN))))))))) +) (FB.COPY/RENAME.ONE +(LAMBDA (FBROWSER ITEM OLDNAME NEWNAME CMD MOVEFN) (* \; "Edited 19-Oct-90 17:50 by gadener") (* |;;;| "Copies or renames a single file ITEM from OLDNAME to NEWNAME and updates browser accordingly") (CL:MULTIPLE-VALUE-BIND (ACTUALNEWNAME CONDITION) (IGNORE-ERRORS (CL:FUNCALL (CAR MOVEFN) OLDNAME NEWNAME (CDR MOVEFN))) (COND (ACTUALNEWNAME (FB.PROMPTW.FORMAT FBROWSER "~%~A ~Aed to ~A" OLDNAME (SELECTQ CMD (|Copy| "copi") (|Rename| "renam") (SHOULDNT)) ACTUALNEWNAME) (LET ((CHANGETYPE (COND ((EQ CMD (QUOTE |Rename|)) (FB.REMOVE.FILE (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER) FBROWSER ITEM) (COND ((|fetch| TIDELETED |of| ITEM) (QUOTE BOTH)) (T (QUOTE TOTAL))))))) (COND ((FB.MAYBE.INSERT.FILE FBROWSER ACTUALNEWNAME ITEM CMD) (* \; "ACTUALNEWNAME belongs in this browser, so TOTAL may have changed") (OR CHANGETYPE (SETQ CHANGETYPE (QUOTE TOTAL))))) (COND (CHANGETYPE (FB.UPDATE.COUNTERS FBROWSER CHANGETYPE))))) (T (FB.PROMPTW.FORMAT FBROWSER "~%Could not ~(~A~) ~A ~A ~A" CMD OLDNAME (|if| CONDITION |then| "because" |else| "to") (OR CONDITION NEWNAME)))))) +) (FB.COPY/RENAME.MANY +(LAMBDA (FBROWSER FILELIST CMD MOVEFN) (* \; "Edited 22-Jan-94 20:24 by ") (PROG (PREFIX OLDNAME FIELDS SUBDIR FIRSTDATA RETAIN HOST DIR DEVICE) (COND ((NULL (SETQ PREFIX (FB.PROMPTFORINPUT (CONCAT CMD " " (LENGTH FILELIST) " files to which directory? ") (OR (|fetch| (FILEBROWSER DEFAULTDIR) |of| FBROWSER) (DIRECTORYNAME T)) FBROWSER T))) (* \; "Aborted")) ((STRPOS "*" PREFIX) (FB.PROMPTWPRINT FBROWSER "Sorry, patterns not supported")) ((AND (OR (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) (QUOTE HOST)) (LISTGET FIELDS (QUOTE DIRECTORY)) (LISTGET FIELDS (QUOTE DEVICE))) (OR (LISTGET FIELDS (QUOTE NAME)) (LISTGET FIELDS (QUOTE EXTENSION)) (LISTGET FIELDS (QUOTE VERSION)))) (* \; "Not a pure directory specification, and not just a simple directory name") (FB.PROMPTWPRINT FBROWSER "Not a well-formed directory specification.")) ((SETQ PREFIX (FB.CANONICAL.DIRECTORY (\\ADD.CONNECTED.DIR PREFIX) FBROWSER CMD)) (SETQ HOST (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING PREFIX)) (QUOTE HOST))) (SETQ DIR (OR (LISTGET FIELDS (QUOTE DIRECTORY)) (LISTGET FIELDS (QUOTE RELATIVEDIRECTORY)))) (SETQ DEVICE (LISTGET FIELDS (QUOTE DEVICE))) (|replace| (FILEBROWSER DEFAULTDIR) |of| FBROWSER |with| PREFIX) (* |;;| "First scan to see if the files are in multiple subdirectories, since then it's unclear how the new files should be named.") (SETQ FIRSTDATA (|fetch| TIDATA |of| (CAR FILELIST))) (COND ((|for| ITEM |in| (CDR FILELIST) |thereis| (NOT (EQ.DIRECTORYP FIRSTDATA (|fetch| TIDATA |of| ITEM)))) (SETQ SUBDIR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| FIRSTDATA)) (FB.PROMPTWPRINT FBROWSER "Selected files are in multiple subdirectories") (SETQ RETAIN (SELECTQ (FB.YES-OR-NO-P (CONCAT "Retain subdirectory names below level of " (|for| ITEM |in| (CDR FILELIST) |repeatwhile| (SETQ SUBDIR (FB.GREATEST.PREFIX SUBDIR (|fetch| (FBFILEDATA FILENAME) |of| (|fetch| TIDATA |of| ITEM)))) |finally| (RETURN (OR SUBDIR (SETQ SUBDIR (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER))))))) "?") FBROWSER (QUOTE Y)) (NIL (* \; "Aborted") (RETURN)) (Y (SETQ SUBDIR (ADD1 (NCHARS SUBDIR))) (* \; "First character that changes") T) NIL)))) (* |;;| "Now make sure the files are sorted by increasing version, so that multiple versions get copied in the right order") (SELECTQ (|fetch| (FILEBROWSER SORTBY) |of| FBROWSER) (FB.NAMES.INCREASING.VERSION (* \; "Okay")) (FB.NAMES.DECREASING.VERSION (SETQ FILELIST (FB.SORT.VERSIONS FILELIST (FUNCTION FB.INCREASING.VERSION)))) (SORT FILELIST (FUNCTION FB.NAMES.INCREASING.VERSION))) (|for| ITEM |in| FILELIST |do| (FB.COPY/RENAME.ONE FBROWSER ITEM (SETQ OLDNAME (FB.FETCHFILENAME ITEM)) (PACKFILENAME.STRING (QUOTE HOST) HOST (QUOTE DEVICE) DEVICE (QUOTE DIRECTORY) (|if| (NOT RETAIN) |then| DIR |else| (* \; "Merge destination directory with subdirectory of name between common prefix and root") (FB.MERGE.DIRECTORIES DIR (SUBSTRING OLDNAME SUBDIR (SUB1 (|fetch| (FBFILEDATA STARTOFNAME) |of| (|fetch| TIDATA |of| ITEM)))))) (QUOTE VERSION) NIL (QUOTE BODY) OLDNAME) CMD MOVEFN)))))) +) (FB.MERGE.DIRECTORIES +(LAMBDA (PREFIX RETAIN) (* \; "Edited 22-Jun-90 11:29 by nm") (COND (PREFIX (|if| RETAIN |then| (CONCAT PREFIX (CL:SECOND \\FILENAME.SYNTAX) RETAIN) |else| PREFIX)) (T (|if| RETAIN |then| RETAIN |else| NIL)))) +) (FB.GREATEST.PREFIX +(LAMBDA (DIR FILENAME) (* \; "Edited 25-Jan-88 16:37 by bvm") (* |;;;| "Greatest common directory prefix of DIR and FILENAME") (AND DIR FILENAME (COND ((STRPOS DIR FILENAME 1 NIL T NIL UPPERCASEARRAY) (* \; "DIR is prefix of FILENAME") DIR) (T (|for| I |from| 1 |bind| LASTDIR C |do| (|if| (OR (NULL (SETQ C (NTHCHARCODE DIR I))) (NEQ C (NTHCHARCODE FILENAME I))) |then| (* \; "Came to end of DIR or a non-matching character. Return the substring of DIR up to the last directory delimiter we saw.") (RETURN (AND LASTDIR (SUBSTRING DIR 1 LASTDIR))) |else| (SELCHARQ C ((/ >) (* \; "end of a subdirectory") (SETQ LASTDIR I)) NIL))))))) +) (FB.MAYBE.INSERT.FILE +(LAMBDA (FBROWSER NEWNAME OLDITEM CMD) (* \; "Edited 19-Oct-90 12:32 by gadener") (* |;;;| "If NEWNAME matches the pattern of files displayed in FBROWSER, insert it in that browser and return T. OLDITEM is the tableitem that formed the source of NEWNAME. CMD is the command that created NEWNAME -- Copy or Rename") (LET ((*UPPER-CASE-FILE-NAMES* NIL) FILEINFO N FULLNAME CRDATE CRDATE2 VERSION NEWDATA NEWITEM FILE-UNCERTAIN) (COND ((AND (DIRECTORY.MATCH (|fetch| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER) NEWNAME) (* |;;| "Need to check that at least the FB pattern is not longer than the NEWNAME") (GEQ (NCHARS NEWNAME) (SETQ N (SUB1 (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER)))) (* |;;| "Checks for match up to where the directory part start. i.e. the host part") (STRING-EQUAL NEWNAME (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) :END1 N :END2 N)) (* |;;| "NEWNAME belongs in this browser, so add it. First create some attributes for it") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER NEWNAME (SETQ FILEINFO (COND (OLDITEM (* \; "Info from old item will do for starters") (APPEND (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| OLDITEM)))) (T (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |collect| (GETFILEINFO NEWNAME (CAR ATTR)))))))) (COND ((NULL.VERSIONP (|fetch| (FBFILEDATA VERSION) |of| NEWDATA)) (* |;;| "Grumble. IFS version of Rename does not return a full file name, due to shortcoming in ftp protocol, so we won't know the version. Best we can do is assume that it's the newest version. If creation date of old file is available, verify that they agree") (|if| (NULL (SETQ FULLNAME (INFILEP NEWNAME))) |then| (* \; "Can't find file?") (SETQ FILE-UNCERTAIN T) |elseif| (NULL (SETQ VERSION (UNPACKFILENAME.STRING FULLNAME (QUOTE VERSION) NIL (QUOTE TENEX)))) |then| (* \; "Was versionless file after all, say Unix. Nothing to do. Pass TENEX as ostype because we know the name was in canonical form from device, and don't want periods turned spuriously into semi-colons") |elseif| (OR (NULL (SETQ CRDATE (CL:POSITION (QUOTE CREATIONDATE) (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER)))) (NULL (SETQ CRDATE (CL:NTH CRDATE FILEINFO))) (AND (SETQ CRDATE (IDATE CRDATE)) (SETQ CRDATE2 (GETFILEINFO FULLNAME (QUOTE ICREATIONDATE))) (= CRDATE2 CRDATE))) |then| (* \; "Assume we're right about it being newest version") (SETQ NEWDATA (FB.CREATE.FILEBUCKET FBROWSER (SETQ NEWNAME (PROGN (* \; "Canonicalize NEWNAME -- some cases where final period was left out") (PACKFILENAME.STRING (QUOTE BODY) NEWNAME (QUOTE EXTENSION) "" (QUOTE VERSION) VERSION))) FILEINFO)) |else| (SETQ FILE-UNCERTAIN T)))) (SETQ NEWITEM (|create| TABLEITEM TIDATA _ NEWDATA)) (|if| OLDITEM |then| (* \; "Update info--some is same as old file, some is new") (|for| TAIL |on| FILEINFO |as| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |unless| (SELECTQ (CAR SPEC) (AUTHOR (* \; "Rename usually preserves this, but Copy sometimes changes it") (EQ CMD (QUOTE |Rename|))) ((CREATIONDATE SIZE LENGTH TYPE BYTESIZE) (* \; "These are preserved by both copy and rename, assuming that the source and destination device are the same") T) (PROGN (* \; "Read and Write dates are generally changed. Also, conservatively assume that Copy/Rename could change any attribute we don't know about") NIL)) |do| (RPLACA TAIL (AND (NOT FILE-UNCERTAIN) (GETFILEINFO NEWNAME (CAR SPEC))))) (COND ((AND (EQ CMD (QUOTE |Rename|)) (|fetch| TISELECTED |of| OLDITEM)) (* \; "If old item was selected, keep the renamed version selected as well") (|replace| TISELECTED |of| NEWITEM |with| T)))) (FB.INSERT.FILE FBROWSER NEWITEM) T)))) +) (FB.GET.NEW.FILE.SPEC +(LAMBDA (OLDNAME BROWSER CMD) (* \; "Edited 22-Nov-88 16:55 by bvm") (* |;;| "For Copy and Rename commands, derives a new name to copy/rename to from OLDNAME. PREFIX if given is a DIRECTORY spec; if not given, we prompt for a destination file. Returns NIL if user aborts") (LET (NEWNAME NAMEFIELD FIELDS DIR) (COND ((NULL (SETQ NEWNAME (FB.PROMPTFORINPUT (CONCAT CMD " file " OLDNAME (SELECTQ CMD (|Rename| " to be: ") (|Copy| " to new file name: ") (SHOULDNT))) (PACKFILENAME.STRING (QUOTE DIRECTORY) (OR (|fetch| (FILEBROWSER DEFAULTDIR) |of| BROWSER) (DIRECTORYNAME T)) (QUOTE VERSION) NIL (QUOTE BODY) OLDNAME) BROWSER T))) (* \; "Aborted") NIL) ((NULL (SETQ NAMEFIELD (LISTGET (SETQ FIELDS (UNPACKFILENAME.STRING NEWNAME)) (QUOTE NAME)))) (* \; "Assume directory spec") (SETQ NEWNAME (\\ADD.CONNECTED.DIR NEWNAME)) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| NEWNAME) (PACKFILENAME.STRING (QUOTE DIRECTORY) NEWNAME (QUOTE VERSION) NIL (QUOTE BODY) OLDNAME)) ((AND (EQ (NCHARS NAMEFIELD) 0) (OR (NULL (SETQ NAMEFIELD (LISTGET FIELDS (QUOTE EXTENSION)))) (EQ (NCHARS NAMEFIELD) 0))) (* \; "Directory spec with some more pieces after it?") (FB.PROMPTWPRINT BROWSER "Failed, malformed name") NIL) (T (* \; "A plain old file name") (|for| TAIL |on| FIELDS |by| (CDDR TAIL) |bind| PREVTAIL |do| (SELECTQ (CAR TAIL) ((HOST DIRECTORY DEVICE) (* \; "Keep these")) (RETURN (COND ((EQ TAIL FIELDS) (SETQ FIELDS NIL)) (T (RPLACD (CDR PREVTAIL)))))) (SETQ PREVTAIL TAIL)) (COND ((SETQ DIR (COND (FIELDS (SETQ DIR (PACKFILENAME.STRING FIELDS)) (FB.CANONICAL.DIRECTORY (COND ((NEQ (CAR FIELDS) (QUOTE HOST)) (\\ADD.CONNECTED.DIR DIR)) (T DIR)) BROWSER CMD)) (T (DIRECTORYNAME T)))) (|replace| (FILEBROWSER DEFAULTDIR) |of| BROWSER |with| DIR) (\\ADD.CONNECTED.DIR NEWNAME))))))) +) (FB.CANONICAL.DIRECTORY +(LAMBDA (DIRNAME FBROWSER CMD) (* \; "Edited 22-Nov-88 16:58 by bvm") (LET* ((PWINDOW (|ffetch| (FILEBROWSER PROMPTWINDOW) |of| (\\DTEST FBROWSER (QUOTE FILEBROWSER)))) (OLDTTYSTREAM (TTYDISPLAYSTREAM PWINDOW)) (OLDTTYPROC (TTY.PROCESS (THIS.PROCESS)))) (* \; "Point tty at our prompt window in case DIRECTORYNAME tries to interact") (CL:UNWIND-PROTECT (COND ((DIRECTORYNAME DIRNAME NIL (QUOTE ASK))) ((EQ (FB.YES-OR-NO-P (CL:FORMAT NIL "Directory ~A does not exist yet; ~A anyway?" DIRNAME CMD) FBROWSER) (QUOTE Y)) DIRNAME)) (TTY.PROCESS OLDTTYPROC) (TTYDISPLAYSTREAM OLDTTYSTREAM) (WINDOWPROP PWINDOW (QUOTE PROCESS) NIL)))) +) ) (DEFINEQ (FB.HARDCOPYCOMMAND +(LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 18-Feb-91 10:44 by gadener") (* |;;;| "Produces hardcopy of selected files. Subcommands allow directing output to particular printer, or to a file") (LET ((FILES (FB.SELECTEDFILES BROWSER)) PRINTOPTIONS) (COND ((AND FILES (SELECTQ OPTION (FILE (FB.ALLOW.ABORT BROWSER) (FB.HARDCOPY.TOFILE BROWSER FILES) NIL) (PRINTER (COND ((SETQ PRINTOPTIONS (|GetPrinterName|)) (SETQ PRINTOPTIONS (LIST (QUOTE SERVER) PRINTOPTIONS)) T))) T)) (FB.ALLOW.ABORT BROWSER) (|for| ITEM |in| FILES |do| (LISTFILES1 (FB.FETCHFILENAME ITEM) PRINTOPTIONS)))))) +) (FB.HARDCOPY.TOFILE +(LAMBDA (BROWSER FILES) (* \; "Edited 15-Feb-91 17:13 by gadener") (* |;;| "Handle the \"Hardcopy>To File\" command. ") (PROG ((HCOPYFILE (FB.PROMPTFORINPUT (COND ((CDR FILES) "Hardcopy file name pattern: ") (T "Hardcopy file name: ")) (COND ((CDR FILES) (PACKFILENAME.STRING (QUOTE NAME) (QUOTE *) (QUOTE EXTENSION) (\\FB.HARDCOPY.TOFILE.EXTENSION))) (T (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE EXTENSION) (\\FB.HARDCOPY.TOFILE.EXTENSION) (QUOTE BODY) (FB.FETCHFILENAME (CAR FILES))))) BROWSER T)) HCOPYFIELDS PRINTFILETYPE MSG HCOPYTAIL FORE AFT EXT) (COND ((NULL HCOPYFILE) (RETURN))) (COND ((CDR FILES) (* |;;| "Hardcopying multiple files. Take apart the pattern so we can figure out how to make the destination names. We insist that the * be in the name.") (COND ((|for| TAIL |on| (SETQ HCOPYFIELDS (UNPACKFILENAME.STRING HCOPYFILE)) |by| (CDDR TAIL) |bind| HOST HAVEDIRECTORY I |do| (COND ((SETQ I (STRPOS (QUOTE *) (CADR TAIL))) (|if| (NEQ (CAR TAIL) (QUOTE NAME)) |then| (RETURN (SETQ MSG "Only name portion can contain *"))) (* \; "Take apart name into FORE*AFT") (SETQ HCOPYTAIL (CDR TAIL)) (SETQ FORE (OR (SUBSTRING (CADR TAIL) 1 (SUB1 I)) "")) (SETQ AFT (OR (SUBSTRING (CADR TAIL) (ADD1 I)) ""))) (T (SELECTQ (CAR TAIL) (NAME (RETURN (SETQ MSG "Name must have * for multiple hardcopy files"))) (EXTENSION (SETQ EXT (MKATOM (U-CASE (CADR TAIL))))) (DIRECTORY (SETQ HAVEDIRECTORY T)) (HOST (SETQ HOST (CADR TAIL))) NIL))) |finally| (|if| (AND HOST (NOT HAVEDIRECTORY)) |then| (* \; "E.g., {DSK}*.IP. This pattern explicitly has no directory") (|push| HCOPYFIELDS (QUOTE DIRECTORY) NIL))) (FB.PROMPTWPRINT BROWSER "Bad pattern -- " MSG) (RETURN)))) (T (SETQ EXT (U-CASE (FILENAMEFIELD HCOPYFILE (QUOTE EXTENSION)))))) (COND ((AND (NULL (SETQ PRINTFILETYPE (|for| TYPE |in| PRINTFILETYPES |when| (FMEMB EXT (CADR (ASSOC (QUOTE EXTENSION) (CDR TYPE)))) |do| (* \; "Opencoded PRINTFILETYPE.FROM.EXTENSION because that one's buggy") (RETURN (CAR TYPE))))) (NULL (SETQ PRINTFILETYPE (MENU (|MakeMenuOfImageTypes| "File type?"))))) (RETURN))) (|for| ITEM |in| FILES |bind| (CONVERTERS _ (PRINTFILEPROP PRINTFILETYPE (QUOTE CONVERSION))) FILETYPE NAME FN FIELDS |do| (SETQ ITEM (FB.FETCHFILENAME ITEM)) (SETQ FILETYPE (OR (PRINTFILETYPE ITEM) (QUOTE TEXT))) (COND ((SETQ FN (LISTGET CONVERTERS FILETYPE)) (FB.PROMPTW.FORMAT BROWSER "~%Writing ~A..." (SETQ NAME (COND ((CDR FILES) (SETQ FIELDS (UNPACKFILENAME.STRING ITEM NIL NIL (QUOTE TENEX))) (RPLACA HCOPYTAIL (CONCAT FORE (LISTGET FIELDS (QUOTE NAME)) AFT)) (CL:APPLY (FUNCTION PACKFILENAME.STRING) (QUOTE VERSION) NIL (APPEND HCOPYFIELDS FIELDS))) (T HCOPYFILE)))) (SETQ NAME (CL:FUNCALL FN ITEM NAME)) (COND ((LISTP NAME) (* \; "Result is (SOURCE DESTINATION)") (SETQ NAME (CADR NAME)))) (FB.PROMPTWPRINT BROWSER "done.") (FB.MAYBE.INSERT.FILE BROWSER NAME)) (T (FB.PROMPTW.FORMAT BROWSER "~%Failed to hardcopy ~A -- Can't convert a ~A file to format ~A" ITEM FILETYPE PRINTFILETYPE)))))) +) ) (DEFINEQ (FB.EDITCOMMAND +(LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 1-Feb-88 19:00 by bvm:") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (*UPPER-CASE-FILE-NAMES* _ NIL) |do| (SETQ FILE (FB.FETCHFILENAME FILE)) (CL:MULTIPLE-VALUE-BIND (IGNORE CONDITION) (IGNORE-ERRORS (SELECTQ (OR OPTION FB.DEFAULT.EDITOR) (READONLY (* \; "From SEE command") (COND ((NOT (GETD (QUOTE OPENTEXTSTREAM))) (FB.FASTSEECOMMAND BROWSER KEY ITEM MENU)) (T (RESETLST (LET ((WINDOW (CREATEW NIL FILE)) (STR (OPENSTREAM FILE (QUOTE INPUT)))) (COND ((LISPSOURCEFILEP STR) (RESETSAVE NIL (LIST (QUOTE CLOSEF) STR)) (SETQ STR (LET ((NSTR (OPENTEXTSTREAM))) (COPY.TEXT.TO.IMAGE STR NSTR) NSTR))) ((NOT (RANDACCESSP STR)) (RESETSAVE NIL (LIST (QUOTE CLOSEF) STR)) (SETQ STR (LET ((NSTR (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH) (QUOTE NEW) NIL (LIST (LIST (QUOTE TYPE) (GETFILEINFO STR (QUOTE TYPE))))))) (COPYBYTES STR NSTR) NSTR)))) (OPENTEXTSTREAM STR WINDOW NIL NIL (QUOTE (READONLY T)))))))) (TEDIT (TEDIT (MKATOM FILE))) (LISP (FB.EDITLISPFILE FILE BROWSER)) (NIL (COND ((LISPSOURCEFILEP FILE) (FB.EDITLISPFILE FILE BROWSER)) (T (TEDIT (MKATOM FILE))))) (CL:FUNCALL OPTION (MKATOM FILE)))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION))))) +) (FB.EDITLISPFILE +(LAMBDA (FILE BROWSER) (* \; "Edited 28-Jan-88 00:38 by bvm") (PROG (ROOT) (COND ((OR (NOT (STRING-EQUAL (CDAR (GETPROP (SETQ ROOT (U-CASE (ROOTFILENAME FILE))) (QUOTE FILEDATES))) FILE)) (NOT (GET ROOT (QUOTE FILE))) (NOT (BOUNDP (FILECOMS ROOT)))) (COND ((MOUSECONFIRM (CONCAT "The file " FILE " is not loaded or is not current. (LOAD '" FILE " 'PROP)?") NIL (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER)) (EXEC-EVAL (BQUOTE (LOAD (QUOTE (\\\, FILE)) (QUOTE PROP))))) (T (RETURN))))) (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) (ED ROOT (QUOTE (FILES :DONTWAIT)))))) +) (FB.BROWSECOMMAND +(LAMBDA (BROWSER KEY ITEM MENU OPTION) (* \; "Edited 1-Feb-88 18:31 by bvm:") (* |;;;| "view selected file by sprouting a recursive file browser on it") (FB.ALLOW.ABORT BROWSER) (|for| FILE |in| (FB.SELECTEDFILES BROWSER) |bind| (DEPTH _ (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER)) NAME |do| (SETQ FILE (|fetch| TIDATA |of| FILE)) (SETQ NAME (|fetch| (FBFILEDATA FILENAME) |of| FILE)) (|if| (OR (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| FILE) (AND (NOT (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER)) (LET* ((FIELDS (UNPACKFILENAME.STRING NAME NIL NIL (QUOTE TENEX))) (NAMETAIL (MEMB (QUOTE NAME) FIELDS)) INTERESTING SUBDIR MAINDIR) (* \; "File is not syntactically a directory. Perhaps the device returned foo.;1 instead of foo>. We know ns servers don't do this.") (|for| TAIL |on| NAMETAIL |by| (CDDR TAIL) |do| (|if| (OR (EQ 0 (NCHARS (CADR TAIL))) (AND (EQ (CAR TAIL) (QUOTE VERSION)) (|if| (NEQ (MKATOM (CADR TAIL)) 1) |then| (* \; "It has a version--most unlikely for a directory") (RETURN NIL) |else| T))) |then| (* \; "turn empty or boring fields into omitted fields") (RPLACA (CDR TAIL) NIL) |else| (SETQ INTERESTING T)) |finally| (SETQ FIELDS (LDIFF FIELDS NAMETAIL)) (|if| INTERESTING |then| (* |;;| "Would like just to do (CL:APPLY (function packfilename.string) (nconc fields `(SUBDIRECTORY subdir))), but PACKFILENAME.STRING doesn't seem to know about unix.") (SETQ MAINDIR (LISTGET FIELDS (QUOTE DIRECTORY))) (SETQ SUBDIR (CL:APPLY (FUNCTION PACKFILENAME.STRING) NAMETAIL)) (LISTPUT FIELDS (QUOTE DIRECTORY) (|if| (NULL MAINDIR) |then| SUBDIR |else| (CONCAT MAINDIR (|if| (STRPOS "/" MAINDIR) |then| "/" |elseif| (STRPOS ">" MAINDIR) |then| ">" |elseif| (EQ (GETHOSTINFO (LISTGET FIELDS (QUOTE HOST)) (QUOTE OSTYPE)) (QUOTE UNIX)) |then| (* \; "Resort to GETHOSTINFO only if the name hasn't given it away yet.") "/" |else| ">") SUBDIR)))) (RETURN (DIRECTORYNAMEP (SETQ NAME (CL:APPLY (FUNCTION PACKFILENAME.STRING) FIELDS)))))))) |then| (ADD.PROCESS (BQUOTE ((\\\, (FUNCTION FILEBROWSER)) (QUOTE (\\\, NAME)) (QUOTE (\\\, (MAPCAR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) (FUNCTION CAR)))) (\\\,@ (AND DEPTH (BQUOTE ((QUOTE (:DEPTH (\\\, DEPTH)))))))))) |else| (FB.PROMPTW.FORMAT BROWSER "~A is not a directory" NAME)))) +) ) (DEFINEQ (FB.FASTSEECOMMAND +(LAMBDA (BROWSER KEY ITEM MENU UNFORMATTED) (* \; "Edited 30-Aug-94 19:46 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) FILELIST SEEWINDOW) (OR (SETQ FILELIST (FB.SELECTEDFILES BROWSER)) (RETURN)) (FB.ALLOW.ABORT BROWSER) (COND ((AND (NOT (WINDOWP (SETQ SEEWINDOW (|fetch| (FILEBROWSER SEEWINDOW) |of| BROWSER)))) (FOR FILE IN FILELIST THEREIS (* |;;| "Only need a SEE window if there's going to be a file to really SEE, as opposed to directories to browse.") (OR (UNPACKFILENAME (FB.FETCHFILENAME FILE) (QUOTE NAME)) (UNPACKFILENAME (FB.FETCHFILENAME FILE) (QUOTE EXTENSION))))) (* \; "Create the SEE window") (SETQ SEEWINDOW (CREATEW NIL "SEE window")) (DSPSCROLL T SEEWINDOW) (|replace| (FILEBROWSER SEEWINDOW) |of| BROWSER |with| SEEWINDOW) (WINDOWPROP SEEWINDOW (QUOTE PAGEFULLFN) (FUNCTION FB.SEEFULLFN)) (WINDOWADDPROP SEEWINDOW (QUOTE CLOSEFN) (FUNCTION (LAMBDA (W) (WINDOWPROP W (QUOTE INUSE) NIL) (DEL.PROCESS (WINDOWPROP W (QUOTE PROCESS)))))))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (WINDOW) (WINDOWPROP WINDOW (QUOTE PROCESS) NIL) (* \; "Remove process attached here by ttydisplaystream") (LET ((BUTTONS (WINDOWPROP WINDOW (WINDOWPROP WINDOW (QUOTE MORETYPE))))) (|if| (AND BUTTONS (OPENWP BUTTONS)) |then| (* \; "If More button still open, detach it") (DETACHWINDOW BUTTONS) (CLOSEW BUTTONS))))) SEEWINDOW)) (TTYDISPLAYSTREAM SEEWINDOW) (* \; "Has to be our TTYDISPLAYSTREAM in order for page holding to work") (|for| TAIL |on| FILELIST |do| (CL:CATCH :NEXT (FB.FASTSEE.ONEFILE BROWSER (FB.FETCHFILENAME (CAR TAIL)) SEEWINDOW UNFORMATTED (CDR TAIL)))))) +) (FB.FASTSEE.ONEFILE (LAMBDA (BROWSER FILE WINDOW UNFORMATTED MORE) (* \;  "Edited 20-Nov-2000 14:24 by rmk:") (* \;  "Edited 20-Nov-2000 14:23 by rmk:") (* \; "Edited 19-Aug-91 13:06 by jds") (COND ((OR (UNPACKFILENAME FILE 'NAME) (UNPACKFILENAME FILE 'EXTENSION)) (* |;;| "We're really browsing a file here, so SEE it.") (CLEARW WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT "Viewing " FILE)) (CL:MULTIPLE-VALUE-BIND (STREAM CONDITION) (IGNORE-ERRORS (OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT) (SEQUENTIAL T)))) (|if| CONDITION |then| (* |;;| "Failed on this file. If this was the only file, the message can be a little more terse (which is desirable, because the typical message is \"File not found xxx\")") (FB.PROMPTW.FORMAT BROWSER "~:[Failed~;~:*Couldn't see ~A~] because ~A" (AND MORE FILE) CONDITION) |else| (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STREAM WINDOW) (AND RESETSTATE (OPENWP WINDOW) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Aborted"))) (CLOSEF STREAM))) STREAM WINDOW)) (WINDOWPROP WINDOW 'MORETYPE (COND (MORE 'YETMOREBUTTONS) (T 'LASTMOREBUTTONS))) (COND (UNFORMATTED (COPYCHARS STREAM WINDOW)) (T (PFCOPYBYTES STREAM WINDOW))) (WINDOWPROP WINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'TITLE) " -- " "Finished")) (COND (MORE (* \; "Wait for OK to proceed") (FB.SEEFULLFN (WINDOWPROP WINDOW 'DSP) 'FINISHEDMOREBUTTONS))))))) (T (* |;;| "We're trying to SEE a directory. Browse it instead. ") (FB.BROWSECOMMAND BROWSER))))) (FB.SEEFULLFN +(LAMBDA (DSP PROP) (* |bvm:| "18-Sep-85 23:29") (* |;;| "PAGEFULLFN for a fast SEE window") (LET* ((WINDOW (WFROMDS DSP)) (BUTTONS (WINDOWPROP WINDOW (OR PROP (SETQ PROP (WINDOWPROP WINDOW (QUOTE MORETYPE)))))) (EVENT (WINDOWPROP WINDOW (QUOTE MOREEVENT)))) (COND ((NOT BUTTONS) (SETQ BUTTONS (|create| MENU ITEMS _ (SELECTQ PROP (YETMOREBUTTONS (QUOTE (("More" MORE "View another screenfull of the file") (" Next File " NEXT "Abort view of this file, go on to next one") ("Abort" ABORT "Abort viewing of this and any further files")))) (FINISHEDMOREBUTTONS (QUOTE ((" Next File " NEXT "Go on to view the next file") ("Abort" ABORT "Abort the SEE command -- see no more files")))) (QUOTE ((" More " MORE "View another screenfull of the file") (" Abort " ABORT "Abort view; allow this window to be re-used")))) MENUROWS _ 1 WHENSELECTEDFN _ (FUNCTION FB.SEEBUTTONFN) CENTERFLG _ T)) (SETQ BUTTONS (ADDMENU BUTTONS (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW (|fetch| (MENU IMAGEWIDTH) |of| BUTTONS) FB.MORE.BORDER) (HEIGHTIFWINDOW (|fetch| (MENU IMAGEHEIGHT) |of| BUTTONS) NIL FB.MORE.BORDER)) NIL FB.MORE.BORDER T) NIL T)) (WINDOWPROP WINDOW PROP BUTTONS))) (COND ((NOT EVENT) (WINDOWPROP WINDOW (QUOTE MOREEVENT) (SETQ EVENT (CREATE.EVENT (WINDOWPROP WINDOW (QUOTE TITLE))))))) (ATTACHWINDOW BUTTONS WINDOW (COND ((GREATERP (|fetch| (REGION HEIGHT) |of| (WINDOWPROP BUTTONS (QUOTE REGION))) (|fetch| (REGION BOTTOM) |of| (WINDOWPROP WINDOW (QUOTE REGION)))) (QUOTE TOP)) (T (QUOTE BOTTOM))) (QUOTE LEFT)) (|do| (TOTOPW BUTTONS) (AWAIT.EVENT EVENT) |repeatuntil| (WINDOWPROP WINDOW (QUOTE MOREOK) NIL)))) +) (FB.SEEBUTTONFN +(LAMBDA (ITEM MENU) (* \; "Edited 28-Jan-88 00:05 by bvm") (* |;;;| "WHENSELECTEDFN for the More/Abort menu") (LET* ((MENUW (WFROMMENU MENU)) (WINDOW (MAINWINDOW MENUW))) (DETACHWINDOW MENUW) (* \; "Take the buttons down") (CLOSEW MENUW) (SELECTQ (CADR ITEM) (MORE (* \; "Notify pagefullfn that it can continue") (WINDOWPROP WINDOW (QUOTE MOREOK) T) (NOTIFY.EVENT (WINDOWPROP WINDOW (QUOTE MOREEVENT)))) (NEXT (* \; "Throw to the loop that is displaying each file") (PROCESS.EVAL (WINDOWPROP WINDOW (QUOTE PROCESS)) (QUOTE (CL:THROW :NEXT)))) (ABORT (* \; "Kill it") (DEL.PROCESS (WINDOWPROP WINDOW (QUOTE PROCESS)))) (SHOULDNT)))) +) ) (DEFINEQ (FB.LOADCOMMAND +(LAMBDA (BROWSER KEY ITEM MENU LOADOP) (* |bvm:| "18-Sep-85 17:16") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR LOADOP (FUNCTION LOAD))) (KWOTE FILES)) (QUOTE NAME) (QUOTE LOAD) (QUOTE BEFOREEXIT) (QUOTE DON\'T))))) +) (FB.COMPILECOMMAND +(LAMBDA (BROWSER KEY ITEM MENU COMPILEOP) (* \; "Edited 5-Mar-87 17:39 by bvm:") (LET ((FILES (FB.SELECTEDFILES BROWSER))) (AND FILES (ADD.PROCESS (LIST (FUNCTION FB.OPERATE.ON.FILES) (KWOTE (OR COMPILEOP *DEFAULT-CLEANUP-COMPILER*)) (KWOTE FILES)) (QUOTE NAME) (QUOTE COMPILE) (QUOTE BEFOREEXIT) (QUOTE DON\'T))))) +) (FB.OPERATE.ON.FILES +(LAMBDA (FN FILELIST) (* \; "Edited 4-Feb-88 15:14 by bvm:") (LET (LDFLG FORMS) (SELECTQ FN ((PROP SYSLOAD) (SETQ LDFLG FN) (SETQ FN (QUOTE LOAD))) NIL) (SETQ FORMS (|for| FILEENTRY |in| FILELIST |collect| (BQUOTE ((\\\, FN) (QUOTE (\\\, (FB.FETCHFILENAME FILEENTRY))) (\\\,@ (AND LDFLG (BQUOTE ((QUOTE (\\\, LDFLG)))))))))) (EXEC-EVAL (|if| (CDR FORMS) |then| (CONS (QUOTE PROGN) FORMS) |else| (CAR FORMS))) (CLOSEW (TTYDISPLAYSTREAM)))) +) ) (DEFINEQ (FB.UPDATECOMMAND +(LAMBDA (BROWSER) (* |bvm:| "27-Sep-85 12:30") (COND ((FB.MAYBE.EXPUNGE BROWSER (QUOTE |Recompute|)) (FB.UPDATEBROWSERITEMS BROWSER)))) +) (FB.MAYBE.EXPUNGE +(LAMBDA (BROWSER COMMAND) (* |bvm:| "27-Sep-85 12:30") (* |;;;| "If BROWSER has files marked for deletion, ask whether user wants to expunge them. Returns T if it is okay to proceed, NIL if not (user aborted or expunge failed)") (COND ((EQ (|fetch| (FILEBROWSER DELETEDFILES) |of| BROWSER) 0) T) (T (FB.PROMPTWPRINT BROWSER "Some files are marked for deletion. +Do you want to expunge them first?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \; "Do expunge in another process, not here in mouse") (FB.EXPUNGECOMMAND BROWSER NIL NIL NIL COMMAND)) (NOEXPUNGE T) NIL)))) +) (FB.UPDATEBROWSERITEMS +(LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:46 by jds") (RESETLST (PROG ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FONT FB.BROWSERFONT) PATTERN INFOWANTED FILEGENERATOR FILENAME NOW INDEX WIDENED CONDITION) (FB.ALLOW.ABORT BROWSER) (COND ((SETQ PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER))) ((SETQ PATTERN (FB.GET.NEWPATTERN BROWSER)) (* \; "Didn't have a pattern before--got one now") (FB.SETNEWPATTERN BROWSER PATTERN)) (T (* \; "Refused to give me a pattern") (RETURN))) (PROGN (* \; "Restore browser to empty state--clear the counter window, set the title, remove any items, reset counters.") (|replace| (FILEBROWSER INFODISPLAYED) |of| BROWSER |with| (SETQ INFOWANTED (|for| SPEC |in| FB.INFO.FIELDS |bind| (WANTED _ (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) W PROTO |when| (MEMB (|fetch| (INFOFIELD INFONAME) |of| SPEC) WANTED) |collect| (SETQ SPEC (COPY SPEC)) (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (* \; "Have prototypical example, use it to get better width estimate.") (SETQ W (STRINGWIDTH PROTO FONT)) (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ W (TIMES 2 (CHARWIDTH (CHARCODE X) FONT)))) (|if| (LISTP (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) |then| (RPLACA (CDR (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC)) W))) SPEC))) (FB.SET.BROWSER.TITLE BROWSER) (CLEARW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER)) (CLEARW (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (* \; "Clear header window in case it has been scrolled.") (TB.REPLACE.ITEMS TBROWSER NIL) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| NIL) (TB.SET.FONT TBROWSER FONT) (|replace| (FILEBROWSER BROWSERFONT) |of| BROWSER |with| FONT) (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|replace| (FILEBROWSER DELETEDFILES) |of| BROWSER |with| (|replace| (FILEBROWSER DELETEDPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALPAGES) |of| BROWSER |with| (|replace| (FILEBROWSER TOTALFILES) |of| BROWSER |with| 0)))) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|replace| (FILEBROWSER PATTERNPARSED?) |of| BROWSER |with| NIL))) (|if| (SETQ INDEX (OR (CL:POSITION (QUOTE SIZE) INFOWANTED :KEY (FUNCTION CAR)) (CL:POSITION (QUOTE LENGTH) INFOWANTED :KEY (FUNCTION CAR)))) |then| (|replace| (FILEBROWSER SIZEINDEX) |of| BROWSER |with| INDEX)) (|replace| (FILEBROWSER PAGECOUNT?) |of| BROWSER |with| (AND INDEX (CAR (CL:NTH INDEX INFOWANTED)))) (PROGN (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| NIL) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| (FUNCTION FB.NAMES.DECREASING.VERSION))) (CL:MULTIPLE-VALUE-SETQ (FILEGENERATOR CONDITION) (IGNORE-ERRORS (LET* ((DESIREDPROPS (MAPCAR INFOWANTED (FUNCTION CAR))) (NSP (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER)) (DEPTH (OR (|fetch| (FILEBROWSER FBDEPTH) |of| BROWSER) (|if| NSP |then| (* \; "FILING.ENUMERATION.DEPTH is significant for NS servers") FILING.ENUMERATION.DEPTH))) (FILING.ENUMERATION.DEPTH (OR DEPTH FILING.ENUMERATION.DEPTH))) (DECLARE (SPECVARS FILING.ENUMERATION.DEPTH)) (FB.PROMPTW.FORMAT BROWSER "~%Enumerating ~A ~@[to depth ~D ~]..." PATTERN (FIXP DEPTH)) (|if| (AND NSP (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER) (OR DEPTH (NOT (UNPACKFILENAME.STRING PATTERN (QUOTE DIRECTORY))))) |then| (* \; "Ask for SUBTREE.SIZE also, so we can give page estimates of subdirectories, or in the case of enumerating a host, the top-level directories") (|push| DESIREDPROPS (QUOTE SUBTREE.SIZE))) (|replace| (FILEBROWSER FBDISPLAYEDDEPTH) |of| BROWSER |with| (|replace| (FILEBROWSER FBCOMPUTEDDEPTH) |of| BROWSER |with| (OR (FIXP DEPTH) 0))) (\\GENERATEFILES PATTERN DESIREDPROPS (QUOTE (SORT RESETLST)))))) (|if| CONDITION |then| (FB.PROMPTW.FORMAT BROWSER "Failed because ~A" CONDITION) (RETURN)) (SETQ NOW (FB.DATE)) (* \; "Time as of which the enumeration is reasonably valid") (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (|while| (SETQ FILENAME (\\GENERATENEXTFILE FILEGENERATOR)) |bind| LASTFILEDATA NEWFILEDATA PREVGROUPDATA OTHERFILES |do| (* |;;| "For each file, create an FBFILEDATA object. Gather together files with the same name, different version, so that we can sort versions. Thus, the display is always (at least) one file behind the generator: LASTFILEDATA is the first item of a given name, OTHERFILES are the remaining versions. PREVGROUPDATA is representative of the previous group.") (COND ((LISTP FILENAME) (* \; "Old kind of generator. Extinct?") (SETQ FILENAME (CONCATCODES FILENAME)))) (SETQ NEWFILEDATA (FB.CREATE.FILEBUCKET BROWSER FILENAME (FB.GETALLFILEINFO BROWSER FILEGENERATOR INFOWANTED) LASTFILEDATA)) (COND ((AND LASTFILEDATA (EQ (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| NEWFILEDATA))) (* \; "This file same name as previous one, so save it in case we need to sort versions. Note that FB.CREATE.FILEBUCKET canonicalizes the VERSIONLESSNAME, so EQ suffices") (|push| OTHERFILES NEWFILEDATA)) (T (COND ((AND LASTFILEDATA (OR (NOT (|fetch| (FBFILEDATA DIRECTORYFILEP) |of| LASTFILEDATA)) (NOT (STRPOS (|fetch| (FBFILEDATA FILENAME) |of| LASTFILEDATA) (|fetch| (FBFILEDATA FILENAME) |of| NEWFILEDATA) 1 NIL T NIL UPPERCASEARRAY)))) (* |;;| "Add the previous group we have accumulated. Second clause says not to add a line for a subdirectory file which is not a leaf, i.e., for which there are files below it in the enumeration (it would be nice if NS filing did this filtering itself).") (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA) (SETQ PREVGROUPDATA LASTFILEDATA))) (SETQ OTHERFILES NIL) (SETQ LASTFILEDATA NEWFILEDATA))) |finally| (AND LASTFILEDATA (FB.ADD.FILEGROUP TBROWSER BROWSER LASTFILEDATA OTHERFILES PREVGROUPDATA))) (COND ((EQ (TB.NUMBER.OF.ITEMS TBROWSER) 0) (FB.PROMPTWPRINT BROWSER (QUOTE CLEAR) "No files in group " PATTERN)) (T (FB.PROMPTWPRINT BROWSER (QUOTE |done|)) (SETQ WIDENED (FB.MAYBE.WIDEN.NAMES BROWSER)) (COND ((OR (FB.ADJUST.DATE.WIDTH BROWSER INFOWANTED) WIDENED) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REDISPLAY.ITEMS (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)))))) (FB.SET.BROWSER.TITLE BROWSER NOW) (|replace| (FILEBROWSER FBREADY) |of| BROWSER |with| T) (FB.DISPLAY.COUNTERS BROWSER)))) +) (FB.DATE +(LAMBDA NIL (* \; "Edited 21-Jan-88 18:40 by bvm") (LET ((DT (DATE (DATEFORMAT DAY.OF.WEEK DAY.SHORT NO.SECONDS)))) (* |;;| "DT is in the form \"dd-mon-yy hh:mm (day)\". Turn it into \"hh:mm day dd-mon-yy\".") (CONCAT (SUBSTRING DT 11 16) (SUBSTRING DT 18 20) " " (SUBSTRING DT (|if| (EQ (CHCON1 DT) (CHARCODE SPACE)) |then| (* \; "Trim leading space from date") 2 |else| 1) 9)))) +) (FB.ADJUST.DATE.WIDTH +(LAMBDA (BROWSER INFOWANTED) (* \; "Edited 30-Aug-94 19:40 by jds") (* |;;| "Adjust the expected with field of any date fields (other than the last) to reflect the width of actual dates this device returns. Returns T if it did anything.") (|for| TAIL |on| INFOWANTED |as| INDEX |from| 0 |while| (CDR TAIL) |bind| (FONT _ (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) SPEC RESULT |when| (AND (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| (SETQ SPEC (CAR TAIL))) (QUOTE DATE)) (TB.FIND.ITEM (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER) (FUNCTION (LAMBDA (TBROWSER ITEM) (|if| (SETQ ITEM (CL:NTH INDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM)))) |then| (* |;;| "Got a sample date. Assuming all dates have the same number of characters, compute a width that fits this date plus a couple spaces. Computation here for variable-width font assumes \"MAY\" is about as wide as you get, and finesses the issue of whether this date happens to start with leading space and/or contain some especially skinny letters.") (|replace| (INFOFIELD INFOWIDTH) |of| SPEC |with| (+ (STRINGWIDTH "XX99-MAY-88 99:99:99" FONT) (|if| (> (NCHARS ITEM) 18) |then| (* \; "Have a time-zone, too, or something") (STRINGWIDTH (SUBSTRING ITEM 19) FONT) |else| 0))) T))))) |do| (SETQ RESULT T) |finally| (RETURN RESULT))) +) (FB.SET.BROWSER.TITLE +(LAMBDA (BROWSER TIME) (* \; "Edited 21-Jan-88 18:37 by bvm") (* |;;| "(Re)display the title on BROWSER's window. If Time is supplied, it is the time at which the enumeration happened, and we include it in the title. Title is not changed if user supplied own title.") (COND ((NOT (|fetch| (FILEBROWSER FIXEDTITLE) |of| BROWSER)) (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW) |of| BROWSER) (QUOTE TITLE) (|if| TIME |then| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " at " TIME) |else| (CONCAT (|fetch| (FILEBROWSER PATTERN) |of| BROWSER) " browser")))))) +) (FB.MAYBE.WIDEN.NAMES +(LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:32") (* |;;;| "Examines the OVERFLOWWIDTHS field to see if we should widen the name area of the browser, shoving everything else to the right. If it changes the width, returns T so that caller knows whether to update display") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (CURRENTSTART (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) THRESHOLD) (COND (OVERFLOW (* \; "See if enough files were too wide for print spec") (SETQ THRESHOLD (IMIN (IMAX (FIXR (FTIMES (|fetch| (FILEBROWSER TOTALFILES) |of| BROWSER) FB.OVERFLOW.MAXFRAC)) 1) FB.OVERFLOW.MAXABSOLUTE)) (|for| PAIR |in| OVERFLOW |when| (AND (IGREATERP (CAR PAIR) CURRENTSTART) (LESSP (SETQ THRESHOLD (IDIFFERENCE THRESHOLD (CADR PAIR))) 0)) |do| (* \; "Stop here! Any further than this and we would have more than the max files overflowing") (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (CAR PAIR)) (RETURN T)))))) +) (FB.SET.DEFAULT.NAME.WIDTH +(LAMBDA (BROWSER) (* |bvm:| "18-Oct-85 17:54") (LET ((FONT (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER))) (|replace| (FILEBROWSER INFOSTART) |of| BROWSER |with| (IPLUS (|replace| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER |with| (IPLUS (DSPLEFTMARGIN NIL (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (CHARWIDTH (CHARCODE SPACE) FONT) (CHARWIDTH (CHARCODE \;) FONT))) FB.DEFAULT.NAME.WIDTH)) (|replace| (FILEBROWSER DIGITWIDTH) |of| BROWSER |with| (CHARWIDTH (CHARCODE 8) FONT)) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| NIL))) +) (FB.CREATE.FILEBUCKET +(LAMBDA (BROWSER FILENAME FILEINFO LASTFILEDATA) (* \; "Edited 1-Feb-88 14:44 by bvm:") (* |;;| "Create a FBFILEDATA encapsulating FILENAME and its FILEINFO. If LASTFILEDATA is supplied, it is the filedata from the previous file parsed, which we make use of to create canonical VERSIONLESSNAME fields.") (|if| (NOT (STRINGP FILENAME)) |then| (* \; "Some things are nicer if we force everything to be a string.") (SETQ FILENAME (STRING FILENAME))) (COND ((NULL (|fetch| (FILEBROWSER PATTERNPARSED?) |of| BROWSER)) (FB.ANALYZE.PATTERN BROWSER FILENAME))) (LET ((STARTOFNAME (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER)) (NAMELENGTH (NCHARS FILENAME)) (VERSION 0) (DEPTH 0) STARTOFSHORTNAME LASTDIR PREVDIR LASTNAMECHAR HASDIRPREFIX DIRP ATTR TEM NEWFILEDATA) (SETQ LASTNAMECHAR NAMELENGTH) (|bind| (DEC _ 1) CH |while| (DIGITCHARP (SETQ CH (NTHCHARCODE FILENAME LASTNAMECHAR))) |do| (|add| VERSION (TIMES (- CH (CHARCODE 0)) DEC)) (SETQ DEC (TIMES 10 DEC)) (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR)) |finally| (* \; "not a version char") (COND ((EQ CH (CHARCODE \;)) (* \; "Pull off the version from the end, so that we can sort with it, etc. Note that we assume that all devices have converted native syntax to Lisp here.") (SETQ LASTNAMECHAR (SUB1 LASTNAMECHAR))) (T (SETQ VERSION 0) (* \; "Null version") (SETQ LASTNAMECHAR NIL)))) (SETQ NEWFILEDATA (|if| (AND LASTFILEDATA (STRING-EQUAL (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| LASTFILEDATA) FILENAME :END2 (OR LASTNAMECHAR NAMELENGTH))) |then| (* \; "This file is just like the previous one, except for attributes, full name and version") (|create| FBFILEDATA |using| LASTFILEDATA) |else| (|for| (N _ STARTOFNAME) |do| (SELCHARQ (NTHCHARCODE FILENAME (|add| N 1)) ((> /) (SETQ PREVDIR LASTDIR) (SETQ LASTDIR N) (|add| DEPTH 1)) (\' (* \; "Next char is quoted") (|add| N 1)) (NIL (RETURN)) NIL)) (|if| (EQ LASTDIR NAMELENGTH) |then| (* \; "It's a directory name (e.g., with ns), so make the name be the last subdirectory") (SETQ LASTDIR PREVDIR) (SETQ DIRP T) (|add| DEPTH -1)) (COND (LASTDIR (* \; "We found a directory delimiter following the common directory prefix of the pattern. ") (SETQ HASDIRPREFIX T) (SETQ STARTOFSHORTNAME (ADD1 LASTDIR)) (* \; "Directoryless name starts here") (COND ((NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) (* \; "Use short name if allowed.") (SETQ STARTOFNAME STARTOFSHORTNAME)))) (T (SETQ STARTOFSHORTNAME STARTOFNAME))) (* \; "Note optimization: SUBDIREND is zero (SUBDIRECTORY null) when HASDIRPREFIX is NIL.") (|create| FBFILEDATA STARTOFPNAME _ STARTOFNAME VERSIONLESSNAME _ (COND (LASTNAMECHAR (SUBSTRING FILENAME 1 LASTNAMECHAR)) (T FILENAME)) SUBDIREND _ (OR LASTDIR 0) STARTOFNAME _ STARTOFSHORTNAME HASDIRPREFIX _ HASDIRPREFIX DIRECTORYFILEP _ DIRP FILEDEPTH _ DEPTH))) (|replace| (FBFILEDATA FILENAME) |of| NEWFILEDATA |with| FILENAME) (|replace| (FBFILEDATA VERSION) |of| NEWFILEDATA |with| VERSION) (|replace| (FBFILEDATA FILEINFO) |of| NEWFILEDATA |with| FILEINFO) (|replace| (FBFILEDATA SIZE) |of| NEWFILEDATA |with| (AND (SETQ ATTR (|fetch| (FILEBROWSER PAGECOUNT?) |of| BROWSER)) (SETQ TEM (CL:NTH (|fetch| (FILEBROWSER SIZEINDEX) |of| BROWSER) FILEINFO)) (SELECTQ ATTR (LENGTH (FOLDHI TEM BYTESPERPAGE)) TEM))) (FB.CHECK.NAME.LENGTH BROWSER NEWFILEDATA) (COND ((SETQ ATTR (|fetch| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER)) (SETQ ATTR (CL:NTH (|fetch| (FILEBROWSER SORTINDEX) |of| BROWSER) FILEINFO)) (COND ((AND ATTR (|fetch| (FILEBROWSER SORTBYDATE) |of| BROWSER)) (SETQ ATTR (IDATE ATTR)))) (|replace| (FBFILEDATA SORTVALUE) |of| NEWFILEDATA |with| ATTR))) NEWFILEDATA)) +) (FB.CHECK.NAME.LENGTH +(LAMBDA (BROWSER FILEDATA) (* \; "Edited 25-Jan-88 15:44 by bvm") (* |;;;| "Checks the name in FILEDATA to see if printing it would overflow the space set aside for the name column in the browser. If so, updates some information that will help us decide later whether to expand the column") (LET ((PRINTLENGTH (+ (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FILEDATA) (|fetch| (FILEBROWSER BROWSERFONT) |of| BROWSER)) (|fetch| (FILEBROWSER NAMEOVERHEAD) |of| BROWSER)))) (COND ((>= PRINTLENGTH (|fetch| (FILEBROWSER INFOSTART) |of| BROWSER)) (* |;;| "Name is longer than allotted space in browser. Shall we allot more space? Don't know until we're thru. For now, record a list of elements (width occurrences), where each name is recorded in the closest entry") (LET ((OVERFLOW (|fetch| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER)) (SPACING (|fetch| (FILEBROWSER OVERFLOWSPACING) |of| BROWSER))) (COND ((OR (NULL OVERFLOW) (> PRINTLENGTH (CAAR OVERFLOW))) (|replace| (FILEBROWSER OVERFLOWWIDTHS) |of| BROWSER |with| (CONS (LIST PRINTLENGTH 1) OVERFLOW))) (T (|for| (TAIL _ OVERFLOW) |bind| PREVTAIL |when| (OR (NULL (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))) (> PRINTLENGTH (CAR (CAR TAIL)))) |do| (* \; "Longer than some previously recorded length, so either add a new entry or bump the preceding one") (COND ((< PRINTLENGTH (- (CAR (CAR PREVTAIL)) SPACING)) (RPLACD PREVTAIL (CONS (LIST PRINTLENGTH 1) TAIL))) (T (|add| (CADR (CAR PREVTAIL)) 1))) (RETURN))))))))) +) (FB.ADD.FILEGROUP +(LAMBDA (TBROWSER FBROWSER FIRSTDATA OTHERDATA PREVDATA) (* \; "Edited 1-Feb-88 14:43 by bvm:") (* |;;| "Appends to FBROWSER the set of files FIRSTDATA plus each of OTHERDATA, all of which are known to have the same name save version number. PREVDATA is representative of the last item we inserted.") (COND ((AND (NOT (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| FBROWSER)) (NOT (|if| PREVDATA |then| (EQ.DIRECTORYP PREVDATA FIRSTDATA) |else| (NULL.DIRECTORYP FIRSTDATA)))) (* \; "The new files have a different subdirectory, so insert a non-selectable line item here") (FB.INSERT.DIRECTORY TBROWSER FBROWSER FIRSTDATA))) (COND (OTHERDATA (* \; "More than one file to add, so sort versions") (|for| ITEM |in| (SORT (|for| D |in| (CONS FIRSTDATA OTHERDATA) |collect| (|create| TABLEITEM TIDATA _ D)) (FUNCTION FB.DECREASING.VERSION)) |do| (FB.ADD.FILE TBROWSER FBROWSER ITEM))) (T (FB.ADD.FILE TBROWSER FBROWSER (|create| TABLEITEM TIDATA _ FIRSTDATA))))) +) (FB.INSERT.DIRECTORY +(LAMBDA (TBROWSER FBROWSER DATAWITHSUBDIR BEFOREITEM) (* \; "Edited 25-Jan-88 17:13 by bvm") (TB.INSERT.ITEM TBROWSER (FB.MAKE.SUBDIRECTORY.ITEM FBROWSER DATAWITHSUBDIR) BEFOREITEM)) +) (FB.MAKE.SUBDIRECTORY.ITEM +(LAMBDA (FBROWSER DATAWITHSUBDIR) (* \; "Edited 26-Jan-88 10:58 by bvm") (* |;;;| "Creates a TABLEITEM containing a subdirectory line identifying the subdirectory in DATAWITHSUBDIR. If item has no subdirectory, we use the browser's pattern directory") (LET* ((SUBDIRECTORY (OR (|fetch| (FBFILEDATA SUBDIRECTORY) |of| DATAWITHSUBDIR) (SUBSTRING (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER) 1 (SUB1 (|fetch| (FILEBROWSER NAMESTART) |of| FBROWSER))))) (DIRSTART (|fetch| (FILEBROWSER DIRECTORYSTART) |of| FBROWSER))) (|create| TABLEITEM TIUNSELECTABLE _ T TIDATA _ (|create| FBFILEDATA FILENAME _ SUBDIRECTORY STARTOFPNAME _ (|if| (<= DIRSTART (NCHARS SUBDIRECTORY)) |then| DIRSTART |else| (* \; "No directory--use whole name") 1) VERSIONLESSNAME _ SUBDIRECTORY DIRECTORYP _ T)))) +) (FB.ADD.FILE +(LAMBDA (TBROWSER FBROWSER ITEM BEFOREITEM) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Inserts one file in TBROWSER / FBROWSER before item BEFOREITEM or at end if BEFOREITEM is NIL") (LET ((SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) SIZE))) (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) 1) (TB.INSERT.ITEM TBROWSER ITEM BEFOREITEM))) +) (FB.INSERT.FILE +(LAMBDA (BROWSER FILE) (* \; "Edited 25-Jan-88 18:31 by bvm") (LET ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (FBSORTFN (|fetch| (FILEBROWSER SORTBY) |of| BROWSER)) (MYDATA (|fetch| TIDATA |of| FILE)) (NOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) OTHERDATA NEXTITEM PREVITEM N) (SETQ NEXTITEM (TB.FIND.ITEM TBROWSER (FUNCTION (LAMBDA (BROWSER ITEM) (AND (NOT (|fetch| TIUNSELECTABLE |of| ITEM)) (CL:FUNCALL FBSORTFN FILE ITEM)))))) (COND ((AND NEXTITEM (NOT NOSUBDIRS) (NEQ (SETQ N (|fetch| TI# |of| NEXTITEM)) 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "We sort before NEXTITEM, but it's preceded by a subdirectory line that isn't ours, so insert in front of the subdirectory") (SETQ NEXTITEM PREVITEM))) (TB.INSERT.ITEM TBROWSER FILE NEXTITEM) (COND (NOSUBDIRS) ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM)) (EQ.DIRECTORYP MYDATA (SETQ OTHERDATA (|fetch| TIDATA |of| NEXTITEM)))) (* |;;| "All ok -- next item is not a subdirectory line, and its subdir is the same as mine, so I must be properly qualified already")) (T (* |;;| "Inserted at end, or newly inserted item has different subdirectory from the item that follows it") (COND ((AND NEXTITEM (NOT (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \; "Need subdirectory id in front of next file") (FB.INSERT.DIRECTORY TBROWSER BROWSER OTHERDATA NEXTITEM))) (COND ((COND ((EQ (SETQ N (|fetch| TI# |of| FILE)) 1) (* \; "Inserted at front, needs qualification if it has a subdir") (NOT (NULL.DIRECTORYP MYDATA))) (T (NOT (EQ.DIRECTORYP MYDATA (|fetch| TIDATA |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))))))) (* \; "Need id in front of new file as well") (FB.INSERT.DIRECTORY TBROWSER BROWSER MYDATA FILE))))) (FB.COUNT.FILE.CHANGE BROWSER FILE (QUOTE ADD)))) +) (FB.ANALYZE.PATTERN +(LAMBDA (BROWSER SAMPLE) (* \; "Edited 6-Apr-90 20:00 by NM") (* |;;;| "Figures out what the 'real pattern' is from SAMPLE, one of the files that is claimed to match the pattern. Sets the NAMESTART field to where the pattern ends and the distinguishable names start. Also resets PATTERN to be the canonicalized pattern") (PROG ((PATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (SAMPLEHOSTEND 0) PATHOSTEND LASTPATDIR STARTOFNAME) (|do| (* \; "Find end of sample's host name") (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) (\' (|add| SAMPLEHOSTEND 1)) (} (* \; "End of directory") (RETURN)) (NIL (* \; "End of file name without end of brace?") (RETURN (SETQ SAMPLEHOSTEND 0))) NIL)) RETRY (SETQ PATHOSTEND 0) (|do| (SELCHARQ (NTHCHARCODE PATTERN (|add| PATHOSTEND 1)) (\' (|add| PATHOSTEND 1)) (} (* \; "End of directory, now look for end of matchable pattern") (RETURN (|for| (N _ PATHOSTEND) |do| (SELCHARQ (NTHCHARCODE PATTERN (|add| N 1)) (\' (|add| N 1)) ((\: < > /) (* \; "{DSK} and {UNIX} on Sun represent root directory in a form of \"{DSK}, or {x/n}<~> might become {x/n}jones>.") (OR (SELCHARQ (NTHCHARCODE SAMPLE (|add| SAMPLEHOSTEND 1)) ((< /) (* \; "Good, there's a directory -- canonicalize it") (LET ((CANONICAL (DIRECTORYNAME (SUBSTRING PATTERN 1 (OR LASTPATDIR (SETQ LASTPATDIR PATHOSTEND)))))) (AND CANONICAL (CONCAT CANONICAL (SUBSTRING PATTERN (ADD1 LASTPATDIR)))))) (PROGN (* \; "File coming back has no directory, so there's nothing interesting to do") NIL)) PATTERN)) +) (FB.GETALLFILEINFO +(LAMBDA (BROWSER GENERATOR ATTRIBUTES) (* \; "Edited 1-Feb-88 15:50 by bvm:") (* |;;| "Returns a FILEINFO field for the given attribute specs") (|for| ATTR |in| ATTRIBUTES |bind| VALUE TREESIZE |collect| (SETQ VALUE (\\GENERATEFILEINFO GENERATOR (CAR ATTR))) (|if| (AND (EQ VALUE 0) (|fetch| (FILEBROWSER NSPATTERN?) |of| BROWSER) (FMEMB (CAR ATTR) (QUOTE (SIZE LENGTH))) (SETQ TREESIZE (\\GENERATEFILEINFO GENERATOR (QUOTE SUBTREE.SIZE)))) |then| (* |;;| "This is an NS directory node, so get its subtree size, which is much more interesting than size, which is always zero (directories have no data)") (SELECTQ (CAR ATTR) (SIZE (FOLDHI TREESIZE BYTESPERPAGE)) (LENGTH TREESIZE) (SHOULDNT)) |else| VALUE))) +) ) (DEFINEQ (FB.SORT.VERSIONS +(LAMBDA (ITEMS SORTFN) (* \; "Edited 25-Jan-88 15:22 by bvm") (* |;;;| "Sort ITEMS so that equal names are sorted by version according to SORTFN. Assumes that ITEMS are already sorted by name") (LET ((TAIL ITEMS) PREVTAIL NEXTTAIL NEWTAIL THISNAME) (|while| (CDR TAIL) |do| (COND ((STRING-EQUAL (SETQ THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CAR TAIL)))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CADR TAIL)))) (* \; "Same name as next, so gather up all equal names") (SETQ NEXTTAIL (CDDR TAIL)) (|while| (AND NEXTTAIL (STRING-EQUAL THISNAME (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (|fetch| TIDATA |of| (CAR NEXTTAIL))))) |do| (SETQ NEXTTAIL (CDR NEXTTAIL))) (SETQ NEWTAIL (SORT (|until| (EQ TAIL NEXTTAIL) |collect| (|pop| TAIL)) SORTFN)) (* \; "Now splice NEWTAIL into list between PREVTAIL and NEXTTAIL") (COND (PREVTAIL (RPLACD PREVTAIL NEWTAIL)) (T (SETQ ITEMS NEWTAIL))) (COND ((SETQ TAIL NEXTTAIL) (RPLACD (SETQ PREVTAIL (LAST NEWTAIL)) NEXTTAIL)))) (T (SETQ TAIL (CDR (SETQ PREVTAIL TAIL)))))) ITEMS)) +) (FB.DECREASING.VERSION +(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:53") (* |;;;| "Comparefn for sorting a group of same named files by decreasing version. Null version considered high") (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y))))) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X)))) (IGREATERP X Y)))) +) (FB.INCREASING.VERSION +(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:55") (* |;;;| "Comparefn for sorting a group of same named files by increasing version. Null version considered high") (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| Y)))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| (|fetch| TIDATA |of| X))))) (ILESSP X Y)))) +) (FB.NAMES.DECREASING.VERSION +(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:57") (* |;;;| "Comparison function for sorting file names in alphabetical order, decreasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (AND (NOT (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y)) 0)) (OR (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X))) (IGREATERP X Y)))) NIL)) +) (FB.NAMES.INCREASING.VERSION +(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:54") (* |;;;| "Comparison function for sorting file names in alphabetical order, increasing versions") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ X (|fetch| TIDATA |of| X))) (|fetch| (FBFILEDATA VERSIONLESSNAME) |of| (SETQ Y (|fetch| TIDATA |of| Y))) UPPERCASEARRAY) (LESSP T) (EQUAL (OR (NULL.VERSIONP (SETQ Y (|fetch| (FBFILEDATA VERSION) |of| Y))) (AND (NOT (NULL.VERSIONP (SETQ X (|fetch| (FBFILEDATA VERSION) |of| X)))) (ILESSP X Y)))) NIL)) +) (FB.DECREASING.NUMERIC.ATTR +(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in decreasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (IGREATERP XVAL YVAL) (AND (NOT (IGREATERP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y))))) +) (FB.INCREASING.NUMERIC.ATTR +(LAMBDA (X Y) (* |bvm:| "13-Oct-85 17:44") (* |;;;| "Comparison function for sorting file names in increasing order of some numeric attribute. If values are equal, fall back on names decreasing version") (LET ((XVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) 0)) (YVAL (OR (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) 0))) (OR (ILESSP XVAL YVAL) (AND (NOT (ILESSP YVAL XVAL)) (FB.NAMES.DECREASING.VERSION X Y))))) +) (FB.ALPHABETIC.ATTR +(LAMBDA (X Y) (* |bvm:| "20-Oct-85 18:07") (* |;;;| "Comparison function for sorting file names in order of some textual attribute. If values are equal, fall back on names decreasing version") (SELECTQ (ALPHORDER (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| X)) (|fetch| (FBFILEDATA SORTVALUE) |of| (|fetch| TIDATA |of| Y)) UPPERCASEARRAY) (LESSP T) (EQUAL (FB.NAMES.DECREASING.VERSION X Y)) NIL)) +) ) (DEFINEQ (FB.SORTCOMMAND +(LAMBDA (BROWSER) (* \; "Edited 29-Jan-88 12:47 by bvm") (PROG ((TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| BROWSER)) (HADNOSUBDIRS (|fetch| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER)) SORTATTR SORT# SORTFN REVERSED ALLFILES DATETYPE BYNAME) (COND ((NULL (SETQ SORTATTR (MENU (FB.GET.SORT.MENU BROWSER)))) (RETURN)) ((LISTP SORTATTR) (SETQ REVERSED T) (SETQ SORTATTR (CAR SORTATTR)))) (SETQ SORTFN (SELECTQ SORTATTR ((SIZE LENGTH BYTESIZE) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) ((CREATIONDATE WRITEDATE READDATE) (SETQ DATETYPE T) (COND (REVERSED (FUNCTION FB.INCREASING.NUMERIC.ATTR)) (T (FUNCTION FB.DECREASING.NUMERIC.ATTR)))) (NAME (SETQ BYNAME T) (COND (REVERSED (FUNCTION FB.NAMES.INCREASING.VERSION)) (T (FUNCTION FB.NAMES.DECREASING.VERSION)))) (FUNCTION FB.ALPHABETIC.ATTR))) (FB.PROMPTW.FORMAT BROWSER "Sorting by ~A..." SORTATTR) (SETQ ALLFILES (TB.COLLECT.ITEMS TBROWSER (FUNCTION FB.IS.NOT.SUBDIRECTORY.ITEM))) (COND ((NOT BYNAME) (* \; "Need to compute the attribute on which we sort") (SETQ SORT# (OR (CL:POSITION SORTATTR (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) :KEY (FUNCTION CAR)) (HELP "Couldn't find sort attribute" SORTATTR))) (|for| ITEM |in| ALLFILES |bind| (NAMESTART _ (AND (NOT HADNOSUBDIRS) (|fetch| (FILEBROWSER NAMESTART) |of| BROWSER))) DATA VALUE |do| (SETQ DATA (|fetch| TIDATA |of| ITEM)) (SETQ VALUE (CL:NTH SORT# (|fetch| (FBFILEDATA FILEINFO) |of| DATA))) (COND ((AND VALUE DATETYPE) (SETQ VALUE (IDATE VALUE)))) (|replace| (FBFILEDATA SORTVALUE) |of| DATA |with| VALUE) (COND ((AND NAMESTART (|fetch| (FBFILEDATA HASDIRPREFIX) |of| DATA)) (* \; "Need to go back to 'full' names, since subdirectories are senseless when not sorted by name") (|replace| (FBFILEDATA STARTOFPNAME) |of| DATA |with| NAMESTART) (FB.CHECK.NAME.LENGTH BROWSER DATA))))) (HADNOSUBDIRS (* \; "We're sorting by name, so switch back to print names without subdirs") (FB.SET.DEFAULT.NAME.WIDTH BROWSER) (|for| DATA |in| ALLFILES |do| (COND ((|fetch| (FBFILEDATA HASDIRPREFIX) |of| (SETQ DATA (|fetch| TIDATA |of| DATA))) (|replace| (FBFILEDATA STARTOFPNAME) |of| DATA |with| (|fetch| (FBFILEDATA STARTOFNAME) |of| DATA)))) (FB.CHECK.NAME.LENGTH BROWSER DATA)))) (SETQ ALLFILES (SORT ALLFILES SORTFN)) (COND ((EQ BYNAME HADNOSUBDIRS) (* \; "Were wide names, now narrow, or vice versa") (FB.MAYBE.WIDEN.NAMES BROWSER))) (COND (BYNAME (FB.INSERT.SUBDIRECTORIES BROWSER ALLFILES))) (FB.HEADINGW.DISPLAY BROWSER (|fetch| (FILEBROWSER HEADINGWINDOW) |of| BROWSER)) (TB.REPLACE.ITEMS TBROWSER ALLFILES) (|replace| (FILEBROWSER NOSUBDIRECTORIES) |of| BROWSER |with| (NOT BYNAME)) (|replace| (FILEBROWSER SORTBY) |of| BROWSER |with| SORTFN) (|replace| (FILEBROWSER SORTATTRIBUTE) |of| BROWSER |with| (AND (NOT BYNAME) SORTATTR)) (|if| SORT# |then| (|replace| (FILEBROWSER SORTINDEX) |of| BROWSER |with| SORT#)) (|replace| (FILEBROWSER SORTBYDATE) |of| BROWSER |with| DATETYPE) (FB.PROMPTWPRINT BROWSER "done"))) +) (FB.INSERT.SUBDIRECTORIES +(LAMBDA (BROWSER FILES) (* \; "Edited 26-Jan-88 10:45 by bvm") (|for| TAIL |on| FILES |bind| (LASTDATA _ (|create| FBFILEDATA SUBDIREND _ 0)) |when| (NOT (EQ.DIRECTORYP LASTDATA (SETQ LASTDATA (|fetch| TIDATA |of| (CAR TAIL))))) |do| (* \; "This guy's directory differs from previous, so add subdirectory item") (ATTACH (FB.MAKE.SUBDIRECTORY.ITEM BROWSER LASTDATA) TAIL) (SETQ TAIL (CDR TAIL)))) +) (FB.GET.SORT.MENU +(LAMBDA (BROWSER) (* \; "Edited 26-Jan-88 12:38 by bvm") (OR (|fetch| (FILEBROWSER SORTMENU) |of| BROWSER) (|replace| (FILEBROWSER SORTMENU) |of| BROWSER |with| (|create| MENU ITEMS _ (CONS (QUOTE ("Name" (QUOTE NAME) "Sort files by name, decreasing version numbers" (SUBITEMS ("Decreasing version" (QUOTE NAME) "Sort files by name, decreasing version numbers") ("Increasing version" (QUOTE (NAME T)) "Sort files by name, increasing version numbers")))) (|for| ATTR |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| BROWSER) |collect| (BQUOTE ((\\\, (SETQ ATTR (CAR ATTR))) (QUOTE (\\\, ATTR)) "Sort by this attribute" (\\\, (SELECTQ ATTR ((SIZE LENGTH BYTESIZE) (BQUOTE (SUBITEMS ("Decreasing" (QUOTE (\\\, ATTR)) "Sort files in order of decreasing size") ("Increasing" (QUOTE ((\\\, ATTR) T)) "Sort files in order of increasing size")))) ((CREATIONDATE WRITEDATE READDATE) (BQUOTE (SUBITEMS ("Newer first" (QUOTE (\\\, ATTR)) "Sort files with newer dates appearing before older dates") ("Older first" (QUOTE ((\\\, ATTR) T)) "Sort files with older dates appearing before newer dates")))) NIL)))))))))) +) ) (DEFINEQ (FB.EXPUNGECOMMAND +(LAMBDA (FBROWSER KEY ITEM MENU CMD) (* \; "Edited 9-Apr-93 22:07 by jds") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (TBROWSER (|fetch| (FILEBROWSER TABLEBROWSER) |of| FBROWSER)) (NDELETED 0) FILES FILENAME FAILED FILE) (COND ((SETQ FILES (TB.COLLECT.ITEMS TBROWSER (QUOTE DELETED))) (FB.PROMPTWPRINT FBROWSER T "Expunging deleted files...") (FB.ALLOW.ABORT FBROWSER) (|for| ITEM |in| FILES |do| (COND ((DELFILE (SETQ FILENAME (FB.FETCHFILENAME ITEM))) (|add| NDELETED 1) (FB.REMOVE.FILE TBROWSER FBROWSER ITEM) (FB.UPDATE.COUNTERS FBROWSER (QUOTE BOTH))) (T (FB.PROMPTWPRINT FBROWSER T "Couldn't expunge " FILENAME) (SETQ FAILED T))) (* |;;| "Let other things run (Like the mouse, so user can ABORT the expunge!)") (BLOCK)) (FB.PROMPTWPRINT FBROWSER (COND ((EQ NDELETED 0) " +No") (T (CONCAT (COND (FAILED " +Done, but only ") (T "done, ")) NDELETED))) " files expunged.") (COND (FAILED (COND (CMD (FB.PROMPTW.FORMAT FBROWSER " ~A aborted." CMD))) (RETURN NIL)))) (T (FB.PROMPTWPRINT FBROWSER T "No files were marked for deletion"))) (RETURN T))) +) (FB.NEWPATTERNCOMMAND +(LAMBDA (BROWSER) (* \; "Edited 28-Jan-88 01:11 by bvm") (LET (PATTERN) (COND ((AND (FB.MAYBE.EXPUNGE BROWSER "New Pattern") (SETQ PATTERN (FB.GET.NEWPATTERN BROWSER))) (FB.SETNEWPATTERN BROWSER PATTERN) (FB.UPDATEBROWSERITEMS BROWSER))))) +) (FB.NEWINFOCOMMAND +(LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (INFOMENUW (|fetch| (FILEBROWSER INFOMENUW) |of| BROWSER)) REG) (COND ((NOT (OPENWP INFOMENUW)) (SETQ INFOMENUW (MENUWINDOW (|create| MENU ITEMS _ FB.INFO.MENU.ITEMS MENUROWS _ 2 TITLE _ "Info Options" CENTERFLG _ T MENUFONT _ FB.MENUFONT WHENSELECTEDFN _ (FUNCTION FB.INFOMENU.WHENSELECTEDFN)))) (ATTACHWINDOW INFOMENUW WINDOW (QUOTE BOTTOM) (QUOTE JUSTIFY) (QUOTE LOCALCLOSE)) (COND ((LESSP (|fetch| (REGION BOTTOM) |of| (SETQ REG (WINDOWPROP INFOMENUW (QUOTE REGION)))) 0) (* \; "Bump whole window up on screen so we can see it") (MOVEW WINDOW (|create| POSITION XCOORD _ (|fetch| (REGION LEFT) |of| REG) YCOORD _ (|fetch| (REGION HEIGHT) |of| REG))))) (FB.INFOMENU.SHADEINITIALSELECTIONS INFOMENUW (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER)) (|replace| (FILEBROWSER INFOMENUW) |of| BROWSER |with| INFOMENUW) (WINDOWADDPROP INFOMENUW (QUOTE CLOSEFN) (FUNCTION (LAMBDA (W) (AND (SETQ W (WINDOWPROP (MAINWINDOW W T) (QUOTE FILEBROWSER))) (|replace| (FILEBROWSER INFOMENUW) |of| W |with| NIL)))) T))) (FB.PROMPTWPRINT BROWSER (QUOTE CLEAR) "Select from the lower menu which attributes are to be displayed, +then click Recompute")))) (FB.DEPTHCOMMAND +(LAMBDA (FBROWSER) (* \; "Edited 1-Feb-88 13:54 by bvm:") (LET ((OLDDEPTH (|fetch| (FILEBROWSER FBDEPTH) |of| FBROWSER)) NEWDEPTH) (FB.PROMPTWPRINT FBROWSER "Current depth is " (SELECTQ OLDDEPTH (NIL "global default") (T "infinite") OLDDEPTH) T "Specify new depth") (|if| (EQ (SETQ NEWDEPTH (MENU (|create| MENU ITEMS _ FB.DEPTH.MENU.ITEMS CENTERFLG _ T))) :NUMBER) |then| (FB.ALLOW.ABORT FBROWSER) (SETQ NEWDEPTH (RNUMBER "Enumeration Depth" NIL NIL NIL T NIL T))) (|if| (NULL NEWDEPTH) |then| (FB.PROMPTWPRINT FBROWSER T "Depth unchanged") |else| (FB.PROMPTWPRINT FBROWSER T "Depth set to " (SELECTQ NEWDEPTH (:GLOBAL (SETQ NEWDEPTH NIL) "global default") (T "infinity") NEWDEPTH) " for future Recomputes") (|replace| (FILEBROWSER FBDEPTH) |of| FBROWSER |with| NEWDEPTH)))) +) (FB.SHAPECOMMAND +(LAMBDA (BROWSER) (* \; "Edited 2-Feb-88 12:02 by bvm:") (* |;;| "Widen or narrow the browser so that all information is visible") (LET* ((WINDOW (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER)) (WREG (WINDOWREGION WINDOW)) (WWIDTH (|fetch| (REGION WIDTH) |of| WREG)) (EXTENT (WINDOWPROP WINDOW (QUOTE EXTENT))) EXCESSHEIGHT MENUW) (* |;;| "Add enough to the whole region width to compensate for the excess of the extent over the actual width, but don't get wider than the screen less a scroll bar. Using the EXTENT is not entirely correct--EXTENT's width reflects the widest line we have attempted to print, not the widest line we MIGHT print if window were scrolled to other items.") (|replace| (REGION WIDTH) |of| WREG |with| (SETQ WWIDTH (MIN (+ WWIDTH (- (|fetch| (REGION WIDTH) |of| EXTENT) (WINDOWPROP WINDOW (QUOTE WIDTH)))) (- SCREENWIDTH SCROLLBARWIDTH)))) (|if| (AND (> (SETQ EXCESSHEIGHT (- (WINDOWPROP WINDOW (QUOTE HEIGHT)) (|fetch| (REGION HEIGHT) |of| EXTENT))) 0) (SETQ MENUW (CDR (|fetch| (FILEBROWSER ABORTWINDOW) |of| BROWSER)))) |then| (* \; "Window is also taller than it needs to be--shrink it back, though not smaller than the minimum height") (|replace| (REGION HEIGHT) |of| WREG |with| (MAX (- (|fetch| (REGION HEIGHT) |of| WREG) EXCESSHEIGHT) (+ (|fetch| (REGION HEIGHT) |of| (WINDOWPROP MENUW (QUOTE REGION))) (|fetch| (REGION HEIGHT) |of| (WINDOWPROP (|fetch| (FILEBROWSER PROMPTWINDOW) |of| BROWSER) (QUOTE REGION)))))) |else| (SETQ EXCESSHEIGHT NIL)) (|if| (> (|fetch| (REGION PRIGHT) |of| WREG) SCREENWIDTH) |then| (* \; "If we're sticking over the edge on the right, move the region leftward.") (|replace| (REGION LEFT) |of| WREG |with| (- SCREENWIDTH WWIDTH))) (RESHAPEALLWINDOWS WINDOW WREG) (|if| EXCESSHEIGHT |then| (* \; "Silly reshaping routine tried to preserve the bottom, so scrolled the window up. Let's scroll it back down.") (SCROLLW WINDOW 0 (- EXCESSHEIGHT))))) +) (FB.REMOVE.FILE +(LAMBDA (TBROWSER FBROWSER ITEM) (* \; "Edited 25-Jan-88 17:24 by bvm") (* |;;;| "Removes ITEM from browser display, counts its removal") (LET ((N (|fetch| TI# |of| ITEM)) PREVITEM NEXTITEM NEXTNEXTITEM) (COND ((AND (NEQ N 1) (|fetch| TIUNSELECTABLE |of| (SETQ PREVITEM (TB.NTH.ITEM TBROWSER (SUB1 N)))) (OR (NULL (SETQ NEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N)))) (|fetch| TIUNSELECTABLE |of| NEXTITEM))) (* \; "ITEM is between two subdirectory lines, so remove at least the preceding line") (TB.REMOVE.ITEM TBROWSER PREVITEM) (COND ((AND NEXTITEM (SETQ NEXTNEXTITEM (TB.NTH.ITEM TBROWSER (ADD1 N))) (COND ((EQ (|add| N -1) 1) (* |;;| "N decremented because of the remove above. Now removing first file, so see if next file has no subdir") (NULL.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM))) (T (EQ.DIRECTORYP (|fetch| TIDATA |of| NEXTNEXTITEM) (|fetch| TIDATA |of| (TB.NTH.ITEM TBROWSER (SUB1 N))))))) (* |;;| "The next subdirectory line is superfluous, because the file after it and the file before us have the same subdirectory") (TB.REMOVE.ITEM TBROWSER NEXTITEM))))) (TB.REMOVE.ITEM TBROWSER ITEM) (FB.COUNT.FILE.CHANGE FBROWSER ITEM (QUOTE REMOVE)))) +) (FB.COUNT.FILE.CHANGE +(LAMBDA (FBROWSER ITEM FLG) (* |bvm:| "13-Oct-85 17:47") (* |;;;| "Account for the addition or removal of ITEM from FBROWSER -- FLG is ADD or REMOVE") (LET ((SIGN (SELECTQ FLG (ADD 1) (REMOVE -1) (SHOULDNT))) (SIZE (|fetch| (FBFILEDATA SIZE) |of| (|fetch| TIDATA |of| ITEM))) (DELETEDP (|fetch| TIDELETED |of| ITEM))) (|replace| (FILEBROWSER TOTALFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) SIGN)) (COND (DELETEDP (|replace| (FILEBROWSER DELETEDFILES) |of| FBROWSER |with| (|add| (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER) SIGN)))) (COND (SIZE (|add| (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) (SETQ SIZE (ITIMES SIZE SIGN))) (COND (DELETEDP (|add| (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER) SIZE))))))) +) (FB.SETNEWPATTERN +(LAMBDA (FBROWSER PATTERN) (* \; "Edited 1-Feb-88 15:46 by bvm:") (* |;;| "Called to install a new PATTERN in a filebrowser. PATTERN should already have been passed thru DIRECTORY.FILL.PATTERN.") (LET (ICON) (|replace| (FILEBROWSER PATTERN) |of| FBROWSER |with| PATTERN) (|replace| (FILEBROWSER PREPAREDPATTERN) |of| FBROWSER |with| (DIRECTORY.MATCH.SETUP PATTERN)) (|replace| (FILEBROWSER PATTERNPARSED?) |of| FBROWSER |with| NIL) (|replace| (FILEBROWSER NSPATTERN?) |of| FBROWSER |with| (STRPOS ":" (UNPACKFILENAME.STRING PATTERN (QUOTE HOST)))) (COND ((SETQ ICON (WINDOWPROP (|fetch| (FILEBROWSER BROWSERWINDOW) |of| FBROWSER) (QUOTE ICONWINDOW))) (* \; "Change the icon label") (ICONW.TITLE ICON PATTERN))) PATTERN)) +) (FB.GET.NEWPATTERN +(LAMBDA (BROWSER) (* \; "Edited 30-Aug-94 19:47 by jds") (FB.ALLOW.ABORT BROWSER) (LET* ((OLDPATTERN (|fetch| (FILEBROWSER PATTERN) |of| BROWSER)) (PATTERN (FB.PROMPTFORINPUT (COND (OLDPATTERN "New file group description: ") (T "File group description: ")) OLDPATTERN BROWSER T))) (COND (PATTERN (DIRECTORY.FILL.PATTERN PATTERN))))) +) (FB.OPTIONSCOMMAND +(LAMBDA (BROWSER) (* |bvm:| "13-Sep-85 16:13") (FB.PROMPTWPRINT BROWSER "Please use the Options roll-out submenu to select the option you desire.")) +) ) (* \; "window functions") (DEFINEQ (FB.INFOMENU.SHADEINITIALSELECTIONS +(LAMBDA (MENUWINDOW INITIALSELECTIONS) (* \; "Edited 21-Jan-88 18:36 by bvm") (LET* ((MENU (CAR (WINDOWPROP MENUWINDOW (QUOTE MENU)))) (MENUITEMS (|fetch| (MENU ITEMS) |of| MENU))) (|for| SELECTION |in| INITIALSELECTIONS |do| (SHADEITEM (FB.INFO.ITEM.NAMED SELECTION MENUITEMS) MENU FB.INFOSHADE MENUWINDOW)))) +) (FB.INFO.ITEM.NAMED +(LAMBDA (TAG ITEMS) (* \; "Edited 21-Jan-88 17:38 by bvm") (* |;;;| "search list items for one with second element TAG") (|for| ITEM |in| ITEMS |when| (STRING-EQUAL (CADR ITEM) TAG) |do| (RETURN ITEM))) +) ) (DEFINEQ (FB.MAKECOUNTERWINDOW +(LAMBDA (BROWSERWINDOW FONT WIDTH HEIGHT TITLE) (* \; "Edited 30-Aug-94 19:47 by jds") (LET ((COUNTERW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 HEIGHT _ HEIGHT WIDTH _ WIDTH) (OR TITLE "File Browser Window") NIL T))) (FB.MAKERIGIDWINDOW COUNTERW) (DSPFONT FONT COUNTERW) (ATTACHWINDOW COUNTERW BROWSERWINDOW (QUOTE TOP)) (|replace| (FILEBROWSER COUNTERWINDOW) |of| (WINDOWPROP BROWSERWINDOW (QUOTE FILEBROWSER)) |with| COUNTERW) (WINDOWPROP COUNTERW (QUOTE REPAINTFN) (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW (QUOTE RESHAPEFN) (FUNCTION FB.COUNTERW.REDISPLAYFN)) (WINDOWPROP COUNTERW (QUOTE PAGEFULLFN) (FUNCTION NILL)) COUNTERW)) +) (FB.COUNTERW.REDISPLAYFN +(LAMBDA (COUNTERWINDOW) (* \; "Edited 4-Feb-88 15:11 by bvm:") (LET ((BROWSER (WINDOWPROP (MAINWINDOW COUNTERWINDOW T) (QUOTE FILEBROWSER)))) (|if| (|fetch| (FILEBROWSER FBREADY) |of| BROWSER) |then| (* \; "Don't do this if user reshapes while we're still enumerating.") (CLEARW COUNTERWINDOW) (FB.DISPLAY.COUNTERS BROWSER)))) +) (FB.UPDATE.COUNTERS +(LAMBDA (FBROWSER TYPE) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (XPOSPAIRS (|fetch| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (PAGESTRING (|fetch| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER)) (HEIGHT (WINDOWPROP COUNTERW (QUOTE HEIGHT))) HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES))) ((NEQ TYPE (QUOTE DELETED)) (* \; "Don't need to update total if only deleted count changed") (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES))) (AND (NEQ TYPE (QUOTE TOTAL)) (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (|for| LAB |in| LABELS |as| PAIR |in| XPOSPAIRS |when| LAB |do| (DSPXPOSITION (CAR PAIR) COUNTERW) (PRIN3 LAB COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE (CADR PAIR) HERE) HEIGHT (QUOTE REPLACE))))) +) (FB.DISPLAY.COUNTERS +(LAMBDA (FBROWSER) (* \; "Edited 30-Aug-94 19:48 by jds") (LET* ((COUNTERW (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER)) (TOTAL (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER)) (TOTALPAGES (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER)) (DEL (|fetch| (FILEBROWSER DELETEDFILES) |of| FBROWSER)) (DELPAGES (|fetch| (FILEBROWSER DELETEDPAGES) |of| FBROWSER)) (COUNTERWIDTH (WINDOWPROP COUNTERW (QUOTE WIDTH))) (COUNTERFONT (DSPFONT NIL COUNTERW)) (SECTIONWIDTH (IQUOTIENT COUNTERWIDTH 2)) (THRESHOLDWIDTH (IDIFFERENCE SECTIONWIDTH (ITIMES 2 (CHARWIDTH (CHARCODE \a) COUNTERFONT)))) (HEIGHT (WINDOWPROP COUNTERW (QUOTE HEIGHT))) PAGESTRING MAXWIDTH HERE LABELS) (SETQ LABELS (LIST (COND ((|fetch| (FILEBROWSER SHOWUNDELETED?) |of| FBROWSER) (LIST "Undeleted: " (FB.COUNTER.STRING FBROWSER (IDIFFERENCE TOTAL DEL) (IDIFFERENCE TOTALPAGES DELPAGES)))) (T (LIST "Total: " (FB.COUNTER.STRING FBROWSER TOTAL TOTALPAGES)))) (LIST "Deleted: " (FB.COUNTER.STRING FBROWSER DEL DELPAGES)))) (DSPXPOSITION 0 COUNTERW) (DSPRIGHTMARGIN MAX.SMALLP COUNTERW) (LINELENGTH MAX.SMALLP COUNTERW) (SETQ MAXWIDTH 0) (|for| LAB |in| LABELS |do| (SETQ MAXWIDTH (IMAX MAXWIDTH (IPLUS (STRINGWIDTH (CAR LAB) COUNTERFONT) (STRINGWIDTH (CADR LAB) COUNTERFONT))))) (COND ((NOT (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER)) (SETQ PAGESTRING "")) ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH (SETQ PAGESTRING " pages") COUNTERFONT)) THRESHOLDWIDTH) (* \; "Try a shorter word") (SETQ PAGESTRING " pgs"))) (COND ((IGREATERP (PLUS MAXWIDTH (STRINGWIDTH PAGESTRING COUNTERFONT)) THRESHOLDWIDTH) (* \; "The long labels are too long, so abbreviate them. Only have to do this for very narrow windows") (|for| LAB |in| LABELS |do| (RPLACA LAB (CONCAT (SUBSTRING (CAR LAB) 1 3) ": "))))) (|replace| (FILEBROWSER COUNTERPOSITIONS) |of| FBROWSER |with| (|for| LAB |in| LABELS |as| NEXTPOS |from| SECTIONWIDTH |by| SECTIONWIDTH |collect| (PRIN3 (CAR LAB) COUNTERW) (LIST (DSPXPOSITION NIL COUNTERW) (PROGN (PRIN3 (CADR LAB) COUNTERW) (PRIN3 PAGESTRING COUNTERW) (BLTSHADE WHITESHADE COUNTERW (SETQ HERE (DSPXPOSITION NIL COUNTERW)) 0 (IDIFFERENCE NEXTPOS HERE) HEIGHT (QUOTE REPLACE)) (DSPXPOSITION NEXTPOS COUNTERW) NEXTPOS)))) (|replace| (FILEBROWSER COUNTERPAGESTRING) |of| FBROWSER |with| PAGESTRING))) +) (FB.COUNTER.STRING +(LAMBDA (FBROWSER NFILES NPAGES) (* |bvm:| "11-Sep-85 11:44") (COND ((|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) (CONCAT NFILES " / " NPAGES)) (T (MKSTRING NFILES)))) +) ) (DEFINEQ (FB.MAKEHEADINGWINDOW +(LAMBDA (BROWSERWINDOW WIDTH HEIGHT FONT) (* \; "Edited 22-Jan-88 17:45 by bvm") (LET ((HEADINGW (CREATEW (|create| REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ WIDTH HEIGHT _ HEIGHT) NIL 0 T))) (DSPFONT FONT HEADINGW) (FB.MAKERIGIDWINDOW HEADINGW) (ATTACHWINDOW HEADINGW BROWSERWINDOW (QUOTE TOP)) (WINDOWPROP HEADINGW (QUOTE PASSTOMAINCOMS) T) (* \; "Pass ALL window ops to main window, since we look sort of like a title bar") (DSPTEXTURE BLACKSHADE HEADINGW) (WINDOWPROP HEADINGW (QUOTE REPAINTFN) (FUNCTION FB.HEADINGW.REDISPLAYFN)) (WINDOWPROP HEADINGW (QUOTE RESHAPEFN) (FUNCTION FB.HEADINGW.RESHAPEFN)) (* \; "This is a white on black window") (DSPOPERATION (QUOTE INVERT) HEADINGW) (DSPFILL NIL BLACKSHADE (QUOTE REPLACE) HEADINGW) HEADINGW)) +) (FB.HEADINGW.REDISPLAYFN +(LAMBDA (WINDOW) (* |bvm:| "19-Sep-85 14:39") (FB.HEADINGW.DISPLAY (WINDOWPROP (WINDOWPROP WINDOW (QUOTE MAINWINDOW)) (QUOTE FILEBROWSER)) WINDOW)) +) (FB.HEADINGW.RESHAPEFN +(LAMBDA (WINDOW) (* \; "Edited 22-Jan-88 17:51 by bvm") (* |;;;| "Redraw the heading window after a reshape") (LET ((FBROWSER (WINDOWPROP (WINDOWPROP WINDOW (QUOTE MAINWINDOW)) (QUOTE FILEBROWSER)))) (CLEARW WINDOW) (FB.HEADINGW.DISPLAY FBROWSER WINDOW))) +) (FB.HEADINGW.DISPLAY +(LAMBDA (FBROWSER WINDOW) (* \; "Edited 30-Aug-94 19:42 by jds") (LET* ((STREAM (WINDOWPROP WINDOW (QUOTE DSP))) (CLIP (DSPCLIPPINGREGION NIL WINDOW)) (RMARG (|fetch| (REGION RIGHT) |of| CLIP)) (BORDER (WINDOWPROP (MAINWINDOW WINDOW) (QUOTE BORDER))) (NEXTPOS (+ BORDER (|fetch| (FILEBROWSER INFOSTART) |of| FBROWSER))) (DEPTH (|fetch| (FILEBROWSER FBDISPLAYEDDEPTH) |of| FBROWSER)) FORMAT) (DSPFILL CLIP BLACKSHADE (QUOTE REPLACE) STREAM) (* \; "Note: title window has no border, so add the main window's border width to all x computations here.") (DSPRIGHTMARGIN 32000 STREAM) (|if| (< (|fetch| (REGION LEFT) |of| CLIP) NEXTPOS) |then| (* \; "Some of \"Name (depth n)\" field may be visible.") (DSPXPOSITION (+ TB.LEFT.MARGIN BORDER) STREAM) (PRIN3 "Name" STREAM) (|if| (NEQ DEPTH 0) |then| (CL:FORMAT STREAM " (depth ~D)" DEPTH))) (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |until| (> NEXTPOS RMARG) |do| (DSPXPOSITION (|if| (LISTP (SETQ FORMAT (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC))) |then| (* \; "Right-justified integer field, so right-justify title") (- (+ NEXTPOS (CADR FORMAT)) (STRINGWIDTH (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM)) |else| NEXTPOS) STREAM) (PRIN3 (|fetch| (INFOFIELD INFOLABEL) |of| SPEC) STREAM) (|add| NEXTPOS (|fetch| (INFOFIELD INFOWIDTH) |of| SPEC))))) +) ) (DEFINEQ (FB.ICONFN +(LAMBDA (WINDOW OLDICON POSITION) (* \; "Edited 30-Aug-94 19:48 by jds") (OR OLDICON (TITLEDICONW FB.ICONSPEC (|fetch| (FILEBROWSER PATTERN) |of| (WINDOWPROP WINDOW (QUOTE FILEBROWSER))) FB.ICONFONT POSITION NIL NIL (QUOTE FILE)))) +) (FB.INFOMENU.WHENSELECTEDFN +(LAMBDA (ITEM MENU KEY) (* |bvm:| "18-Sep-85 11:51") (LET* ((INFO (CADR ITEM)) (WINDOW (WINDOWPROP (WFROMMENU MENU) (QUOTE MAINWINDOW))) (BROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER))) (CHOSEN (|fetch| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER))) (COND ((FMEMB INFO CHOSEN) (SHADEITEM ITEM MENU WHITESHADE) (SETQ CHOSEN (REMOVE INFO CHOSEN))) (T (SHADEITEM ITEM MENU FB.INFOSHADE) (SETQ CHOSEN (CONS INFO CHOSEN)))) (|replace| (FILEBROWSER INFOMENUCHOICES) |of| BROWSER |with| CHOSEN))) +) (FB.CLOSEFN +(LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 27-Jan-88 23:52 by bvm") (* |;;| "did you really want to close up shop?") (RESETLST (COND ((NOT (OBTAIN.MONITORLOCK (|fetch| (FILEBROWSER FBLOCK) |of| (TB.USERDATA TBROWSER)) T T)) (* \; "We're busy") (PROMPTPRINT (CONCAT "Can't " (L-CASE FLG) " window while browser is busy")) (QUOTE DON\'T)) ((NEQ (TB.NUMBER.OF.ITEMS TBROWSER (QUOTE DELETED)) 0) (* \; "There are deleted items. Shall we expunge?") (SELECTQ (MENU (FB.EXPUNGE?.MENU)) (EXPUNGE (* \; "Do expunge in another process, not here in mouse") (FUNCTION FB.CLOSE&EXPUNGE)) (NOEXPUNGE NIL) (QUOTE DON\'T)))))) +) (FB.EXPUNGE?.MENU +(LAMBDA NIL (* \; "Edited 1-Feb-88 15:25 by bvm:") (OR FB.EXPUNGE?MENU (SETQ FB.EXPUNGE?MENU (|create| MENU ITEMS _ FB.CLOSE.MENU.ITEMS MENUROWS _ 2 CENTERFLG _ T TITLE _ "Do what with deleted files?" MENUFONT _ FB.BROWSERFONT)))) +) (FB.AFTERCLOSEFN +(LAMBDA (TBROWSER WINDOW) (* |bvm:| "12-Sep-85 15:12") (* |;;;| "Snap circularities before window vanishes") (LET ((FBROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER) NIL))) (|replace| (FILEBROWSER TABLEBROWSER) |of| FBROWSER |with| NIL) (TB.USERDATA TBROWSER NIL))) +) (FB.CLOSE&EXPUNGE +(LAMBDA (TBROWSER WINDOW FLG) (* \; "Edited 1-Feb-88 16:37 by bvm:") (LET ((BROWSER (TB.USERDATA TBROWSER)) MENU ITEM) (|find| W |in| (ATTACHEDWINDOWS WINDOW) |suchthat| (AND (SETQ MENU (CAR (WINDOWPROP W (QUOTE MENU)))) (EQ 1 (|fetch| (MENU MENUCOLUMNS) |of| MENU)))) (SETQ ITEM (ASSOC (QUOTE |Expunge|) (|fetch| (MENU ITEMS) |of| MENU))) (RESETLST (FB.MAKE.BROWSER.BUSY BROWSER ITEM MENU) (COND ((FB.EXPUNGECOMMAND BROWSER NIL NIL NIL FLG) (* |;;| "Expunge succeeded. Unshade the Expunge item and get rid of Abort before we shrink, or else they will still be shaded/Open when we expand") (FB.FINISH.COMMAND BROWSER ITEM MENU) (TB.FINISH.CLOSE TBROWSER (|fetch| (FILEBROWSER BROWSERWINDOW) |of| BROWSER) FLG)))))) +) ) (DEFINEQ (FB.HARDCOPY.DIRECTORY +(LAMBDA (WINDOW IMAGESTREAM) (* \; "Edited 30-Aug-94 19:42 by jds") (RESETLST (LET ((FBROWSER (WINDOWPROP WINDOW (QUOTE FILEBROWSER))) (TBROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) (SCALE (DSPSCALE NIL IMAGESTREAM)) (RMARG (DSPRIGHTMARGIN MAX.SMALLP IMAGESTREAM)) (LMARG (DSPLEFTMARGIN NIL IMAGESTREAM)) (MAXNAMEWIDTH 0) (MAINFONT FB.HARDCOPY.FONT) (DIRFONT (OR FB.HARDCOPY.DIRECTORY.FONT ITALICFONT)) FDATA INFO W LABEL COLUMNSPECS INFOLMARG PROPS FILES TITLE PAD DATEWIDTH) (ALLOW.BUTTON.EVENTS) (* \; "Ensure that we are no longer the mouse process (should be redundant)") (FB.MAKE.BROWSER.BUSY FBROWSER) (* \; "Grab the browser, so it doesn't change out from under us") (FB.ALLOW.ABORT FBROWSER) (* \; "Enable abort button") (FB.PROMPTWPRINT FBROWSER T "Producing hardcopy listing of directory...") (|if| MAINFONT |then| (* \; "User-settable font for listing to appear in") (DSPFONT MAINFONT IMAGESTREAM)) (SETQ MAINFONT (DSPFONT NIL IMAGESTREAM)) (* \; "Get coerced font, or default") (SETQ TITLE (CONCAT "Directory of " (|fetch| (FILEBROWSER PATTERN) |of| FBROWSER))) (STREAMPROP IMAGESTREAM (QUOTE PRINTOPTIONS) (LIST* (QUOTE DOCUMENT.NAME) TITLE (STREAMPROP IMAGESTREAM (QUOTE PRINTOPTIONS)))) (* \; "Give the document a nice name") (FB.HARDCOPY.PRINT.TITLE (CONCAT "Directory of " (WINDOWPROP (|fetch| (FILEBROWSER COUNTERWINDOW) |of| FBROWSER) (QUOTE TITLE))) IMAGESTREAM LMARG RMARG) (|if| (|fetch| (FILEBROWSER PAGECOUNT?) |of| FBROWSER) |then| (FB.HARDCOPY.PRINT.TITLE (CONCAT (|fetch| (FILEBROWSER TOTALFILES) |of| FBROWSER) " files in " (|fetch| (FILEBROWSER TOTALPAGES) |of| FBROWSER) " pages") IMAGESTREAM LMARG RMARG)) (SETQ PAD (TIMES SCALE 12)) (* \; "Space between columns") (|for| ITEM |in| (SETQ FILES (TB.COLLECT.ITEMS TBROWSER)) |unless| (|fetch| (FBFILEDATA DIRECTORYP) |of| (SETQ FDATA (|fetch| TIDATA |of| ITEM))) |do| (SETQ MAXNAMEWIDTH (IMAX (STRINGWIDTH (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) MAINFONT) MAXNAMEWIDTH))) (SETQ COLUMNSPECS (|for| SPEC |in| (|fetch| (FILEBROWSER INFODISPLAYED) |of| FBROWSER) |as| INDEX |from| 0 |bind| PROTO |collect| (* \; "For each bit of info to print, compute how much space we expect it to need. Second slot filled in below") (LIST* (+ PAD (|if| (SETQ PROTO (|fetch| (INFOFIELD INFOPROTOTYPE) |of| SPEC)) |then| (STRINGWIDTH PROTO IMAGESTREAM) |elseif| (EQ (|fetch| (INFOFIELD INFOFORMAT) |of| SPEC) (QUOTE DATE)) |then| (OR DATEWIDTH (SETQ DATEWIDTH (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT T))) |else| (FB.HARDCOPY.MAXWIDTH FILES INDEX MAINFONT))) NIL SPEC))) (SETQ INFOLMARG (- RMARG (|for| PAIR |in| COLUMNSPECS |sum| (CAR PAIR)))) (LET ((NAMERIGHTMARG (+ LMARG MAXNAMEWIDTH PAD))) (|if| (< NAMERIGHTMARG INFOLMARG) |then| (* \; "Enough space for name plus all info with room left over") (SETQ INFOLMARG NAMERIGHTMARG) |elseif| (> INFOLMARG LMARG) |then| (* \; "Ok, there's enough space for info, though it might end up on a separate line from file name") |else| (* \; "Ugh, want to print more info than fits on a line. Punt") (SETQ INFOLMARG NAMERIGHTMARG) (DSPRIGHTMARGIN RMARG IMAGESTREAM) (* \; "make it wrap after all"))) (LET ((FIRSTINFOCOLUMN INFOLMARG)) (|for| PAIR |in| COLUMNSPECS |do| (* \; "Print headers") (SETQ LABEL (|fetch| (INFOFIELD INFOLABEL) |of| (CDDR PAIR))) (SETQ W (FIXR (CAR PAIR))) (DSPXPOSITION (+ FIRSTINFOCOLUMN (IQUOTIENT (- (- W PAD) (STRINGWIDTH LABEL IMAGESTREAM)) 2)) IMAGESTREAM) (* \; "Center the label") (PRIN3 LABEL IMAGESTREAM) (RPLACA PAIR (PROG1 FIRSTINFOCOLUMN (|add| FIRSTINFOCOLUMN W))) (* \; "First element is left position of the entry ") (|if| (|fetch| (INFOFIELD INFOFORMAT) |of| (CDDR PAIR)) |then| (* \; "Second element is right margin (for right-justified items)") (RPLACA (CDR PAIR) (- FIRSTINFOCOLUMN PAD)))) (TERPRI IMAGESTREAM) (TERPRI IMAGESTREAM)) (|for| ITEM |in| FILES |bind| FILEINFO INFO FORMAT HERE NEXT |do| (SETQ FDATA (|fetch| TIDATA |of| ITEM)) (|if| (|fetch| (FBFILEDATA DIRECTORYP) |of| FDATA) |then| (DSPFONT DIRFONT IMAGESTREAM) (DSPXPOSITION (+ LMARG (TIMES SCALE 16)) IMAGESTREAM) (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (DSPFONT MAINFONT IMAGESTREAM) |else| (PRIN3 (|fetch| (FBFILEDATA PRINTNAME) |of| FDATA) IMAGESTREAM) (|if| COLUMNSPECS |then| (SETQ FILEINFO (|fetch| (FBFILEDATA FILEINFO) |of| FDATA)) (|if| (AND (> (SETQ HERE (DSPXPOSITION NIL IMAGESTREAM)) INFOLMARG) (OR (NULL (SETQ NEXT (CADR (CAR COLUMNSPECS)))) (> HERE NEXT) (AND (SETQ INFO (CAR FILEINFO)) (> (+ HERE (TIMES SCALE 6)) (- NEXT (STRINGWIDTH INFO MAINFONT)))))) |then| (* \; "name overran start of info--go to next line. The complex second clause lets us cheat in the case where the first info column is right-justified and will turn out to be short enough to leave space") (TERPRI IMAGESTREAM)) (|for| PAIR |in| COLUMNSPECS |as| INFO |in| FILEINFO |do| (DSPXPOSITION (COND ((SETQ NEXT (CADR PAIR)) (* \; "Get numbers to line up right justified") (- NEXT (STRINGWIDTH INFO MAINFONT))) (T (CAR PAIR))) IMAGESTREAM) (|if| INFO |then| (PRIN3 INFO IMAGESTREAM))))) (TERPRI IMAGESTREAM) (BLOCK)) (FB.PROMPTWPRINT FBROWSER "done") (DSPRIGHTMARGIN RMARG IMAGESTREAM)))) +) (FB.HARDCOPY.PRINT.TITLE +(LAMBDA (TITLE IMAGESTREAM LMARG RMARG) (* \; "Edited 5-Mar-87 17:59 by bvm:") (DSPXPOSITION (+ LMARG (IQUOTIENT (- RMARG (+ LMARG (STRINGWIDTH TITLE IMAGESTREAM))) 2)) IMAGESTREAM) (|printout| IMAGESTREAM TITLE T T)) +) (FB.HARDCOPY.MAXWIDTH +(LAMBDA (FILES ATTRINDEX FONT DATEP) (* \; "Edited 27-Jan-88 13:10 by bvm") (* |;;| "Compute maximum width of values of the ATTRIBUTE prop of each of the items in FILES.") (* |;;| "If DATEP is true, we assume all dates are created equal, and just return the first one") (|if| (AND DATEP (NEQ (CHARWIDTH (CHARCODE W) FONT) (CHARWIDTH (CHARCODE \i) FONT))) |then| (* \; "Variable-width font, let's compute it for real") (SETQ DATEP NIL)) (|for| ITEM |in| FILES |bind| (MAXWIDTH _ 0) INFO WIDTH |when| (AND (SETQ INFO (CL:NTH ATTRINDEX (|fetch| (FBFILEDATA FILEINFO) |of| (|fetch| TIDATA |of| ITEM)))) (> (SETQ WIDTH (STRINGWIDTH INFO FONT)) MAXWIDTH)) |do| (|if| DATEP |then| (RETURN WIDTH)) (SETQ MAXWIDTH WIDTH) |finally| (RETURN MAXWIDTH))) +) ) (DECLARE\: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) TABLEBROWSERDECLS) (DECLARE\: EVAL@COMPILE (RECORD INFOFIELD (INFONAME INFOLABEL INFOWIDTH INFOFORMAT INFOPROTOTYPE)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (* \; "Full name of this file") (FILEINFO POINTER) (* \; "Plist of attributes") (VERSIONLESSNAME POINTER) (* \; "FILENAME sans version") (DIRECTORYP FLAG) (* \; "True if it's a directory line") (HASDIRPREFIX FLAG) (* \;  "True if it has a directory prefix beyond that in common to all the files") (DIRECTORYFILEP FLAG) (* \;  "True if the \"file\" in this item is actually a subdirectory") (SIZE POINTER) (* \; "Size of file, for stats") (FILEDEPTH BYTE) (* \;  "Number of levels of subdirectory beneath the main pattern--zero for files at that level") (SORTVALUE POINTER) (* \;  "Cached value by which we are sorting the dir.") (SUBDIREND WORD) (* \;  "Index of last char in subdirectory, or zero if HASDIRPREFIX is false") (STARTOFPNAME WORD) (* \;  "Start of name for printing purposes. Same as STARTOFNAME when browser sorted by name") (VERSION WORD) (* \; "Version, or zero if none") (STARTOFNAME WORD) (* \;  "Index beyond all directory fields") DUMMY) (ACCESSFNS FBFILEDATA ((PRINTNAME (SUBSTRING (FETCH (FBFILEDATA FILENAME ) OF DATUM) (FETCH (FBFILEDATA STARTOFPNAME ) OF DATUM))) (SUBDIRECTORY (SUBSTRING (FETCH (FBFILEDATA FILENAME) OF DATUM) 1 (FETCH (FBFILEDATA SUBDIREND ) OF DATUM)))))) (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (* \;  "True if we don't want separate subdirectory lines -- subdirs then included in name") (NSPATTERN? FLAG) (* \; "True if host is an ns host") (SHOWUNDELETED? FLAG) (* \;  "True if counter window should show `Undeleted' rather than `Total' counts") (PATTERNPARSED? FLAG) (* \;  "True if PREPAREDPATTERN, NAMESTART, DIRECTORYSTART are valid") (SORTBYDATE FLAG) (* \;  "True if SORTATTRIBUTE is one of the date attributes") (FBREADY FLAG) (* \; "False while FB is enumerating.") (ABORTING FLAG) (* \;  "True if enumeration is being aborted") (FIXEDTITLE FLAG) (* \; "True if caller supplied title") (FBCOMPUTEDDEPTH BYTE) (* \;  "Depth at the time we enumerated directory (zero for infinite)") (FBDISPLAYEDDEPTH BYTE) (* \;  "Depth we are currently displaying (zero for infinite)") (TABLEBROWSER POINTER) (* \;  "Pointer to TABLEBROWSER object controlling the browser") (BROWSERWINDOW POINTER) (* \; "Main window") (COUNTERWINDOW POINTER) (* \;  "Window that counts files, pages, deletions") (HEADINGWINDOW POINTER) (* \;  "Window with headings for browser columns") (INFOMENUW POINTER) (* \;  "Window containing choices for info to be displayed, or NIL if none yet") (PROMPTWINDOW POINTER) (* \; "GETPROMPTWINDOW BROWSERWINDOW") (INFODISPLAYED POINTER) (* \;  "List of attribute specs to be displayed") (PATTERN POINTER) (* \;  "Directory pattern being enumerated") (PREPAREDPATTERN POINTER) (* \; "DIRECTORY.MATCH.SETUP of same") (SEEWINDOW POINTER) (* \;  "Primary window used by FAST SEE command") (BROWSERFONT POINTER) (* \; "Font of BROWSERWINDOW") (SORTBY POINTER) (* \;  "Sorting function or NIL for default sort") (NAMESTART WORD) (* \;  "Index of first character in file name beyond the common prefix shared by all") (DIRECTORYSTART WORD) (* \;  "Index of first character of directory in file names") (INFOSTART WORD) (* \;  "X position in browser where first col of info is displayed") (NAMEOVERHEAD WORD) (* \;  "This plus width of name gives is how much to allow before INFOSTART") (OVERFLOWSPACING WORD) (* \;  "Increment between sizes considered for INFOSTART") (DIGITWIDTH WORD) (TOTALFILES WORD) (* \;  "Total number of files, deleted files, pages, deleted pages at the moment") (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (* \;  "True if INFOCHOICES includes SIZE or LENGTH, so that we can count pages") (COUNTERPOSITIONS POINTER) (* \;  "List of pairs (left right) describing regions where the values of the counters are displayed") (COUNTERPAGESTRING POINTER) (* \;  "String to print after file/page count") (OVERFLOWWIDTHS POINTER) (* \;  "List of (xpos occurrences) describing files whose names exceed default INFOSTART") (INFOMENUCHOICES POINTER) (* \;  "Selections user has made in Info window, not necessarily the info currently displayed") (UPDATEPROC POINTER) (* \;  "Process doing an Update (Recompute)") (DEFAULTDIR POINTER) (* \;  "Default directory for destination of Copy/Rename") (SORTATTRIBUTE POINTER) (* \;  "Attribute being sorted on, or NIL if by name") (SORTMENU POINTER) (FBLOCK POINTER) (* \;  "Lock acquired by filebrowser operations") (SORTINDEX WORD) (* \;  "Index (zero-based) in file info of the sort attribute") (SIZEINDEX WORD) (* \; "Index of size attribute") (FBDEPTH POINTER) (* \;  "Enumeration depth, or NIL for default") (ABORTWINDOW POINTER) (* \;  "Dotted pair of (abortwindow . menuw) for this browser's abort window.") DUMMY)) ) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (DECLARE\: EVAL@COMPILE (RPAQQ FB.MORE.BORDER 8) (RPAQQ FB.NULL.VERSION 0) (CONSTANTS FB.MORE.BORDER FB.NULL.VERSION) ) (DECLARE\: EVAL@COMPILE (PUTPROPS NULL.VERSIONP MACRO ((V) (EQ V 0))) (PUTPROPS NULL.DIRECTORYP MACRO ((FILEDATA) (EQ (FETCH (FBFILEDATA SUBDIREND) OF FILEDATA) 0))) (PUTPROPS EQ.DIRECTORYP MACRO (OPENLAMBDA (FD1 FD2) (STRING-EQUAL (|fetch| (FBFILEDATA FILENAME) |of| FD1) (|fetch| (FBFILEDATA FILENAME) |of| FD2) :END1 (|fetch| (FBFILEDATA SUBDIREND) |of| FD1) :END2 (|fetch| (FBFILEDATA SUBDIREND) |of| FD2)))) (PUTPROPS NULL.FIELDP MACRO (OPENLAMBDA (STR) (OR (NULL STR) (EQ (NCHARS STR) 0)))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FB.ICONFONT FB.BROWSERFONT FB.PROMPTFONT FB.MENUFONT FB.HARDCOPY.FONT FB.HARDCOPY.DIRECTORY.FONT FB.EXPUNGE?MENU FB.CLOSE.MENU.ITEMS FB.DEPTH.MENU.ITEMS FB.MENU.ITEMS FB.DEFAULT.INFO FB.INFOSHADE FB.INFO.MENU.ITEMS FB.ITEMUNSELECTEDSHADE FB.ITEMSELECTEDSHADE DIRCOMMANDS FB.PROMPTLINES FB.INFO.FIELDS |WindowTitleDisplayStream| FB.ICONSPEC FB.DEFAULT.NAME.WIDTH FB.OVERFLOW.MAXABSOLUTE FB.OVERFLOW.MAXFRAC FB.DEFAULT.EDITOR FB.BROWSER.DIRECTORY.FONT ITALICFONT PRINTFILETYPES) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (/DECLAREDATATYPE 'FILEBROWSER '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILEBROWSER 0 (FLAGBITS . 0)) (FILEBROWSER 0 (FLAGBITS . 16)) (FILEBROWSER 0 (FLAGBITS . 32)) (FILEBROWSER 0 (FLAGBITS . 48)) (FILEBROWSER 0 (FLAGBITS . 64)) (FILEBROWSER 0 (FLAGBITS . 80)) (FILEBROWSER 0 (FLAGBITS . 96)) (FILEBROWSER 0 (FLAGBITS . 112)) (FILEBROWSER 0 (BITS . 135)) (FILEBROWSER 1 (BITS . 7)) (FILEBROWSER 2 POINTER) (FILEBROWSER 4 POINTER) (FILEBROWSER 6 POINTER) (FILEBROWSER 8 POINTER) (FILEBROWSER 10 POINTER) (FILEBROWSER 12 POINTER) (FILEBROWSER 14 POINTER) (FILEBROWSER 16 POINTER) (FILEBROWSER 18 POINTER) (FILEBROWSER 20 POINTER) (FILEBROWSER 22 POINTER) (FILEBROWSER 24 POINTER) (FILEBROWSER 26 (BITS . 15)) (FILEBROWSER 27 (BITS . 15)) (FILEBROWSER 28 (BITS . 15)) (FILEBROWSER 29 (BITS . 15)) (FILEBROWSER 30 (BITS . 15)) (FILEBROWSER 31 (BITS . 15)) (FILEBROWSER 32 (BITS . 15)) (FILEBROWSER 33 (BITS . 15)) (FILEBROWSER 34 POINTER) (FILEBROWSER 36 POINTER) (FILEBROWSER 38 POINTER) (FILEBROWSER 40 POINTER) (FILEBROWSER 42 POINTER) (FILEBROWSER 44 POINTER) (FILEBROWSER 46 POINTER) (FILEBROWSER 48 POINTER) (FILEBROWSER 50 POINTER) (FILEBROWSER 52 POINTER) (FILEBROWSER 54 POINTER) (FILEBROWSER 56 POINTER) (FILEBROWSER 58 (BITS . 15)) (FILEBROWSER 59 (BITS . 15)) (FILEBROWSER 60 POINTER) (FILEBROWSER 62 POINTER) (FILEBROWSER 64 POINTER)) '66) (/DECLAREDATATYPE 'FBFILEDATA '(POINTER POINTER POINTER FLAG FLAG FLAG POINTER BYTE POINTER WORD WORD WORD WORD POINTER) '((FBFILEDATA 0 POINTER) (FBFILEDATA 2 POINTER) (FBFILEDATA 4 POINTER) (FBFILEDATA 4 (FLAGBITS . 0)) (FBFILEDATA 4 (FLAGBITS . 16)) (FBFILEDATA 4 (FLAGBITS . 32)) (FBFILEDATA 6 POINTER) (FBFILEDATA 8 (BITS . 7)) (FBFILEDATA 10 POINTER) (FBFILEDATA 9 (BITS . 15)) (FBFILEDATA 12 (BITS . 15)) (FBFILEDATA 13 (BITS . 15)) (FBFILEDATA 14 (BITS . 15)) (FBFILEDATA 16 POINTER)) '18) (ADDTOVAR SYSTEMRECLST (DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (NSPATTERN? FLAG) (SHOWUNDELETED? FLAG) (PATTERNPARSED? FLAG) (SORTBYDATE FLAG) (FBREADY FLAG) (ABORTING FLAG) (FIXEDTITLE FLAG) (FBCOMPUTEDDEPTH BYTE) (FBDISPLAYEDDEPTH BYTE) (TABLEBROWSER POINTER) (BROWSERWINDOW POINTER) (COUNTERWINDOW POINTER) (HEADINGWINDOW POINTER) (INFOMENUW POINTER) (PROMPTWINDOW POINTER) (INFODISPLAYED POINTER) (PATTERN POINTER) (PREPAREDPATTERN POINTER) (SEEWINDOW POINTER) (BROWSERFONT POINTER) (SORTBY POINTER) (NAMESTART WORD) (DIRECTORYSTART WORD) (INFOSTART WORD) (NAMEOVERHEAD WORD) (OVERFLOWSPACING WORD) (DIGITWIDTH WORD) (TOTALFILES WORD) (DELETEDFILES WORD) (TOTALPAGES POINTER) (DELETEDPAGES POINTER) (PAGECOUNT? POINTER) (COUNTERPOSITIONS POINTER) (COUNTERPAGESTRING POINTER) (OVERFLOWWIDTHS POINTER) (INFOMENUCHOICES POINTER) (UPDATEPROC POINTER) (DEFAULTDIR POINTER) (SORTATTRIBUTE POINTER) (SORTMENU POINTER) (FBLOCK POINTER) (SORTINDEX WORD) (SIZEINDEX WORD) (FBDEPTH POINTER) (ABORTWINDOW POINTER) DUMMY)) (DATATYPE FBFILEDATA ((FILENAME POINTER) (FILEINFO POINTER) (VERSIONLESSNAME POINTER) (DIRECTORYP FLAG) (HASDIRPREFIX FLAG) (DIRECTORYFILEP FLAG) (SIZE POINTER) (FILEDEPTH BYTE) (SORTVALUE POINTER) (SUBDIREND WORD) (STARTOFPNAME WORD) (VERSION WORD) (STARTOFNAME WORD) DUMMY)) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T) (ADDTOVAR *ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW) (HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW)) (ADDTOVAR |BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER) "Opens a filebrowser window; prompts for pattern")) (RPAQQ |BackgroundMenu| NIL) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA FB) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FB.PROMPTW.FORMAT FB.PROMPTWPRINT) ) (PUTPROPS FILEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1993 1994 1999 2000 2001)) (DECLARE\: DONTCOPY (FILEMAP (NIL (20917 33529 (FB 20927 . 21482) (FB.COPYBINARYCOMMAND 21484 . 21672) (FB.COPYTEXTCOMMAND 21674 . 21858) (FILEBROWSER 21860 . 28102) (FB.TABLEBROWSER 28104 . 28266) (FB.SELECTEDFILES 28268 . 28722) (FB.FETCHFILENAME 28724 . 28959) (FB.PROMPTWPRINT 28961 . 29412) (FB.PROMPTW.FORMAT 29414 . 29935) (FB.PROMPTFORINPUT 29937 . 32189) (FB.YES-OR-NO-P 32191 . 32751) (FB.ALLOW.ABORT 32753 . 33328) (\\FB.HARDCOPY.TOFILE.EXTENSION 33330 . 33527)) (33553 34215 (FB.STARTUP 33563 . 33858) ( FB.MAKERIGIDWINDOW 33860 . 34213)) (34216 37235 (FB.PRINTFN 34226 . 37086) (FB.COPYFN 37088 . 37233)) (37285 40702 (FB.MENU.WHENSELECTEDFN 37295 . 37589) (FB.COMMANDSELECTEDFN 37591 . 38452) (FB.SUBITEMP 38454 . 38766) (FB.MAKE.BROWSER.BUSY 38768 . 39176) (FB.FINISH.COMMAND 39178 . 40097) ( FB.HANDLE.ABORT.BUTTON 40099 . 40700)) (40703 43411 (FB.DELETECOMMAND 40713 . 40913) (FB.DELVERCOMMAND 40915 . 42294) (FB.IS.NOT.SUBDIRECTORY.ITEM 42296 . 42423) (FB.DELVER.FILES 42425 . 43001) ( FB.DELETE.FILE 43003 . 43409)) (43412 44242 (FB.UNDELETECOMMAND 43422 . 43626) (FB.UNDELETEALLCOMMAND 43628 . 43826) (FB.UNDELETE.FILE 43828 . 44240)) (44243 56381 (FB.COPYCOMMAND 44253 . 44411) ( FB.RENAMECOMMAND 44413 . 44577) (FB.COPY/RENAME.COMMAND 44579 . 45102) (FB.COPY/RENAME.ONE 45104 . 46202) (FB.COPY/RENAME.MANY 46204 . 49315) (FB.MERGE.DIRECTORIES 49317 . 49554) (FB.GREATEST.PREFIX 49556 . 50216) (FB.MAYBE.INSERT.FILE 50218 . 53907) (FB.GET.NEW.FILE.SPEC 53909 . 55720) ( FB.CANONICAL.DIRECTORY 55722 . 56379)) (56382 59993 (FB.HARDCOPYCOMMAND 56392 . 57007) ( FB.HARDCOPY.TOFILE 57009 . 59991)) (59994 64171 (FB.EDITCOMMAND 60004 . 61295) (FB.EDITLISPFILE 61297 . 61891) (FB.BROWSECOMMAND 61893 . 64169)) (64172 71205 (FB.FASTSEECOMMAND 64182 . 65775) ( FB.FASTSEE.ONEFILE 65777 . 68924) (FB.SEEFULLFN 68926 . 70548) (FB.SEEBUTTONFN 70550 . 71203)) (71206 72336 (FB.LOADCOMMAND 71216 . 71523) (FB.COMPILECOMMAND 71525 . 71866) (FB.OPERATE.ON.FILES 71868 . 72334)) (72337 97097 (FB.UPDATECOMMAND 72347 . 72506) (FB.MAYBE.EXPUNGE 72508 . 73103) ( FB.UPDATEBROWSERITEMS 73105 . 79551) (FB.DATE 79553 . 79949) (FB.ADJUST.DATE.WIDTH 79951 . 81294) ( FB.SET.BROWSER.TITLE 81296 . 81892) (FB.MAYBE.WIDEN.NAMES 81894 . 82870) (FB.SET.DEFAULT.NAME.WIDTH 82872 . 83457) (FB.CREATE.FILEBUCKET 83459 . 87084) (FB.CHECK.NAME.LENGTH 87086 . 88583) ( FB.ADD.FILEGROUP 88585 . 89565) (FB.INSERT.DIRECTORY 89567 . 89776) (FB.MAKE.SUBDIRECTORY.ITEM 89778 . 90590) (FB.ADD.FILE 90592 . 91042) (FB.INSERT.FILE 91044 . 92941) (FB.ANALYZE.PATTERN 92943 . 95612 ) (FB.CANONICALIZE.PATTERN 95614 . 96360) (FB.GETALLFILEINFO 96362 . 97095)) (97098 101508 ( FB.SORT.VERSIONS 97108 . 98201) (FB.DECREASING.VERSION 98203 . 98593) (FB.INCREASING.VERSION 98595 . 98982) (FB.NAMES.DECREASING.VERSION 98984 . 99534) (FB.NAMES.INCREASING.VERSION 99536 . 100081) ( FB.DECREASING.NUMERIC.ATTR 100083 . 100577) (FB.INCREASING.NUMERIC.ATTR 100579 . 101067) ( FB.ALPHABETIC.ATTR 101069 . 101506)) (101509 106088 (FB.SORTCOMMAND 101519 . 104531) ( FB.INSERT.SUBDIRECTORIES 104533 . 104960) (FB.GET.SORT.MENU 104962 . 106086)) (106089 114725 ( FB.EXPUNGECOMMAND 106099 . 107166) (FB.NEWPATTERNCOMMAND 107168 . 107435) (FB.NEWINFOCOMMAND 107437 . 108724) (FB.DEPTHCOMMAND 108726 . 109525) (FB.SHAPECOMMAND 109527 . 111464) (FB.REMOVE.FILE 111466 . 112646) (FB.COUNT.FILE.CHANGE 112648 . 113441) (FB.SETNEWPATTERN 113443 . 114189) (FB.GET.NEWPATTERN 114191 . 114548) (FB.OPTIONSCOMMAND 114550 . 114723)) (114760 115354 ( FB.INFOMENU.SHADEINITIALSELECTIONS 114770 . 115122) (FB.INFO.ITEM.NAMED 115124 . 115352)) (115355 120184 (FB.MAKECOUNTERWINDOW 115365 . 116044) (FB.COUNTERW.REDISPLAYFN 116046 . 116404) ( FB.UPDATE.COUNTERS 116406 . 117685) (FB.DISPLAY.COUNTERS 117687 . 119984) (FB.COUNTER.STRING 119986 . 120182)) (120185 122784 (FB.MAKEHEADINGWINDOW 120195 . 120964) (FB.HEADINGW.REDISPLAYFN 120966 . 121144) (FB.HEADINGW.RESHAPEFN 121146 . 121430) (FB.HEADINGW.DISPLAY 121432 . 122782)) (122785 125489 (FB.ICONFN 122795 . 123043) (FB.INFOMENU.WHENSELECTEDFN 123045 . 123568) (FB.CLOSEFN 123570 . 124200) (FB.EXPUNGE?.MENU 124202 . 124457) (FB.AFTERCLOSEFN 124459 . 124745) (FB.CLOSE&EXPUNGE 124747 . 125487 )) (125490 131674 (FB.HARDCOPY.DIRECTORY 125500 . 130650) (FB.HARDCOPY.PRINT.TITLE 130652 . 130901) ( FB.HARDCOPY.MAXWIDTH 130903 . 131672))))) STOP \ No newline at end of file diff --git a/library/FONTSAMPLE b/library/FONTSAMPLE new file mode 100644 index 00000000..862b09f5 --- /dev/null +++ b/library/FONTSAMPLE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "11-Jun-90 15:51:10" {DSK}local>lde>lispcore>library>FONTSAMPLE.;2 16609 changes to%: (VARS FONTSAMPLECOMS) previous date%: "10-Jan-87 15:47:00" {DSK}local>lde>lispcore>library>FONTSAMPLE.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FONTSAMPLECOMS) (RPAQQ FONTSAMPLECOMS ((MACROS IDIVUP) (VARS FNT.PANEL FNT.FNAME FNT.INFOFONT FNT.OUTFTEXT) (FNS FNT.MAKEBOOK FNT.LESSP FNT.SORTP FNT.DISPLOOK FNT.DISPTBLE FNT.DISPDSCR FNT.NARRDSCR FNT.DISPINIT FNT.FACEMAP FNT.SIZEMAP FNT.MAKENAME FNT.MAKEWIND FNT.FILEMAP FNT.FINDALL FNT.FLST))) (DECLARE%: EVAL@COMPILE (PUTPROPS IDIVUP DMACRO ((INUMEXPR IDENEXPR) (LET (INUM IDEN) (SETQ INUM INUMEXPR) (SETQ IDEN IDENEXPR) (IQUOTIENT (IPLUS INUM IDEN -1) IDEN)))) ) (RPAQQ FNT.PANEL ([PROG (SETQ FNT.WIND (FNT.MAKEWIND)) (SETQ FNT.FONTLIST '(GACHA 10 (MEDIUM REGULAR REGULAR) 0 INTERPRESS] (PROG (CLEARW FNT.WIND) (FNT.DISPTBLE FNT.WIND FNT.FONTLIST)) (PROG (SETQ FNT.FILENAME (FNT.MAKENAME FNT.FONTLIST)) (SETQ FNT.STRM (OPENIMAGESTREAM FNT.FILENAME 'INTERPRESS)) (TOTOPW FNT.WIND) (BITBLT FNT.WIND 0 0 FNT.STRM 0 0 612 792 'INPUT 'REPLACE) (CLOSEF FNT.STRM)))) (RPAQQ FNT.FNAME {DSK}FONTBOOK.IP) (RPAQQ FNT.INFOFONT (TERMINAL 8 (MEDIUM REGULAR REGULAR) 0)) (RPAQQ FNT.OUTFTEXT "abcdefghijkl ABCDEFGHIJKL") (DEFINEQ (FNT.MAKEBOOK [LAMBDA (OUTFROOTNAME ListOfFonts PRNTFN PERPAGE) (* FS "30-Jun-86 11:45") (* * takes a file name and font specification and iteratively invokes a given  print function (fnt.dispfont by default) on each font in the sorted list) (LET (FONTLIST OUTFTYPE OUTFDSCR OUTFOPTS ITER THISPAGE OUTFNAME) (* * Handle input parm defaults * *) (if (EQ PRNTFN NIL) then (SETQQ PRNTFN FNT.DISPLOOK)) (if (EQ PERPAGE NIL) then (SETQ PERPAGE (SELECTQ PRNTFN (FNT.DISPTBLE 1) (FNT.DISPLOOK 18) 1))) (SETQQ OUTFTYPE INTERPRESS) (SETQQ OUTFOPTS (REGION (2794 1905 25400 24765))) (if (EQUAL ListOfFonts 'ALL) then (SETQ FONTLIST (FNT.FINDALL OUTFTYPE)) else (SETQ FONTLIST ListOfFonts)) (* * Iterate over files increment file names, iterate over fonts * *) (SETQ ITER 0) (for PAGENO from 1 to (IDIVUP (LENGTH FONTLIST) PERPAGE) do (SETQ OUTFNAME (FNT.FILEMAP OUTFROOTNAME PAGENO)) (if OUTFNAME then (SETQ OUTFDSCR (OPENIMAGESTREAM OUTFNAME OUTFTYPE OUTFOPTS))) (SETQ THISPAGE (IMIN PERPAGE (IDIFFERENCE (LENGTH FONTLIST) ITER))) [for I from 1 to THISPAGE do (SETQ ITER (ADD1 ITER)) (APPLY* PRNTFN OUTFDSCR (CAR (NTH FONTLIST ITER] (CLOSEF OUTFDSCR) (BLOCK]) (FNT.LESSP [LAMBDA (DSC1 DSC2) (* FS " 5-Jul-86 23:11") (* * Impose alpha order on font list) (PROG NIL (if (NOT (LISTP DSC1)) then (RETURN (ALPHORDER DSC1 DSC2))) (* * Switch face & size for order * *) [SETQ DSC1 (LIST (CAR DSC1) (CADDR DSC1) (CADR DSC1) (CADDDR DSC1) (CAR (CDDDR DSC1] [SETQ DSC2 (LIST (CAR DSC2) (CADDR DSC2) (CADR DSC2) (CADDDR DSC2) (CAR (CDDDR DSC2] (RETURN (FNT.SORTP DSC1 DSC2]) (FNT.SORTP [LAMBDA (DSC1 DSC2) (* FS " 5-Jul-86 23:15") (* * Impose alpha order on font list) (PROG (KEY1 KEY2) (if (NOT (LISTP DSC1)) then (RETURN (ALPHORDER DSC1 DSC2))) (SETQ KEY1 (CAR DSC1)) (SETQ KEY2 (CAR DSC2)) (* * Reverse order of face * *) [if (EQUAL KEY1 KEY2) then (RETURN (FNT.SORTP (CDR DSC1) (CDR DSC2] [if (LISTP KEY1) then (RETURN (NOT (FNT.SORTP KEY1 KEY2] (if (NUMBERP KEY1) then (RETURN (LESSP KEY1 KEY2))) (RETURN (ALPHORDER KEY1 KEY2]) (FNT.DISPLOOK [LAMBDA (FILEDSC FONTDSC) (* FS "24-Jan-86 18:19") (* * uses "private" global vars fnt.infofont and fnt.outftext to generate  sample string) (LET NIL (DSPFONT FNT.INFOFONT FILEDSC) (TERPRI FILEDSC) (TERPRI FILEDSC) (TERPRI FILEDSC) (TERPRI FILEDSC) (FNT.NARRDSCR FILEDSC (LIST FONTDSC)) (DSPFONT FONTDSC FILEDSC) (printout FILEDSC FNT.OUTFTEXT]) (FNT.DISPTBLE [LAMBDA (Stream FONTDSC) (* FS "17-Mar-86 17:37") (* * generates a font table using prin1) (LET* ((TitleFont (FONTCREATE FNT.INFOFONT)) (FontList (LIST FONTDSC)) (InchesToPrinterUnits (FTIMES 72.0 (DSPSCALE NIL Stream))) (DDev (IMAGESTREAMTYPE Stream))) (for Font in FontList do (DSPRIGHTMARGIN (TIMES 100.0 InchesToPrinterUnits) Stream) (* Let clip on right *) (MOVETO (FTIMES 0.75 InchesToPrinterUnits) (FTIMES 10.0 InchesToPrinterUnits) Stream) (DSPFONT TitleFont Stream) (FNT.NARRDSCR Stream FontList) (DSPFONT FONTDSC Stream) (printout Stream FNT.OUTFTEXT) (DSPFONT Font Stream) (for YPosition from (TIMES 9 InchesToPrinterUnits) to (TIMES 1.5 InchesToPrinterUnits ) by (TIMES -0.5 InchesToPrinterUnits) bind (CharacterCode _ 0) do (for XPosition from (TIMES 0.75 InchesToPrinterUnits) to (TIMES 7.5 InchesToPrinterUnits) by (TIMES 0.45 InchesToPrinterUnits) do (MOVETO XPosition YPosition Stream) (if (NEQ CharacterCode (CHARCODE FF)) then (if (EQ DDev 'DISPLAY) then (BLTCHAR CharacterCode Stream) else (PRIN1 (CHARACTER CharacterCode) Stream))) (SETQ CharacterCode (ADD1 CharacterCode))) (printout T ".")) (printout T " done." T]) (FNT.DISPDSCR [LAMBDA (OUTF FONTLIST) (* FS " 2-Jul-85 13:00") (* * Prints a list of fontlists with facelist formatting appropriate for 8 pt.  terminal) (PROG (NAME SIZE JUNK NUMB STRM TEMP OFFX UNITS T0 T1 T2 T3 T4 T5 T6 T7) (if (EQ FONTLIST NIL) then (RETURN NIL)) (SETQ TEMP (DSPSCALE NIL OUTF)) (SETQ UNITS (TIMES 4.25 TEMP)) (SETQ OFFX (TIMES 42.5 TEMP)) (SETQ T0 (PLUS OFFX (TIMES 0 UNITS))) (SETQ T1 (PLUS OFFX (TIMES 14 UNITS))) (SETQ T2 (PLUS OFFX (TIMES 20 UNITS))) (SETQ T3 (PLUS OFFX (TIMES 30 UNITS))) (SETQ T4 (PLUS OFFX (TIMES 40 UNITS))) (SETQ T5 (PLUS OFFX (TIMES 50 UNITS))) (SETQ T6 (PLUS OFFX (TIMES 55 UNITS))) (SETQ T7 (PLUS OFFX (TIMES 70 UNITS))) [MAPC FONTLIST '(LAMBDA (DESCR) (SETQ NAME (CAR DESCR)) (SETQ SIZE (CADR DESCR)) (SETQ JUNK (CADDR DESCR)) (SETQ TEMP (CDDDR DESCR)) (SETQ NUMB (CAR TEMP)) (SETQ STRM (CADR TEMP)) (DSPXPOSITION T0 OUTF) (printout OUTF NAME) (DSPXPOSITION T1 OUTF) (printout OUTF |.I3| SIZE) (DSPXPOSITION T2 OUTF) (printout OUTF "(" (CAR JUNK)) (DSPXPOSITION T3 OUTF) (printout OUTF (CADR JUNK)) (DSPXPOSITION T4 OUTF) (printout OUTF (CADDR JUNK) ")") (DSPXPOSITION T5 OUTF) (printout OUTF NUMB) (DSPXPOSITION T6 OUTF) (printout OUTF STRM) (DSPXPOSITION T7 OUTF] (RETURN NIL]) (FNT.NARRDSCR [LAMBDA (OUTF FONTLIST) (* ; "Edited 9-Jan-87 18:57 by FS") (* * Prints a list of fontlists with narrow formatting appropriate for 8 pt.  terminal) (PROG (NAME SIZE FACE NUMB STRM TEMP OFFX UNITS T0 T1 T2 T3 T4 T5 DESCR) (if (EQ FONTLIST NIL) then (RETURN NIL)) (if (TYPENAMEP FONTLIST 'FONTDESCRIPTOR) then (SETQ FONTLIST (FNT.FLST FONTLIST))) (SETQ TEMP (DSPSCALE NIL OUTF)) (SETQ UNITS (TIMES 4.25 TEMP)) (SETQ OFFX (TIMES 42.5 TEMP)) (SETQ T0 (PLUS OFFX (TIMES 0 UNITS))) (SETQ T1 (PLUS OFFX (TIMES 14 UNITS))) (SETQ T2 (PLUS OFFX (TIMES 20 UNITS))) (SETQ T3 (PLUS OFFX (TIMES 28 UNITS))) (SETQ T4 (PLUS OFFX (TIMES 33 UNITS))) (SETQ T5 (PLUS OFFX (TIMES 48 UNITS))) (* * (MAPC FONTLIST (QUOTE (LAMBDA (DESCR)  (SETQ NAME (CAR DESCR)) (SETQ SIZE (CADR DESCR))  (SETQ FACE (FNT.FACEMAP (CADDR DESCR))) (SETQ TEMP  (CDDDR DESCR)) (SETQ NUMB (CAR TEMP)) (SETQ STRM  (CADR TEMP)) (DSPXPOSITION T0 OUTF) (printout OUTF NAME)  (DSPXPOSITION T1 OUTF) (printout OUTF |.I3| SIZE)  (DSPXPOSITION T2 OUTF) (printout OUTF FACE)  (DSPXPOSITION T3 OUTF) (printout OUTF NUMB)  (DSPXPOSITION T4 OUTF) (printout OUTF STRM)  (DSPXPOSITION T5 OUTF))))) (for I in FONTLIST do (if (type? FONTDESCRIPTOR I) then (SETQ DESCR (FNT.FLST I)) else (SETQ DESCR I)) (SETQ NAME (CAR DESCR)) (SETQ SIZE (CADR DESCR)) (SETQ FACE (FNT.FACEMAP (CADDR DESCR))) (SETQ TEMP (CDDDR DESCR)) (SETQ NUMB (CAR TEMP)) (SETQ STRM (CADR TEMP)) (DSPXPOSITION T0 OUTF) (printout OUTF NAME) (DSPXPOSITION T1 OUTF) (printout OUTF |.I3| SIZE) (DSPXPOSITION T2 OUTF) (printout OUTF FACE) (DSPXPOSITION T3 OUTF) (printout OUTF NUMB) (DSPXPOSITION T4 OUTF) (printout OUTF STRM) (DSPXPOSITION T5 OUTF)) (RETURN NIL]) (FNT.DISPINIT [LAMBDA (FILEDSC) (* FS " 2-Jul-85 14:14") (* * initialization or optimization for fnt.dispfont) (PROG (vars...) (SETQ FNT.OUTFTEXT "abcdefghijkl ABCDEFGHIJKL") (SETQQ FNT.INFOFONT (TERMINAL 8 (MEDIUM REGULAR REGULAR) 0 INTERPRESS)) (RETURN NIL]) (FNT.FACEMAP [LAMBDA (OLDFACE) (* FS " 5-Sep-85 19:04") (* * make short face from facelist) (SETQ OLDFACE (\FONTFACE OLDFACE)) (* make list form *) (CONCAT (GNC (MKSTRING (CAR OLDFACE))) (GNC (MKSTRING (CADR OLDFACE))) (GNC (MKSTRING (CADDR OLDFACE]) (FNT.SIZEMAP [LAMBDA (SIZE) (* FS " 2-Jul-85 14:13") (* * make size into two character string) (PROG (STR) (if (ILESSP SIZE 10) then (RETURN (CONCAT "0" (MKSTRING SIZE))) else (RETURN (MKSTRING SIZE]) (FNT.MAKENAME [LAMBDA (FONTLIST) (* FS " 3-Sep-85 16:07") (* * make a unique interpress file name given a fontlist) (PROG (STR TYPE SIZE FACE DDEV) (SETQ TYPE (MKSTRING (CAR FONTLIST))) (SETQ SIZE (FNT.SIZEMAP (CADR FONTLIST))) [SETQ FACE (MKSTRING (FNT.FACEMAP (CADDR FONTLIST] (SETQ DDEV (CAR (CDDDDR FONTLIST))) (SETQ STR (CONCAT (MKSTRING TYPE) (MKSTRING SIZE) (MKSTRING FACE) (GNC (MKSTRING DDEV)) ".IP")) (RETURN STR]) (FNT.MAKEWIND [LAMBDA NIL (* FS "21-Mar-86 18:07") (* * MAKE A WINDOW) (PROG (PPI) (SETQ PPI (TIMES 72 (DSPSCALE NIL T))) [SETQ FNT.WINDOW (CREATEW (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (FIX (TIMES 8.5 PPI)) HEIGHT _ (TIMES 11 PPI] (RETURN FNT.WINDOW]) (FNT.FILEMAP [LAMBDA (OUTFNAME NUMBER) (* FS " 5-Sep-85 16:56") (* * Takes a file name and returns an Interpress file name with number at end *  *) (PROG (FNAME ROOTNAME DESTNAME) (if (OR (EQ OUTFNAME T) (EQ OUTFNAME NIL)) then (RETURN OUTFNAME)) (SETQ FNAME OUTFNAME) (SETQ ROOTNAME (FILENAMEFIELD FNAME 'NAME)) (SETQ ROOTNAME (MKATOM (CONCAT ROOTNAME NUMBER))) (SETQ DESTNAME (PACKFILENAME 'NAME ROOTNAME 'BODY FNAME)) (RETURN DESTNAME]) (FNT.FINDALL [LAMBDA (DEVICE) (* FS " 5-Sep-85 19:18") (* * Returns list of all fonts for device * *) (LET (RESULT) (SETQ RESULT (FONTSAVAILABLE '* '* ' (* * *) '* DEVICE T)) (SETQ RESULT (SORT RESULT 'FNT.LESSP]) (FNT.FLST [LAMBDA (FONTOBJ) (* ; "Edited 9-Jan-87 18:56 by FS") (COND [(TYPENAMEP FONTOBJ 'FONTDESCRIPTOR) (LIST (FONTPROP FONTOBJ 'FAMILY) (FONTPROP FONTOBJ 'SIZE) (FONTPROP FONTOBJ 'FACE) (FONTPROP FONTOBJ 'ROTATION) (FONTPROP FONTOBJ 'DEVICE] ((LISTP FONTOBJ) FONTOBJ]) ) (PUTPROPS FONTSAMPLE COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1964 16504 (FNT.MAKEBOOK 1974 . 3779) (FNT.LESSP 3781 . 4575) (FNT.SORTP 4577 . 5343) ( FNT.DISPLOOK 5345 . 5862) (FNT.DISPTBLE 5864 . 7867) (FNT.DISPDSCR 7869 . 9976) (FNT.NARRDSCR 9978 . 12722) (FNT.DISPINIT 12724 . 13136) (FNT.FACEMAP 13138 . 13525) (FNT.SIZEMAP 13527 . 13863) ( FNT.MAKENAME 13865 . 14549) (FNT.MAKEWIND 14551 . 15105) (FNT.FILEMAP 15107 . 15737) (FNT.FINDALL 15739 . 16082) (FNT.FLST 16084 . 16502))))) STOP \ No newline at end of file diff --git a/library/FOREIGN-FUNCTIONS b/library/FOREIGN-FUNCTIONS new file mode 100644 index 00000000..c7f092d8 --- /dev/null +++ b/library/FOREIGN-FUNCTIONS @@ -0,0 +1,921 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "FOREIGN-FUNCTIONS" (USE "CL" "CONDITIONS") ( +NICKNAMES "FF") (EXPORT "DEFFOREIGN" "DEF-C-STRUCT" "MALLOC" "C-FREE" "C-GETBASEBYTE" "GETBASEFLOAT" + "GETBASEINT" "GETBASEWORD" "GETBASEBYTE" "GETBASEBIT" "LINK-FILE" "UNLINK-FILE" "UNDEFINED-SYMBOLS" +"EXECUTABLE-P" "C-PUTBASEBYTE" "PUTBASEFLOAT" "PUTBASEINT" "PUTBASEWORD" "PUTBASEBYTE" "PUTBASEBIT")) +BASE 10) +(IL:FILECREATED "19-Jan-94 13:35:27"  +IL:|{DSK}export>users>nilsson>foreign-functions>FOREIGN-FUNCTIONS.;16| 49773 + + IL:|changes| IL:|to:| (IL:VARS IL:FOREIGN-FUNCTIONSCOMS) + (IL:STRUCTURES FOREIGN-POINTER) + (IL:SETFS ERROR-FLAG) + (IL:VARIABLES *ALL-FOREIGN-FUNCTIONS* *ALL-FOREIGN-FILES* VALID-C-TYPES + *VALID-C-TYPES-MENU*) + (IL:FUNCTIONS C-FREE CHECK-FOREIGN-TYPE DEFFOREIGN DEF-C-STRUCT + EXECUTABLE-P FOREIGN-ERROR-CASE FOREIGN-FUNCTIONS-AROUNDEXITFN + GET-FUNCTION GET-SYMBOL IL-TO-UNIX-FILENAME LINK-FILE MALLOC + UNLINK-FILE UNDEFINED-SYMBOLS SMASHING-APPLY ERROR-FLAG + C-GETBASEBYTE GETBASEFLOAT GETBASEINT GETBASEWORD GETBASEBYTE + GETBASEBIT C-PUTBASEBYTE PUTBASEFLOAT PUTBASEINT PUTBASEWORD + PUTBASEBYTE PUTBASEBIT TRANSMOGRIFY-C-STRUCT) + + IL:|previous| IL:|date:| "23-Dec-93 09:55:27" +IL:|{DSK}export>users>nilsson>foreign-functions>FOREIGN-FUNCTIONS.;15|) + + +; Copyright (c) 1992, 1993, 1994 by Venue. All rights reserved. + +(IL:PRETTYCOMPRINT IL:FOREIGN-FUNCTIONSCOMS) + +(IL:RPAQQ IL:FOREIGN-FUNCTIONSCOMS + ((IL:ALISTS (IL:\\INITSUBRS IL:CALL-C-FUNCTION IL:DLD-LINK IL:DLD-UNLINK-BY-FILE + IL:DLD-UNLINK-BY-SYMBOL IL:DLD-GET-SYMBOL IL:DLD-GET-FUNC + IL:DLD-FUNCTION-EXECUTABLE-P IL:DLD-LIST-UNDEFINED-SYMBOLS IL:C-MALLOC + IL:C-FREE IL:C-PUTBASEBYTE IL:C-GETBASEBYTE IL:CALL-SMASHING-FUNCTION)) + (IL:VARIABLES *ALL-FOREIGN-FUNCTIONS* *ALL-FOREIGN-FILES* VALID-C-TYPES + *VALID-C-TYPES-MENU* *COFF-FILE-HEADER-SIZE* *AOUT-FILE-HEADER-SIZE* + *FOREIGN-SYMBOLS*) + (IL:VARS ENCLOSING-TYPES) + (IL:FUNCTIONS C-FREE CHECK-FOREIGN-TYPE DEFFOREIGN DEF-C-STRUCT EXECUTABLE-P + FOREIGN-ERROR-CASE FOREIGN-FUNCTIONS-AROUNDEXITFN GET-FUNCTION GET-SYMBOL + IL-TO-UNIX-FILENAME LINK-FILE MALLOC UNLINK-FILE UNDEFINED-SYMBOLS) + + (IL:* IL:|;;| "Functions for Ron Kaplan's access mode.") + + (IL:FUNCTIONS SMASHING-APPLY ERROR-FLAG) + (IL:SETFS ERROR-FLAG) + + (IL:* IL:|;;| "Record defs.") + + (IL:FUNCTIONS TRANSMOGRIFY-C-STRUCT) + (IL:ADDVARS (IL:CLISPRECORDTYPES C-STRUCT)) + (IL:COMS (IL:* IL:\; "for handling datatype") + (IL:P (IL:MOVD 'IL:RECORD 'C-STRUCT) + (IL:PUTPROP 'C-STRUCT 'IL:USERRECORDTYPE 'TRANSMOGRIFY-C-STRUCT))) + (IL:STRUCTURES FOREIGN-POINTER) + + (IL:* IL:|;;| "COFF stuff") + + (IL:RECORDS COFF-HEADER COFF-OPTIONAL-HEADER COFF-SECTION-HEADER) + (IL:FUNCTIONS READ-COFF-FILE) + + (IL:* IL:|;;| "AOUT stuff") + + (IL:RECORDS AOUT-HEADER AOUT-FILE N_LIST FOREIGN-SYMBOL-ENTRY) + (IL:FUNCTIONS READ-AOUT-HEADER REGISTER-AOUT-SYMBOLS N_TXTOFF N_DATOFF N_TRELOFF N_DRELOFF + N_SYMOFF N_STROFF STRING-TABLE-SIZE GET-C-INTEGER GET-C-SHORT GET-C-BYTE + GET-C-ADRESS) + (IL:P (PUSH 'FOREIGN-FUNCTIONS-AROUNDEXITFN IL:AROUNDEXITFNS)) + (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:FOREIGN-FUNCTIONS))) + +(IL:ADDTOVAR IL:\\INITSUBRS (IL:CALL-C-FUNCTION 167) + (IL:DLD-LINK 168) + (IL:DLD-UNLINK-BY-FILE 169) + (IL:DLD-UNLINK-BY-SYMBOL 170) + (IL:DLD-GET-SYMBOL 171) + (IL:DLD-GET-FUNC 172) + (IL:DLD-FUNCTION-EXECUTABLE-P 173) + (IL:DLD-LIST-UNDEFINED-SYMBOLS 174) + (IL:C-MALLOC 175) + (IL:C-FREE 176) + (IL:C-PUTBASEBYTE 177) + (IL:C-GETBASEBYTE 178) + (IL:CALL-SMASHING-FUNCTION 179)) + +(DEFVAR *ALL-FOREIGN-FUNCTIONS* NIL + "The list of all defined foreign functions on the form ({( .
)}*") + +(DEFVAR *ALL-FOREIGN-FILES* NIL) + +(DEFVAR VALID-C-TYPES) + +(DEFVAR *VALID-C-TYPES-MENU* (IL:|create| IL:MENU + IL:TITLE IL:_ "C types" + IL:ITEMS IL:_ VALID-C-TYPES)) + +(DEFVAR *COFF-FILE-HEADER-SIZE* 20 + "The size of the coff file header in bytes.") + +(DEFVAR *AOUT-FILE-HEADER-SIZE* 32 + "The size of the exec struct in bytes.") + +(DEFVAR *FOREIGN-SYMBOLS* (MAKE-HASH-TABLE :TEST #'EQUAL) + "The global symbol table for the foreign symbols.") + +(IL:RPAQQ ENCLOSING-TYPES (:CPOINTER :VECTOR :STRUCTURE)) + +(DEFUN C-FREE (POINTER SIZE) + (IL:SUBRCALL IL:C-FREE POINTER SIZE)) + +(DEFUN CHECK-FOREIGN-TYPE (TYPE &KEY VOID-ALLOWED-P) + (DECLARE (SPECIAL *VALID-C-TYPES-MENU*)) + (LOOP (IF (IL:FMEMB TYPE VALID-C-TYPES) + (RETURN-FROM CHECK-FOREIGN-TYPE (CASE TYPE + (:VOID (IF VOID-ALLOWED-P + -1 + (ERROR "Type :VOID is not allowed here.")) +) + (:INT (IL:\\TYPENUMBERFROMNAME 'IL:FIXP)) + (:LONG (IL:\\TYPENUMBERFROMNAME 'IL:FIXP)) + (:SHORT (IL:\\TYPENUMBERFROMNAME 'IL:FIXP)) + (:CHAR (IL:\\TYPENUMBERFROMNAME 'IL:CHARACTER)) + (:BYTE (IL:\\TYPENUMBERFROMNAME 'IL:FIXP)) + (:LISPPTR (IL:\\TYPENUMBERFROMNAME 'IL:FIXP)) + (:CPOINTER (IL:\\TYPENUMBERFROMNAME 'IL:FIXP)) + (:FLOAT (IL:\\TYPENUMBERFROMNAME 'IL:FLOATP)))) + (RESTART-CASE (ERROR 'SIMPLE-ERROR :FORMAT-STRING "Bogus type for foreign function: ~s." + :FORMAT-ARGUMENTS (LIST TYPE)) + (CONTINUE (NEW-TYPE) + :REPORT "Try new type." :INTERACTIVE (LAMBDA NIL (LIST (IL:MENU + *VALID-C-TYPES-MENU* + ))) + (SETQ TYPE NEW-TYPE)))))) + +(DEFMACRO DEFFOREIGN (FUNCTION (&REST ARGLIST) + &KEY RESULT-TYPE FOREIGN-NAME FUNCTION-DOCUMENTATION) + "Define a foreign function." + (SETQ FOREIGN-NAME (CTYPECASE FOREIGN-NAME (NULL (SYMBOL-NAME FUNCTION)) + (STRING FOREIGN-NAME))) + (SETQ FUNCTION-DOCUMENTATION (AND (STRINGP FUNCTION-DOCUMENTATION) + FUNCTION-DOCUMENTATION)) + (LET + ((DESCRIPTOR-BLOCK (IL:\\ALLOCBLOCK (+ 5 (LENGTH ARGLIST)) + NIL)) + + (IL:* IL:|;;| "The conversion block looks looks this:") + (IL:* IL:\; "1 function pointer.") + (IL:* IL:\; "2 RESULT-TYPE") + (IL:* IL:\; "3 ERRORFLAG") + (IL:* IL:\; + "4 Number of args to the function.") + (IL:* IL:\; "5 0 If returnvalue on the stack else a pointer to a cell where the result should be stored. (This was ordered by Ron Kaplan /jarl)") + (IL:* IL:\; + "6-... The argument types.") + (FUNCARGS (IL:|for| ARG IL:|in| ARGLIST IL:|as| I IL:|from| 1 + IL:|collect| (INTERN (IL:CONCAT "Arg-" I) + (SYMBOL-PACKAGE FUNCTION)))) + (FUNCTION-POINTER (IL:SUBRCALL IL:DLD-GET-FUNC FOREIGN-NAME))) + (BLOCK (IL:* IL:\; "If the function is on the *ALL-FOREIGN-FUNCTIONS* list then just stuff it there, else push the new def on the list.") + CHECK-FUNCS + (DOLIST (A *ALL-FOREIGN-FUNCTIONS*) + (WHEN (EQUAL (CAR A) + FOREIGN-NAME) + (RPLACD A DESCRIPTOR-BLOCK) + (RETURN-FROM CHECK-FUNCS))) + (PUSH (CONS FOREIGN-NAME DESCRIPTOR-BLOCK) + *ALL-FOREIGN-FUNCTIONS*)) + (IL:\\PUTBASEFIXP DESCRIPTOR-BLOCK 0 (IL:* IL:\; "If the function is defined and executable we set the 0'th position in DESCRIPTOR-BLOCK to the address, else the address is set to 0.") + (IF (AND (< 16 FUNCTION-POINTER) + (EXECUTABLE-P FOREIGN-NAME)) + FUNCTION-POINTER + 0)) + (IL:\\PUTBASEFIXP DESCRIPTOR-BLOCK 2 (IL:* IL:\; "Set the RESULT-TYPE") + (CHECK-FOREIGN-TYPE RESULT-TYPE :VOID-ALLOWED-P T)) + + (IL:* IL:|;;| "Leave a hole at 4 for the errorflag.") + + (IL:\\PUTBASEFIXP DESCRIPTOR-BLOCK 4 0) + (IL:\\PUTBASEFIXP DESCRIPTOR-BLOCK 6 (IL:* IL:\; + "Set the # of args that we pass.") + (LENGTH FUNCARGS)) (IL:* IL:\; "") + + (IL:* IL:|;;| + "Set smasher pointer to 0. That tells the emulator to return values instead of smashing them. ") + + (IL:\\PUTBASEFIXP DESCRIPTOR-BLOCK 8 0) + (DOTIMES (ARG# (LENGTH ARGLIST)) (IL:* IL:\; "Set the typevector.") + (IL:\\PUTBASEFIXP DESCRIPTOR-BLOCK (+ 10 (* 2 ARG#)) + (CHECK-FOREIGN-TYPE (NTH ARG# ARGLIST) + :VOID-ALLOWED-P NIL))) + (SETF (GET FUNCTION 'FOREIGN-NAME) + FOREIGN-NAME) (IL:* IL:\; + "Keep name and descriptorblock around.") + (SETF (GET FUNCTION 'DESCRIPTOR-BLOCK) + DESCRIPTOR-BLOCK) + (EVAL + `(DEFUN ,FUNCTION ,FUNCARGS + ,@FUNCTION-DOCUMENTATION + (LET + ((RESULT (IL:SUBRCALL IL:CALL-C-FUNCTION ,DESCRIPTOR-BLOCK ,@FUNCARGS)) + (ERRNO (IL:\\GETBASEFIXP ,DESCRIPTOR-BLOCK 4))) + (CASE ERRNO + (0 T) + (-1 (ERROR "Foreign function ~s is not executable." ,FOREIGN-NAME)) + (-2 (ERROR "Bogus return type.")) + (T ,(WHEN FUNCARGS + `(ERROR "Type of argument# ~d (~s) is not ~s as declared." ERRNO + (TYPE-OF (NTH ERRNO (LIST ,@FUNCARGS))) + (IL:|fetch| IL:DTDNAME + IL:|of| (IL:\\GETDTD (IL:NTYPX (IL:\\GETBASEFIXP + ,DESCRIPTOR-BLOCK + (+ 8 (* 2 ERRNO)))))))))) + ,(IF (EQUAL RESULT-TYPE :VOID) + '(VALUES) (IL:* IL:\; + "If the result type is :VOID it is only fair that we return (VALUES)") + 'RESULT (IL:* IL:\; + "ELSE let the emulator take care of the type conversion.") + )))) + (SETF (GET 'IL:\\GETBASEFIXP 'COMPILER::SIDE-EFFECTS-DATA) + NIL) + (COMPILE FUNCTION) + (SETF (GET 'IL:\\GETBASEFIXP 'COMPILER::SIDE-EFFECTS-DATA) + '(:NONE . :NONE)) + (LIST 'QUOTE FUNCTION))) + +(DEFMACRO DEF-C-STRUCT (FOOT) + 42) + +(DEFUN EXECUTABLE-P (NAME) + (DECLARE (TYPE (OR STRING SYMBOL) + NAME)) + (LET* ((NAME (CTYPECASE NAME (SYMBOL (OR (IL:* IL:\; + "See if we stored the name.") + (GET NAME 'FOREIGN-NAME) + (IL:* IL:\; + "If not, try the symbol name.") + (SYMBOL-NAME NAME))) + (STRING NAME))) + (RESULT (IL:SUBRCALL IL:DLD-FUNCTION-EXECUTABLE-P NAME))) + (IF (ZEROP RESULT) + NIL + T))) + +(DEFUN FOREIGN-ERROR-CASE (DLD-ERROR-NUMBER) + (CASE DLD-ERROR-NUMBER + (1 "Can't open foreign file ~s.") + (2 "Bad magic number in foreign file ~S") + (3 "Failiure reading header in foreign file ~s") + (4 "Premature EOF in text section of foreign file ~s") + (5 "Premature EOF in symbol section of foreign file ~s") + (6 "Bad string table in foreign file ~s") + (7 "Premature EOF in text relocation of foreign file ~s") + (8 "Premature EOF in data section in foreign file ~s") + (9 "Premature EOF in data relocation in foreign file ~s") + (10 "Multiple definitions of symbol in foreign file ~s") + (11 "Malformed library archive (foreign file ~s)") + (12 "Common block not supported (foreign file ~s)") + (13 "Malformed input file (foreign file ~s)") + (14 "Bad relocation info (foreign file ~s)") + (15 "Virtual memory exhausted while loading foreign file ~s.") + (16 "Undefined symbol in foreign file ~s.") + (T (CERROR "CONTINUE?" "BOGUS ERROR CODE IN DLD.")))) + +(DEFUN FOREIGN-FUNCTIONS-AROUNDEXITFN (EVENT) + (CASE EVENT + ((IL:AFTERLOGOUT IL:AFTERMAKESYS IL:AFTERSAVEVM IL:AFTERSYSOUT) + (DOLIST (F *ALL-FOREIGN-FILES*) (IL:* IL:\; + "Atempt to link the files we had in memory.") + (LINK-FILE F)) + (DOLIST (A *ALL-FOREIGN-FUNCTIONS* (IL:* IL:\; "Redefine the functions.") + ) + (LET ((FUNCTION-POINTER (IL:SUBRCALL IL:DLD-GET-FUNC (CAR A)))) + (IL:\\PUTBASEFIXP (CDR A) + 0 + (IF (AND (< 16 FUNCTION-POINTER) + (EXECUTABLE-P (CAR A))) + FUNCTION-POINTER + 0)))) + (IL:PROMPTPRINT (FORMAT NIL "Foreign relink done.~&"))) + ((IL:BEFORELOGOUT IL:BEFOREMAKESYS IL:BEFORESYSOUT) (IL:* IL:\; + "Invalidate all descriptors") + (DOLIST (A *ALL-FOREIGN-FUNCTIONS*) + (IL:\\PUTBASEFIXP (CDR A) + 0 0))))) + +(DEFUN GET-FUNCTION (SYMBOLNAME) + (DECLARE (TYPE (OR STRING SYMBOL) + SYMBOLNAME)) + (DO* ((SYMBOLNAME (CTYPECASE SYMBOLNAME (SYMBOL (SYMBOL-NAME SYMBOLNAME)) + (STRING SYMBOLNAME))) + (RESULT (IL:SUBRCALL IL:DLD-GET-FUNC SYMBOLNAME) + (IL:SUBRCALL IL:DLD-GET-FUNC SYMBOLNAME))) + ((< 16 RESULT) + RESULT) + (RESTART-CASE (ERROR 'SIMPLE-ERROR :FORMAT-STRING "Can't find foreign function ~s" + :FORMAT-ARGUMENTS (LIST SYMBOLNAME)) + (CONTINUE (NEW-SYMBOLNAME) + :REPORT "Try another foreign function name." :INTERACTIVE + (LAMBDA NIL (LIST (IL:PROMPTFORWORD "New foreign function name:" SYMBOLNAME))) + (SETQ SYMBOLNAME NEW-SYMBOLNAME))))) + +(DEFUN GET-SYMBOL (SYMBOLNAME) + (DECLARE (TYPE (OR STRING SYMBOL) + SYMBOLNAME)) + (DO* ((SYMBOLNAME (CTYPECASE SYMBOLNAME (SYMBOL (SYMBOL-NAME SYMBOLNAME)) + (STRING SYMBOLNAME))) + (RESULT (IL:SUBRCALL IL:DLD-GET-SYMBOL SYMBOLNAME) + (IL:SUBRCALL IL:DLD-GET-SYMBOL SYMBOLNAME))) + ((< 16 RESULT) + RESULT) + (RESTART-CASE (ERROR 'SIMPLE-ERROR :FORMAT-STRING "Can't find foreign symbol ~s" + :FORMAT-ARGUMENTS (LIST SYMBOLNAME)) + (CONTINUE (NEW-SYMBOLNAME) + :REPORT "Try another foreign symbol." :INTERACTIVE (LAMBDA NIL + (LIST (IL:PROMPTFORWORD + + "New foreign symbol name:" + SYMBOLNAME))) + (SETQ SYMBOLNAME NEW-SYMBOLNAME))))) + +(DEFUN IL-TO-UNIX-FILENAME (FILENAME) + + (IL:* IL:|;;| "Coerse a string that looks like \"{dsk}bar>...\" into /foo/bar/...") + + (IF (FIND #\> FILENAME) + (LET* ((PATH (PARSE-NAMESTRING FILENAME)) + (DIR (STRING-TRIM '(#\< #\>) + (DIRECTORY-NAMESTRING PATH))) + (NAME (PATHNAME-NAME PATH)) + (TYPE (PATHNAME-TYPE PATH))) + (DOTIMES (A (LENGTH DIR)) + (IF (EQL #\> (AREF DIR A)) + (SETF (AREF DIR A) + #\/))) + (FORMAT NIL "/~A/~A~@[.~A~]" DIR NAME TYPE)) (IL:* IL:\; "No TYPE, no dot.") + FILENAME)) + +(DEFUN LINK-FILE (PATHNAME) + "Link foreign objectfile" + (DECLARE (TYPE (OR STRING PATHNAME) + PATHNAME)) + + (IL:* IL:|;;| "Make shure that we have a propper file.") + + (PROG1 (BLOCK CHECK + (LOOP (LET* ((PATHNAME (IL-TO-UNIX-FILENAME + (SYMBOL-NAME (IL:FINDFILE (CTYPECASE PATHNAME + (SYMBOL (SYMBOL-NAME PATHNAME) + ) + (STRING PATHNAME) + (PATHNAME (NAMESTRING PATHNAME + ))))))) + (RESULT (IL:SUBRCALL IL:DLD-LINK PATHNAME))) + (IF (ZEROP RESULT) + (RETURN-FROM CHECK PATHNAME) + (RESTART-CASE (ERROR 'SIMPLE-ERROR :FORMAT-STRING (FOREIGN-ERROR-CASE + RESULT) + :FORMAT-ARGUMENTS + (LIST PATHNAME)) + (CONTINUE (NEW-PATHNAME) + :REPORT "Try another file." :INTERACTIVE + (LAMBDA NIL (LIST (IL:PROMPTFORWORD "New file name:" + (NAMESTRING PATHNAME)))) + (SETQ PATHNAME NEW-PATHNAME))))))) + + (IL:* IL:|;;| + "Run down the list of defined functions and see if we can resolve any references.") + + (PUSH PATHNAME *ALL-FOREIGN-FILES*) (IL:* IL:\; + "Remember this file for later.") + (DOLIST (A *ALL-FOREIGN-FUNCTIONS* (IL:* IL:\; + "car is the name cdr is the descriptor.") + ) + (WHEN (ZEROP (IL:\\GETBASE (CDR A) + 1)) + (LET ((FUNCTION-POINTER (IL:SUBRCALL IL:DLD-GET-FUNC (CAR A)))) + (IL:\\PUTBASEFIXP (CDR A) + 0 + (IF (AND (< 16 FUNCTION-POINTER) + (EXECUTABLE-P (CAR A))) + FUNCTION-POINTER + 0))))))) + +(DEFUN MALLOC (SIZE) + (IL:SUBRCALL IL:C-MALLOC SIZE)) + +(DEFUN UNLINK-FILE (NAME &KEY (SYMBOL-NAME-P NIL) + (FORCE-P NIL)) + + (IL:* IL:|;;| "Do the raw unlinking.") + + (PROG1 (BLOCK GUARD + (LOOP (LET ((NAME (IL-TO-UNIX-FILENAME (SYMBOL-NAME + (IL:FINDFILE (CTYPECASE NAME + (SYMBOL (SYMBOL-NAME + NAME)) + (STRING NAME) + (PATHNAME (NAMESTRING + NAME))))))) + (RESULT (IF SYMBOL-NAME-P + (IL:SUBRCALL IL:DLD-UNLINK-BY-SYMBOL NAME (IF FORCE-P + 1 + 0)) + (IL:SUBRCALL IL:DLD-UNLINK-BY-FILE NAME (IF FORCE-P + 1 + 0))))) + (IF (ZEROP RESULT) + (RETURN-FROM GUARD NAME) + (RESTART-CASE (ERROR 'SIMPLE-ERROR :FORMAT-STRING (DLD-ERROR-CASE RESULT + ) + :FORMAT-ARGUMENTS + (LIST NAME)) + (CONTINUE (NEW-NAME) + :REPORT "Try another foreign symbol." :INTERACTIVE + (LAMBDA NIL (LIST (IL:PROMPTFORWORD "New foreign name:" + NAME))) + (SETQ NAME NEW-NAME))))))) + (SETQ *ALL-FOREIGN-FILES* (IL:* IL:\; + "Forget that this file was loaded.") + (REMOVE NAME *ALL-FOREIGN-FILES*)) + + (IL:* IL:|;;| "Run down the list of defined functions and revalidate them.") + + (DOLIST (A *ALL-FOREIGN-FUNCTIONS* (IL:* IL:\; + "car is the name cdr is the descriptor.") + ) + (WHEN (OR (< 16 (IL:SUBRCALL IL:DLD-GET-FUNC (CAR A))) + (NOT (EXECUTABLE-P (CAR A)))) + (IL:\\PUTBASEFIXP (CDR A) + 0 0))))) + +(DEFUN UNDEFINED-SYMBOLS () + (LET ((HEADPOINTER (IL:* IL:\; + "This is a pointer to an array of pointers to a string") + (IL:SUBRCALL IL:DLD-LIST-UNDEFINED-SYMBOLS)) + S) + (WHEN HEADPOINTER + (DOTIMES (OFFSET (C-GETBASEBYTE + + (IL:* IL:|;;| "Number of undefined symbols.") + + (GET-SYMBOL "dld_undefined_sym_count") + 0 :INT)) + (LET ((STRINGPOINTER (C-GETBASEBYTE HEADPOINTER OFFSET :INT))) + (DO* ((CHARPTR 1 (IL:* IL:\; + "Start at index 1 to avoid leading #\\_ in the name") + (1+ CHARPTR)) + (CHAR (CHARACTER (C-GETBASEBYTE STRINGPOINTER CHARPTR :BYTE)) + (CHARACTER (C-GETBASEBYTE STRINGPOINTER CHARPTR :BYTE))) + (STRN (LIST CHAR) + (CONS CHAR STRN))) + ((EQL CHAR #\Null) + (PUSH (MAP 'STRING #'IDENTITY (REVERSE + (IL:* IL:\; "STRN is in reverse order") + (CDR STRN))) + S (IL:* IL:\; "Get rid of the #\\Null") + )))))) + S)) + + + +(IL:* IL:|;;| "Functions for Ron Kaplan's access mode.") + + +(DEFMACRO SMASHING-APPLY (DESCRIPTOR PLACE &REST ARGS) + `(IL:SUBRCALL IL:CALL-SMASHING-FUNCTION ,DESCRIPTOR ,PLACE ,@ARGS)) + +(DEFMACRO ERROR-FLAG (DESCRIPTOR) + `(IL:\\GETBASEFIXP ,DESCRIPTOR 4)) + +(DEFSETF ERROR-FLAG (DESCRIPTOR) (NEWVAL) + `(IL:\\PUTBASEFIXP ,DESCRIPTOR 4 ,NEWVAL)) + + + +(IL:* IL:|;;| "Record defs.") + + +(DEFUN TRANSMOGRIFY-C-STRUCT (STRUCTURE-DESCRIPTION) + + (IL:* IL:|;;| "Test the description for discrepancies an build a description of the slots.") + + (LET ((NAME (SECOND STRUCTURE-DESCRIPTION)) + (BODY (THIRD STRUCTURE-DESCRIPTION)) + (DESCRIPTOR NIL) + (BYTE-ADDR 0) + (LST NIL)) + + (IL:* IL:|;;| "The format of a field is (FIELDNAME TYPE ) where the modifier is either :POINTER :STRUCTURE or an integer denoting that it is an array.") + + (MACROLET ((MAKE-ACCESSOR (D GET PUT OFFSET) + ``(,(FIRST D) + (,GET 'IL:DATUM ,OFFSET) + (,PUT 'IL:DATUM ,OFFSET IL:NEWVALUE)))) + (DOLIST (D BODY) + (LET ((BASE BYTE-ADDR)) + (CASE (SECOND D) + (:BIT (INCF BYTE-ADDR)) + + (IL:* IL:|;;| "8 bit addrs. No address adjustment.") + + (:CHAR + (PUSH (MAKE-ACCESSOR D GETBASEBYTE PUTBASEBYTE BYTE-ADDR) + LST) + (INCF BYTE-ADDR)) + (:BYTE + (PUSH (MAKE-ACCESSOR D GETBASEBYTE PUTBASEBYTE BYTE-ADDR) + LST) + (INCF BYTE-ADDR)) + + (IL:* IL:|;;| "16 bit addrs. Adjust address to even boundries.") + + (:SHORT + (WHEN (ODDP BYTE-ADDR) + (INCF BYTE-ADDR)) + (PUSH (MAKE-ACCESSOR D GETBASEWORD PUTBASEWORD (ASH BYTE-ADDR -1)) + LST) + (INCF BYTE-ADDR 2)) + + (IL:* IL:|;;| "32 bit addrs. Adjust address to 4 boundries.") + + (:INT + (INCF BYTE-ADDR (MOD (- 4 (MOD BYTE-ADDR 4)) + 4)) + (PUSH (MAKE-ACCESSOR D GETBASEINT PUTBASEINT (ASH BYTE-ADDR -2)) + LST) + (INCF BYTE-ADDR 4)) + (:LONG + (INCF BYTE-ADDR (MOD (- 4 (MOD BYTE-ADDR 4)) + 4)) + (PUSH (MAKE-ACCESSOR D GETBASEINT PUTBASEINT (ASH BYTE-ADDR -2)) + LST) + (INCF BYTE-ADDR 4)) + (:FLOAT + (INCF BYTE-ADDR (MOD (- 4 (MOD BYTE-ADDR 4)) + 4)) + (PUSH (MAKE-ACCESSOR D GETBASEFLOAT PUTBASEFLOAT (ASH BYTE-ADDR -2)) + LST) + (INCF BYTE-ADDR 4)))))) + `(IL:ACCESSFNS ,NAME ,(REVERSE LST) + (CREATE (IL:\\\\ALLOCBLOCK (ASH BYTE-ADDR -2)))))) + +(IL:ADDTOVAR IL:CLISPRECORDTYPES C-STRUCT) + + + +(IL:* IL:\; "for handling datatype") + + +(IL:MOVD 'IL:RECORD 'C-STRUCT) + +(IL:PUTPROP 'C-STRUCT 'IL:USERRECORDTYPE 'TRANSMOGRIFY-C-STRUCT) + +(DEFSTRUCT FOREIGN-POINTER + "Pointer to a foreign object" + (DESTINATION-TYPE NIL) + (VALUE NIL)) + + + +(IL:* IL:|;;| "COFF stuff") + +(IL:DECLARE\: IL:EVAL@COMPILE + +(IL:BLOCKRECORD COFF-HEADER ((F_MAGIC + IL:BITS 16) + (F_NSCNS + IL:BITS 16) + (F_TIMDAT + IL:BITS 32) + (F_SYMPTR + IL:BITS 32) + (F_NSYMS + IL:BITS 32) + (F_OPTHEADER + IL:BITS 16) + (F_FLAGS + IL:BITS 16))) + +(IL:BLOCKRECORD COFF-OPTIONAL-HEADER ((MAGIC IL:BITS 16) + (VSTAMP IL:BITS 16) + (TSIZE IL:BITS 32) + (DSIZE IL:BITS 32) + (BSIZE IL:BITS 32) + (ENTRY IL:BITS 32) + (TEXT_START + IL:BITS 32) + (DATA_START + IL:BITS 32))) + +(IL:BLOCKRECORD COFF-SECTION-HEADER ((S_NAME1 + IL:BITS 32) + (S_NAME2 + IL:BITS 32) + (S_PADDR + IL:BITS 32) + (S_VADDR + IL:BITS 32) + (S_SIZE + IL:BITS 32) + (S_SCNPTR + IL:BITS 32) + (S_RELPTR + IL:BITS 32) + (S_LNNOPTR + IL:BITS 32) + (S_NRELOC + IL:BITS 16) + (S_NLNNO + IL:BITS 16) + (S_FLAGS + IL:BITS 32))) +) + +(DEFUN READ-COFF-FILE (FILENAME) + (LET* ((FILEHEADER (MAKE-ARRAY *COFF-FILE-HEADER-SIZE* :ELEMENT-TYPE '(UNSIGNED-BYTE 8) + :ADJUSTABLE NIL)) + (FILEHEADERBASE (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of| FILEHEADER)) + (OPTIONALHEADER (MAKE-ARRAY '(100) + :ELEMENT-TYPE + '(UNSIGNED-BYTE 8) + :ADJUSTABLE NIL)) + (OPTHEADERBASE (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of| OPTIONALHEADER))) + (WITH-OPEN-FILE (FILE FILENAME :IF-DOES-NOT-EXITS :ERROR :ELEMENT-TYPE '(UNSIGNED-BYTE + 8) + :DIRECTION :INPUT) + (DOTIMES (INDEX *COFF-FILE-HEADER-SIZE*) + (SETF (AREF FILEHEADER INDEX) + (READ-BYTE FILE :EOF-ERROR-P T))) + (FORMAT T "optheader size: ~d~&" (IL:|fetch| (COFF-HEADER F_OPTHEADER) + IL:|of| FILEHEADERBASE)) + (IL:|if| (PLUSP (IL:|fetch| (COFF-HEADER F_OPTHEADER) IL:|of| + FILEHEADERBASE)) + IL:|then| (DOTIMES (INDEX (IL:|fetch| (COFF-HEADER F_OPTHEADER) + IL:|of| FILEHEADERBASE)) + (SETF (AREF OPTIONALHEADER INDEX) + (READ-BYTE FILE :EOF-ERROR-P T))) + (FORMAT T "Magic: ~o~&" (IL:|fetch| (COFF-OPTIONAL-HEADER MAGIC) + IL:|of| OPTHEADERBASE)) + (FORMAT T "Text size: ~d~&" (IL:|fetch| (COFF-OPTIONAL-HEADER TSIZE) + IL:|of| OPTHEADERBASE)) + (FORMAT T "data size: ~d~&" (IL:|fetch| (COFF-OPTIONAL-HEADER DSIZE) + IL:|of| OPTHEADERBASE)) + (FORMAT T "uninit data size: ~d~&" (IL:|fetch| (COFF-OPTIONAL-HEADER + BSIZE) IL:|of| + OPTHEADERBASE))) + (FORMAT T "Number of symtab entries: ~b~&" (IL:|fetch| (COFF-HEADER F_NSYMS) + IL:|of| FILEHEADERBASE))))) + + + +(IL:* IL:|;;| "AOUT stuff") + +(IL:DECLARE\: IL:EVAL@COMPILE + +(IL:BLOCKRECORD AOUT-HEADER ((A_MAGIC + IL:BITS 32) + (A_TEXT + IL:BITS 32) + (A_DATA + IL:BITS 32) + (A_BSS + IL:BITS 32) + (A_SYMS + IL:BITS 32) + (A_ENTRY + IL:BITS 32) + (A_TRSIZE + IL:BITS 32) + (A_DRSIZE + IL:BITS 32))) + +(IL:DATATYPE AOUT-FILE (NAME HEADER TEXT DATA TEXT-RELOC DATA-RELOC SYMBOL-TABLE STRING-TABLE)) + +(IL:BLOCKRECORD N_LIST ((N_NAME + IL:BITS 32) + (N_MISC + IL:BITS 32) + (N_VALUE + IL:BITS 32))) + +(IL:DATATYPE FOREIGN-SYMBOL-ENTRY (NAME TYPE EXTERNAL-P VALUE-INDEX OBJECTFILE) + (IL:ACCESSFNS + (VALUE (IL:|with| FOREIGN-SYMBOL-ENTRY IL:DATUM + (CASE TYPE + (:UNDEFINED :UNDEFINED) + (:ABSOLUTE ) + (:TEXT ) + (:DATA (GET-C-INTEGER (IL:|fetch| + (AOUT-FILE HEADER) + IL:|of| + OBJECTFILE) + VALUE-INDEX)) + (:BSS ) + (:COMMON ) + (:FILE-NAME )))))) +) + +(IL:/DECLAREDATATYPE 'AOUT-FILE '(IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER + IL:POINTER IL:POINTER) + '((AOUT-FILE 0 IL:POINTER) + (AOUT-FILE 2 IL:POINTER) + (AOUT-FILE 4 IL:POINTER) + (AOUT-FILE 6 IL:POINTER) + (AOUT-FILE 8 IL:POINTER) + (AOUT-FILE 10 IL:POINTER) + (AOUT-FILE 12 IL:POINTER) + (AOUT-FILE 14 IL:POINTER)) + '16) + +(IL:/DECLAREDATATYPE 'FOREIGN-SYMBOL-ENTRY '(IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) + '((FOREIGN-SYMBOL-ENTRY 0 IL:POINTER) + (FOREIGN-SYMBOL-ENTRY 2 IL:POINTER) + (FOREIGN-SYMBOL-ENTRY 4 IL:POINTER) + (FOREIGN-SYMBOL-ENTRY 6 IL:POINTER) + (FOREIGN-SYMBOL-ENTRY 8 IL:POINTER)) + '10) + +(DEFUN READ-AOUT-HEADER (FILENAME) + (WITH-OPEN-FILE (FILE FILENAME :IF-DOES-NOT-EXITS :ERROR :ELEMENT-TYPE '(UNSIGNED-BYTE 8) + :DIRECTION :INPUT) + (LET* ((OBJECTARRAY (MAKE-ARRAY (FILE-LENGTH FILE) + :ELEMENT-TYPE + '(UNSIGNED-BYTE 8) + :ADJUSTABLE NIL)) + (OBJECTBASE (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of| OBJECTARRAY)) + (AOUTSTRUCTURE NIL)) + (DOTIMES (INDEX (FILE-LENGTH FILE)) + (SETF (AREF OBJECTARRAY INDEX) + (READ-BYTE FILE :EOF-ERROR-P T))) + (SETQ AOUTSTRUCTURE (IL:|create| AOUT-FILE + NAME IL:_ FILENAME + + (IL:* IL:|;;| "Header is the start of the whole array,") + + HEADER IL:_ OBJECTARRAY + + (IL:* IL:|;;| "Text is the start of the code array") + + TEXT IL:_ (MAKE-ARRAY (LIST (IL:|fetch| (AOUT-HEADER + A_TEXT) + IL:|of| OBJECTBASE)) + :ELEMENT-TYPE + '(UNSIGNED-BYTE 8) + :DISPLACED-TO OBJECTARRAY + :DISPLACED-INDEX-OFFSET (N_TXTOFF + OBJECTARRAY)) + + (IL:* IL:|;;| "DATA start = aout-end-index + textsize") + + DATA IL:_ (MAKE-ARRAY (LIST (IL:|fetch| (AOUT-HEADER + A_DATA) + IL:|of| OBJECTBASE)) + :ELEMENT-TYPE + '(UNSIGNED-BYTE 8) + :DISPLACED-TO OBJECTARRAY + :DISPLACED-INDEX-OFFSET (N_DATOFF + OBJECTARRAY)) + TEXT-RELOC IL:_ (MAKE-ARRAY (IL:|fetch| (AOUT-HEADER + A_TRSIZE) + IL:|of| OBJECTBASE) + :ELEMENT-TYPE + '(UNSIGNED-BYTE 8) + :DISPLACED-TO OBJECTARRAY + :DISPLACED-INDEX-OFFSET + (N_TRELOFF + OBJECTARRAY)) + DATA-RELOC IL:_ (MAKE-ARRAY (IL:|fetch| (AOUT-HEADER + A_DRSIZE) + IL:|of| OBJECTBASE) + :ELEMENT-TYPE + '(UNSIGNED-BYTE 8) + :DISPLACED-TO OBJECTARRAY + :DISPLACED-INDEX-OFFSET + (N_DRELOFF + OBJECTARRAY)) + SYMBOL-TABLE IL:_ (MAKE-ARRAY (LIST (IL:|fetch| + (AOUT-HEADER A_SYMS) + IL:|of| + OBJECTBASE)) + :ELEMENT-TYPE + '(UNSIGNED-BYTE 8) + :DISPLACED-TO OBJECTARRAY + :DISPLACED-INDEX-OFFSET + (N_SYMOFF + OBJECTARRAY)) + STRING-TABLE IL:_ (MAKE-ARRAY (LIST (STRING-TABLE-SIZE + OBJECTARRAY)) + :ELEMENT-TYPE + '(UNSIGNED-BYTE 8) + :DISPLACED-TO OBJECTARRAY + :DISPLACED-INDEX-OFFSET + (N_STROFF + OBJECTARRAY)))) + + (IL:* IL:|;;| "Make Medley believe that this is an array of string-char instead. This is ugly but it works. /Jarl.") + + (IL:|replace| (IL:ONED-ARRAY IL:TYPE-NUMBER) IL:|of| (IL:|fetch| + (AOUT-FILE STRING-TABLE + ) IL:|of| + AOUTSTRUCTURE) + IL:|with| 67) + AOUTSTRUCTURE))) + +(DEFUN REGISTER-AOUT-SYMBOLS (AOUFILERECORD) + (LET ((SYMBOL-TABLE (IL:|fetch| (AOUT-FILE SYMBOL-TABLE) IL:|of| AOUFILERECORD)) + (STRING-TABLE (IL:|fetch| (AOUT-FILE STRING-TABLE) IL:|of| AOUFILERECORD))) + (DO ((RECORDINDEX 0 (+ RECORDINDEX 12))) + ((>= RECORDINDEX (LENGTH SYMBOL-TABLE))) + (LET* ((STRINGTAB-INDEX (GET-C-INTEGER SYMBOL-TABLE RECORDINDEX)) + (TYPE-ENTRY (GET-C-BYTE SYMBOL-TABLE (+ 4 RECORDINDEX))) + (OTHER-ENTRY (GET-C-BYTE SYMBOL-TABLE (+ 5 RECORDINDEX))) + (DESCRIPTION (GET-C-SHORT SYMBOL-TABLE (+ 6 RECORDINDEX))) + (VALUE-INDEX (GET-C-INTEGER SYMBOL-TABLE (+ 8 RECORDINDEX))) + (NAME (STRING (SUBSEQ STRING-TABLE STRINGTAB-INDEX (POSITION #\Null STRING-TABLE + :START STRINGTAB-INDEX)))) + (REC (IL:|create| FOREIGN-SYMBOL-ENTRY + NAME IL:_ NAME + OBJECTFILE IL:_ AOUFILERECORD + EXTERNAL-P IL:_ (ODDP TYPE-ENTRY) + TYPE IL:_ (CASE (LOGAND TYPE-ENTRY 30) + (0 :UNDEFINED) + (2 :ABSOLUTE) + (4 :TEXT) + (6 :DATA) + (8 :BSS) + (18 :COMMON) + (30 :FILE-NAME))))) + (SETF (GETHASH NAME *FOREIGN-SYMBOLS*) + REC) + (CASE (IL:|fetch| (FOREIGN-SYMBOL-ENTRY TYPE) IL:|of| REC) + (:UNDEFINED ) + (:ABSOLUTE ) + (:TEXT ) + (:DATA (IL:|replace| (FOREIGN-SYMBOL-ENTRY VALUE-INDEX) IL:|of| REC + IL:|with| (+ VALUE-INDEX *AOUT-FILE-HEADER-SIZE*))) + (:BSS ) + (:COMMON ) + (:FILE-NAME )) + REC)))) + +(DEFUN N_TXTOFF (OBJECT) + *AOUT-FILE-HEADER-SIZE*) + +(DEFUN N_DATOFF (OBJECTARRAY) + (+ (N_TXTOFF + OBJECTARRAY) + (IL:|fetch| (AOUT-HEADER A_TEXT) IL:|of| (IL:|fetch| (IL:ONED-ARRAY IL:BASE) + IL:|of| OBJECTARRAY)))) + +(DEFUN N_TRELOFF (OBJECTARRAY) + (+ (N_DATOFF + OBJECTARRAY) + (IL:|fetch| (AOUT-HEADER A_DATA) IL:|of| (IL:|fetch| (IL:ONED-ARRAY IL:BASE) + IL:|of| OBJECTARRAY)))) + +(DEFUN N_DRELOFF (OBJECTARRAY) + (+ (N_TRELOFF + OBJECTARRAY) + (IL:|fetch| (AOUT-HEADER A_TRSIZE) IL:|of| (IL:|fetch| (IL:ONED-ARRAY IL:BASE) + IL:|of| OBJECTARRAY)))) + +(DEFUN N_SYMOFF (OBJECTARRAY) + (+ (N_DRELOFF + OBJECTARRAY) + (IL:|fetch| (AOUT-HEADER A_DRSIZE) IL:|of| (IL:|fetch| (IL:ONED-ARRAY IL:BASE) + IL:|of| OBJECTARRAY)))) + +(DEFUN N_STROFF (OBJECTARRAY) + (+ (N_SYMOFF + OBJECTARRAY) + (IL:|fetch| (AOUT-HEADER A_SYMS) IL:|of| (IL:|fetch| (IL:ONED-ARRAY IL:BASE) + IL:|of| OBJECTARRAY)))) + +(DEFUN STRING-TABLE-SIZE (OBJECTARRAY) + (LET* ((INDEX (N_STROFF + OBJECTARRAY)) + (RESULT (IL:\\GETBASEBYTE (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of| OBJECTARRAY) + INDEX))) + (DOTIMES (A 3) + (SETQ RESULT (+ (IL:LSH RESULT 8) + (IL:\\GETBASEBYTE (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of| + OBJECTARRAY) + (INCF INDEX))))) + RESULT)) + +(DEFUN GET-C-INTEGER (ARRAY INDEX) + (+ (IL:LSH (AREF ARRAY INDEX) + 24) + (IL:LSH (AREF ARRAY (+ INDEX 1)) + 16) + (IL:LSH (AREF ARRAY (+ INDEX 2)) + 8) + (AREF ARRAY (+ INDEX 3)))) + +(DEFUN GET-C-SHORT (ARRAY INDEX) + (+ (IL:LSH (AREF ARRAY INDEX) + 8) + (AREF ARRAY (+ INDEX 1)))) + +(DEFUN GET-C-BYTE (ARRAY INDEX) + (AREF ARRAY INDEX)) + +(DEFUN GET-C-ADRESS () + (ERROR "NOT YET!")) + +(PUSH 'FOREIGN-FUNCTIONS-AROUNDEXITFN IL:AROUNDEXITFNS) + +(IL:PUTPROPS IL:FOREIGN-FUNCTIONS IL:MAKEFILE-ENVIRONMENT + (:READTABLE "XCL" :PACKAGE + (XCL:DEFPACKAGE "FOREIGN-FUNCTIONS" (:USE "CL" "CONDITIONS") + (:NICKNAMES "FF") + (:EXPORT "DEFFOREIGN" "DEF-C-STRUCT" "MALLOC" "C-FREE" "C-GETBASEBYTE" + "GETBASEFLOAT" "GETBASEINT" "GETBASEWORD" "GETBASEBYTE" + "GETBASEBIT" "LINK-FILE" "UNLINK-FILE" "UNDEFINED-SYMBOLS" + "EXECUTABLE-P" "C-PUTBASEBYTE" "PUTBASEFLOAT" "PUTBASEINT" + "PUTBASEWORD" "PUTBASEBYTE" "PUTBASEBIT")) + :BASE 10)) +(IL:PUTPROPS IL:FOREIGN-FUNCTIONS IL:COPYRIGHT ("Venue" 1992 1993 1994)) +(IL:DECLARE\: IL:DONTCOPY + (IL:FILEMAP (NIL))) +IL:STOP diff --git a/library/FX-80DRIVER b/library/FX-80DRIVER new file mode 100644 index 00000000..72b054a1 --- /dev/null +++ b/library/FX-80DRIVER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "11-Jun-90 15:57:59" {DSK}local>lde>lispcore>library>FX-80DRIVER.;2 233870 changes to%: (VARS FX-80DRIVERCOMS) previous date%: "23-Sep-88 10:26:48" {DSK}local>lde>lispcore>library>FX-80DRIVER.;1) (* ; " Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FX-80DRIVERCOMS) (RPAQQ FX-80DRIVERCOMS ( (* ;;; "FX-80 driver") (COMS * FX-80.FAST-DRIVERCOMS (* ; "the fast driver")) (COMS * FX-80.HIGH-QUALITY-DRIVERCOMS (* ; "the higher quality driver")) (COMS * FX80-PRINTCOMS (* ; "FXPrinter emulation")) (COMS (* ; "common routines") (FUNCTIONS (* ; "abort window stuff") WITH-ABORT-WINDOW \FX80.CREATE-SEND-ABORT-WINDOW) (FUNCTIONS (* ; "font profile hacking") \ADD-TO-FONTPROFILE \GET-FROM-FONTPROFILE)) (* ;;; "initialization") [COMS (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\HQFX80.INIT) (\FASTFX80.INIT] (PROP FILETYPE FX-80DRIVER))) (* ;;; "FX-80 driver") (RPAQQ FX-80.FAST-DRIVERCOMS [ (* ;; "Fast driver") (* ;; "") (STRUCTURES FASTFX80DATA) (FNS \FASTFX80.INIT) (* ;; "Imagestream methods") (COMS (* ;; "opening/closing imagestream") (COMS (FNS OPENFASTFX80STREAM) (FUNCTIONS \FASTFX80.PREAMBLE \FASTFX80.RESET-PRINTER \FASTFX80.OUTPUT-SIGNATURE) ) (FNS \FASTFX80.CLOSE)) (COMS (* ;; "methods that hack fonts") (FNS \FASTFX80.CHANGEFONT \FASTFX80.FONTCREATE \FASTFX80.CREATECHARSET) (FUNCTIONS \FASTFX80.INIT-FONT-PROFILE)) (COMS (* ;; "methods for measuring") (FNS \FASTFX80.STRINGWIDTH \FASTFX80.CHARWIDTH \FASTFX80.SUBCHARWIDTH) (FUNCTIONS \FASTFX80.SPACEFACTOR)) (COMS (* ;; "methods that affect the current position/size of drawing surface") (FNS \FASTFX80.CLIPPINGREGION \FASTFX80.MOVETO \FASTFX80.XPOSITION \FASTFX80.YPOSITION \FASTFX80.BACKUP.PAPER \FASTFX80.ADVANCE.PAPER \FASTFX80.NEWPAGE \FASTFX80.OUTCHAR \FASTFX80.NEWLINE \FASTFX80.LINEFEED \FASTFX80.DRAWLINE) (FUNCTIONS \FASTFX80.STARTPAGE \FASTFX80.SMART-XPOSITION \FASTFX80.TOPMARGIN \FASTFX80.BOTTOMMARGIN \FASTFX80.LEFTMARGIN \FASTFX80.RIGHTMARGIN \FASTFX80.CUR-POS-VISIBLE? \FASTFX80.HORIZONTAL)) (COMS (* ;; "printer code") (FUNCTIONS \FASTFX80.SEND MAKE-FASTFX80 FASTFX80FILEP \FASTFX80.CANNOT-PRINT-BITMAPS) (FNS \FASTFX80.CONVERT-TEDIT)) (COMS (* ;; "Character transmission method") (FNS \FASTFX80.BOUT)) (* ;; "Miscellany") (FUNCTIONS \FASTFX80.TRANSLATE-CHAR WITH-FASTFX80-DATA) (CONSTANTS (\FASTFX80.DOTSPERINCH 72) (\FASTFX80.LINESPERINCH 6) (\FASTFX80.LINEHEIGHT 12) (* ; "in dots") (\FASTFX80.FILE-SIGNATURE "FastFX-80/Xerox/1.0 ")) (INITVARS (FASTFX80-DEFAULT-DESTINATION "{TTY}") (\FASTFX80.INCHES-PER-PAGE 11) (\FASTFX80.INCHES-PER-LINE 8.5)) (COMS (* ;; "need to load these exports") (DECLARE%: EVAL@LOAD EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) ADISPLAY]) (* ;; "Fast driver") (* ;; "") (CL:DEFSTRUCT FASTFX80DATA (* ;; "the imagedata vector for a fastfx80 imagestream") (VIRTUAL-XPOS 0) (VIRTUAL-YPOS 0) (REAL-XPOS 0) (REAL-YPOS 0) CLIPPINGREGION BACKINGSTREAM (LEFTMARGIN 72) RIGHTMARGIN TOPMARGIN (BOTTOMMARGIN 0) FONT PAPER-WIDTH PAPER-HEIGHT (SPACEFACTOR 1.0)) (DEFINEQ (\FASTFX80.INIT [LAMBDA NIL (* ; "Edited 16-Dec-86 12:03 by hdj") (DECLARE (GLOBALVARS DEFAULTPRINTINGHOST IMAGESTREAMTYPES PRINTERTYPES PRINTFILETYPES \FASTFX80.IMAGEOPS \FASTFX80.FDEV)) (SETQ \FASTFX80.FDEV (create FDEV DEVICENAME _ (LIST 'FASTFX80 'PRINTER) CLOSEFILE _ (FUNCTION NILL) BOUT _ (FUNCTION \FASTFX80.BOUT))) (SETQ \FASTFX80.IMAGEOPS (create IMAGEOPS IMAGETYPE _ 'FASTFX80 IMFONT _ (FUNCTION \FASTFX80.CHANGEFONT) IMLEFTMARGIN _ (FUNCTION \FASTFX80.LEFTMARGIN) IMRIGHTMARGIN _ (FUNCTION \FASTFX80.RIGHTMARGIN) IMTOPMARGIN _ (FUNCTION \FASTFX80.TOPMARGIN) IMBOTTOMMARGIN _ (FUNCTION \FASTFX80.BOTTOMMARGIN) IMLINEFEED _ (FUNCTION NILL) IMTERPRI _ (FUNCTION \FASTFX80.NEWLINE) IMXPOSITION _ (FUNCTION \FASTFX80.XPOSITION) IMYPOSITION _ (FUNCTION \FASTFX80.YPOSITION) IMCLOSEFN _ (FUNCTION \FASTFX80.CLOSE) IMMOVETO _ (FUNCTION \FASTFX80.MOVETO) IMDRAWCURVE _ (FUNCTION NILL) IMFILLCIRCLE _ (FUNCTION NILL) IMDRAWLINE _ (FUNCTION NILL) IMDRAWELLIPSE _ (FUNCTION NILL) IMDRAWCIRCLE _ (FUNCTION NILL) IMBITBLT _ (FUNCTION NILL) IMBLTSHADE _ (FUNCTION NILL) IMNEWPAGE _ (FUNCTION \FASTFX80.NEWPAGE) IMSCALE _ [FUNCTION (LAMBDA NIL 1] IMSPACEFACTOR _ (FUNCTION NILL) IMFONTCREATE _ 'FASTFX80 IMCOLOR _ (FUNCTION NILL) IMBACKCOLOR _ (FUNCTION NILL) IMOPERATION _ (FUNCTION NILL) IMSTRINGWIDTH _ (FUNCTION \FASTFX80.STRINGWIDTH) IMCHARWIDTH _ (FUNCTION \FASTFX80.CHARWIDTH) IMCLIPPINGREGION _ (FUNCTION \FASTFX80.CLIPPINGREGION) IMRESET _ (FUNCTION NILL) IMDRAWPOLYGON _ (FUNCTION NILL) IMFILLPOLYGON _ (FUNCTION NILL) IMSCALEDBITBLT _ (FUNCTION NILL))) [push IMAGESTREAMTYPES (COPYALL '(FASTFX80 (OPENSTREAM OPENFASTFX80STREAM) (FONTCREATE \FASTFX80.FONTCREATE) (FONTSAVAILABLE \SEARCHDISPLAYFONTFILES) (CREATECHARSET \FASTFX80.CREATECHARSET] [push PRINTERTYPES (COPYALL '((FASTFX80) (CANPRINT (FASTFX80)) (STATUS TRUE) (SEND \FASTFX80.SEND) (BITMAPSCALE NIL) (BITMAPFILE (\FASTFX80.CANNOT-PRINT-BITMAPS FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)) (PROPERTIES NILL] [push PRINTFILETYPES (COPYALL '(FASTFX80 (TEST FASTFX80FILEP) (EXTENSION (FASTFX80)) (CONVERSION (TEXT MAKE-FASTFX80 TEDIT \FASTFX80.CONVERT-TEDIT] (push DEFAULTPRINTINGHOST (LIST 'FASTFX80 'FASTFX80)) (PUTPROP 'FASTFX80 'PRINTERTYPE 'FASTFX80) (\FASTFX80.INIT-FONT-PROFILE) T]) ) (* ;; "Imagestream methods") (* ;; "opening/closing imagestream") (DEFINEQ (OPENFASTFX80STREAM [LAMBDA (FILENAME OPTIONS) (* ; "Edited 20-Jan-88 11:22 by jds") (* ;; "open a fastfx80 imagestream") (LET* [[BACKING (OPENSTREAM FILENAME 'OUTPUT NIL '((SEQUENTIAL T) (TYPE FASTFX80] (PAPER-WIDTH (FIX (TIMES \FASTFX80.INCHES-PER-LINE \FASTFX80.DOTSPERINCH))) (PAPER-HEIGHT (FIX (TIMES \FASTFX80.INCHES-PER-PAGE \FASTFX80.DOTSPERINCH))) (FASTFX80STREAM (create STREAM FULLFILENAME _ (FULLNAME BACKING) DEVICE _ \FASTFX80.FDEV ACCESS _ 'OUTPUT OUTCHARFN _ (FUNCTION \FASTFX80.OUTCHAR) IMAGEOPS _ \FASTFX80.IMAGEOPS IMAGEDATA _ (MAKE-FASTFX80DATA :BACKINGSTREAM BACKING :CLIPPINGREGION (CREATEREGION 0 0 PAPER-WIDTH PAPER-HEIGHT) :RIGHTMARGIN (- PAPER-WIDTH \FASTFX80.DOTSPERINCH) :TOPMARGIN (- PAPER-HEIGHT (TIMES 3 \FASTFX80.LINEHEIGHT)) :BOTTOMMARGIN (TIMES 3 \FASTFX80.LINEHEIGHT) :PAPER-WIDTH PAPER-WIDTH :PAPER-HEIGHT PAPER-HEIGHT] (replace (STREAM USERVISIBLE) of BACKING with NIL) (\FASTFX80.PREAMBLE FASTFX80STREAM) FASTFX80STREAM]) ) (CL:DEFUN \FASTFX80.PREAMBLE (FASTFX80STREAM) (* ;; "start a FASTFX80 master") (* ;;; "must change FASTFX80FILEP when this changes") (DECLARE (GLOBALVARS \FASTFX80.INCHES-PER-PAGE)) (\FASTFX80.RESET-PRINTER FASTFX80STREAM \FASTFX80.INCHES-PER-PAGE) (\FASTFX80.OUTPUT-SIGNATURE FASTFX80STREAM) (\FASTFX80.CHANGEFONT FASTFX80STREAM (DEFAULTFONT 'FASTFX80)) (\FASTFX80.STARTPAGE FASTFX80STREAM)) (CL:DEFUN \FASTFX80.RESET-PRINTER (FASTFX80STREAM INCHES-PER-PAGE) (* ;; "send a reset sequence to the fx-80") (IF (AND (<= 1 INCHES-PER-PAGE) (<= INCHES-PER-PAGE 21)) THEN (* ;; "send a reset sequence to the fx-80...") (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE ESC)) (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE @)) (* ;; "...and set the form length") (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE ESC)) (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE C)) (\FASTFX80.BOUT FASTFX80STREAM (FIXR (TIMES INCHES-PER-PAGE \FASTFX80.LINESPERINCH)) ) ELSE (ERROR "Illegal page length value" INCHES-PER-PAGE))) (CL:DEFUN \FASTFX80.OUTPUT-SIGNATURE (FASTFX80STREAM) (* ;; "start the file with an identifying signature. Ensure it is not printed by following it with an equal number of ASCII 127's.") (* ;; "This will not work if SIGNATURE contains line-ending characters.") (LET ((DEL-BYTE 127)) (FOR BYTE INSTRING \FASTFX80.FILE-SIGNATURE DO (\FASTFX80.BOUT FASTFX80STREAM BYTE)) (FOR BYTE INSTRING \FASTFX80.FILE-SIGNATURE DO (\FASTFX80.BOUT FASTFX80STREAM DEL-BYTE)))) (DEFINEQ (\FASTFX80.CLOSE [LAMBDA (FASTFX80STREAM) (* ; "Edited 2-Jun-87 19:11 by Snow") (* ;; "close a fast fx80 stream ") (WITH-FASTFX80-DATA (DATA FASTFX80STREAM) (\FASTFX80.OUTCHAR FASTFX80STREAM (CHARCODE CR)) (* ;;  "do a bout here because an outchar will cause a new-page which then adds 4 lines to the output.") (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE FF)) (\CLOSEFILE (FASTFX80DATA-BACKINGSTREAM DATA)) (fetch (STREAM FULLFILENAME) of FASTFX80STREAM]) ) (* ;; "methods that hack fonts") (DEFINEQ (\FASTFX80.CHANGEFONT [LAMBDA (STREAM FONT) (* ; "Edited 14-Aug-87 14:40 by Snow") (* ;; "font-change method for the fast fx-80 device") (WITH-FASTFX80-DATA (DATA STREAM) (PROG1 (FASTFX80DATA-FONT DATA) (COND (FONT (SETQ FONT (FONTCREATE FONT NIL NIL NIL 'FASTFX80)) (COND ((NEQ FONT (FASTFX80DATA-FONT DATA)) [LET [[ITALICP (FMEMB 'ITALIC (FONTPROP FONT 'FACE] [BOLDP (FMEMB 'BOLD (FONTPROP FONT 'FACE] (UNDERLINE-NESS 128) (ITALIC-NESS 64) (EXPANDED-NESS 32) (DOUBLE-STRIKE-NESS 16) (EMPHASIZED-NESS 8) (COMPRESSED-NESS 4) (ELITE-NESS 1) (PICA-NESS 0) (SIZE (FONTPROP FONT 'SIZE] (* ;; "Send master select code and inform printer of boldness, italicism, and new font size: pica for regular sized fonts, emphasized pica for large fonts.") (\FASTFX80.BOUT STREAM (CHARCODE ESC)) (\FASTFX80.BOUT STREAM (CHARCODE !)) [\FASTFX80.BOUT STREAM (LOGOR (COND (ITALICP ITALIC-NESS) (T PICA-NESS)) (COND (BOLDP EMPHASIZED-NESS) (T PICA-NESS)) (COND ((> SIZE 12) EXPANDED-NESS) ((<= SIZE 8) COMPRESSED-NESS) (T PICA-NESS] (* ;; "Set italicness, since FX-80 doesn't support the ITALIC bit in master reset.") (\FASTFX80.BOUT STREAM (CHARCODE ESC)) (COND (ITALICP (* ; "turn it on") (\FASTFX80.BOUT STREAM (CHARCODE 4))) (T (* ; "turn it off") (\FASTFX80.BOUT STREAM (CHARCODE 5] (CL:SETF (FASTFX80DATA-FONT DATA) FONT]) (\FASTFX80.FONTCREATE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* hdj "27-Oct-86 14:59") (* ;; " create and return a fontdescriptor for a fastfx80 font") (LET ((FONTDESC (create FONTDESCRIPTOR FONTDEVICE _ 'FASTFX80 FONTFAMILY _ FAMILY FONTSIZE _ SIZE FONTFACE _ FACE ROTATION _ ROTATION FONTSCALE _ 1 \SFHeight _ 9 \SFAscent _ 7 \SFDescent _ 2))) (if (\GETCHARSETINFO CHARSET FONTDESC T) then FONTDESC else NIL]) (\FASTFX80.CREATECHARSET [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC) (* hdj "27-Oct-86 14:57") (* ;; "Create a character set for the fast fx-80. Really only works for char set 0; returns the same info for all sets.") (* * (if (NEQ 0 CHARSET) then (ERROR "FX-80 does not support NS characters."))) (LET ((WIDTHS (\CREATECSINFOELEMENT))) (for C from 32 to 254 do (\FSETWIDTH WIDTHS C (\FASTFX80.SUBCHARWIDTH C SIZE))) (create CHARSETINFO WIDTHS _ WIDTHS IMAGEWIDTHS _ WIDTHS YWIDTHS _ (\CREATECSINFOELEMENT) CHARSETASCENT _ (ffetch \SFAscent of FONTDESC) CHARSETDESCENT _ (ffetch \SFDescent of FONTDESC]) ) (CL:DEFUN \FASTFX80.INIT-FONT-PROFILE () (* ;; "set up the fonts for the FASTFX80, based on the DISPLAY font profile entries") [FOR FONT-CLASS IN '(DEFAULTFONT ITALICFONT BOLDFONT LITTLEFONT TINYFONT BIGFONT COMMENTFONT TEXTFONT) DO (\ADD-TO-FONTPROFILE FONTPROFILE FONT-CLASS 'FASTFX80 (\GET-FROM-FONTPROFILE FONTPROFILE FONT-CLASS 'DISPLAY] (FONTPROFILE FONTPROFILE) T) (* ;; "methods for measuring") (DEFINEQ (\FASTFX80.STRINGWIDTH [LAMBDA (FASTFX80STREAM STRING RDTBL) (* hdj " 6-Nov-86 15:15") (* ;;  " returns STRING's width, relative to STREAM's current font and the readtable RDTBL") (if RDTBL then (bind (FIRSTFLG _ T) (SA _ (fetch READSA of RDTBL)) (ESCAPE-CHAR-WIDTH _ (\FASTFX80.CHARWIDTH FASTFX80STREAM (fetch (READTABLEP ESCAPECHAR) of RDTBL)) ) (SYN _ NIL) for CHARCODE instring STRING sum (PROG1 (+ (\FASTFX80.CHARWIDTH FASTFX80STREAM CHARCODE) (IF (AND (fetch (READCODE ESCQUOTE) of (SETQ SYN (\SYNCODE SA CHARCODE))) (OR FIRSTFLG (fetch (READCODE INNERESCQUOTE) of SYN))) THEN ESCAPE-CHAR-WIDTH ELSE 0)) (SETQ FIRSTFLG NIL))) else (for CHAR instring STRING sum (\FASTFX80.CHARWIDTH FASTFX80STREAM CHAR ]) (\FASTFX80.CHARWIDTH [LAMBDA (STREAM CHARCODE) (* ; "Edited 4-Feb-87 15:52 by hdj") (* ;; " returns the width of CHARCODE, relative to STREAM's current font") (WITH-FASTFX80-DATA (DATA STREAM) (LET [(WIDTH (\FASTFX80.SUBCHARWIDTH (\FASTFX80.TRANSLATE-CHAR CHARCODE) (FONTPROP (FASTFX80DATA-FONT DATA) 'SIZE] (IF (EQ CHARCODE (CHARCODE SPACE)) THEN (FIXR (TIMES WIDTH (FASTFX80DATA-SPACEFACTOR DATA))) ELSE WIDTH]) (\FASTFX80.SUBCHARWIDTH [LAMBDA (CHARCODE SIZE) (* ; "Edited 21-Jan-88 12:10 by jds") (* ;; "Computes the size for a single character in Fast-FX80 mode.") (COND ((IGEQ CHARCODE 31) (* ;  "Only non-control characters have real widths") (COND ((GREATERP SIZE 12) (* ;  "Fonts bigger than 12 are printed EXPANDED.") 14) ((<= SIZE 8) (* ;  "Sizes 8 & under are printed compressed, 17.16 pitch, or 4.19 dots per") 4) (T (* ;  "Should really be 7.2 dots, but this is close.") 7))) (T 0]) ) (CL:DEFUN \FASTFX80.SPACEFACTOR (FASTFX80STREAM FACTOR) (* ;; "returns/sets the width of the space character (32 ASCII) for FASTFX80STREAM") [WITH-FASTFX80-DATA (DATA FASTFX80STREAM) (PROG1 (FASTFX80DATA-SPACEFACTOR DATA) (AND FACTOR (IF (NUMBERP FACTOR) THEN (CL:SETF (FASTFX80DATA-SPACEFACTOR DATA) FACTOR) ELSE (\ILLEGAL.ARG FACTOR))))]) (* ;; "methods that affect the current position/size of drawing surface") (DEFINEQ (\FASTFX80.CLIPPINGREGION [LAMBDA (STREAM REGION) (* ; "Edited 8-Dec-86 15:16 by hdj") (* ;;  "Returns old clipping region and sets new one. will never set onelarger than the paper size.") (DECLARE (GLOBALVARS \FASTFX80.PAGESIZE)) (WITH-FASTFX80-DATA (DATA STREAM) (PROG1 (COPY (FASTFX80DATA-CLIPPINGREGION DATA)) (AND REGION (CL:SETF (FASTFX80DATA-CLIPPINGREGION DATA) (INTERSECTREGIONS REGION (CREATEREGION 0 0 ( FASTFX80DATA-PAPER-WIDTH DATA) (FASTFX80DATA-PAPER-HEIGHT DATA]) (\FASTFX80.MOVETO [LAMBDA (STREAM X Y) (* hdj "27-Oct-86 11:40") (* ;; " move to (X,Y) on STREAM's drawing surface") (\FASTFX80.XPOSITION STREAM X) (\FASTFX80.YPOSITION STREAM Y]) (\FASTFX80.XPOSITION [LAMBDA (FASTFX80STREAM XPOS) (* hdj "20-Nov-86 17:50") (* ;; "Return old x-position, optionally move to new one. If new position would lie outside the clipping region, set the virtual x position, but don't change the real x position or move the printer's print head.") (WITH-FASTFX80-DATA (DATA FASTFX80STREAM) (LET ((OLD-REAL-XPOS (FASTFX80DATA-REAL-XPOS DATA)) (OLD-VIRTUAL-XPOS (FASTFX80DATA-VIRTUAL-XPOS DATA)) (CLIPPINGREGION (FASTFX80DATA-CLIPPINGREGION DATA))) (PROG1 OLD-VIRTUAL-XPOS (if XPOS then (* ;; "Space or backspace till new x-pos approximates desired position") (LET ((LEFT-BORDER (fetch (REGION LEFT) of CLIPPINGREGION)) (RIGHT-BORDER (fetch (REGION RIGHT) of CLIPPINGREGION))) (if (AND (LEQ LEFT-BORDER XPOS) (LEQ XPOS RIGHT-BORDER)) then (if (AND (EQP (FASTFX80DATA-LEFTMARGIN DATA) 0) (EQP XPOS 0)) then (* ; "if we can, just send a CR") (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE CR)) else (* ; "otherwise do the full schmeer") (\FASTFX80.SMART-XPOSITION OLD-REAL-XPOS XPOS FASTFX80STREAM)) (CL:SETF (FASTFX80DATA-REAL-XPOS DATA) XPOS))) (CL:SETF (FASTFX80DATA-VIRTUAL-XPOS DATA) XPOS]) (\FASTFX80.YPOSITION [LAMBDA (STREAM YPOS) (* ; "Edited 9-Dec-86 22:43 by hdj") (* ;; "Return old y position, optionally move to new one. If new position would lie outside the clipping region, set the virtual Y position, but don't change the real Y position or move the printer's print head.") (WITH-FASTFX80-DATA (DATA STREAM) (LET ((OLD-REAL-YPOS (FASTFX80DATA-REAL-YPOS DATA)) (OLD-VIRTUAL-YPOS (FASTFX80DATA-VIRTUAL-YPOS DATA)) (CLIPPINGREGION (FASTFX80DATA-CLIPPINGREGION DATA))) (PROG1 OLD-VIRTUAL-YPOS (if YPOS then [if (NOT (EQP YPOS OLD-REAL-YPOS)) then (LET ((TOP-BORDER (fetch (REGION TOP) of CLIPPINGREGION )) (BOTTOM-BORDER (fetch (REGION BOTTOM) of CLIPPINGREGION))) (if (NOT (EQP YPOS OLD-REAL-YPOS)) then (LET [(DOTS-TO-MOVE (FIX (- YPOS OLD-REAL-YPOS ] (if (MINUSP DOTS-TO-MOVE) then (  \FASTFX80.ADVANCE.PAPER STREAM DOTS-TO-MOVE) else (  \FASTFX80.BACKUP.PAPER STREAM DOTS-TO-MOVE))) (CL:SETF (FASTFX80DATA-REAL-YPOS DATA) YPOS] (CL:SETF (FASTFX80DATA-VIRTUAL-YPOS DATA) YPOS]) (\FASTFX80.BACKUP.PAPER [LAMBDA (STREAM DOTS) (* hdj "28-Oct-86 12:59") (* ;; "backup the page DOTS raster lines") (SETQ DOTS (TIMES 3 (ABS DOTS))) (while (GREATERP DOTS 0) do (\FASTFX80.BOUT STREAM (CHARCODE ESC)) (\FASTFX80.BOUT STREAM (CHARCODE j)) (\FASTFX80.BOUT STREAM (LET ((MAXBACKUP (MIN DOTS 255))) (add DOTS (MINUS MAXBACKUP )) MAXBACKUP]) (\FASTFX80.ADVANCE.PAPER [LAMBDA (STREAM DOTS) (* hdj "28-Oct-86 12:58") (* ;; "advance the page DOTS raster lines") (SETQ DOTS (TIMES 3 (ABS DOTS))) (while (GREATERP DOTS 0) do (\FASTFX80.BOUT STREAM (CHARCODE ESC)) (\FASTFX80.BOUT STREAM (CHARCODE J)) (\FASTFX80.BOUT STREAM (LET ((MAXADVANCE (MIN DOTS 255))) (add DOTS (MINUS MAXADVANCE )) MAXADVANCE]) (\FASTFX80.NEWPAGE [LAMBDA (FASTFX80STREAM) (* ; "Edited 17-Dec-86 10:32 by hdj") (* ;; "End the old page, start a new one") (* ;; "Just send a form-feed") (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE FF)) (\FASTFX80.STARTPAGE FASTFX80STREAM]) (\FASTFX80.OUTCHAR [LAMBDA (FASTFX80STREAM CHARCODE) (* ; "Edited 12-Feb-87 09:08 by jds") (* ;; "outcharfn for fastfx80 imagestreams") (LET ((TRANSLATED-CHAR (\FASTFX80.TRANSLATE-CHAR CHARCODE))) (WITH-FASTFX80-DATA (DATA FASTFX80STREAM) (SELCHARQ CHARCODE (^L (\FASTFX80.NEWPAGE FASTFX80STREAM)) ((CR EOL) (\FASTFX80.NEWLINE FASTFX80STREAM)) (LF (\FASTFX80.LINEFEED FASTFX80STREAM)) (SPACE [\FASTFX80.XPOSITION FASTFX80STREAM (+ (\FASTFX80.XPOSITION FASTFX80STREAM) (\FASTFX80.CHARWIDTH FASTFX80STREAM (CHARCODE SPACE] (COND ((> (FASTFX80DATA-VIRTUAL-XPOS DATA) (FASTFX80DATA-RIGHTMARGIN DATA)) (\FASTFX80.NEWLINE FASTFX80STREAM)))) (COND ((GREATERP CHARCODE 32) (* ;; "only print graphic characters") (LET ((CHARWIDTH (\FASTFX80.CHARWIDTH FASTFX80STREAM TRANSLATED-CHAR))) (* ;; "if character will be visible, output it") (COND ((\FASTFX80.CUR-POS-VISIBLE? DATA) (\FASTFX80.BOUT FASTFX80STREAM TRANSLATED-CHAR))) (CL:INCF (FASTFX80DATA-REAL-XPOS DATA) CHARWIDTH) (CL:INCF (FASTFX80DATA-VIRTUAL-XPOS DATA) CHARWIDTH) (* ;; "if we've passed the margin, DING!, do a newline") (COND ((> (FASTFX80DATA-VIRTUAL-XPOS DATA) (FASTFX80DATA-RIGHTMARGIN DATA)) (\FASTFX80.NEWLINE FASTFX80STREAM]) (\FASTFX80.NEWLINE [LAMBDA (FASTFX80STREAM) (* hdj "11-Nov-86 14:02") (* ;; "perform a newline on a fastfx80 imagestream. if we go below the bottom margin, start a new page.") (DECLARE (GLOBALVARS \FASTFX80.LINEHEIGHT)) (WITH-FASTFX80-DATA (DATA FASTFX80STREAM) (LET ((NEW-Y (- (FASTFX80DATA-VIRTUAL-YPOS DATA) \FASTFX80.LINEHEIGHT))) (if (< NEW-Y (FASTFX80DATA-BOTTOMMARGIN DATA)) then (\FASTFX80.NEWPAGE FASTFX80STREAM) else (* ; "move to the left margin") (\FASTFX80.XPOSITION FASTFX80STREAM (FASTFX80DATA-LEFTMARGIN DATA)) (FREPLACE (STREAM CHARPOSITION) OF FASTFX80STREAM WITH 0) (* ; "then move down or newpage") (\FASTFX80.YPOSITION FASTFX80STREAM NEW-Y]) (\FASTFX80.LINEFEED [LAMBDA (FASTFX80STREAM) (* hdj " 6-Nov-86 15:38") (* ;; "move down 1 line, leaving the x-position alone") (DECLARE (GLOBALVARS \FASTFX80.LINEHEIGHT)) (WITH-FASTFX80-DATA (DATA FASTFX80STREAM) (LET ((NEW-YPOS (- (FASTFX80DATA-VIRTUAL-YPOS DATA) \FASTFX80.LINEHEIGHT)) (OLD-XPOS (FASTFX80DATA-VIRTUAL-XPOS DATA))) (if (< NEW-YPOS (FASTFX80DATA-BOTTOMMARGIN DATA)) then (* ; "move to a new page") (\FASTFX80.NEWPAGE FASTFX80STREAM) (* ; "restore the old x position") (\FASTFX80.XPOSITION FASTFX80STREAM OLD-XPOS) else (* ; "move down") (\FASTFX80.YPOSITION FASTFX80STREAM NEW-YPOS]) (\FASTFX80.DRAWLINE [LAMBDA (STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) (* hdj "31-Oct-86 14:09") (* ;; "dummy drawline for the fast fx80 device") (MOVETO X2 Y2 STREAM]) ) (CL:DEFUN \FASTFX80.STARTPAGE (FASTFX80STREAM) (WITH-FASTFX80-DATA (DATA FASTFX80STREAM) (LET [(ASCENT (FONTPROP (DSPFONT NIL FASTFX80STREAM) 'ASCENT] (* ;; "set the %"actual%" position of printhead on paper after a newpage, then let the driver figure out how to get to (leftmargin, topmargin).") (CL:SETF (FASTFX80DATA-VIRTUAL-XPOS DATA) 0) (CL:SETF (FASTFX80DATA-REAL-XPOS DATA) 0) (CL:SETF (FASTFX80DATA-VIRTUAL-YPOS DATA) (FASTFX80DATA-PAPER-HEIGHT DATA)) (CL:SETF (FASTFX80DATA-REAL-YPOS DATA) (FASTFX80DATA-PAPER-HEIGHT DATA)) (* ;; "move the paper") (MOVETO (FASTFX80DATA-LEFTMARGIN DATA) (- (FASTFX80DATA-TOPMARGIN DATA) ASCENT) FASTFX80STREAM) FASTFX80STREAM))) (CL:DEFUN \FASTFX80.SMART-XPOSITION (CURRENT-XPOS DESIRED-XPOS FASTFX80STREAM) (* ;; "if it would create less output to space from the left margin, rather than to backspace from the current position, do so") (LET* ((SPACEWIDTH (\FASTFX80.CHARWIDTH FASTFX80STREAM (CHARCODE SP))) (CURRENT-XPOS-IN-SPACES (IQUOTIENT CURRENT-XPOS SPACEWIDTH)) (DESIRED-XPOS-IN-SPACES (IQUOTIENT DESIRED-XPOS SPACEWIDTH)) (NUM-BACKSPACES-NEEDED (- CURRENT-XPOS-IN-SPACES DESIRED-XPOS-IN-SPACES))) (IF (< NUM-BACKSPACES-NEEDED DESIRED-XPOS-IN-SPACES) THEN (* ;; "if backspacing's cheaper, backspace away") (\FASTFX80.HORIZONTAL (- NUM-BACKSPACES-NEEDED) FASTFX80STREAM) ELSE (* ;; "otherwise, go to the left margin... ") (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE CR)) (* ;; "... and then space to the right spot") (\FASTFX80.HORIZONTAL DESIRED-XPOS-IN-SPACES FASTFX80STREAM)))) (CL:DEFUN \FASTFX80.TOPMARGIN (STREAM &OPTIONAL YPOSITION) [WITH-FASTFX80-DATA (DATA STREAM) (PROG1 (FASTFX80DATA-TOPMARGIN DATA) (AND YPOSITION (IF (SMALLP YPOSITION) THEN (CL:SETF (FASTFX80DATA-TOPMARGIN DATA) YPOSITION) ELSE (\ILLEGAL.ARG YPOSITION))))]) (CL:DEFUN \FASTFX80.BOTTOMMARGIN (STREAM &OPTIONAL YPOSITION) [WITH-FASTFX80-DATA (DATA STREAM) (PROG1 (FASTFX80DATA-BOTTOMMARGIN DATA) (AND YPOSITION (IF (SMALLP YPOSITION) THEN (CL:SETF (FASTFX80DATA-BOTTOMMARGIN DATA) YPOSITION) ELSE (\ILLEGAL.ARG YPOSITION))))]) (CL:DEFUN \FASTFX80.LEFTMARGIN (STREAM &OPTIONAL XPOSITION) [WITH-FASTFX80-DATA (DATA STREAM) (PROG1 (FASTFX80DATA-LEFTMARGIN DATA) (AND XPOSITION (IF (SMALLP XPOSITION) THEN (CL:SETF (FASTFX80DATA-LEFTMARGIN DATA) XPOSITION) ELSE (\ILLEGAL.ARG XPOSITION))))]) (CL:DEFUN \FASTFX80.RIGHTMARGIN (STREAM &OPTIONAL XPOSITION) [WITH-FASTFX80-DATA (DATA STREAM) (PROG1 (FASTFX80DATA-RIGHTMARGIN DATA) (AND XPOSITION (IF (SMALLP XPOSITION) THEN (CL:SETF (FASTFX80DATA-RIGHTMARGIN DATA) XPOSITION) ELSE (\ILLEGAL.ARG XPOSITION))))]) (DEFMACRO \FASTFX80.CUR-POS-VISIBLE? (FASTFX80DATA) `(INSIDEP (FASTFX80DATA-CLIPPINGREGION ,FASTFX80DATA) (FASTFX80DATA-REAL-XPOS ,FASTFX80DATA) (FASTFX80DATA-REAL-YPOS ,FASTFX80DATA))) (CL:DEFUN \FASTFX80.HORIZONTAL (SPACES FASTFX80STREAM) (* ;; "print SPACES space characters if SPACES > 0, print SPACES backspaces if < 0, and do nothing if SPACES=0.") [if (MINUSP SPACES) then (for SPACE from 1 to (ABS SPACES) by 1 do (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE BS))) else (for SPACE from 1 to SPACES by 1 do (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE SP]) (* ;; "printer code") (CL:DEFUN \FASTFX80.SEND (PRINTER FILENAME &OPTIONAL OPTIONS) (* ;; "send the file designated by FILENAME to PRINTER, obeying OPTIONS. Since we only have one fx-80 per machine, ignore PRINTER and send to FASTFX80-DEFAULT-DESTINATION") (DECLARE (GLOBALVARS FASTFX80-DEFAULT-DESTINATION)) [LET [(COPIES (LISTGET OPTIONS '%#COPIES] (FOR COPY FROM 1 TO COPIES DO (* ;;  "allow the user to abort it while running") (WITH-ABORT-WINDOW ((THIS.PROCESS) FILENAME PRINTER COPY) (COPYFILE FILENAME FASTFX80-DEFAULT-DESTINATION '((TYPE FASTFX80]) (CL:DEFUN MAKE-FASTFX80 (FILE FASTFX80FILE &OPTIONAL FONTS HEADING TABS OPTIONS) (* ;; "turn FILE into a FASTFX80 master") (TEXTTOIMAGEFILE FILE FASTFX80FILE 'FASTFX80 FONTS HEADING TABS OPTIONS)) (CL:DEFUN FASTFX80FILEP (FASTFX80FILE?) (* ;; "is FILE (a filename or stream) a fastfx80 file?") [LET [(FILE-TYPE (GETFILEINFO FASTFX80FILE? 'TYPE] (IF (EQ FILE-TYPE 'FASTFX80) THEN (* ;  "if file has a type, and type=FASTFX80, we win") T ELSE (* ;  "no filetype or filetype not FASTFX80, so read the file") (LET [(STREAM (OPENSTREAM (INTERLISP-NAMESTRING FASTFX80FILE?) 'INPUT 'OLD '(SEQUENTIAL] (* ;; "file looks like ESC@ESCCn...") (PROG1 [AND (> (GETFILEINFO STREAM 'LENGTH) (+ 5 (NCHARS \FASTFX80.FILE-SIGNATURE))) (* ;; "yuck...") (EQ (CHARCODE ESC) (BIN STREAM)) (EQ (CHARCODE @) (BIN STREAM)) (EQ (CHARCODE ESC) (BIN STREAM)) (EQ (CHARCODE C) (BIN STREAM)) (BIN STREAM) (FOR CH INSTRING \FASTFX80.FILE-SIGNATURE ALWAYS (EQ CH (BIN STREAM] (CLOSEF STREAM]) (CL:DEFUN \FASTFX80.CANNOT-PRINT-BITMAPS (&OPTIONAL FILE BITMAP SCALEFACTOR REGION ROTATION TITLE ) (PRINTOUT PROMPTWINDOW "Sorry, FASTFX80 cannot render graphics." T "Use HQFX80 instead.")) (DEFINEQ (\FASTFX80.CONVERT-TEDIT [LAMBDA (TEDIT-FILE IMAGESTREAM) (* ; "Edited 11-Dec-86 17:29 by hdj") (* ;; "Send the text to the printer.") (SETQ TEDIT-FILE (OPENTEXTSTREAM TEDIT-FILE)) (TEDIT.FORMAT.HARDCOPY TEDIT-FILE IMAGESTREAM T NIL NIL NIL 'FASTFX80) (CLOSEF? IMAGESTREAM) IMAGESTREAM]) ) (* ;; "Character transmission method") (DEFINEQ (\FASTFX80.BOUT [LAMBDA (FASTFX80STREAM BYTE) (* hdj "27-Oct-86 11:51") (* ;; "send a byte to the fx80") (WITH-FASTFX80-DATA (DATA FASTFX80STREAM) (BOUT (FASTFX80DATA-BACKINGSTREAM DATA) BYTE]) ) (* ;; "Miscellany") (DEFMACRO \FASTFX80.TRANSLATE-CHAR (CHARCODE) `(SELCHARQ ,CHARCODE (357,146 (* ; "bullet") (CHARCODE *)) (357,45 (* ; "em-dash") 95) (357,44 (* ; "en-dash") 45) (\CHAR8CODE ,CHARCODE))) (DEFMACRO WITH-FASTFX80-DATA ((VAR-NAME STREAM) &BODY (BODY DECLS ENV)) `(LET [(,VAR-NAME (FETCH (STREAM IMAGEDATA) OF ,STREAM] ,@DECLS ,@BODY)) (DECLARE%: EVAL@COMPILE (RPAQQ \FASTFX80.DOTSPERINCH 72) (RPAQQ \FASTFX80.LINESPERINCH 6) (RPAQQ \FASTFX80.LINEHEIGHT 12) (RPAQ \FASTFX80.FILE-SIGNATURE "FastFX-80/Xerox/1.0 ") (CONSTANTS (\FASTFX80.DOTSPERINCH 72) (\FASTFX80.LINESPERINCH 6) (\FASTFX80.LINEHEIGHT 12) (\FASTFX80.FILE-SIGNATURE "FastFX-80/Xerox/1.0 ")) ) (RPAQ? FASTFX80-DEFAULT-DESTINATION "{TTY}") (RPAQ? \FASTFX80.INCHES-PER-PAGE 11) (RPAQ? \FASTFX80.INCHES-PER-LINE 8.5) (* ;; "need to load these exports") (DECLARE%: EVAL@LOAD EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) ADISPLAY) ) (RPAQQ FX-80.HIGH-QUALITY-DRIVERCOMS [ (* ;; "High-quality driver") (* ;; "") (STRUCTURES HQFX80DATA) (FNS \HQFX80.INIT) (COMS (* ;; "imagestream methods") (COMS (* ;; "opening/closing imagestream") (COMS (FNS OPENHQFX80STREAM) (FUNCTIONS \HQFX80.PREAMBLE \HQFX80.RESET-PRINTER \HQFX80.OUTPUT-SIGNATURE) ) (FNS \HQFX80.CLOSE)) (COMS (* ;; "methods that hack fonts") (FNS \HQFX80.FONTCREATE \HQFX80.CHANGEFONT \HQFX80.CREATECHARSET \HQFX80.CHANGE-CHARSET \HQFX80.READ-FONT-FILE \HQFX80.SEARCH-FONTS) (FUNCTIONS \HQFX80.INIT-FONT-PROFILE)) (COMS (* ;; "methods for measuring") (FNS \HQFX80.CHARWIDTH \HQFX80.STRINGWIDTH) (FUNCTIONS \HQFX80.SPACEFACTOR)) (COMS (* ;; "methods that affect the current position/size of drawing surface") (FNS \HQFX80.CLIPPINGREGION \HQFX80.LEFTMARGIN \HQFX80.RIGHTMARGIN \HQFX80.TOPMARGIN \HQFX80.BOTTOMMARGIN \HQFX80.XPOSITION \HQFX80.YPOSITION \HQFX80.NEWLINE \HQFX80.NEWPAGE \HQFX80.LINEFEED \HQFX80.RESET \HQFX80.STARTPAGE) (FUNCTIONS \HQFX80.CUR-POS-VISIBLE?)) (COMS (* ;; "graphical operations") (RESOURCES \HQFX80.BRUSHBBT) (FNS \HQFX80.BITBLT \HQFX80.BLTSHADE \HQFX80.DRAWELLIPSE \HQFX80.OPERATION \HQFX80.DRAWPOINT) (FNS \HQFX80.DRAWLINE \HQFX80.CLIP-AND-DRAW-LINE \HQFX80.CLIP-AND-DRAW-LINE1) (COMS (FNS \HQFX80.DRAWCIRCLE \HQFX80.CREATE-BRUSH-BBT) (FUNCTIONS \HQFX80.DRAW-4-CIRCLE-POINTS)) (COMS (FNS \HQFX80.FILLCIRCLE \HQFX80.DRAWARC) (FUNCTIONS \HQFX80.FILL-CIRCLE-BLT)) (COMS (* ;; "curve-drawing") (FNS \HQFX80.DRAWCURVE \HQFX80.DRAWCURVE2 \HQFX80.DRAWCURVE3 \HQFX80.LINEWITHBRUSH) (FNS \HQFX80.BBTCURVEPT) (MACROS \HQFX80.CURVEPT) (FUNCTIONS \HQFX80.SMOOTH-CURVE .SETUP.FOR.\HQFX80.BBTCURVEPT.))) (COMS (* ;; "character printing methods") (FNS \HQFX80.OUTCHAR \HQFX80.BLT-CHAR)) (COMS (* ;; "printer code") (FNS \HQFX80.DUMP-PAGE-BUFFER \HQFX80.ADVANCE-8-LINES) (FUNCTIONS \HQFX80.EIGHT-LINES-BLANK? \HQFX80.BITMAP-LDB \HQFX80.CLEAR-SCANLINE \HQFX80.CLEAR-WORD-BOX) (FUNCTIONS \HQFX80.SEND MAKE-HQFX80 HQFX80FILEP)) (COMS (* ;; "window hardcopy") (FNS \HQFX80.BITMAP-FILE \HQFX80.CONVERT-TEDIT)) (COMS (* ;; "character transmission method") (FNS \HQFX80.BOUT)) (COMS (* ;; "handling font-information caching") (FNS \HQFX80.FIX-LINE-LENGTH \HQFX80.FIX-FONT \HQFX80.FIX-Y) (FUNCTIONS \HQFX80.INVALIDATE-CACHE \HQFX80.INVALIDATE-FONT-CACHE \HQFX80.GET-CACHED-CHAR-WIDTH \HQFX80.GET-CHARACTER-OFFSET)) (COMS (* ;; "auxiliary functions") (FUNCTIONS \HQFX80.GRAPHICS-MODE) (FNS \HQFX80.PRINTER-MODE) (FUNCTIONS WITH-HQFX80-DATA)) (* ;; "and miscellany") (CONSTANTS (\HQFX80.FILE-SIGNATURE "HQFX-80/Xerox/1.0 ") (\HQFX80.1-TO-1-MODE-DPI 72) (\HQFX80.LOW-SPEED-DOUBLE-MODE-DPI 120)) (INITVARS (\HQFX80.INCHES-PER-PAGE 11) (\HQFX80.INCHES-PER-LINE 8.5) (HQFX80-DEFAULT-DESTINATION "{TTY}") (HQFX80-FONT-EXTENSIONS DISPLAYFONTEXTENSIONS) (HQFX80-FONT-DIRECTORIES DISPLAYFONTDIRECTORIES) (HQFX80-FONT-COERCIONS DISPLAYFONTCOERCIONS) (HQFX80-MISSING-FONT-COERCIONS MISSINGDISPLAYFONTCOERCIONS]) (* ;; "High-quality driver") (* ;; "") (CL:DEFSTRUCT HQFX80DATA (* ;; "the imagedata vector for an HQFX80 imagestream") BACKINGBITMAP BACKINGSTREAM (XPOS 0) (YPOS 0) (CLIPPINGREGION (create REGION)) LINEFEED RIGHTMARGIN (LEFTMARGIN 0) TOPMARGIN (BOTTOMMARGIN 0) OPERATION SOURCETYPE (PILOTBBT (create PILOTBBT PBTDISJOINT _ T)) (TEXTURE WHITESHADE) FONT (CHARSET-ASCENT-CACHE MAX.SMALLP) WIDTHS-CACHE OFFSETS-CACHE IMAGE-WIDTHS-CACHE (CHARSET-CACHE MAX.SMALLP) CHARSET-DESCENT-CACHE CHARHEIGHTDELTA (SPACEWIDTH 1.0) (* ;  "a misnomer -- this is actually the space factor, not its width") [SERIALIZING-BOX (fetch (ARRAYP BASE) of (ARRAY 1 'BYTE] SERIALIZING-PILOTBBT SCRATCH-SCANLINE SCRATCH-SCANLINE-PILOTBBT [EIGHT-LINES-BLANK (fetch (ARRAYP BASE) of (ARRAY 1 'WORD] EIGHT-LINES-BLANK-PILOTBBT COMPRESSED?) (DEFINEQ (\HQFX80.INIT [LAMBDA NIL (* ; "Edited 3-Feb-87 17:23 by hdj") (* ;; "Initializes global variables for the FX80") (DECLARE (GLOBALVARS DEFAULTPRINTINGHOST IMAGESTREAMTYPES PRINTERTYPES PRINTFILETYPES \HQFX80.IMAGEOPS \HQFX80.FDEV)) (SETQ \HQFX80.FDEV (create FDEV DEVICENAME _ (LIST 'HQFX80 'PRINTER) CLOSEFILE _ (FUNCTION NILL) BOUT _ (FUNCTION \HQFX80.OUTCHAR))) (SETQ \HQFX80.IMAGEOPS (create IMAGEOPS IMAGETYPE _ 'HQFX80 IMFONT _ (FUNCTION \HQFX80.CHANGEFONT) IMLEFTMARGIN _ (FUNCTION \HQFX80.LEFTMARGIN) IMRIGHTMARGIN _ (FUNCTION \HQFX80.RIGHTMARGIN) IMTOPMARGIN _ (FUNCTION \HQFX80.TOPMARGIN) IMBOTTOMMARGIN _ (FUNCTION \HQFX80.BOTTOMMARGIN) IMLINEFEED _ (FUNCTION \HQFX80.LINEFEED) IMXPOSITION _ (FUNCTION \HQFX80.XPOSITION) IMYPOSITION _ (FUNCTION \HQFX80.YPOSITION) IMCLOSEFN _ (FUNCTION \HQFX80.CLOSE) IMDRAWCURVE _ (FUNCTION \HQFX80.DRAWCURVE) IMFILLCIRCLE _ (FUNCTION \HQFX80.FILLCIRCLE) IMDRAWLINE _ (FUNCTION \HQFX80.DRAWLINE) IMDRAWELLIPSE _ (FUNCTION \HQFX80.DRAWELLIPSE) IMDRAWCIRCLE _ (FUNCTION \HQFX80.DRAWCIRCLE) IMBITBLT _ (FUNCTION \HQFX80.BITBLT) IMBLTSHADE _ (FUNCTION \HQFX80.BLTSHADE) IMNEWPAGE _ (FUNCTION \HQFX80.NEWPAGE) IMSCALE _ [FUNCTION (LAMBDA NIL 1] IMSPACEFACTOR _ (FUNCTION \HQFX80.SPACEFACTOR) IMFONTCREATE _ 'HQFX80 IMCOLOR _ (FUNCTION NILL) IMBACKCOLOR _ (FUNCTION NILL) IMOPERATION _ (FUNCTION \HQFX80.OPERATION) IMSTRINGWIDTH _ (FUNCTION \HQFX80.STRINGWIDTH) IMCHARWIDTH _ (FUNCTION \HQFX80.CHARWIDTH) IMCLIPPINGREGION _ (FUNCTION \HQFX80.CLIPPINGREGION) IMRESET _ (FUNCTION \HQFX80.RESET) IMDRAWPOINT _ (FUNCTION \HQFX80.DRAWPOINT) IMDRAWARC _ (FUNCTION \HQFX80.DRAWARC) IMFILLPOLYGON _ (FUNCTION POLYSHADE.BLT))) [push IMAGESTREAMTYPES (COPYALL '(HQFX80 (OPENSTREAM OPENHQFX80STREAM) (FONTCREATE \HQFX80.FONTCREATE) (CREATECHARSET \HQFX80.CREATECHARSET) (FONTSAVAILABLE \HQFX80.SEARCH-FONTS] [push PRINTERTYPES (COPYALL '((HQFX80) (CANPRINT (HQFX80)) (STATUS TRUE) (PROPERTIES NILL) (SEND \HQFX80.SEND) (BITMAPSCALE NIL) (BITMAPFILE (\HQFX80.BITMAP-FILE FILE BITMAP SCALEFACTOR REGION ROTATION TITLE] [push PRINTFILETYPES (COPYALL '(HQFX80 (TEST HQFX80FILEP) (EXTENSION (HQFX80)) (CONVERSION (TEXT MAKE-HQFX80 TEDIT \HQFX80.CONVERT-TEDIT] (push DEFAULTPRINTINGHOST (LIST 'HQFX80 'HQFX80)) (PUTPROP 'HQFX80 'PRINTERTYPE 'HQFX80) (\HQFX80.INIT-FONT-PROFILE) T]) ) (* ;; "imagestream methods") (* ;; "opening/closing imagestream") (DEFINEQ (OPENHQFX80STREAM [LAMBDA (FILENAME OPTIONS) (* ; "Edited 29-May-87 19:30 by Snow") (* ;; "Opens an imagestream on a high-quality FX80") (LET* ([BACKING (OPENSTREAM FILENAME 'OUTPUT NIL '((SEQUENTIAL T) (TYPE HQFX80] (COMPRESSED? (LISTGET OPTIONS 'COMPRESSED)) [DOTS-PER-LINE (FIX (TIMES \HQFX80.INCHES-PER-LINE (if COMPRESSED? then \HQFX80.LOW-SPEED-DOUBLE-MODE-DPI else \HQFX80.1-TO-1-MODE-DPI] (DOTS-PER-PAGE (ITIMES 8 (CL:CEILING (FIX (TIMES \HQFX80.INCHES-PER-PAGE (if COMPRESSED? then \HQFX80.LOW-SPEED-DOUBLE-MODE-DPI else \HQFX80.1-TO-1-MODE-DPI))) 8))) (BACKING-BITMAP (BITMAPCREATE DOTS-PER-LINE DOTS-PER-PAGE)) (BACKING-BITMAP-WORD-WIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BACKING-BITMAP)) (DATA (MAKE-HQFX80DATA :BACKINGSTREAM BACKING :CLIPPINGREGION (CREATEREGION 0 0 DOTS-PER-LINE DOTS-PER-PAGE) :BACKINGBITMAP BACKING-BITMAP :RIGHTMARGIN DOTS-PER-LINE :TOPMARGIN (- DOTS-PER-PAGE 15) :BOTTOMMARGIN 30 :PILOTBBT (create PILOTBBT PBTDISJOINT _ T PBTDESTBPL _ (UNFOLD BACKING-BITMAP-WORD-WIDTH BITSPERWORD)) :SCRATCH-SCANLINE (fetch (BITMAP BITMAPBASE) of (BITMAPCREATE DOTS-PER-LINE 1)) :OPERATION 'REPLACE :SOURCETYPE 'INPUT :COMPRESSED? COMPRESSED?)) (HQFX80STREAM (create STREAM FULLFILENAME _ (FULLNAME BACKING) DEVICE _ \HQFX80.FDEV ACCESS _ 'OUTPUT OUTCHARFN _ (FUNCTION \HQFX80.OUTCHAR) STRMBOUTFN _ (FUNCTION \HQFX80.OUTCHAR) IMAGEOPS _ \HQFX80.IMAGEOPS USERCLOSEABLE _ T USERVISIBLE _ T IMAGEDATA _ DATA))) (* ;;  "set up the BitBLT table that transforms 8-bit columns of bitmap data into single BOUT-able bytes") (CL:SETF (HQFX80DATA-SERIALIZING-PILOTBBT DATA) (create PILOTBBT PBTDISJOINT _ T PBTDEST _ (HQFX80DATA-SERIALIZING-BOX DATA) PBTWIDTH _ 1 PBTHEIGHT _ 8 PBTSOURCEBPL _ (UNFOLD BACKING-BITMAP-WORD-WIDTH BITSPERWORD) PBTDESTBPL _ 1)) (* ;; "set up the BitBLT table that ORs together eight sequential scanlines (for blank-line group detection) into one scanline") (CL:SETF (HQFX80DATA-SCRATCH-SCANLINE-PILOTBBT DATA) (create PILOTBBT PBTDISJOINT _ T PBTDEST _ (HQFX80DATA-SCRATCH-SCANLINE DATA) PBTWIDTH _ (UNFOLD BACKING-BITMAP-WORD-WIDTH BITSPERWORD) PBTHEIGHT _ 8 PBTSOURCEBPL _ (UNFOLD BACKING-BITMAP-WORD-WIDTH BITSPERWORD) PBTDESTBPL _ 0 PBTSOURCEBIT _ 0 PBTDESTBIT _ 0 PBTOPERATION _ 2)) (* ;; "set up the BitBLT table that ORs one scanline into one 16-bit word") (CL:SETF (HQFX80DATA-EIGHT-LINES-BLANK-PILOTBBT DATA) (create PILOTBBT PBTDISJOINT _ T PBTSOURCE _ (HQFX80DATA-SCRATCH-SCANLINE DATA) PBTDEST _ (HQFX80DATA-EIGHT-LINES-BLANK DATA) PBTWIDTH _ BITSPERWORD PBTHEIGHT _ (FOLDHI DOTS-PER-LINE BITSPERWORD) PBTSOURCEBPL _ BITSPERWORD PBTDESTBPL _ 0 PBTSOURCEBIT _ 0 PBTDESTBIT _ 0 PBTOPERATION _ 2)) (* ;; "make the backing file invisible") (replace (STREAM USERVISIBLE) of BACKING with NIL) (* ;; "put the preamble on the master") (\HQFX80.PREAMBLE HQFX80STREAM) HQFX80STREAM]) ) (CL:DEFUN \HQFX80.PREAMBLE (HQFX80STREAM) (* ;; "start an HQFX80 master") (DECLARE (GLOBALVARS \HQFX80.INCHES-PER-PAGE)) (\HQFX80.RESET-PRINTER HQFX80STREAM \HQFX80.INCHES-PER-PAGE) (\HQFX80.OUTPUT-SIGNATURE HQFX80STREAM) (DSPFONT (DEFAULTFONT 'HQFX80) HQFX80STREAM) (\HQFX80.STARTPAGE HQFX80STREAM)) (CL:DEFUN \HQFX80.RESET-PRINTER (HQFX80STREAM INCHES-PER-PAGE) (* ;; "send a reset sequence to the fx-80") (IF (AND (<= 1 INCHES-PER-PAGE) (<= INCHES-PER-PAGE 22)) THEN (* ;; "send a reset sequence to the fx-80...") (\HQFX80.BOUT HQFX80STREAM (CHARCODE ESC)) (\HQFX80.BOUT HQFX80STREAM (CHARCODE @)) (* ;; "...and set the form length") (\HQFX80.BOUT HQFX80STREAM (CHARCODE ESC)) (\HQFX80.BOUT HQFX80STREAM (CHARCODE C)) (\HQFX80.BOUT HQFX80STREAM (FIXR (TIMES 6 INCHES-PER-PAGE))) ELSE (ERROR "Illegal page length value" INCHES-PER-PAGE))) (CL:DEFUN \HQFX80.OUTPUT-SIGNATURE (HQFX80TREAM) (* ;; "start the file with an identifying signature. Ensure it is not printed by following it with an equal number of ASCII 127's.") (* ;; "This will not work if SIGNATURE contains line-ending characters.") (LET ((DEL-BYTE 127)) (FOR BYTE INSTRING \HQFX80.FILE-SIGNATURE DO (\HQFX80.BOUT HQFX80TREAM BYTE)) (FOR BYTE INSTRING \HQFX80.FILE-SIGNATURE DO (\HQFX80.BOUT HQFX80TREAM DEL-BYTE)))) (DEFINEQ (\HQFX80.CLOSE [LAMBDA (HQFX80STREAM) (* ; "Edited 21-Jan-88 12:20 by jds") (* ;; "do the cleanup prefatory to closing the HQFX80STREAM") (WITH-HQFX80-DATA (DATA HQFX80STREAM) (* ; "") (LET ((BACKING-STREAM (HQFX80DATA-BACKINGSTREAM DATA))) (\HQFX80.DUMP-PAGE-BUFFER (HQFX80DATA-BACKINGBITMAP DATA) HQFX80STREAM) (\BOUT BACKING-STREAM (CHARCODE ESCAPE)) (\BOUT BACKING-STREAM (CHARCODE !)) (\BOUT BACKING-STREAM 0) (\BOUT BACKING-STREAM (CHARCODE ESCAPE)) (\BOUT BACKING-STREAM (CHARCODE 5)) (\CLOSEFILE BACKING-STREAM) (fetch (STREAM FULLFILENAME) of HQFX80STREAM]) ) (* ;; "methods that hack fonts") (DEFINEQ (\HQFX80.FONTCREATE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* hdj "10-Nov-86 11:30") (* ;; "create a font for the hqfx80") (LET [(FONTDESC (create FONTDESCRIPTOR FONTDEVICE _ DEVICE FONTFAMILY _ FAMILY FONTSIZE _ SIZE FONTFACE _ FACE \SFAscent _ 0 \SFDescent _ 0 \SFHeight _ 0 ROTATION _ ROTATION FONTDEVICESPEC _ (LIST FAMILY SIZE FACE ROTATION DEVICE] (AND (\GETCHARSETINFO CHARSET FONTDESC T) FONTDESC]) (\HQFX80.CHANGEFONT [LAMBDA (HQFX80STREAM FONT) (* ; "Edited 4-Feb-87 11:48 by hdj") (* ;; "sets/returns the font of an HQFX80 imagestream") (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) (LET ((OLD-FONT (HQFX80DATA-FONT HQFX80DATA))) (* ;; "save old value to return, smash new value and update the record.") (PROG1 OLD-FONT (if FONT then (LET [(NEW-FONT (OR (\COERCEFONTDESC FONT HQFX80STREAM T) (FONTCOPY (HQFX80DATA-FONT HQFX80DATA) FONT] (* ;;  "updating font information is fairly expensive operation. Don't bother unless font has changed.") (OR (EQ OLD-FONT NEW-FONT) (UNINTERRUPTABLY (CL:SETF (HQFX80DATA-FONT HQFX80DATA) NEW-FONT) (CL:SETF (HQFX80DATA-LINEFEED HQFX80DATA) (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) of NEW-FONT))) (\HQFX80.FIX-FONT HQFX80STREAM HQFX80DATA))]) (\HQFX80.CREATECHARSET [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) (* ; "Edited 1-Jun-87 13:08 by Snow") (* ;;; "Tries to build the csinfo required for CHARSET. Does the necessary coercions.") (* ;;; "NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL.") (DECLARE (GLOBALVARS HQFX80-FONT-COERCIONS HQFX80-MISSING-FONT-COERCIONS)) (* ;; "HQFX80-FONT-COERCIONS 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.") (PROG (XCSINFO) [SETQ XCSINFO (COND [(PROGN (* ;; "Just recursively call ourselves to handle entries in HQFX80-FONT-COERCIONS") (for TRANSL in HQFX80-FONT-COERCIONS bind NEWCSINFO USRFONT REALFONT when (AND (SETQ USRFONT (CAR TRANSL)) (EQ FAMILY (CAR USRFONT)) (OR (NOT (CADR USRFONT)) (EQ SIZE (CADR USRFONT))) (OR (NOT (CADDR USRFONT)) (EQ CHARSET (CADDR USRFONT))) (SETQ REALFONT (CADR TRANSL)) (SETQ NEWCSINFO (\HQFX80.CREATECHARSET (OR (CAR REALFONT) FAMILY) (OR (CADR REALFONT) SIZE) FACE ROTATION DEVICE (OR (CADDR REALFONT) CHARSET) FONTDESC NOSLUG?))) do (RETURN NEWCSINFO] ((AND (EQ ROTATION 0) (* ;;  "If it is available, this will force the appropriate file to be read to fill in the charset entry") (\HQFX80.READ-FONT-FILE FAMILY SIZE FACE ROTATION 'HQFX80 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 CSINFO) (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 '(90 270)) (ERROR "only implemented rotations are 0, 90 and 270." ROTATION)) (COND ((SETQ XFONT (FONTCREATE FAMILY SIZE FACE 0 'HQFX80 T CHARSET)) (* ;; "actually call FONTCREATE here, rather than a device-specific method, so that the vanilla font that is built in this process will be cached and not repeated.") (COND ((SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T )) (\SFROTATECSINFO CSINFO ROTATION)) (T NIL] ((AND (EQ (fetch (FONTFACE WEIGHT) of FACE) 'BOLD) (SETQ XFONT (FONTCREATE FAMILY SIZE (create FONTFACE using FACE WEIGHT _ 'MEDIUM) 0 'HQFX80 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") (COND ((SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) (\SFMAKEBOLD CSINFO)) (T NIL))) ((AND (EQ (fetch (FONTFACE SLOPE) of FACE) 'ITALIC) (SETQ XFONT (FONTCREATE FAMILY SIZE (create FONTFACE using FACE SLOPE _ 'REGULAR) 0 'HQFX80 T CHARSET))) (COND ((SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) (\SFMAKEITALIC CSINFO)) (T NIL))) ((for TRANSL in HQFX80-MISSING-FONT-COERCIONS bind NEWCSINFO USRFONT REALFONT when (AND (SETQ USRFONT (CAR TRANSL)) (EQ FAMILY (CAR USRFONT)) (OR (NOT (CADR USRFONT)) (EQ SIZE (CADR USRFONT))) (OR (NOT (CADDR USRFONT)) (EQ CHARSET (CADDR USRFONT))) (SETQ REALFONT (CADR TRANSL)) (SETQ NEWCSINFO (\HQFX80.CREATECHARSET (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 'ASCENT) (FONTPROP FONTDESC 'DESCENT) (FONTPROP FONTDESC 'DEVICE] (RETURN XCSINFO]) (\HQFX80.CHANGE-CHARSET [LAMBDA (HQFX80DATA CHARSET) (* hdj "10-Nov-86 16:00") (* ;;  "Called when the character set information cached in hqfx80 stream doesn't correspond to CHARSET") (LET* ((PBT (HQFX80DATA-PILOTBBT HQFX80DATA)) (CSINFO (\GETCHARSETINFO CHARSET (HQFX80DATA-FONT HQFX80DATA))) (CHARACTER-BITMAP (ffetch CHARSETBITMAP of CSINFO))) (* ;; "Since we called \GETCHARSETINFO without the NOSLUG? flag, we presume we will get back a CSINFO , even if it is a slug csinfo") (UNINTERRUPTABLY (CL:SETF (HQFX80DATA-WIDTHS-CACHE HQFX80DATA) (ffetch (CHARSETINFO WIDTHS) of CSINFO)) (CL:SETF (HQFX80DATA-OFFSETS-CACHE HQFX80DATA) (ffetch (CHARSETINFO OFFSETS) of CSINFO)) (CL:SETF (HQFX80DATA-IMAGE-WIDTHS-CACHE HQFX80DATA) (ffetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) (CL:SETF (HQFX80DATA-CHARSET-CACHE HQFX80DATA) CHARSET) (freplace PBTSOURCEBPL of PBT with (UNFOLD (ffetch (BITMAP BITMAPRASTERWIDTH) of CHARACTER-BITMAP) BITSPERWORD)) [IF (OR (NEQ (HQFX80DATA-CHARSET-ASCENT-CACHE HQFX80DATA) (ffetch CHARSETASCENT of CSINFO)) (NEQ (HQFX80DATA-CHARSET-DESCENT-CACHE HQFX80DATA) (ffetch CHARSETDESCENT of CSINFO))) THEN (\HQFX80.FIX-Y HQFX80DATA CSINFO) ELSE (freplace PBTSOURCE of PBT with (\ADDBASE (ffetch (BITMAP BITMAPBASE) of CHARACTER-BITMAP) (ITIMES (ffetch (BITMAP BITMAPRASTERWIDTH ) of CHARACTER-BITMAP ) (HQFX80DATA-CHARHEIGHTDELTA HQFX80DATA])]) (\HQFX80.READ-FONT-FILE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 6-Jan-87 17:52 by hdj") (* ;; "Look for new filename convention, then old file name convention, with extensions. Note we assume \FONTFILENAME calls \FONTFILENAME.NEW") (DECLARE (GLOBALVARS HQFX80-FONT-EXTENSIONS HQFX80-FONT-DIRECTORIES)) (bind FONTFILE CSINFO STRM for EXT inside HQFX80-FONT-EXTENSIONS when (SETQ FONTFILE (\FINDFONTFILE FAMILY SIZE FACE ROTATION DEVICE CHARSET HQFX80-FONT-DIRECTORIES (LIST EXT))) do (SETQ STRM (OPENSTREAM FONTFILE 'INPUT)) [RESETLST (SETQ CSINFO (SELECTQ (FONTFILEFORMAT STRM T) (STRIKE (RESETSAVE NIL (LIST (FUNCTION CLOSEF) STRM)) (\READSTRIKEFONTFILE STRM FAMILY SIZE FACE)) (AC (* ;; "CLOSEF is guaranteed inside \READACFONTFILE, against the possibility that we have to copy to make randaccessp") (\READACFONTFILE STRM FAMILY SIZE FACE)) (PROG1 (CLOSEF STRM) (SHOULDNT) (* ;  "This would get done by RESETSAVE if AC's were read sequentially and we could factor the RESETSAVE") ] (* ;; "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]) (\HQFX80.SEARCH-FONTS [LAMBDA (FAMILY SIZE FACE ROTATION) (* hdj "10-Nov-86 12:09") (* ;;; "returns a list of the fonts that can be read in for the hqfx80 device. (This is the same as all fonts for the dissplay device.) Rotation is ignored because it is assumed that all devices support 0 90 and 270") (DECLARE (GLOBALVARS HQFX80-FONT-EXTENSIONS HQFX80-FONT-DIRECTORIES)) (for E FILENAMEPATTERN FONTSFOUND THISFONT THISFACE inside HQFX80-FONT-EXTENSIONS do (SETQ FILENAMEPATTERN (\FONTFILENAME FAMILY SIZE FACE E)) [for DIR inside HQFX80-FONT-DIRECTORIES do (for FONTFILE in (DIRECTORY (PACKFILENAME 'DIRECTORY DIR 'BODY FILENAMEPATTERN)) do (OR (MEMBER (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE 'DISPLAY)) FONTSFOUND) (COND ((AND [OR (EQ FACE '*) (EQUAL FACE (SETQ THISFACE (CADDR THISFONT))) (AND (OR (EQ (CAR FACE) '*) (EQ (CAR FACE) (CAR THISFACE))) (OR (EQ (CADR FACE) '*) (EQ (CADR FACE) (CADR THISFACE))) (OR (EQ (CADR FACE) '*) (EQ (CADR FACE) (CADR THISFACE] (OR (EQ FAMILY '*) (EQ FAMILY (CAR THISFONT)) (STRPOS "*" FAMILY))) (* ;; "make sure the face, size, and family really match. Family name match allows anything if the family has a * in it. This is wrong but better than what was there before which let in anything with the right beginning.") (SETQ FONTSFOUND (CONS THISFONT FONTSFOUND] finally (RETURN FONTSFOUND]) ) (CL:DEFUN \HQFX80.INIT-FONT-PROFILE () (* ;; "set up the fonts for the HQFX80, based on the DISPLAY font profile entries") [FOR FONT-CLASS IN '(DEFAULTFONT ITALICFONT BOLDFONT LITTLEFONT TINYFONT BIGFONT COMMENTFONT TEXTFONT) DO (\ADD-TO-FONTPROFILE FONTPROFILE FONT-CLASS 'HQFX80 (\GET-FROM-FONTPROFILE FONTPROFILE FONT-CLASS 'DISPLAY] (FONTPROFILE FONTPROFILE) T) (* ;; "methods for measuring") (DEFINEQ (\HQFX80.CHARWIDTH [LAMBDA (HQFX80STREAM CHARCODE) (* ; "Edited 4-Feb-87 13:20 by hdj") (* ;;  "gets the width of the rendering of charcode on an hqfx80 image stream. We treat space specially.") (WITH-HQFX80-DATA (DATA HQFX80STREAM) (LET ((WIDTH (\FGETCHARWIDTH (HQFX80DATA-FONT DATA) CHARCODE))) (if (EQ CHARCODE (CHARCODE SPACE)) then (FIXR (TIMES WIDTH (HQFX80DATA-SPACEWIDTH DATA))) else WIDTH]) (\HQFX80.STRINGWIDTH [LAMBDA (HQFX80STREAM STRING RDTBL) (* ; "Edited 3-Feb-87 17:36 by hdj") (* ;;  " returns STRING's width, relative to HQFX80STREAM's current font and the readtable RDTBL") (IF RDTBL THEN (BIND (FIRSTFLG _ T) (SA _ (FETCH READSA OF RDTBL)) (ESCAPE-CHAR-WIDTH _ (\HQFX80.CHARWIDTH HQFX80STREAM (FETCH (READTABLEP ESCAPECHAR ) OF RDTBL))) (SYN _ NIL) FOR CHARCODE INSTRING STRING SUM (PROG1 (IPLUS (COND ((AND (FETCH (READCODE ESCQUOTE) OF (SETQ SYN (\SYNCODE SA CHARCODE))) (OR FIRSTFLG (FETCH (READCODE INNERESCQUOTE) OF SYN))) ESCAPE-CHAR-WIDTH) (T 0)) (\FASTFX80.CHARWIDTH HQFX80STREAM CHARCODE)) (SETQ FIRSTFLG NIL))) ELSE (FOR CHAR INSTRING STRING SUM (\HQFX80.CHARWIDTH HQFX80STREAM CHAR]) ) (CL:DEFUN \HQFX80.SPACEFACTOR (HQFX80STREAM FACTOR) (* ;; "returns/sets the width of the space character (32 ASCII) for HQFX80STREAM") [WITH-HQFX80-DATA (DATA HQFX80STREAM) (PROG1 (HQFX80DATA-SPACEWIDTH DATA) (AND FACTOR (IF (NUMBERP FACTOR) THEN (CL:SETF (HQFX80DATA-SPACEWIDTH DATA) FACTOR) ELSE (\ILLEGAL.ARG FACTOR))))]) (* ;; "methods that affect the current position/size of drawing surface") (DEFINEQ (\HQFX80.CLIPPINGREGION [LAMBDA (HQFX80STREAM REGION) (* ; "Edited 8-Dec-86 14:04 by hdj") (* ;; "sets the clipping region of an HQFX80 image stream. do not allow it to exceed the confines of the bitmap.") (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) (PROG1 (COPY (HQFX80DATA-CLIPPINGREGION HQFX80DATA)) (* ;  "copy so it can't be side-effected later") (LET ((BACKING (HQFX80DATA-BACKINGBITMAP HQFX80DATA))) (AND REGION (OR (type? REGION REGION) (ERROR REGION " is not a REGION.")) (UNINTERRUPTABLY (CL:SETF (HQFX80DATA-CLIPPINGREGION HQFX80DATA) (INTERSECTREGIONS (CREATEREGION 0 0 (BITMAPWIDTH BACKING) (BITMAPHEIGHT BACKING)) REGION)) (\HQFX80.INVALIDATE-FONT-CACHE HQFX80DATA))]) (\HQFX80.LEFTMARGIN [LAMBDA (HQFX80STREAM XPOSITION) (* ; "Edited 3-Feb-87 17:11 by hdj") (* ;; "sets/returns the position that a carriage return returns to for an hqfx80stream") (WITH-HQFX80-DATA (DATA HQFX80STREAM) (PROG1 (HQFX80DATA-LEFTMARGIN DATA) (AND XPOSITION (if (SMALLP XPOSITION) then (UNINTERRUPTABLY (CL:SETF (HQFX80DATA-LEFTMARGIN DATA) XPOSITION) (\HQFX80.FIX-LINE-LENGTH HQFX80STREAM)) else (\ILLEGAL.ARG XPOSITION]) (\HQFX80.RIGHTMARGIN [LAMBDA (HQFX80STREAM XPOSITION) (* ; "Edited 10-Dec-86 18:17 by hdj") (* ;; "Sets the right margin of an HQFX80STREAM") (WITH-HQFX80-DATA (DATA HQFX80STREAM) (PROG1 (HQFX80DATA-RIGHTMARGIN DATA) (AND XPOSITION (IF (SMALLP XPOSITION) THEN (UNINTERRUPTABLY (CL:SETF (HQFX80DATA-RIGHTMARGIN DATA) XPOSITION) (\HQFX80.FIX-LINE-LENGTH HQFX80STREAM)) ELSE (\ILLEGAL.ARG XPOSITION]) (\HQFX80.TOPMARGIN [LAMBDA (HQFX80STREAM YPOSITION) (* ; "Edited 10-Dec-86 18:16 by hdj") (* ;; "Sets the top margin of an hqfx80stream") (WITH-HQFX80-DATA (DATA HQFX80STREAM) (PROG1 (HQFX80DATA-TOPMARGIN DATA) (AND YPOSITION (IF (SMALLP YPOSITION) THEN (CL:SETF (HQFX80DATA-TOPMARGIN DATA) YPOSITION) ELSE (\ILLEGAL.ARG YPOSITION]) (\HQFX80.BOTTOMMARGIN [LAMBDA (HQFX80STREAM YPOSITION) (* ; "Edited 10-Dec-86 18:17 by hdj") (* ;; "Sets the bottom margin of an HQFX80STREAM") (WITH-HQFX80-DATA (DATA HQFX80STREAM) (PROG1 (HQFX80DATA-BOTTOMMARGIN DATA) (AND YPOSITION (IF (SMALLP YPOSITION) THEN (CL:SETF (HQFX80DATA-BOTTOMMARGIN DATA) YPOSITION) ELSE (\ILLEGAL.ARG YPOSITION]) (\HQFX80.XPOSITION [LAMBDA (HQFX80STREAM XPOSITION) (* hdj " 3-Nov-86 15:14") (WITH-HQFX80-DATA (DATA HQFX80STREAM) (PROG1 (HQFX80DATA-XPOS DATA) (AND XPOSITION (IF (NUMBERP XPOSITION) THEN (CL:SETF (HQFX80DATA-XPOS DATA) XPOSITION) ELSE (\ILLEGAL.ARG XPOSITION]) (\HQFX80.YPOSITION [LAMBDA (HQFX80STREAM YPOSITION) (* ; "Edited 5-Jan-87 17:25 by hdj") (* ;; "set the y-pos of an HQFX80STREAM") (WITH-HQFX80-DATA (DATA HQFX80STREAM) (PROG1 (HQFX80DATA-YPOS DATA) (AND YPOSITION (if (NUMBERP YPOSITION) then (UNINTERRUPTABLY (CL:SETF (HQFX80DATA-YPOS DATA) YPOSITION) (\HQFX80.INVALIDATE-CACHE DATA)) else (\ILLEGAL.ARG YPOSITION]) (\HQFX80.NEWLINE [LAMBDA (CHARCODE HQFX80STREAM) (* hdj "14-Nov-86 17:44") (* ;;  "CODE is EOL, CR, or LF. Performs the appropriate printing operation on hqfx80stream.") (WITH-HQFX80-DATA (DATA HQFX80STREAM) (LET [(NEW-Y (+ (HQFX80DATA-YPOS DATA) (HQFX80DATA-LINEFEED DATA] (if (< NEW-Y (HQFX80DATA-BOTTOMMARGIN DATA)) then (* ;;  "we're below the bottom margin, so eject the page. If this was a LF, restore the old x-position") (LET ((OLD-X (HQFX80DATA-XPOS DATA))) (\HQFX80.NEWPAGE HQFX80STREAM) (if (EQ CHARCODE (CHARCODE LF)) then (\HQFX80.XPOSITION HQFX80STREAM OLD-X))) else (* ;; "just decrement the y coord") (\HQFX80.YPOSITION HQFX80STREAM NEW-Y) (* ;; "if this was a CR or EOL, set the x-position too.") (if (NEQ CHARCODE (CHARCODE LF)) then (\HQFX80.XPOSITION HQFX80STREAM (HQFX80DATA-LEFTMARGIN DATA)) (freplace (STREAM CHARPOSITION) of HQFX80STREAM with 0]) (\HQFX80.NEWPAGE [LAMBDA (HQFX80STREAM) (* ; "Edited 8-Dec-86 15:18 by hdj") (* ;; "end an HQFX80 page") (WITH-HQFX80-DATA (DATA HQFX80STREAM) (\HQFX80.DUMP-PAGE-BUFFER (HQFX80DATA-BACKINGBITMAP DATA) HQFX80STREAM) (* ;; "start a new page") (\HQFX80.STARTPAGE HQFX80STREAM]) (\HQFX80.LINEFEED [LAMBDA (HQFX80STREAM DELTAY) (* hdj " 3-Nov-86 14:58") (* ;; "Sets the linefeed distance for an HQFX80 stream") (WITH-HQFX80-DATA (DATA HQFX80STREAM) (PROG1 (HQFX80DATA-LINEFEED DATA) (AND DELTAY (IF (NUMBERP DELTAY) THEN (CL:SETF (HQFX80DATA-LINEFEED DATA) DELTAY) ELSE (\ILLEGAL.ARG DELTAY]) (\HQFX80.RESET [LAMBDA (HQFX80STREAM) (* hdj " 4-Nov-86 15:35") (* ;; "resets an hqfx80 image stream to a virgin state") (\HQFX80.STARTPAGE HQFX80STREAM]) (\HQFX80.STARTPAGE [LAMBDA (HQFX80STREAM) (* ; "Edited 18-Dec-86 15:25 by hdj") (* ;; "start a new page for an HQFX80 imagestream") (WITH-HQFX80-DATA (DATA HQFX80STREAM) (LET* ((CLIPPINGREGION (HQFX80DATA-CLIPPINGREGION DATA)) (FONT (HQFX80DATA-FONT DATA)) (FONT-ASCENT (FONTASCENT FONT))) (* ;; "first clear the backing bitmap...") (BLTSHADE (HQFX80DATA-TEXTURE DATA) (HQFX80DATA-BACKINGBITMAP DATA) NIL NIL NIL NIL 'REPLACE) (* ;; "... and then reset the current position") (\HQFX80.XPOSITION HQFX80STREAM (HQFX80DATA-LEFTMARGIN DATA)) (\HQFX80.YPOSITION HQFX80STREAM (ADD1 (- (HQFX80DATA-TOPMARGIN DATA) FONT-ASCENT]) ) (DEFMACRO \HQFX80.CUR-POS-VISIBLE? (HQFX80DATA) `(INSIDEP (HQFX80DATA-CLIPPINGREGION ,HQFX80DATA) (HQFX80DATA-XPOS ,HQFX80DATA) (HQFX80DATA-YPOS ,HQFX80DATA))) (* ;; "graphical operations") (DECLARE%: EVAL@COMPILE [PUTDEF '\HQFX80.BRUSHBBT 'RESOURCES '(NEW (CREATE PILOTBBT] ) (DEFINEQ (\HQFX80.BITBLT [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM HQFX80STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (* ; "Edited 1-Jun-87 13:07 by Snow") (* ;;; "BITBLT onto the HQFX80 page") (* ;;; "") (DECLARE (LOCALVARS . T)) (COND ((NEQ 1 (fetch (BITMAP BITMAPBITSPERPIXEL) of SOURCEBITMAP)) (* ;; "going from color bitmap into black and white bitmap.") (ERROR "Cannot BitBLT a color bitmap onto the FX-80 page"))) (WITH-HQFX80-DATA (DATA HQFX80STREAM) (PROG (SOURCE-TO-DEST-X SOURCE-TO-DEST-Y LEFT TOP BOTTOM RIGHT DESTBITMAP) (SETQ DESTBITMAP (HQFX80DATA-BACKINGBITMAP DATA)) [LET ((FXCLIPPINGREGION (HQFX80DATA-CLIPPINGREGION DATA))) (* ;; "compute limits based on clipping regions.") (SETQ LEFT (fetch (REGION LEFT) of FXCLIPPINGREGION)) (SETQ BOTTOM (fetch (REGION BOTTOM) of FXCLIPPINGREGION)) (SETQ RIGHT (fetch (REGION RIGHT) of FXCLIPPINGREGION)) (SETQ TOP (fetch (REGION TOP) of FXCLIPPINGREGION)) (COND (CLIPPINGREGION (* ;; "hard case, two destination clipping regions: do calculations to merge them.") (PROG (CRLEFT CRBOTTOM) [SETQ LEFT (IMAX LEFT (SETQ CRLEFT (fetch (REGION LEFT) of CLIPPINGREGION] [SETQ BOTTOM (IMAX BOTTOM (SETQ CRBOTTOM (fetch (REGION BOTTOM) of CLIPPINGREGION] [SETQ RIGHT (IMIN RIGHT (IPLUS CRLEFT (fetch (REGION WIDTH) of CLIPPINGREGION] (SETQ TOP (IMIN TOP (IPLUS CRBOTTOM (fetch (REGION HEIGHT) of CLIPPINGREGION] (* ;; "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)) (AND WIDTH (SETQ RIGHT (IMIN (IPLUS DESTINATIONLEFT WIDTH) RIGHT)))(* ; "WIDTH is optional") (AND HEIGHT (SETQ TOP (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) TOP))) (* ; "HEIGHT is optional") ) (* ; "Clip and translate coordinates.") (SETQ SOURCE-TO-DEST-X (IDIFFERENCE DESTINATIONLEFT SOURCELEFT)) (SETQ SOURCE-TO-DEST-Y (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 SOURCE-TO-DEST-X) 0)) (* ; "compute bottom margin") (SETQ BOTTOM (IMAX CLIPPEDSOURCEBOTTOM (IDIFFERENCE BOTTOM SOURCE-TO-DEST-Y) 0)) [PROGN (* ; "compute right margin") (SETQ RIGHT (IMIN (ffetch (BITMAP BITMAPWIDTH) of SOURCEBITMAP) (IDIFFERENCE RIGHT SOURCE-TO-DEST-X) (IPLUS CLIPPEDSOURCELEFT WIDTH] (PROGN (* ; "compute top margin") (SETQ TOP (IMIN (ffetch (BITMAP BITMAPHEIGHT) of SOURCEBITMAP) (IDIFFERENCE TOP SOURCE-TO-DEST-Y) (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] (COND ((OR (ILEQ RIGHT LEFT) (ILEQ TOP BOTTOM)) (* ; "there is nothing to move.") (RETURN))) (OR OPERATION (SETQ OPERATION (HQFX80DATA-OPERATION DATA))) (SELECTQ SOURCETYPE (MERGE (* ; "Need to use complement of TEXTURE") [SETQ TEXTURE (COND ((NULL TEXTURE) BLACKSHADE) ((FIXP TEXTURE) (LOGXOR (LOGAND TEXTURE BLACKSHADE) BLACKSHADE)) [(type? BITMAP TEXTURE) (INVERT.TEXTURE.BITMAP TEXTURE (OR \BBSCRATCHTEXTURE (SETQ \BBSCRATCHTEXTURE (BITMAPCREATE 16 16] (T (\ILLEGAL.ARG TEXTURE]) NIL) (UNINTERRUPTABLY [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 SOURCE-TO-DEST-Y))) (DLX (IPLUS LEFT SOURCE-TO-DEST-X)) (STY (\SFInvert SOURCEBITMAP TOP)) (SLX LEFT)) (replace PBTWIDTH of PILOTBBT with WIDTH) (replace PBTHEIGHT of PILOTBBT with HEIGHT) (COND ((EQ SOURCETYPE '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]) (RETURN T]) (\HQFX80.BLTSHADE [LAMBDA (TEXTURE HQFX80STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* ; "Edited 1-Jun-87 13:05 by Snow") (* ;; "BLTSHADE to an HQFX80 imagestream") (DECLARE (LOCALVARS . T)) (WITH-HQFX80-DATA (DATA HQFX80STREAM) (PROG (LEFT TOP BOTTOM RIGHT DESTINATIONBITMAP) (* ;; "compute limits based on clipping regions.") (LET ((FXCLIPPINGREGION (HQFX80DATA-CLIPPINGREGION DATA))) (SETQ LEFT (fetch (REGION LEFT) of FXCLIPPINGREGION)) (SETQ BOTTOM (fetch (REGION BOTTOM) of FXCLIPPINGREGION)) (SETQ RIGHT (fetch (REGION RIGHT) of FXCLIPPINGREGION)) (SETQ TOP (fetch (REGION TOP) of FXCLIPPINGREGION))) [COND (CLIPPINGREGION (* ;; "hard case, two destination clipping regions: do calculations to merge them.") (PROG (CRLEFT CRBOTTOM) [SETQ LEFT (IMAX LEFT (SETQ CRLEFT (fetch (REGION LEFT) of CLIPPINGREGION ] [SETQ BOTTOM (IMAX BOTTOM (SETQ CRBOTTOM (fetch (REGION BOTTOM) of CLIPPINGREGION] [SETQ RIGHT (IMIN RIGHT (IPLUS CRLEFT (fetch (REGION WIDTH) of CLIPPINGREGION] (SETQ TOP (IMIN TOP (IPLUS CRBOTTOM (fetch (REGION HEIGHT) of CLIPPINGREGION] (SETQ DESTINATIONBITMAP (HQFX80DATA-BACKINGBITMAP DATA)) (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") (SETQ LEFT (IMAX DESTINATIONLEFT LEFT)) (SETQ BOTTOM (IMAX DESTINATIONBOTTOM BOTTOM)) (AND WIDTH (SETQ RIGHT (IMIN (IPLUS DESTINATIONLEFT WIDTH) RIGHT))) (* ; "WIDTH is optional") (AND HEIGHT (SETQ TOP (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) TOP))) (* ; "HEIGHT is optional") (COND ((AND (IGREATERP RIGHT LEFT) (IGREATERP TOP BOTTOM))) (T (* ; "there is nothing to move.") (RETURN NIL))) (CL:ETYPECASE TEXTURE [LITATOM (* ; "includes NIL case") (COND ((NULL TEXTURE) (* ;  "default texture to background texture.") (SETQ TEXTURE (HQFX80DATA-TEXTURE DATA))) (T (\ILLEGAL.ARG TEXTURE] (SMALLP (SETQ TEXTURE (LOGAND TEXTURE BLACKSHADE))) (FIXP (SETQ TEXTURE (LOGAND TEXTURE BLACKSHADE))) (BITMAP NIL)) (UNINTERRUPTABLY (LET ([PILOTBBT (IF (type? PILOTBBT \SYSPILOTBBT) THEN \SYSPILOTBBT ELSE (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 'TEXTURE (OR OPERATION (HQFX80DATA-OPERATION DATA)) TEXTURE))) (RETURN T]) (\HQFX80.DRAWELLIPSE [LAMBDA (HQFX80STREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) (* ; "Edited 12-Feb-87 14:37 by jds") (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 HQFX80STREAM) (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. 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.") (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) (GLOBALRESOURCE \HQFX80.BRUSHBBT (PROG (DESTINATION-BITMAP LEFT RIGHTPLUS1 BOTTOM TOP BOTTOMMINUSBRUSH TOPMINUSBRUSH LEFTMINUSBRUSH DESTINATIONBASE BRUSHBASE BRUSHHEIGHT BRUSHWIDTH RASTERWIDTH BRUSHRASTERWIDTH BRUSHBM OPERATION HEIGHTMINUS1 (BBT \HQFX80.BRUSHBBT) (COS-ORIENTATION (COS ORIENTATION)) (SIN-ORIENTATION (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 (USERFN (AND (LITATOM BRUSH) BRUSH))) [COND (USERFN (* ;  "if calling user fn, don't bother with set up") (SETQ CX CENTERX) (SETQ CY CENTERY)) (T (.SETUP.FOR.\HQFX80.BBTCURVEPT. HQFX80DATA) (* ;  "take into account the brush thickness.") (SETQ CX (- CENTERX (FOLDLO BRUSHWIDTH 2))) (SETQ CY (- CENTERY (FOLDLO BRUSHHEIGHT 2] (SETQ A (FPLUS (FTIMES SEMIMAJORRADIUSSQUARED COS-ORIENTATION COS-ORIENTATION) (FTIMES SEMIMINORRADIUSSQUARED SIN-ORIENTATION SIN-ORIENTATION))) (SETQ B (LSH (FIXR (FPLUS (FTIMES SEMIMINORRADIUSSQUARED COS-ORIENTATION COS-ORIENTATION) (FTIMES SEMIMAJORRADIUSSQUARED SIN-ORIENTATION SIN-ORIENTATION))) 3)) (SETQ G (FTIMES COS-ORIENTATION SIN-ORIENTATION (LSH (- SEMIMINORRADIUSSQUARED SEMIMAJORRADIUSSQUARED ) 1))) [SETQ yOffset (FIXR (FQUOTIENT (ITIMES SEMIMINORRADIUS SEMIMAJORRADIUS) (SQRT A] (SETQ CYPlusOffset (+ CY yOffset)) (SETQ CYMinusOffset (- 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 (- k1 G)) (SETQ k3 (- k2 (+ B G))) (SETQ b (+ U (RSH (+ A G) 1))) (SETQ a (IMINUS (+ b V))) (SETQ d (+ 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 (- k1 G)) (SETQ k3 (+ k2 B (IMINUS G))) (SETQ b (+ U (RSH (- G A) 1))) (SETQ a (- V b)) (SETQ d (+ b K (IMINUS (+ (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 (+ k1 G)) (SETQ k3 (+ k2 A G)) [SETQ b (IMINUS (+ V (RSH (+ B G) 1] (SETQ a (- U b)) (SETQ d (+ b K (IMINUS (+ (RSH A 3) (RSH U 1] (T (* ; "start in octant 8") (SETQ y2 -1) (SETQ k1 (IMINUS B)) (SETQ k2 (+ k1 G)) (SETQ k3 (+ k2 G (IMINUS A))) (SETQ b (+ V (RSH (- B G) 1))) (SETQ a (- U b)) (SETQ d (+ b (RSH A 3) (IMINUS (+ 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 (+ x x1)) (SETQ y (+ y y1)) (SETQ b (- b k1)) (SETQ a (+ a k2)) (SETQ d (+ b d))) (T (* ; "move 2") (SETQ x (+ x x2)) (SETQ y (+ y y2)) (SETQ b (- b k2)) (SETQ a (+ a k3)) (SETQ d (- d a] (COND ((MINUSP x) (MOVETO CENTERX CENTERY HQFX80STREAM) (RETURN NIL))) [COND (USERFN (APPLY* USERFN (+ CX x) (+ CYPlusOffset y) HQFX80STREAM) (APPLY* USERFN (- CX x) (- CYMinusOffset y) HQFX80STREAM)) (T (\HQFX80.CURVEPT (+ CX x) (+ CYPlusOffset y)) (\HQFX80.CURVEPT (- CX x) (- CYMinusOffset y] (AND (MINUSP b) (GO SQUARE)) DIAGONAL (OR (MINUSP a) (GO MOVE)) (* ; "diagonal octant change") (SETQ x1 (- x2 x1)) (SETQ y1 (- y2 y1)) (SETQ w (- (LSH k2 1) k3)) (SETQ k1 (- w k1)) (SETQ k2 (- k2 k3)) (SETQ k3 (IMINUS k3)) [SETQ b (+ b a (IMINUS (RSH (ADD1 k2) 1] [SETQ d (+ b (RSH (+ k3 4) 3) (IMINUS d) (IMINUS (RSH (ADD1 a) 1] (SETQ a (- (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 (- k2 k1)) (SETQ k1 (IMINUS k1)) (SETQ k2 (+ w k1)) (SETQ k3 (- (LSH w 2) k3)) (SETQ b (- (IMINUS b) w)) (SETQ d (- (- b a) d)) (SETQ a (- (- a w) (LSH b 1))) (GO DIAGONAL]) (\HQFX80.OPERATION [LAMBDA (HQFX80STREAM OPERATION) (* hdj " 4-Nov-86 17:25") (* ;; "sets the operation field of an hqfx80 stream") (WITH-HQFX80-DATA (DATA HQFX80STREAM) (PROG1 (HQFX80DATA-OPERATION DATA) (AND OPERATION (OR (FMEMB OPERATION '(PAINT REPLACE INVERT ERASE)) (\ILLEGAL.ARG OPERATION)) (UNINTERRUPTABLY (CL:SETF (HQFX80DATA-OPERATION DATA) OPERATION) (* ;  "update other fields that depend on operation.") (\SETPBTFUNCTION (HQFX80DATA-PILOTBBT DATA) (HQFX80DATA-SOURCETYPE DATA) OPERATION))]) (\HQFX80.DRAWPOINT [LAMBDA (HQFX80STREAM X Y BRUSH OPERATION) (* hdj "19-Nov-86 15:21") (* ;; "draws a brush point at position X Y on an HQFX80STREAM") (LET ((BRUSHBM (\GETBRUSH BRUSH))) (* ;  "SUB1 is to put extra bit of even brush on the top or left.") (BITBLT BRUSHBM 0 0 HQFX80STREAM [IDIFFERENCE X (HALF (SUB1 (BITMAPWIDTH BRUSHBM] [IDIFFERENCE Y (HALF (SUB1 (BITMAPHEIGHT BRUSHBM] NIL NIL NIL OPERATION]) ) (DEFINEQ (\HQFX80.DRAWLINE [LAMBDA (HQFX80STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) (* ; "Edited 5-Jan-87 18:10 by hdj") (* ;;  "Draws a line from (x1,y1) to (x2,y2) on an hqfx80 imagestream, leaving the position at (x2,y2).") (WITH-HQFX80-DATA (DATA HQFX80STREAM) (LET ((CLIPPINGREGION (HQFX80DATA-CLIPPINGREGION DATA))) (* ;; "draw the line ...") (if DASHING then (GLOBALRESOURCE \HQFX80.BRUSHBBT (LET ((BBT \HQFX80.BRUSHBBT) (BRUSH (LIST 'ROUND WIDTH COLOR))) (\HQFX80.LINEWITHBRUSH (OR (FIXP X1) (FIXR X1)) (OR (FIXP Y1) (FIXR Y1)) (OR (FIXP X2) (FIXR X2)) (OR (FIXP Y2) (FIXR Y2)) BRUSH (\GOOD.DASHLST DASHING BRUSH) HQFX80STREAM BBT))) else (\HQFX80.CLIP-AND-DRAW-LINE (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 (HQFX80DATA-OPERATION DATA)) ((REPLACE PAINT INVERT ERASE) OPERATION) (\ILLEGAL.ARG OPERATION)) (HQFX80DATA-BACKINGBITMAP DATA) (ffetch (REGION LEFT) of CLIPPINGREGION) (SUB1 (ffetch (REGION RIGHT) of CLIPPINGREGION)) (ffetch (REGION BOTTOM) of CLIPPINGREGION) (SUB1 (ffetch (REGION TOP) of CLIPPINGREGION)) HQFX80STREAM)) (* ;; "... then move to (x2,y2)") (\HQFX80.XPOSITION HQFX80STREAM X2) (\HQFX80.YPOSITION HQFX80STREAM Y2]) (\HQFX80.CLIP-AND-DRAW-LINE [LAMBDA (X1 Y1 X2 Y2 WIDTH OPERATION BITMAP LEFT RIGHT BOTTOM TOP HQFX80STREAM) (* ; "Edited 5-Jan-87 17:59 by hdj") (* ;; "draws a line from (X1,Y1) to (X2,Y2) clipped to region specified by LEFT RIGHT BOTTOM and TOP. This code is a transliterated version of the BCPL routine that was in chat.") (* ;; "") (* ;; "assumes that the width is at least 1") (PROG NIL (COND [(EQP X1 X2) (* ; "special case of vertical line.") [COND ((IGREATERP WIDTH 2) (COND ((EQP Y1 Y2) (* ;; "special case. Since we don't know whether the guy is headed horizontally or vertically, put out a round brush.") (RETURN (\HQFX80.DRAWPOINT HQFX80STREAM X1 Y1 (LIST 'ROUND WIDTH) OPERATION))) (T (SETQ X1 (SETQ X2 (IDIFFERENCE X1 (LRSH (SUB1 WIDTH) 1] (PROG (MIN MAX) (RETURN (COND ([OR (IGREATERP X1 RIGHT) (IGEQ LEFT (SETQ X2 (IPLUS X1 WIDTH))) (IGREATERP (SETQ MIN (IMIN Y1 Y2)) TOP) (IGREATERP BOTTOM (SETQ MAX (IMAX Y1 Y2] (* ; "outside clippingregion.") NIL) (T (BLTSHADE BLACKSHADE BITMAP (SETQ X1 (IMAX X1 LEFT)) (SETQ MIN (IMAX MIN BOTTOM)) (IDIFFERENCE (IMIN X2 (ADD1 RIGHT)) X1) (ADD1 (IDIFFERENCE (IMIN MAX TOP) MIN)) OPERATION] [(EQP Y1 Y2) (* ; "special case of horizontal line.") [COND ((IGREATERP WIDTH 2) (SETQ Y1 (SETQ Y2 (IDIFFERENCE Y1 (LRSH (SUB1 WIDTH) 1] (PROG (MIN MAX) (RETURN (COND ([OR (IGREATERP Y1 TOP) (IGEQ BOTTOM (SETQ Y2 (IPLUS Y1 WIDTH))) (IGREATERP (SETQ MIN (IMIN X1 X2)) RIGHT) (IGREATERP LEFT (SETQ MAX (IMAX X1 X2] (* ; "outside clippingregion.") NIL) (T (BLTSHADE BLACKSHADE BITMAP (SETQ MIN (IMAX MIN LEFT)) (SETQ Y1 (IMAX Y1 BOTTOM)) (ADD1 (IDIFFERENCE (IMIN MAX RIGHT) MIN)) (IDIFFERENCE (IMIN Y2 (ADD1 TOP)) Y1) OPERATION] ((EQP WIDTH 1) (* ; "special case of width 1") (\HQFX80.CLIP-AND-DRAW-LINE1 X1 Y1 X2 Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP HQFX80STREAM)) ((IGREATERP (IABS (IDIFFERENCE X1 X2)) (IABS (IDIFFERENCE Y1 Y2))) (* ;  "slope is more horizontal, so make line grow in the positive y direction.") [COND ((IGREATERP WIDTH 2) (PROG (HALFWIDTH) (SETQ HALFWIDTH (LRSH (SUB1 WIDTH) 1)) (SETQ Y1 (IDIFFERENCE Y1 HALFWIDTH)) (SETQ Y2 (IDIFFERENCE Y2 HALFWIDTH] (for I from Y1 to (SUB1 (IPLUS Y1 WIDTH)) as J from Y2 do (\HQFX80.CLIP-AND-DRAW-LINE1 X1 I X2 J OPERATION BITMAP LEFT RIGHT BOTTOM TOP))) (T (* ;  "slope is more vertical, so make line grow in the positive x direction.") [COND ((IGREATERP WIDTH 2) (PROG (HALFWIDTH) (SETQ HALFWIDTH (LRSH (SUB1 WIDTH) 1)) (SETQ X1 (IDIFFERENCE X1 HALFWIDTH)) (SETQ X2 (IDIFFERENCE X2 HALFWIDTH] (for I from X1 to (SUB1 (IPLUS X1 WIDTH)) as J from X2 do (\HQFX80.CLIP-AND-DRAW-LINE1 I Y1 J Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP]) (\HQFX80.CLIP-AND-DRAW-LINE1 [LAMBDA (X1 Y1 X2 Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP) (* hdj " 6-Nov-86 14:30") (* ;; "LEFT, RIGHT, BOTTOM, TOP are set to the boundaries of the clipping region") (PROG (DX DY YMOVEUP HALFDX HALFDY (BMRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP))) (COND ((IGREATERP X1 X2) (* ;  "switch points so DX is always positive.") (SETQ HALFDX X1) (SETQ X1 X2) (SETQ X2 HALFDX) (SETQ HALFDX Y1) (SETQ Y1 Y2) (SETQ Y2 HALFDX))) (* ;  "calculate differences and sign of Y movement.") (SETQ HALFDX (LRSH (SETQ DX (IDIFFERENCE X2 X1)) 1)) (SETQ HALFDY (LRSH [SETQ DY (COND ((IGREATERP Y2 Y1) (SETQ YMOVEUP T) (IDIFFERENCE Y2 Y1)) (T (IDIFFERENCE Y1 Y2] 1)) (COND ((AND (IGEQ X1 LEFT) (IGEQ RIGHT X2) [COND (YMOVEUP (AND (IGEQ Y1 BOTTOM) (IGEQ TOP Y2))) (T (AND (IGEQ Y2 BOTTOM) (IGEQ TOP Y1] (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP) 1)) (* ;  "line is completely visible, fast case.") (\DRAWLINE1 X1 (SUB1 (\SFInvert BITMAP Y1)) DX DY DX DY (COND ((IGREATERP DX DY) (* ; "X is the fastest mover.") HALFDX) (T (* ; "y is the fastest mover.") HALFDY)) (COND (YMOVEUP (* ;  "y is moving in positive direction but bits are stored inversely") (IMINUS BMRASTERWIDTH)) (T BMRASTERWIDTH)) OPERATION (fetch BITMAPBASE of BITMAP) BMRASTERWIDTH)) (T (PROG ((CX1 X1) (CY1 Y1) (CX2 X2) (CY2 Y2) (CA1 (\CLIPCODE X1 Y1 LEFT RIGHT TOP BOTTOM)) (CA2 (\CLIPCODE X2 Y2 LEFT RIGHT TOP BOTTOM))) (* ;  "save the original points for the clipping computation.") (* ;  "determine the sectors in which the points fall.") CLIPLP [COND ((NOT (EQ 0 (LOGAND CA1 CA2))) (* ;  "line is entirely out of clipping region") (RETURN NIL)) ((EQ 0 (IPLUS CA1 CA2)) (* ; "line is completely visible") (* ;; "\SFInvert has an off by one bug that everybody else in LLDISPLAY uses to save computation so SUB1 from what you would expect.") (* ; "reuse the variable CA1") (RETURN (\DRAWLINE1 CX1 (SUB1 (\SFInvert BITMAP CY1)) (IDIFFERENCE CX2 CX1) (COND (YMOVEUP (IDIFFERENCE CY2 CY1)) (T (IDIFFERENCE CY1 CY2))) DX DY (COND ((IGREATERP DX DY) (* ; "X is the fastest mover.") (IREMAINDER (IPLUS (ITIMES DY (IDIFFERENCE CX1 X1)) HALFDX) DX)) (T (* ; "y is the fastest mover.") (IREMAINDER (IPLUS [ITIMES DX (COND (YMOVEUP (IDIFFERENCE CY1 Y1)) (T (IDIFFERENCE Y1 CY1] HALFDY) DY))) (COND (YMOVEUP (* ;  "y is moving in positive direction but bits are stored inversely") (IMINUS BMRASTERWIDTH)) (T BMRASTERWIDTH)) OPERATION (fetch BITMAPBASE of BITMAP) BMRASTERWIDTH] [COND ((NEQ CA1 0) (* ;; "now move point CX1 CY1 so that one of the coordinates is on one of the boundaries. Which boundary is done first was copied from BCPL.") (COND ((IGREATERP CA1 7) (* ; "y1 less than bottom") (* ;  "calculate the least X for which Y will be at bottom.") [SETQ CX1 (IPLUS X1 (\LEASTPTAT DX DY (IDIFFERENCE BOTTOM Y1] (SETQ CY1 BOTTOM)) ((IGREATERP CA1 3) (* ; "y1 is greater than top") [SETQ CX1 (IPLUS X1 (\LEASTPTAT DX DY (IDIFFERENCE Y1 TOP] (SETQ CY1 TOP)) (T (* ; "x1 is less than left") [SETQ CY1 (COND [YMOVEUP (IPLUS Y1 (\LEASTPTAT DY DX (IDIFFERENCE LEFT X1] (T (IDIFFERENCE Y1 (\LEASTPTAT DY DX (IDIFFERENCE LEFT X1] (SETQ CX1 LEFT))) (SETQ CA1 (\CLIPCODE CX1 CY1 LEFT RIGHT TOP BOTTOM))) (T (* ;  "now move point CX2 CY2 so that one of the coordinates is on one of the boundaries") (COND ((IGREATERP CA2 7) (* ; "y2 less than bottom") [SETQ CX2 (IPLUS X1 (\GREATESTPTAT DX DY (IDIFFERENCE Y1 BOTTOM] (SETQ CY2 BOTTOM)) ((IGREATERP CA2 3) (* ; "y2 is greater than top") [SETQ CX2 (IPLUS X1 (\GREATESTPTAT DX DY (IDIFFERENCE TOP Y1] (SETQ CY2 TOP)) (T (* ; "x2 is greater than right") [SETQ CY2 (COND [YMOVEUP (IPLUS Y1 (\GREATESTPTAT DY DX (IDIFFERENCE RIGHT X1] (T (IDIFFERENCE Y1 (\GREATESTPTAT DY DX (IDIFFERENCE RIGHT X1] (SETQ CX2 RIGHT))) (SETQ CA2 (\CLIPCODE CX2 CY2 LEFT RIGHT TOP BOTTOM] (GO CLIPLP]) ) (DEFINEQ (\HQFX80.DRAWCIRCLE [LAMBDA (HQFX80STREAM CENTERX CENTERY RADIUS BRUSH DASHING)(* hdj "21-Nov-86 17:11") (* ;; "draw a circle on a hqfx80 stream") (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 \HQFX80.BRUSHBBT (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) (PROG ((X 0) (Y RADIUS) (D (ITIMES 2 (- 1 RADIUS))) LEFT RIGHTPLUS1 TOP BOTTOM DESTINATION-BITMAP BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH OPERATION HEIGHTMINUS1 CX CY (BBT \HQFX80.BRUSHBBT) (USERFN (AND (LITATOM BRUSH) BRUSH))) (* ;; "many of these variables are used by the macro for \HQFX80.CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\HQFX80.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.\HQFX80.BBTCURVEPT. HQFX80DATA) (SETQ CX (- CENTERX (FOLDLO BRUSHWIDTH 2))) (* ;  "take into account the brush thickness.") (SETQ CY (- CENTERY (FOLDLO BRUSHHEIGHT 2] [COND ((EQ RADIUS 1) (* ; "put a single brush down.") (* ;  "draw the top and bottom most points.") (COND (USERFN (APPLY* USERFN CX CY HQFX80STREAM)) (T (\HQFX80.CURVEPT CX CY))) (RETURN)) (T (* ;  "draw the top and bottom most points.") (COND (USERFN (APPLY* USERFN CX (+ CY RADIUS) HQFX80STREAM) (APPLY* USERFN CX (- CY RADIUS) HQFX80STREAM)) (T (\HQFX80.CURVEPT CX (+ CY RADIUS)) (\HQFX80.CURVEPT CX (- CY RADIUS] LP (* ;  "(UNFOLD x 2) is used instead of (ITIMES x 2)") [COND [(IGREATERP 0 D) (SETQ X (ADD1 X)) (COND ((IGREATERP (UNFOLD (+ D Y) 2) 1) (SETQ D (+ D (UNFOLD (- X Y) 2) 4)) (SETQ Y (SUB1 Y))) (T (SETQ D (+ D (UNFOLD X 2) 1] ((OR (EQ 0 D) (IGREATERP X D)) (SETQ X (ADD1 X)) (SETQ D (+ D (UNFOLD (- X Y) 2) 4)) (SETQ Y (SUB1 Y))) (T (SETQ D (+ (- 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 (+ CX X) CY HQFX80STREAM) (APPLY* USERFN (- CX X) CY HQFX80STREAM)) (T (\HQFX80.CURVEPT (+ CX X) CY) (\HQFX80.CURVEPT (- CX X) CY] (T (COND (USERFN (APPLY* USERFN (+ CX X) (+ CY Y) HQFX80STREAM) (APPLY* USERFN (- CX X) (+ CY Y) HQFX80STREAM) (APPLY* USERFN (+ CX X) (- CY Y) HQFX80STREAM) (APPLY* USERFN (- CX X) (- CY Y) HQFX80STREAM)) (T (\HQFX80.DRAW-4-CIRCLE-POINTS CX CY X Y))) (GO LP))) (MOVETO CENTERX CENTERY HQFX80STREAM) (RETURN NIL]) (\HQFX80.CREATE-BRUSH-BBT [LAMBDA (BRUSHBM HQFX80DATA BITBLT-TABLE) (* hdj "18-Nov-86 17:33") (* ;; "Initializes BITBLT-TABLE for the BRUSHBM and an HQFX80 stream and returns BITBLT-TABLE, unless the BRUSHBM is a 1-point brush, in which case it returns NIL.") (COND ((AND (EQ (fetch (BITMAP BITMAPHEIGHT) of BRUSHBM) 1) (EQ (fetch (BITMAP BITMAPWIDTH) of BRUSHBM) 1) (EQ (BITMAPBIT BRUSHBM 0 0) 1)) (* ;  "special case of single point brush shape.") NIL) (T (* ;  "update as many fields in the brush bitblt table as possible from HQFX80DATA.") (replace (PILOTBBT PBTDESTBPL) of BITBLT-TABLE with (UNFOLD (fetch (BITMAP BITMAPRASTERWIDTH ) of (HQFX80DATA-BACKINGBITMAP HQFX80DATA)) BITSPERWORD)) (replace (PILOTBBT PBTSOURCEBPL) of BITBLT-TABLE with (UNFOLD (fetch (BITMAP BITMAPRASTERWIDTH ) of BRUSHBM) BITSPERWORD)) (replace (PILOTBBT PBTFLAGS) of BITBLT-TABLE with 0) (replace (PILOTBBT PBTDISJOINT) of BITBLT-TABLE with T) (\SETPBTFUNCTION BITBLT-TABLE (HQFX80DATA-SOURCETYPE HQFX80DATA) (SELECTQ (HQFX80DATA-OPERATION HQFX80DATA) ((PAINT REPLACE) 'PAINT) ((INVERT ERASE) 'ERASE) (SHOULDNT))) BITBLT-TABLE]) ) (DEFMACRO \HQFX80.DRAW-4-CIRCLE-POINTS (CENTER-X CENTER-Y EDGE-X EDGE-Y) (* ;; "draw four points 90 degress apart on the circumference of a circle") `[PROGN (\HQFX80.CURVEPT (+ ,CENTER-X ,EDGE-X) (+ ,CENTER-Y ,EDGE-Y)) (\HQFX80.CURVEPT (- ,CENTER-X ,EDGE-X) (+ ,CENTER-Y ,EDGE-Y)) (\HQFX80.CURVEPT (+ ,CENTER-X ,EDGE-X) (- ,CENTER-Y ,EDGE-Y)) (\HQFX80.CURVEPT (- ,CENTER-X ,EDGE-X) (- ,CENTER-Y ,EDGE-Y]) (DEFINEQ (\HQFX80.FILLCIRCLE [LAMBDA (HQFX80STREAM CENTERX CENTERY RADIUS TEXTURE) (* hdj " 6-Nov-86 15:45") (COND ((OR (NOT (NUMBERP RADIUS)) (ILESSP (SETQ RADIUS (FIXR RADIUS)) 0)) (\ILLEGAL.ARG RADIUS)) (T (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) (GLOBALRESOURCE \HQFX80.BRUSHBBT (LET* [(CLIPPINGREGION (HQFX80DATA-CLIPPINGREGION HQFX80DATA)) (TOP (SUB1 (fetch (REGION TOP) of CLIPPINGREGION))) (BOTTOM (fetch (REGION BOTTOM) of CLIPPINGREGION)) (LEFT (fetch (REGION LEFT) of CLIPPINGREGION)) (RIGHT (SUB1 (fetch (REGION RIGHT) of HQFX80DATA] (PROG (TOP BOTTOM RIGHT LEFT OPERATION DESTINATION-BITMAP (X 0) (Y RADIUS) (D (ITIMES 2 (- 1 RADIUS))) DESTINATIONBASE RASTERWIDTH CX CY TEXTUREBM GRAYHEIGHT GRAYWIDTH GRAYBASE (FCBBT \HQFX80.BRUSHBBT)) (SETQ OPERATION (HQFX80DATA-OPERATION HQFX80DATA)) (SETQ DESTINATION-BITMAP (HQFX80DATA-BACKINGBITMAP HQFX80DATA)) [SETQ TEXTUREBM (COND ((BITMAPP TEXTURE)) [(AND (NULL TEXTURE) (BITMAPP (HQFX80DATA-TEXTURE HQFX80DATA] ([OR (FIXP TEXTURE) (AND (NULL TEXTURE) (SETQ TEXTURE (HQFX80DATA-TEXTURE HQFX80DATA] (* ;  "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 (BITMAP BITMAPBASE) of DESTINATION-BITMAP )) (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of DESTINATION-BITMAP )) (* ;; "update as many fields in the brush bitblt table as possible from the stream.") (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 'TEXTURE OPERATION) (replace PBTHEIGHT of FCBBT with 1) (* ;  "take into account the brush thickness.") (SETQ CX (\DSPTRANSFORMX CENTERX HQFX80DATA)) (SETQ CY (\DSPTRANSFORMY CENTERY HQFX80DATA)) (* ;  "change Y TOP and BOTTOM to be in bitmap coordinates") (SETQ CY (\SFInvert DESTINATION-BITMAP CY)) [SETQ BOTTOM (PROG1 (SUB1 (\SFInvert DESTINATION-BITMAP TOP)) (SETQ TOP (SUB1 (\SFInvert DESTINATION-BITMAP 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 1) (RETURN))) LOOP (* ;  "(UNFOLD x 2) is used instead of (ITIMES x 2)") [COND [(IGREATERP 0 D) (SETQ X (ADD1 X)) (COND ((IGREATERP (UNFOLD (+ D Y) 2) 1) (SETQ D (+ D (UNFOLD (- X Y) 2) 4))) (T (SETQ D (+ D (UNFOLD X 2) 1)) (* ; "don't draw unless Y changes.") (GO LOOP] ((OR (EQ 0 D) (IGREATERP X D)) (SETQ X (ADD1 X)) (SETQ D (+ D (UNFOLD (- X Y) 2) 4))) (T (SETQ D (+ (- D (UNFOLD Y 2)) 3] (COND ((EQ Y 0) (* ;  "draw the middle line differently to avoid duplication.") (\LINEBLT FCBBT (- CX X) CY (+ CX X) DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE 1)) (T (\HQFX80.FILL-CIRCLE-BLT CX CY X Y) (SETQ Y (SUB1 Y)) (GO LOOP))) (MOVETO CENTERX CENTERY HQFX80STREAM) (RETURN NIL]) (\HQFX80.DRAWARC [LAMBDA (HQFX80STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) (* hdj "20-Nov-86 14:27") (* ;; "draws an arc on an hqfx80stream") (\DRAWARC.GENERIC HQFX80STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING]) ) (DEFMACRO \HQFX80.FILL-CIRCLE-BLT (CENTER-X CENTER-Y X Y) (* ;; "calls bitblt twice to fill in one line of the circle.") `(PROGN (\LINEBLT FCBBT (- ,CENTER-X ,X) (+ ,CENTER-Y ,Y) (+ ,CENTER-X ,X) DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE 1) (\LINEBLT FCBBT (- ,CENTER-X ,X) (- ,CENTER-Y ,Y) (+ ,CENTER-X ,X) DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE 1))) (* ;; "curve-drawing") (DEFINEQ (\HQFX80.DRAWCURVE [LAMBDA (HQFX80STREAM KNOTS CLOSED BRUSH DASHING) (* hdj "19-Nov-86 14:42") (* ;; "draws a spline curve with a given brush on HQFX80STREAM") (GLOBALRESOURCE \HQFX80.BRUSHBBT (LET ([DASHLST (AND DASHING (OR (AND (LISTP DASHING) (EVERY DASHING (FUNCTION FIXP)) DASHING) (\ILLEGAL.ARG DASHING] (BBT \HQFX80.BRUSHBBT)) (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 HQFX80STREAM)) (2 (OR (type? POSITION (CAR KNOTS)) (ERROR "bad knot" (CAR KNOTS))) (OR (type? POSITION (CADR KNOTS)) (ERROR "bad knot" (CADR KNOTS))) (\HQFX80.LINEWITHBRUSH (fetch XCOORD of (CAR KNOTS)) (fetch YCOORD of (CAR KNOTS)) (fetch XCOORD of (CADR KNOTS)) (fetch YCOORD of (CADR KNOTS)) BRUSH DASHLST HQFX80STREAM BBT)) (\HQFX80.DRAWCURVE2 (PARAMETRICSPLINE KNOTS CLOSED) BRUSH DASHLST BBT HQFX80STREAM)) HQFX80STREAM]) (\HQFX80.DRAWCURVE2 [LAMBDA (SPLINE BRUSH DASHLST BBT HQFX80STREAM) (* hdj "19-Nov-86 11:58") (* ;;; "Given a spline curve, represented as a set of derivatives for each segment, draw it on HQFX80STREAM using the brush BRUSH, and dashing it according to DASHLST. For speed, use the bitblt table BBT.") (DECLARE (SPECVARS . T)) (* ;; "Should declare most of these variables local but currently have the \CURVE function between here and \CURVEBBT so can't") (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) (PROG (BRUSHBM DESTINATION-BITMAP OPERATION BRUSHWIDTH BRUSHHEIGHT BRUSHBASE BRUSHRASTERWIDTH LEFT RIGHTPLUS1 TOP BOTTOM DESTINATIONBASE LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH RASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 \CURX \CURY \OLDX \OLDY \OLDERX \OLDERY LKNOT (DASHON T) (DASHTAIL DASHLST) (DASHCNT (CAR DASHLST)) NPOINTS NSEGS POINTSPERSEG DX D2X D3X DY D2Y D3Y D1 D2 D3 X0 Y0 X1 Y1 DX DDX DDDX DY DDY DDDY (XPOLY (create POLYNOMIAL)) (X/PRIME/POLY (create POLYNOMIAL)) (YPOLY (create POLYNOMIAL)) (Y/PRIME/POLY (create POLYNOMIAL)) (USERFN (AND (LITATOM BRUSH) BRUSH))) (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\HQFX80.BBTCURVEPT. sets them up.") [COND (USERFN (* ;  "if calling user fn, don't bother with set up and leave points in window coordinates.") (\CURVESTART (ELT (fetch (SPLINE SPLINEX) of SPLINE) 1) (ELT (fetch (SPLINE SPLINEY) of SPLINE) 1))) (T (.SETUP.FOR.\HQFX80.BBTCURVEPT. HQFX80DATA) (* ;  "curve pts will be kept in screen coordinates, start smoothing values there.") (\CURVESTART (IDIFFERENCE (ELT (fetch (SPLINE SPLINEX) of SPLINE) 1) (LRSH (SUB1 BRUSHWIDTH) 1)) (IDIFFERENCE (ELT (fetch (SPLINE SPLINEY) of SPLINE) 1) (LRSH (SUB1 BRUSHHEIGHT) 1] [bind PERSEG for KNOT from 1 to (SUB1 (fetch %#KNOTS of SPLINE)) when (PROGN (* ;;; "Loop thru the segments of the spline curve, drawing each in turn.") (SETQ X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE) KNOT)) (* ;  "Set up X0,Y0 -- the starting point of this segment") (SETQ Y0 (ELT (fetch (SPLINE SPLINEY) of SPLINE) KNOT)) (SETQ X1 (ELT (fetch (SPLINE SPLINEX) of SPLINE) (ADD1 KNOT))) (* ; "And X1,Y1 -- the ending point") (SETQ Y1 (ELT (fetch (SPLINE SPLINEY) of SPLINE) (ADD1 KNOT))) (SETQ DX (ELT (fetch (SPLINE SPLINEDX) of SPLINE) KNOT)) (* ;  "And the initial derivatives -- first") (SETQ DY (ELT (fetch (SPLINE SPLINEDY) of SPLINE) KNOT)) (SETQ DDX (ELT (fetch SPLINEDDX of SPLINE) KNOT)) (* ; "Second") (SETQ DDY (ELT (fetch SPLINEDDY of SPLINE) KNOT)) (SETQ DDDX (ELT (fetch SPLINEDDDX of SPLINE) KNOT)) (* ; "And third.") (SETQ DDDY (ELT (fetch SPLINEDDDY of SPLINE) KNOT)) (SETQ NPOINTS (FOLDLO (ITIMES (IMAX (IABS (IDIFFERENCE X1 X0)) (IABS (IDIFFERENCE Y1 Y0))) 3) 2)) (* ;; "Establish an upper bound on the number of points we'll draw while painting this segment. We know that 3/2 the maximum DX or DY is the right amount.") (NOT (ZEROP NPOINTS))) do (* ;; "NPOINTS can be zero if a knot is duplicated in the spline curve to produce a discontinuity. Skip over zero-length segments to avoid divide-by-zero trouble") (* ;; "To prevent round-off errors from accumulating, we'll draw this segment as runs of no more than 64 points each -- recomputing completely at the start of each run. This is a trade off of speed and accuracy.") [COND ((ILEQ NPOINTS 64) (* ;  "Fewer than 64 points to draw. Do it in one run.") (SETQ NSEGS 1) (SETQ POINTSPERSEG NPOINTS)) (T (* ;  "Figure out how many runs to do it in.") (SETQ NSEGS (FOLDLO NPOINTS 64)) (SETQ POINTSPERSEG 64) (SETQ NPOINTS (UNFOLD NSEGS 64] (SETQ D1 (FQUOTIENT 1.0 NPOINTS)) (* ;  "Set up ÿ&Eÿt, ÿ&Eÿt**2 and ÿ&Eÿt**3, for computing the next point.") (SETQ D2 (FTIMES D1 D1)) (SETQ D3 (FTIMES D2 D1)) (SETQ D3X (FTIMES D3 DDDX)) (SETQ D3Y (FTIMES D3 DDDY)) (COND [(EQ NSEGS 1) (* ; "Just one segment to draw.") [SETQ DX (FPLUS (FTIMES D1 DX) (FTIMES DDX D2 0.5) (FTIMES DDDX D3 (CONSTANT (FQUOTIENT 1.0 6.0] (SETQ D2X (FPLUS (FTIMES D2 DDX) (FTIMES D3 DDDX))) [SETQ DY (FPLUS (FTIMES D1 DY) (FTIMES D2 DDY 0.5) (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] (SETQ D2Y (FPLUS (FTIMES D2 DDY) (FTIMES D3 DDDY))) (COND (USERFN (* ;  "Draw this run of points, using the user's supplied function.") (\HQFX80.DRAWCURVE3 X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM HQFX80DATA BBT NIL USERFN HQFX80STREAM)) (T (* ;  "Draw this run of points, using the brush.") (\HQFX80.DRAWCURVE3 X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM HQFX80DATA BBT NIL NIL HQFX80STREAM] (T (* ;  "Have to do this segment in several runs.") (SETQ PERSEG (FQUOTIENT 1.0 NSEGS)) (LOADPOLY XPOLY X/PRIME/POLY DDDX DDX DX X0) (LOADPOLY YPOLY Y/PRIME/POLY DDDY DDY DY Y0) (bind (TT _ 0.0) (DDDX/PER/SEG _ (FTIMES DDDX PERSEG)) (DDDY/PER/SEG _ (FTIMES DDDY PERSEG)) [D3XFACTOR _ (FTIMES D3 DDDX (CONSTANT (FQUOTIENT 1.0 6.0] [D3YFACTOR _ (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] for I from 0 to (SUB1 NSEGS) do (* ;;; "TT is the parameter, and runs from 0 to 1 as the curve segment runs from beginning to end.") (SETQ TT (FPLUS TT PERSEG)) (SETQ X1 (POLYEVAL TT XPOLY 3)) (SETQ Y1 (POLYEVAL TT YPOLY 3)) (SETQ DX (FPLUS (FTIMES D1 DX) (FTIMES D2 DDX 0.5) D3XFACTOR)) (SETQ D2X (FPLUS (FTIMES D2 DDX) (FTIMES D3 DDDX))) (SETQ DY (FPLUS (FTIMES D1 DY) (FTIMES D2 DDY 0.5) D3YFACTOR)) (SETQ D2Y (FPLUS (FTIMES D2 DDY) (FTIMES D3 DDDY))) (COND (USERFN (\HQFX80.DRAWCURVE3 X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM HQFX80DATA BBT NIL USERFN HQFX80STREAM)) (T (\HQFX80.DRAWCURVE3 X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM HQFX80DATA BBT NIL NIL HQFX80STREAM))) (SETQ X0 X1) (SETQ Y0 Y1) (SETQ DDX (FPLUS DDX DDDX/PER/SEG)) (SETQ DDY (FPLUS DDY DDDY/PER/SEG)) (SETQ DX (POLYEVAL TT X/PRIME/POLY 2)) (SETQ DY (POLYEVAL TT Y/PRIME/POLY 2] (* ;;; "Draw the final point on the curve.") (COND (USERFN (\HQFX80.DRAWCURVE3 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM HQFX80DATA BBT T USERFN HQFX80STREAM)) (T (\HQFX80.DRAWCURVE3 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM HQFX80DATA BBT T NIL HQFX80STREAM]) (\HQFX80.DRAWCURVE3 [LAMBDA (X0 Y0 X1 Y1 DX DY DDX DDY DDDX DDDY N BRUSHBM HQFX80DATA BBT ENDING USERFN HQFX80STREAM) (* hdj "19-Nov-86 12:18") (DECLARE (LOCALVARS . T) (USEDFREE BRUSHWIDTH BRUSHHEIGHT \CURX \OLDX \CURY \OLDY)) (* ;; "Puts a spline segment down. Since it calls BitBlt directly, it must clip to both clipping region and the size of the destination bit map.") (PROG (OLDX X Y OLDY DELTAX DELTAY DELTA TX TY OOLDX OOLDY) [COND ((NEQ N 0) [COND (USERFN (* ;  "if there is a user fn, stay in his coordinates.") (SETQ OLDX X0) (SETQ OLDY Y0)) (T (* ;; "SUB1 on brush size is to cause the extra bit to be in the top left direction as is documented for lines.") (SETQ OLDX (IDIFFERENCE X0 (LRSH (SUB1 BRUSHWIDTH) 1))) (SETQ OLDY (IDIFFERENCE Y0 (LRSH (SUB1 BRUSHHEIGHT) 1] (* ; "draw origin point") (\HQFX80.SMOOTH-CURVE OLDX OLDY USERFN HQFX80STREAM) (* ;  "convert the derivatives to fractional representation.") (* ; "\CONVERTTOFRACTION always returns a large number box. This uses .49 because .5 causes rounding up.") (SETQ X (\CONVERTTOFRACTION (FPLUS OLDX 0.49))) (SETQ Y (\CONVERTTOFRACTION (FPLUS OLDY 0.49))) (SETQ DX (\CONVERTTOFRACTION DX)) (SETQ DY (\CONVERTTOFRACTION DY)) (SETQ DDX (\CONVERTTOFRACTION DDX)) (SETQ DDY (\CONVERTTOFRACTION DDY)) (SETQ DDDX (\CONVERTTOFRACTION DDDX)) (SETQ DDDY (\CONVERTTOFRACTION DDDY)) [for I from 1 to N do (* ;  "uses \BOXIPLUS to save box and also set the new value of the variable.") (\BOXIPLUS X DX) (\BOXIPLUS DX DDX) (\BOXIPLUS DDX DDDX) (\BOXIPLUS Y DY) (\BOXIPLUS DY DDY) (\BOXIPLUS DDY DDDY) (SETQ OOLDX OLDX) (SETQ OOLDY OLDY) (SETQ DELTAX (IDIFFERENCE (SETQ OLDX (\GETINTEGERPART X)) OOLDX)) (SETQ DELTAY (IDIFFERENCE (SETQ OLDY (\GETINTEGERPART Y)) OOLDY)) (SETQ DELTA (IMAX (IABS DELTAX) (IABS DELTAY))) (COND ((EQ DELTA 1) (\HQFX80.SMOOTH-CURVE OLDX OLDY USERFN HQFX80STREAM))) (COND ((IGREATERP DELTA 1) (SETQ DELTAX (\CONVERTTOFRACTION (FQUOTIENT DELTAX DELTA))) (SETQ DELTAY (\CONVERTTOFRACTION (FQUOTIENT DELTAY DELTA))) (SETQ TX (\CONVERTTOFRACTION OOLDX)) (SETQ TY (\CONVERTTOFRACTION OOLDY)) (for I from 0 to DELTA do (\HQFX80.SMOOTH-CURVE ( \GETINTEGERPART TX) (\GETINTEGERPART TY) USERFN HQFX80STREAM) (\BOXIPLUS TX DELTAX) (\BOXIPLUS TY DELTAY] (* ; "draw the end point") (COND (USERFN (\HQFX80.SMOOTH-CURVE X1 Y1 USERFN HQFX80STREAM)) (T (\HQFX80.SMOOTH-CURVE (IDIFFERENCE X1 (LRSH (SUB1 BRUSHWIDTH) 1)) (IDIFFERENCE Y1 (LRSH (SUB1 BRUSHHEIGHT) 1)) NIL HQFX80STREAM))) (AND HQFX80STREAM (MOVETO (FIX X1) (FIX Y1) HQFX80STREAM] (COND (ENDING (\HQFX80.SMOOTH-CURVE (IPLUS \CURX \CURX (IMINUS \OLDX)) (IPLUS \CURY \CURY (IMINUS \OLDY)) USERFN HQFX80STREAM) (\HQFX80.SMOOTH-CURVE (IPLUS \CURX \CURX (IMINUS \OLDX)) (IPLUS \CURY \CURY (IMINUS \OLDY)) USERFN HQFX80STREAM))) (RETURN NIL]) (\HQFX80.LINEWITHBRUSH [LAMBDA (X1 Y1 X2 Y2 BRUSH DASHLST HQFX80STREAM BBT) (* ; "Edited 5-Jan-87 16:57 by hdj") (* ;; "draws a line with a brush on a HQFX80STREAM") (DECLARE (LOCALVARS . T)) (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) (PROG (DESTINATION-BITMAP LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH OPERATION HEIGHTMINUS1 HALFBRUSHWIDTH HALFBRUSHHEIGHT DX DY YINC CDL (DASHON T) (DASHTAIL DASHLST) (DASHCNT (CAR DASHLST)) (USERFN (AND (LITATOM BRUSH) BRUSH))) (* ;; "many of these variables are used by the macro for \HQFX80.CURVEPT that passes them to \HQFX80.BBTCURVEPT and .SETUP.FOR.\\HQFX80.BBTCURVEPT. sets them up.") [COND ((NOT USERFN) (.SETUP.FOR.\HQFX80.BBTCURVEPT. HQFX80DATA) (* ;  "SUB1 is so that the extra bit goes on the top and right as it is documented as doing for lines.") [SETQ X1 (- X1 (SETQ HALFBRUSHWIDTH (FOLDLO (SUB1 BRUSHWIDTH) 2] (SETQ X2 (- X2 HALFBRUSHWIDTH)) [SETQ Y1 (- Y1 (SETQ HALFBRUSHHEIGHT (FOLDLO (SUB1 BRUSHHEIGHT) 2] (* ;  "take into account the brush thickness.") (SETQ Y2 (- Y2 HALFBRUSHHEIGHT] (* ;  "arrange things so that dx is positive.") (COND ((> X1 X2) (* ; "switch points") (swap X1 X2) (swap Y1 Y2))) (SETQ DX (ADD1 (- X2 X1))) [SETQ DY (ADD1 (COND ((> Y2 Y1) (SETQ YINC 1) (- Y2 Y1)) (T (SETQ YINC -1) (- Y1 Y2] [SETQ CDL (HALF (COND ((> DX DY) (* ;  "set up the bucket so that the ends will be the same.") (IREMAINDER DX DY)) (T (IREMAINDER DY DX] [COND [USERFN (* ;  "if user function is being called, don't bother bringing window to top uninterruptably.") (COND ((IGEQ DX DY) (* ; "X is the fastest mover.") (until (> X1 X2) do (* ; "main loop") (COND (DASHON (APPLY* USERFN X1 Y1 HQFX80STREAM))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ((NOT (> DX (add CDL DY))) (add Y1 YINC) (COND ((COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((> Y1 Y2))) (RETURN))) (SETQ CDL (- CDL DX] (add X1 1))) (T (* ; "Y is the fastest mover.") (until (COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((> Y1 Y2))) do (* ; "main loop") (COND (DASHON (APPLY* USERFN X1 Y1 HQFX80STREAM))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ([NOT (> DY (SETQ CDL (+ CDL DX] (COND ((> (SETQ X1 (ADD1 X1)) X2) (RETURN))) (SETQ CDL (- CDL DY] (add Y1 YINC] (T (COND [(IGEQ DX DY) (* ; "X is the fastest mover.") (until (> X1 X2) do (* ; "main loop") (COND (DASHON (\HQFX80.CURVEPT X1 Y1))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ([NOT (> DX (SETQ CDL (+ CDL DY] (SETQ Y1 (+ Y1 YINC)) (COND ((COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((> Y1 Y2))) (RETURN))) (SETQ CDL (- CDL DX] (SETQ X1 (ADD1 X1] (T (* ; "Y is the fastest mover.") (until (COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((> Y1 Y2))) do (* ; "main loop") (COND (DASHON (\HQFX80.CURVEPT X1 Y1))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ([NOT (> DY (SETQ CDL (+ CDL DX] (COND ((> (SETQ X1 (ADD1 X1)) X2) (RETURN))) (SETQ CDL (- CDL DY] (SETQ Y1 (+ Y1 YINC] (RETURN NIL]) ) (DEFINEQ (\HQFX80.BBTCURVEPT [LAMBDA (X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH RIGHTPLUS1 TOPMINUSBRUSH DESTINATION-BITMAP BRUSHHEIGHT BOTTOMMINUSBRUSH TOP BRUSHBASE DESTINATIONBASE RASTERWIDTH BRUSHRASTERWIDTH HQFX80DATA) (* hdj " 6-Nov-86 14:36") (* ;; "Called by \hqfx80.CURVEPT macro. Draws a brush point by bitblting BRUSHBM to point X,Y in DestinationBitMap. BBT is a BitBlt table where everything is already set except the source and destination addresses, width and height. In other words, only the easy stuff") (* ; "") (* ; "set the width fields of the bbt") [PROG (CLIPPEDTOP STY) [COND [(ILEQ Y TOPMINUSBRUSH) (* ;  "the top part of the brush is visible") (SETQ CLIPPEDTOP (IPLUS Y BRUSHHEIGHT)) (replace PBTSOURCE of BBT with BRUSHBASE) (replace PBTHEIGHT of BBT with (IMIN BRUSHHEIGHT (IDIFFERENCE Y BOTTOMMINUSBRUSH] (T (* ; "only the bottom is visible") (SETQ CLIPPEDTOP TOP) [replace PBTSOURCE of BBT with (\ADDBASE BRUSHBASE (ITIMES BRUSHRASTERWIDTH (SETQ STY (IDIFFERENCE Y TOPMINUSBRUSH] (replace PBTHEIGHT of BBT with (IDIFFERENCE (IMIN BRUSHHEIGHT (IDIFFERENCE Y BOTTOMMINUSBRUSH )) STY] (replace PBTDEST of BBT with (\ADDBASE DESTINATIONBASE (ITIMES RASTERWIDTH (\SFInvert DESTINATION-BITMAP CLIPPEDTOP] [COND [(ILESSP X LEFT) (* ;  "only the right part of the brush is visible") (replace PBTDESTBIT of BBT with LEFT) (replace PBTSOURCEBIT of BBT with (IDIFFERENCE BRUSHWIDTH (replace PBTWIDTH of BBT with (IDIFFERENCE X LEFTMINUSBRUSH] (T (* ; "left edge is visible") (replace PBTDESTBIT of BBT with X) (replace PBTSOURCEBIT of BBT with 0) (* ;  "set width to the amount that is visible") (replace PBTWIDTH of BBT with (IMIN BRUSHWIDTH (IDIFFERENCE RIGHTPLUS1 X] (\PILOTBITBLT BBT 0]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \HQFX80.CURVEPT MACRO [OPENLAMBDA (X Y) (* ;; "puts a brush shape at point X,Y. Assumes X and Y have been corrected so that it is the lower left corner of the brush. Does a clipping to the region defined by LEFT RIGHTPLUS1 BOTTOM and LEFTMINUSBRUSH TOPMINUSBRUSH BOTTOMMINUSBRUSH.") (COND ((OR (ILEQ X LEFTMINUSBRUSH) (IGEQ X RIGHTPLUS1) (ILEQ Y BOTTOMMINUSBRUSH) (IGEQ Y TOP)) (* ; "Brush is entirely out of region") NIL) ((NULL BBT)(* ;  "Special case of single point brush") (\FBITMAPBIT DESTINATIONBASE X Y OPERATION HEIGHTMINUS1 RASTERWIDTH)) (T (* ;  "Some part of the brush in in the region") (\HQFX80.BBTCURVEPT X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH RIGHTPLUS1 TOPMINUSBRUSH DESTINATION-BITMAP BRUSHHEIGHT BOTTOMMINUSBRUSH TOP BRUSHBASE DESTINATIONBASE RASTERWIDTH BRUSHRASTERWIDTH HQFX80DATA]) ) (DEFMACRO \HQFX80.SMOOTH-CURVE (NEWX NEWY USERFN HQFX80STREAM) `(LET [(DX (IABS (- ,NEWX \OLDX))) (DY (IABS (- ,NEWY \OLDY] (COND ((OR (> DX 1) (> DY 1)) [COND ((NEQ [+ (ADD1 (- \OLDX \OLDERX)) (ITIMES 3 (ADD1 (- \OLDY \OLDERY] 4) [COND (DASHON (COND (,USERFN (APPLY* ,USERFN \OLDX \OLDY ,HQFX80STREAM)) (T (\HQFX80.CURVEPT \OLDX \OLDY] (COND (DASHTAIL (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] (SETQ \OLDERX \OLDX) (SETQ \OLDERY \OLDY) (SETQ \OLDX \CURX) (SETQ \OLDY \CURY))) (SETQ \CURX ,NEWX) (SETQ \CURY ,NEWY))) (DEFMACRO .SETUP.FOR.\HQFX80.BBTCURVEPT. (HQFX80DATA) `(LET [(CLIPPINGREGION (HQFX80DATA-CLIPPINGREGION ,HQFX80DATA] (SETQ BOTTOM (ffetch (REGION BOTTOM) of CLIPPINGREGION)) (SETQ TOP (ffetch (REGION TOP) of CLIPPINGREGION)) (SETQ RIGHTPLUS1 (ffetch (REGION RIGHT) of CLIPPINGREGION)) (SETQ LEFT (ffetch (REGION LEFT) of CLIPPINGREGION)) (SETQ DESTINATION-BITMAP (HQFX80DATA-BACKINGBITMAP ,HQFX80DATA)) (SETQ OPERATION (HQFX80DATA-OPERATION ,HQFX80DATA)) (SETQ BRUSHBM (\GETBRUSH BRUSH)) (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of DESTINATION-BITMAP)) (SETQ DESTINATIONBASE (fetch (BITMAP BITMAPBASE) of DESTINATION-BITMAP)) (SETQ BBT (\HQFX80.CREATE-BRUSH-BBT BRUSHBM ,HQFX80DATA BBT)) (SETQ BRUSHBASE (fetch (BITMAP BITMAPBASE) of BRUSHBM)) (* ;; "keep Brush width and raster width in number of bits units.") (SETQ BRUSHRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BRUSHBM)) [COND ((NULL BBT) (* ;; "BBT is NIL if single point brush. Set the destination bitmap base.") (SETQ HEIGHTMINUS1 (SUB1 (fetch (BITMAP BITMAPHEIGHT) of DESTINATION-BITMAP))) (COND ((EQ (HQFX80DATA-OPERATION ,HQFX80DATA) 'INVERT) (* ;; "really do invert in single brush case.") (SETQ OPERATION 'INVERT] (SETQ BRUSHWIDTH (fetch (BITMAP BITMAPWIDTH) of BRUSHBM)) (SETQ BRUSHHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BRUSHBM)) (SETQ LEFTMINUSBRUSH (IDIFFERENCE LEFT BRUSHWIDTH)) (SETQ BOTTOMMINUSBRUSH (IDIFFERENCE BOTTOM BRUSHHEIGHT)) (SETQ TOPMINUSBRUSH (IDIFFERENCE TOP BRUSHHEIGHT)))) (* ;; "character printing methods") (DEFINEQ (\HQFX80.OUTCHAR [LAMBDA (HQFX80STREAM CHARCODE) (* ; "Edited 4-Feb-87 15:11 by hdj") (* ;; "Displays the character and increments the Xposition on the HQFX80STREAM.") (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) (* ;; "If necessary, change the charset ") (if (NEQ (HQFX80DATA-CHARSET-CACHE HQFX80DATA) (\CHARSET CHARCODE)) then (\HQFX80.CHANGE-CHARSET HQFX80DATA (\CHARSET CHARCODE))) (SELCHARQ CHARCODE (^L (* ; "form-feed") (\HQFX80.NEWPAGE HQFX80STREAM)) ((EOL CR LF) (* ; "various line-enders") (\HQFX80.NEWLINE CHARCODE HQFX80STREAM)) (LET ((CHARWIDTH (\HQFX80.CHARWIDTH HQFX80STREAM CHARCODE))) (* ;; "if character will be at least partly visible, output it") (if (\HQFX80.CUR-POS-VISIBLE? HQFX80DATA) then (IF (NEQ CHARCODE (CHARCODE SPACE)) THEN (* ;;  "only bitblt real, printing characters -- pilotbbt won't do the right thing with amplified spaces") (\HQFX80.BLT-CHAR CHARCODE CHARWIDTH HQFX80STREAM HQFX80DATA)) ) (CL:INCF (HQFX80DATA-XPOS HQFX80DATA) CHARWIDTH) (* ;; "if we've passed the margin, DING!, do a newline") (if (> (HQFX80DATA-XPOS HQFX80DATA) (HQFX80DATA-RIGHTMARGIN HQFX80DATA)) then (\HQFX80.NEWLINE (CHARCODE EOL) HQFX80STREAM]) (\HQFX80.BLT-CHAR [LAMBDA (CHARCODE CHARWIDTH HQFX80STREAM HQFX80DATA) (* ; "Edited 12-Feb-87 14:17 by jds") (* ;; "puts a character on an HQFX80 stream. Much of the information needed by the BitBlt microcode is prestored by the routines that change it. This is kept in the BitBltTable.") (* (DECLARE (LOCALVARS . T))) (LET* ((CURX (FIXR (HQFX80DATA-XPOS HQFX80DATA))) (CHAR8CODE (\CHAR8CODE CHARCODE)) (RIGHT (+ CURX CHARWIDTH)) (LEFT NIL) (CLIPPINGREGION (HQFX80DATA-CLIPPINGREGION HQFX80DATA)) (RIGHT-CLIPPING-EDGE (fetch (REGION RIGHT) of CLIPPINGREGION)) (LEFT-CLIPPING-EDGE (fetch (REGION LEFT) of CLIPPINGREGION)) (PILOTBBT (HQFX80DATA-PILOTBBT HQFX80DATA))) (* ;;; "clip the bitmap to fit the stream's clipping region") (* ;; "does character overlap right edge of clipping region?") (SETQ RIGHT (MIN RIGHT-CLIPPING-EDGE RIGHT)) (* ;; "does character overlap left edge of clipping region?") (SETQ LEFT (MAX CURX LEFT-CLIPPING-EDGE)) (COND ((AND (< LEFT RIGHT) (NEQ (fetch (PILOTBBT PBTHEIGHT) of PILOTBBT) 0)) (UNINTERRUPTABLY (freplace (PILOTBBT PBTDESTBIT) of PILOTBBT with LEFT) (freplace (PILOTBBT PBTWIDTH) of PILOTBBT with (- RIGHT LEFT)) (freplace (PILOTBBT PBTSOURCEBIT) of PILOTBBT with (- (+ ( \HQFX80.GET-CHARACTER-OFFSET CHAR8CODE HQFX80DATA) LEFT) CURX)) (\PILOTBITBLT PILOTBBT 0)) T]) ) (* ;; "printer code") (DEFINEQ (\HQFX80.DUMP-PAGE-BUFFER [LAMBDA (BITMAP HQFX80STREAM) (* ; "Edited 23-Sep-88 10:25 by jds") (* ;;; "send a bitmap to the FX-80") (* ;; "how it works: we use a specially created bitblt table (HQFX80DATA-SERIALIZING-PILOTBBT) to turn eight-bit-high by one-bit-wide columns of BITMAP into eight-bit-wide by one-bit-high bytes. This extraction is done by \HQFX80.BITMAP-LDB.") (DECLARE (LOCALVARS . T)) (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) (LET* ((WIDTH (BITMAPWIDTH BITMAP)) (WIDTH-MINUS-1 (SUB1 WIDTH)) [HEIGHT (FIX (TIMES \HQFX80.INCHES-PER-PAGE (if (HQFX80DATA-COMPRESSED? HQFX80DATA) then \HQFX80.LOW-SPEED-DOUBLE-MODE-DPI else \HQFX80.1-TO-1-MODE-DPI] (HEIGHT-MINUS-1 (SUB1 HEIGHT)) (BACKING-STREAM (HQFX80DATA-BACKINGSTREAM HQFX80DATA)) (BITMAP-BASE (fetch (BITMAP BITMAPBASE) of BITMAP)) (BITMAP-WIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP)) (MAPPING-TABLE (HQFX80DATA-SERIALIZING-PILOTBBT HQFX80DATA)) (BYTE-BOX (HQFX80DATA-SERIALIZING-BOX HQFX80DATA)) (SCRATCH-SCANLINE-PILOTBBT (HQFX80DATA-SCRATCH-SCANLINE-PILOTBBT HQFX80DATA)) (EIGHT-LINES-BLANK (HQFX80DATA-EIGHT-LINES-BLANK HQFX80DATA)) (EIGHT-LINES-BLANK-PILOTBBT (HQFX80DATA-EIGHT-LINES-BLANK-PILOTBBT HQFX80DATA)) (COMPRESSED? (HQFX80DATA-COMPRESSED? HQFX80DATA))) (* ;; "set the mode") (\HQFX80.PRINTER-MODE :UNIDIRECTIONAL-ON BACKING-STREAM) (\HQFX80.PRINTER-MODE :EIGHT-SPACING-ON BACKING-STREAM) (* ;; "pack the bitmap into FX80 format and ship it") [for EIGHT-SCANLINE-SWATH from 0 to HEIGHT-MINUS-1 by 8 do [COND ((ILESSP (IDIFFERENCE HEIGHT-MINUS-1 EIGHT-SCANLINE-SWATH) 8) (* ;  "There are fewer than 8 scan lines left on the page image; only advance by that amount.") (\HQFX80.PRINTER-MODE :N-SPACING-ON BACKING-STREAM (IDIFFERENCE HEIGHT-MINUS-1 EIGHT-SCANLINE-SWATH] (COND ((\HQFX80.EIGHT-LINES-BLANK? BITMAP-BASE EIGHT-SCANLINE-SWATH BITMAP-WIDTH SCRATCH-SCANLINE-PILOTBBT EIGHT-LINES-BLANK-PILOTBBT EIGHT-LINES-BLANK) (* ;; "skip the next eight blank lines") (\HQFX80.PRINTER-MODE :EIGHT-SPACING-ON BACKING-STREAM) (\HQFX80.ADVANCE-8-LINES HQFX80STREAM)) (T (* ;; "something to print in the next eight scanlines; do so") (\HQFX80.PRINTER-MODE :EIGHT-SPACING-ON BACKING-STREAM) (\HQFX80.GRAPHICS-MODE WIDTH COMPRESSED? BACKING-STREAM) (for COLUMN from 0 to WIDTH-MINUS-1 do (\HQFX80.BITMAP-LDB BITMAP-BASE COLUMN EIGHT-SCANLINE-SWATH MAPPING-TABLE BITMAP-WIDTH) (BOUT BACKING-STREAM (\GETBASEBYTE BYTE-BOX 0))) (BOUT BACKING-STREAM (CHARCODE CR)) (BOUT BACKING-STREAM (CHARCODE LF] (\HQFX80.PRINTER-MODE :UNIDIRECTIONAL-OFF BACKING-STREAM) (\HQFX80.PRINTER-MODE :TWELVE-SPACING-ON BACKING-STREAM]) (\HQFX80.ADVANCE-8-LINES [LAMBDA (HQFX80STREAM) (* ; "Edited 11-Feb-87 11:03 by jds") (* ;; "advance the printhead 8 raster lines. since we assume that we're in the :eight-spacing-on printermode, just send an LF") (\HQFX80.BOUT HQFX80STREAM (CHARCODE LF]) ) (DEFMACRO \HQFX80.EIGHT-LINES-BLANK? (BITMAP-BASE Y-COORD BITMAP-WIDTH-IN-WORDS EIGHT-INTO-ONE-PBBT SCANLINE-INTO-WORD-PBBT WORD-BOX) (* ;; "returns T if the next 8 lines of the bitmap are all blank. This is done by or'ing the 8 scanlines into a scratch bitmap, then or'ing the words of that scanline into a result word, and comparing that to 0. We clear the scanline and word buffers at the end.") `(LET ((EIGHT-INTO-ONE-PBBT ,EIGHT-INTO-ONE-PBBT) (SCANLINE-INTO-WORD-PBBT ,SCANLINE-INTO-WORD-PBBT) (WORD-BOX ,WORD-BOX) (BITMAP-WIDTH-IN-WORDS ,BITMAP-WIDTH-IN-WORDS)) [FREPLACE (PILOTBBT PBTSOURCE) OF EIGHT-INTO-ONE-PBBT WITH (\ADDBASE ,BITMAP-BASE (TIMES ,BITMAP-WIDTH-IN-WORDS ,Y-COORD] (\PILOTBITBLT EIGHT-INTO-ONE-PBBT 0) (\PILOTBITBLT SCANLINE-INTO-WORD-PBBT 0) (PROG1 (EQ (\GETBASE WORD-BOX 0) 0) (\HQFX80.CLEAR-SCANLINE EIGHT-INTO-ONE-PBBT BITMAP-WIDTH-IN-WORDS) (\HQFX80.CLEAR-WORD-BOX WORD-BOX)))) (DEFMACRO \HQFX80.BITMAP-LDB (BITMAP-BASE X Y PILOTBBT BITMAP-WIDTH-IN-WORDS) (* ;; "point the serializing bitblt table at a new column of the bitmap. The X coord increases left to right, the Y coord increases top to bottom, and names the uppermost pixel of the column we're moving.") `(LET ((X ,X) (PILOTBBT ,PILOTBBT)) [FREPLACE (PILOTBBT PBTSOURCE) OF PILOTBBT WITH (\ADDBASE ,BITMAP-BASE (+ (TIMES ,Y ,BITMAP-WIDTH-IN-WORDS) (FOLDLO X BITSPERWORD] (FREPLACE (PILOTBBT PBTSOURCEBIT) OF PILOTBBT WITH (LOGAND 15 X)) (\PILOTBITBLT PILOTBBT 0))) (DEFMACRO \HQFX80.CLEAR-SCANLINE (SCANLINE-PILOTBBT SCANLINE-WIDTH-IN-WORDS) (* ;; "clear out the destination of the pilotbbt the fast way - store a zero in its last word and perform an overlapping blt (which runs back to front).") `(LET [(SCANLINE (FETCH (PILOTBBT PBTDEST) OF ,SCANLINE-PILOTBBT)) (LAST-WORD (SUB1 ,SCANLINE-WIDTH-IN-WORDS] (\PUTBASE SCANLINE LAST-WORD 0) (\BLT SCANLINE (\ADDBASE SCANLINE 1) LAST-WORD))) (DEFMACRO \HQFX80.CLEAR-WORD-BOX (WORD-BOX) `(\PUTBASE ,WORD-BOX 0 0)) (CL:DEFUN \HQFX80.SEND (PRINTER FILENAME &OPTIONAL OPTIONS) (* ;; "send the file designated by FILENAME to PRINTER, obeying OPTIONS. Since we only have one fx-80 per machine, ignore PRINTER and send to HQFX80-DEFAULT-DESTINATION") (DECLARE (GLOBALVARS HQFX80-DEFAULT-DESTINATION)) [LET ((COPIES (OR (LISTGET OPTIONS '%#COPIES) 1))) (FOR COPY FROM 1 TO COPIES DO (* ;;  "allow the user to abort it while running") (WITH-ABORT-WINDOW ((THIS.PROCESS) FILENAME PRINTER COPY) (COPYFILE FILENAME HQFX80-DEFAULT-DESTINATION '((TYPE HQFX80]) (CL:DEFUN MAKE-HQFX80 (FILE HQFX80FILE &OPTIONAL FONTS HEADING TABS OPTIONS) (* ;; "turn FILE into an HQFX80 master") (TEXTTOIMAGEFILE FILE HQFX80FILE 'HQFX80 FONTS HEADING TABS OPTIONS)) (CL:DEFUN HQFX80FILEP (HQFX80FILE?) (* ;; "is FILE (a filename or stream) an hqfx80 file?") [LET [(FILE-TYPE (GETFILEINFO HQFX80FILE? 'TYPE] (IF (EQ FILE-TYPE 'HQFX80) THEN (* ;  "if file has a type, and type=HQFX80, we win") T ELSE (* ;  "no filetype or filetype not HQFX80, so read the file") (LET [(STREAM (OPENSTREAM (INTERLISP-NAMESTRING HQFX80FILE?) 'INPUT 'OLD '(SEQUENTIAL] (* ;; "file looks like ESC@...") (PROG1 [AND (> (GETFILEINFO STREAM 'LENGTH) (+ 2 (NCHARS \HQFX80.FILE-SIGNATURE))) (EQ (CHARCODE ESC) (BIN STREAM)) (EQ (CHARCODE @) (BIN STREAM)) (FOR CH INSTRING \HQFX80.FILE-SIGNATURE ALWAYS (EQ CH (BIN STREAM] (CLOSEF STREAM]) (* ;; "window hardcopy") (DEFINEQ (\HQFX80.BITMAP-FILE [LAMBDA (FILE BITMAP SCALEFACTOR REGION ROTATION TITLE) (* ; "Edited 1-Jun-87 13:10 by Snow") (* ;; "print a bitmap on the fx-80. ignore SCALEFACTOR and ROTATION for now.") (LET* ((HQFX80STREAM (OPENIMAGESTREAM FILE 'HQFX80)) (NEWBITMAP (COND (REGION (BITMAPCREATE (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION))) (T BITMAP))) (WIDTH (BITMAPWIDTH NEWBITMAP)) (HEIGHT (BITMAPHEIGHT NEWBITMAP)) (PAGE-REGION (DSPCLIPPINGREGION NIL HQFX80STREAM)) (PAGE-WIDTH (fetch (REGION WIDTH) of PAGE-REGION)) (PAGE-HEIGHT (fetch (REGION HEIGHT) of PAGE-REGION))) (* ;; "clip the bitmap, if requested") (AND REGION (BITBLT BITMAP (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) NEWBITMAP)) (LET* ((PORTRAIT-OVERHANG (- WIDTH (fetch (REGION WIDTH) of PAGE-REGION))) (LANDSCAPE-OVERHANG (- HEIGHT (fetch (REGION WIDTH) of PAGE-REGION))) (BITS-LOST (AND (> PORTRAIT-OVERHANG 0) (> LANDSCAPE-OVERHANG 0))) (LANDSCAPE-PRINT (> PORTRAIT-OVERHANG LANDSCAPE-OVERHANG))) (* ;; "print the title of the image on the top of the page") (LET* ((IMAGE-TITLE (OR TITLE "Window Image")) (TITLE-REGION (STRINGREGION IMAGE-TITLE HQFX80STREAM))) (MOVETO (/ (- PAGE-WIDTH (fetch (REGION WIDTH) of TITLE-REGION)) 2) (- (- PAGE-HEIGHT 1) (FONTPROP HQFX80STREAM 'HEIGHT)) HQFX80STREAM) (PRIN1 IMAGE-TITLE HQFX80STREAM)) (* ;; "blt the bitmap onto the page. use replace mode so it will obscure title if need be") [COND (BITS-LOST (* ;; "apologize and blt as much as will fit") (PRINTOUT PROMPTWINDOW "Bitmap is larger than FX-80 page - " "image will be clipped" T) (BITBLT NEWBITMAP NIL NIL HQFX80STREAM 0 0 NIL NIL 'INPUT 'REPLACE)) (T (* ;; "center it on the page ") (* ;; "if there is more overhang in portrait than in landscape - rotate it remember to swap the height and width.") (AND LANDSCAPE-PRINT (SETQ NEWBITMAP (ROTATE-BITMAP NEWBITMAP)) (swap WIDTH HEIGHT)) (BITBLT NEWBITMAP NIL NIL HQFX80STREAM (/ (- PAGE-WIDTH WIDTH) 2) (/ (- PAGE-HEIGHT HEIGHT) 2) NIL NIL 'INPUT 'REPLACE] (CLOSEF HQFX80STREAM]) (\HQFX80.CONVERT-TEDIT [LAMBDA (TEDIT-FILE IMAGESTREAM) (* ; "Edited 11-Dec-86 17:24 by hdj") (* ;; "Send the text to the printer.") (SETQ TEDIT-FILE (OPENTEXTSTREAM TEDIT-FILE)) (TEDIT.FORMAT.HARDCOPY TEDIT-FILE IMAGESTREAM T NIL NIL NIL 'HQFX80) (CLOSEF? IMAGESTREAM) IMAGESTREAM]) ) (* ;; "character transmission method") (DEFINEQ (\HQFX80.BOUT [LAMBDA (HQFX80SSTREAM BYTE) (* hdj " 7-Nov-86 17:18") (* ;; "send a byte to the fx80") (WITH-HQFX80-DATA (DATA HQFX80SSTREAM) (BOUT (HQFX80DATA-BACKINGSTREAM DATA) BYTE]) ) (* ;; "handling font-information caching") (DEFINEQ (\HQFX80.FIX-LINE-LENGTH [LAMBDA (HQFX80STREAM) (* hdj "14-Nov-86 17:15") (* ;; "HQFX80STREAM is a stream of type hqfx80. Called by RIGHTMARGIN LEFTMARGIN and \hqfx80.fix-font to update the LINELENGTH field in the stream. Also called when the stream is created.") (WITH-HQFX80-DATA (DATA HQFX80STREAM) (freplace (STREAM LINELENGTH) of HQFX80STREAM with (MIN MAX.SMALLP (MAX 1 (IQUOTIENT (- (HQFX80DATA-RIGHTMARGIN DATA) (HQFX80DATA-LEFTMARGIN DATA)) (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of (HQFX80DATA-FONT DATA]) (\HQFX80.FIX-FONT [LAMBDA (HQFX80STREAM HQFX80DATA) (* hdj "10-Nov-86 16:37") (* ;; "used to fix up those parts of the bitblt table which depend upon the FONT.") (\HQFX80.INVALIDATE-CACHE HQFX80DATA) (\HQFX80.FIX-LINE-LENGTH HQFX80STREAM]) (\HQFX80.FIX-Y [LAMBDA (HQFX80DATA CSINFO) (* ; "Edited 12-Feb-87 11:46 by jds") (* ;; "makes that part of the bitblt table of an HQFX80 stream which deals with the Y information consistent. This is called from \\HQFX80.change-charset whenever a character is being printed and the charset/y-position caches are invalid") (PROG ((PBT (HQFX80DATA-PILOTBBT HQFX80DATA)) (Y (HQFX80DATA-YPOS HQFX80DATA)) TOP CHARTOP BM) [SETQ CHARTOP (FIXR (+ Y (CL:SETF (HQFX80DATA-CHARSET-ASCENT-CACHE HQFX80DATA) (ffetch CHARSETASCENT of CSINFO] [freplace PBTDEST of PBT with (\ADDBASE (fetch BITMAPBASE of (SETQ BM (HQFX80DATA-BACKINGBITMAP HQFX80DATA))) (TIMES (ffetch BITMAPRASTERWIDTH of BM) (\SFInvert BM (SETQ TOP (FIXR (MAX (MIN (fetch (REGION TOP) of ( HQFX80DATA-CLIPPINGREGION HQFX80DATA)) CHARTOP) 0] [freplace PBTSOURCE of PBT with (\ADDBASE (ffetch BITMAPBASE of (SETQ BM (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO))) (TIMES (ffetch BITMAPRASTERWIDTH of BM) (CL:SETF (HQFX80DATA-CHARHEIGHTDELTA HQFX80DATA) (FIXR (MIN (MAX (- CHARTOP TOP) 0) MAX.SMALL.INTEGER] (freplace PBTHEIGHT of PBT with (FIXR (MAX [- TOP (MAX (- Y (CL:SETF (HQFX80DATA-CHARSET-DESCENT-CACHE HQFX80DATA) (ffetch CHARSETDESCENT of CSINFO))) (fetch (REGION BOTTOM) of (HQFX80DATA-CLIPPINGREGION HQFX80DATA] 0]) ) (DEFMACRO \HQFX80.INVALIDATE-CACHE (HQFX80DATA) (* ;;  "marks the stream as needing to have its cached fields recomputed. used when font changes, etc.") `(PROGN (CL:SETF (HQFX80DATA-CHARSET-CACHE ,HQFX80DATA) MAX.SMALLP) (CL:SETF (HQFX80DATA-CHARSET-ASCENT-CACHE ,HQFX80DATA) MAX.SMALLP))) (DEFMACRO \HQFX80.INVALIDATE-FONT-CACHE (HQFX80DATA) `(PROGN (CL:SETF (HQFX80DATA-CHARSET-CACHE ,HQFX80DATA) MAX.SMALLP) (CL:SETF (HQFX80DATA-CHARSET-ASCENT-CACHE ,HQFX80DATA) MAX.SMALLP))) (DEFMACRO \HQFX80.GET-CACHED-CHAR-WIDTH (CHARCODE HQFX80DATA) (* ;; "get the cached image width of CHARCODE") `(\FGETIMAGEWIDTH (HQFX80DATA-IMAGE-WIDTHS-CACHE ,HQFX80DATA) ,CHARCODE)) (DEFMACRO \HQFX80.GET-CHARACTER-OFFSET (CHAR8CODE HQFX80DATA) `(\GETBASE (HQFX80DATA-OFFSETS-CACHE ,HQFX80DATA) ,CHAR8CODE)) (* ;; "auxiliary functions") (CL:DEFUN \HQFX80.GRAPHICS-MODE (ROWS COMPRESSED? BACKING-STREAM) (* ;; "put the FX-80 in some graphics mode") (BOUT BACKING-STREAM (CHARCODE ESC)) (BOUT BACKING-STREAM (CHARCODE *)) (BOUT BACKING-STREAM (* ;  "compressed prints at 120 dpi, regular at 72") (if COMPRESSED? then 1 else 5)) (BOUT BACKING-STREAM (IREMAINDER ROWS 256)) (BOUT BACKING-STREAM (FOLDLO ROWS 256))) (DEFINEQ (\HQFX80.PRINTER-MODE [LAMBDA (FX80-MODE STREAM N-SPACING) (* ; "Edited 23-Sep-88 10:21 by jds") (* ;; "put the FX80 printer in some mode") (CL:FLET [(SEND-PRINTER-COMMAND (COMMAND-STRING STREAM) (* ;; "Send an ESC, to tell the printer there is to be a mode change, and then the specific mode change byte") (BOUT STREAM (CHARCODE ESC)) (for CHAR instring COMMAND-STRING do (BOUT STREAM CHAR] (SELECTQ FX80-MODE (:BOLD-ON (SEND-PRINTER-COMMAND "E" STREAM)) (:BOLD-OFF (SEND-PRINTER-COMMAND "F" STREAM)) (:COMPRESSED-ON (SEND-PRINTER-COMMAND (CHARACTER 15) STREAM)) (:COMPRESSED-OFF (BOUT STREAM 18)) (:ELITE-ON (SEND-PRINTER-COMMAND "M" STREAM)) (:ELITE-OFF (SEND-PRINTER-COMMAND "P" STREAM)) (:ITALIC-ON (SEND-PRINTER-COMMAND "4" STREAM)) (:ITALIC-OFF (SEND-PRINTER-COMMAND "5" STREAM)) (:PICA-ON (SEND-PRINTER-COMMAND (CONCAT "P" (CHARACTER 18)) STREAM)) (:SUBSCRIPT-ON (SEND-PRINTER-COMMAND "S0" STREAM)) (:SCRIPT-OFF (SEND-PRINTER-COMMAND "T" STREAM)) (:SUPERSCRIPT-ON (SEND-PRINTER-COMMAND "S1" STREAM)) (:EXPAND-ON (SEND-PRINTER-COMMAND "W1" STREAM)) (:EXPAND-OFF (SEND-PRINTER-COMMAND "W0" STREAM)) (:PROPORTIONAL-ON (SEND-PRINTER-COMMAND "p1" STREAM)) (:PROPORTIONAL-OFF (SEND-PRINTER-COMMAND "p0" STREAM)) (:UNIDIRECTIONAL-ON (SEND-PRINTER-COMMAND "U1" STREAM)) (:UNIDIRECTIONAL-OFF (SEND-PRINTER-COMMAND "U0" STREAM)) (:N-SPACING-ON (* ; "Space n/72 of an inch on LF.") (SEND-PRINTER-COMMAND (CONCAT "A" (CHARACTER N-SPACING)) STREAM)) (:SEVEN-SPACING-ON (SEND-PRINTER-COMMAND "1" STREAM)) (:EIGHT-SPACING-ON (SEND-PRINTER-COMMAND (CONCAT "A" (CHARACTER 8)) STREAM)) (:NINE-SPACING-ON (* ;  "Space by 9 print dots per LF. Mostly for graphics mode used in HQ FX-80.") (SEND-PRINTER-COMMAND "0" STREAM)) (:TWELVE-SPACING-ON (* ; "Restore normal 1/6%" spacing") (SEND-PRINTER-COMMAND "2" STREAM)) (:NO-SKIP (SEND-PRINTER-COMMAND "O" STREAM)) NIL]) ) (DEFMACRO WITH-HQFX80-DATA ((VAR-NAME STREAM) &BODY (BODY DECLS ENV)) `(LET [(,VAR-NAME (FETCH (STREAM IMAGEDATA) OF ,STREAM] ,@DECLS ,@BODY)) (* ;; "and miscellany") (DECLARE%: EVAL@COMPILE (RPAQ \HQFX80.FILE-SIGNATURE "HQFX-80/Xerox/1.0 ") (RPAQQ \HQFX80.1-TO-1-MODE-DPI 72) (RPAQQ \HQFX80.LOW-SPEED-DOUBLE-MODE-DPI 120) (CONSTANTS (\HQFX80.FILE-SIGNATURE "HQFX-80/Xerox/1.0 ") (\HQFX80.1-TO-1-MODE-DPI 72) (\HQFX80.LOW-SPEED-DOUBLE-MODE-DPI 120)) ) (RPAQ? \HQFX80.INCHES-PER-PAGE 11) (RPAQ? \HQFX80.INCHES-PER-LINE 8.5) (RPAQ? HQFX80-DEFAULT-DESTINATION "{TTY}") (RPAQ? HQFX80-FONT-EXTENSIONS DISPLAYFONTEXTENSIONS) (RPAQ? HQFX80-FONT-DIRECTORIES DISPLAYFONTDIRECTORIES) (RPAQ? HQFX80-FONT-COERCIONS DISPLAYFONTCOERCIONS) (RPAQ? HQFX80-MISSING-FONT-COERCIONS MISSINGDISPLAYFONTCOERCIONS) (RPAQQ FX80-PRINTCOMS ( (* ;; "The FXPrinter emulator") (COMS (* ;; "top level routine") (FUNCTIONS FX80-PRINT)) (COMS (* ;; "how to print bitmaps") (FUNCTIONS FX80-PRINT.BITMAP) (FUNCTIONS FX80-PRINT.PRINT-BITMAP FX80-PRINT.PRINT-BITMAP-PORTRAIT FX80-PRINT.PRINT-BITMAP-LANDSCAPE)) (COMS (* ;; "how to print files") (FUNCTIONS FX80-PRINT.FILE)))) (* ;; "The FXPrinter emulator") (* ;; "top level routine") (CL:DEFUN FX80-PRINT (THING-TO-PRINT &KEY LANDSCAPE? COMPRESS? HIGH-QUALITY?) "Prints thing-to-print on the FX-80 printer" (CL:ETYPECASE THING-TO-PRINT ((OR WINDOW BITMAP) (FX80-PRINT.BITMAP THING-TO-PRINT LANDSCAPE? COMPRESS?)) ((OR CL:SYMBOL STRING PATHNAME) (FX80-PRINT.FILE THING-TO-PRINT HIGH-QUALITY?))) THING-TO-PRINT) (* ;; "how to print bitmaps") (CL:DEFUN FX80-PRINT.BITMAP (BITMAP-OR-WINDOW LANDSCAPE? COMPRESS?) "Prints a bitmap or window on the FX-80 printer" (CL:ETYPECASE BITMAP-OR-WINDOW (WINDOW (LET* [(WINDOW-REGION (DSPCLIPPINGREGION NIL BITMAP-OR-WINDOW)) (BM (BITMAPCREATE (FETCH (REGION WIDTH) OF WINDOW-REGION) (FETCH (REGION HEIGHT) OF WINDOW-REGION] (BITBLT BITMAP-OR-WINDOW NIL NIL BM) (FX80-PRINT.BITMAP BM LANDSCAPE? COMPRESS?))) (BITMAP (FX80-PRINT.PRINT-BITMAP BITMAP-OR-WINDOW LANDSCAPE? COMPRESS?)))) (CL:DEFUN FX80-PRINT.PRINT-BITMAP (BITMAP LANDSCAPE? COMPRESS?) "Print a bitmap on the FX-80, either landscape or portrait" (IF LANDSCAPE? THEN (FX80-PRINT.PRINT-BITMAP-LANDSCAPE BITMAP COMPRESS?) ELSE (FX80-PRINT.PRINT-BITMAP-PORTRAIT BITMAP COMPRESS?))) (CL:DEFUN FX80-PRINT.PRINT-BITMAP-PORTRAIT (BITMAP COMPRESS?) "Prints a bitmap on the FX-80 in portrait mode" [LET ((HQFX80STREAM (OPENIMAGESTREAM HQFX80-DEFAULT-DESTINATION 'HQFX80 (LIST 'COMPRESSED COMPRESS?))) (WIDTH (BITMAPWIDTH BITMAP)) (HEIGHT (BITMAPHEIGHT BITMAP))) (WITH-HQFX80-DATA (DATA HQFX80STREAM) (LET ((PAGE-WIDTH (fetch (REGION WIDTH) of (HQFX80DATA-CLIPPINGREGION DATA))) (PAGE-HEIGHT (fetch (REGION HEIGHT) of (HQFX80DATA-CLIPPINGREGION DATA)) (HQFX80DATA-CLIPPINGREGION DATA))) (* ;; "center it if possible") (BITBLT BITMAP NIL NIL HQFX80STREAM (MAX 0 (/ (- PAGE-WIDTH WIDTH) 2)) (MAX 0 (/ (- PAGE-HEIGHT HEIGHT) 2)) NIL NIL 'INPUT 'REPLACE) (CLOSEF HQFX80STREAM]) (CL:DEFUN FX80-PRINT.PRINT-BITMAP-LANDSCAPE (BITMAP COMPRESS?) "Prints a bitmap on the FX-80 in landscape mode" [LET ((HQFX80STREAM (OPENIMAGESTREAM HQFX80-DEFAULT-DESTINATION 'HQFX80 (LIST 'COMPRESSED COMPRESS?))) (WIDTH (BITMAPHEIGHT BITMAP)) (HEIGHT (BITMAPWIDTH BITMAP)) (ROTATED-BITMAP (ROTATE-BITMAP BITMAP))) (WITH-HQFX80-DATA (DATA HQFX80STREAM) (LET ((PAGE-WIDTH (fetch (REGION WIDTH) of (HQFX80DATA-CLIPPINGREGION DATA))) (PAGE-HEIGHT (fetch (REGION HEIGHT) of (HQFX80DATA-CLIPPINGREGION DATA)) (HQFX80DATA-CLIPPINGREGION DATA))) (BITBLT ROTATED-BITMAP NIL NIL HQFX80STREAM (MAX 0 (/ (- PAGE-WIDTH WIDTH) 2)) (MAX 0 (/ (- PAGE-HEIGHT HEIGHT) 2)) NIL NIL 'INPUT 'REPLACE) (CLOSEF HQFX80STREAM]) (* ;; "how to print files") (CL:DEFUN FX80-PRINT.FILE (FILE-NAME HIGH-QUALITY?) "Prints a file on the FX-80" (SEND.FILE.TO.PRINTER (INTERLISP-NAMESTRING FILE-NAME) (IF HIGH-QUALITY? THEN 'HQFX80 ELSE 'FASTFX80))) (* ; "common routines") (DEFMACRO WITH-ABORT-WINDOW ((PROCESS FILE-NAME PRINTER-NAME COPY#) &BODY (FORMS DECLS)) "executes FORMS, allowing termination by menu selection" `(LET [(WINDOW (\FX80.CREATE-SEND-ABORT-WINDOW ,PROCESS ,FILE-NAME ,PRINTER-NAME ,COPY#] (CL:UNWIND-PROTECT (PROGN ,@DECLS (BLOCK 3000) ,@FORMS) (CLOSEW WINDOW)))) (CL:DEFUN \FX80.CREATE-SEND-ABORT-WINDOW (SENDING-PROCESS FILE-OR-STREAM PRINTER-NAME COPY#) (LET* [(DOCUMENT-TYPE-AND-NAME-STRING (IF (STREAMP FILE-OR-STREAM) THEN (IF (FETCH (STREAM NAMEDP) OF FILE-OR-STREAM ) THEN (CONCAT "the file " (FULLNAME FILE-OR-STREAM )) ELSE "an unnamed document") ELSE FILE-OR-STREAM)) (WINDOW-WIDTH (WIDTHIFWINDOW 270)) (WINDOW-HEIGHT (HEIGHTIFWINDOW 120)) (ABORT-MENU-ITEM "Abort") (ABORT-MENU-FONT (FONTCREATE 'GACHA 12 'BRR)) (ABORT-WINDOW (CREATEW (CREATEREGION (RAND 0 (- SCREENWIDTH WINDOW-WIDTH)) (- SCREENHEIGHT WINDOW-HEIGHT) WINDOW-WIDTH WINDOW-HEIGHT))) (ABORT-WINDOW-FONT (DSPFONT NIL ABORT-WINDOW)) (BOLD-ABORT-WINDOW-FONT (FONTCOPY ABORT-WINDOW-FONT 'WEIGHT 'BOLD] (PRINTOUT ABORT-WINDOW "Sending copy " COPY# " of " .FONT BOLD-ABORT-WINDOW-FONT DOCUMENT-TYPE-AND-NAME-STRING .FONT ABORT-WINDOW-FONT " to " .FONT BOLD-ABORT-WINDOW-FONT PRINTER-NAME .FONT ABORT-WINDOW-FONT "." T) (PRINTOUT ABORT-WINDOW "Select %"Abort%" below to stop printing " " this and all subsequent copies." T) (ADDMENU (CREATE MENU ITEMS _ `[(,ABORT-MENU-ITEM (PROGN (PROCESS.EVAL ,SENDING-PROCESS '(ERROR!)) (PRINTOUT ,ABORT-WINDOW T "... printing aborted.") (BLOCK 2000) (CLOSEW ,ABORT-WINDOW)) ,(CONCAT "Stops printing this and all subsequent copies of " DOCUMENT-TYPE-AND-NAME-STRING "."] MENUFONT _ ABORT-MENU-FONT) ABORT-WINDOW (CREATEPOSITION (/ (- WINDOW-WIDTH (STRINGWIDTH ABORT-MENU-ITEM ABORT-MENU-FONT)) 2) 20)) ABORT-WINDOW)) (CL:DEFUN \ADD-TO-FONTPROFILE (FONTPROFILE FONTCLASS DEVICE FONT-DESCRIPTION) (* ;; "sets the DEVICE component of the FONTCLASS entry of FONTPROFILE to be FONT-DESCRIPTION.") (LET ((BUCKET (FASSOC FONTCLASS FONTPROFILE))) (IF (NULL BUCKET) THEN (ERROR "No such fontclass as " FONTCLASS) ELSE (* ;; "the bucket looks like") (* ;; "(fontclass prettyfont# displayfont pressfont interpressfont") (* ;; " (dev1 dev1-font) (dev2 dev2-font) ... )") [SELECTQ DEVICE (DISPLAY (CL:SETF (CL:THIRD BUCKET) FONT-DESCRIPTION)) (PRESS (CL:SETF (CL:FOURTH BUCKET) FONT-DESCRIPTION)) (INTERPRESS (CL:SETF (CL:FIFTH BUCKET) FONT-DESCRIPTION)) (DESTRUCTURING-BIND (CLASS-NAME PRETTY-FONT# DISPLAY-FONT PRESS-FONT INTERPRESS-FONT . A-LIST) BUCKET (IF (NULL A-LIST) THEN (RPLACD (LAST BUCKET) (LIST (LIST DEVICE FONT-DESCRIPTION))) ELSE (PUTASSOC DEVICE (LIST FONT-DESCRIPTION) A-LIST] BUCKET))) (CL:DEFUN \GET-FROM-FONTPROFILE (FONTPROFILE FONTCLASS DEVICE) (* ;; "Retunrs the DEVICE component of the FONTCLASS entry of FONTPROFILE.") [LET ((BUCKET (FASSOC FONTCLASS FONTPROFILE))) (IF (NULL BUCKET) THEN (ERROR "No such fontclass as " FONTCLASS) ELSE (* ;; "the bucket looks like") (* ;; "(fontclass prettyfont# displayfont pressfont interpressfont") (* ;; " (dev1 dev1-font) (dev2 dev2-font) ... )") (SELECTQ DEVICE (DISPLAY (CL:THIRD BUCKET)) (PRESS (CL:FOURTH BUCKET)) (INTERPRESS (CL:FIFTH BUCKET)) (DESTRUCTURING-BIND (CLASS-NAME PRETTY-FONT# DISPLAY-FONT PRESS-FONT INTERPRESS-FONT . A-LIST) BUCKET (IF (NULL A-LIST) THEN NIL ELSE (CADR (FASSOC DEVICE A-LIST]) (* ;;; "initialization") (DECLARE%: DONTEVAL@LOAD DOCOPY (\HQFX80.INIT) (\FASTFX80.INIT) ) (PUTPROPS FX-80DRIVER FILETYPE CL:COMPILE-FILE) (PUTPROPS FX-80DRIVER COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4418 8707 (\FASTFX80.INIT 4428 . 8705)) (8790 10727 (OPENFASTFX80STREAM 8800 . 10725)) (12632 13264 (\FASTFX80.CLOSE 12642 . 13262)) (13306 18268 (\FASTFX80.CHANGEFONT 13316 . 16540) ( \FASTFX80.FONTCREATE 16542 . 17305) (\FASTFX80.CREATECHARSET 17307 . 18266)) (19096 22229 ( \FASTFX80.STRINGWIDTH 19106 . 20565) (\FASTFX80.CHARWIDTH 20567 . 21204) (\FASTFX80.SUBCHARWIDTH 21206 . 22227)) (22810 35399 (\FASTFX80.CLIPPINGREGION 22820 . 23756) (\FASTFX80.MOVETO 23758 . 24027) ( \FASTFX80.XPOSITION 24029 . 26173) (\FASTFX80.YPOSITION 26175 . 28678) (\FASTFX80.BACKUP.PAPER 28680 . 29447) (\FASTFX80.ADVANCE.PAPER 29449 . 30313) (\FASTFX80.NEWPAGE 30315 . 30661) (\FASTFX80.OUTCHAR 30663 . 33017) (\FASTFX80.NEWLINE 33019 . 34075) (\FASTFX80.LINEFEED 34077 . 35114) ( \FASTFX80.DRAWLINE 35116 . 35397)) (43264 43641 (\FASTFX80.CONVERT-TEDIT 43274 . 43639)) (43689 43991 (\FASTFX80.BOUT 43699 . 43989)) (51112 55226 (\HQFX80.INIT 51122 . 55224)) (55309 60662 ( OPENHQFX80STREAM 55319 . 60660)) (62320 63172 (\HQFX80.CLOSE 62330 . 63170)) (63214 81061 ( \HQFX80.FONTCREATE 63224 . 63964) (\HQFX80.CHANGEFONT 63966 . 65474) (\HQFX80.CREATECHARSET 65476 . 74398) (\HQFX80.CHANGE-CHARSET 74400 . 76923) (\HQFX80.READ-FONT-FILE 76925 . 78694) ( \HQFX80.SEARCH-FONTS 78696 . 81059)) (81883 83843 (\HQFX80.CHARWIDTH 81893 . 82479) ( \HQFX80.STRINGWIDTH 82481 . 83841)) (84408 93048 (\HQFX80.CLIPPINGREGION 84418 . 85640) ( \HQFX80.LEFTMARGIN 85642 . 86407) (\HQFX80.RIGHTMARGIN 86409 . 87138) (\HQFX80.TOPMARGIN 87140 . 87704 ) (\HQFX80.BOTTOMMARGIN 87706 . 88282) (\HQFX80.XPOSITION 88284 . 88753) (\HQFX80.YPOSITION 88755 . 89450) (\HQFX80.NEWLINE 89452 . 90869) (\HQFX80.NEWPAGE 90871 . 91300) (\HQFX80.LINEFEED 91302 . 91840 ) (\HQFX80.RESET 91842 . 92080) (\HQFX80.STARTPAGE 92082 . 93046)) (93370 121105 (\HQFX80.BITBLT 93380 . 100624) (\HQFX80.BLTSHADE 100626 . 105377) (\HQFX80.DRAWELLIPSE 105379 . 119620) (\HQFX80.OPERATION 119622 . 120519) (\HQFX80.DRAWPOINT 120521 . 121103)) (121106 138506 (\HQFX80.DRAWLINE 121116 . 124334) (\HQFX80.CLIP-AND-DRAW-LINE 124336 . 129547) (\HQFX80.CLIP-AND-DRAW-LINE1 129549 . 138504)) ( 138507 147502 (\HQFX80.DRAWCIRCLE 138517 . 145135) (\HQFX80.CREATE-BRUSH-BBT 145137 . 147500)) (148030 158201 (\HQFX80.FILLCIRCLE 148040 . 157839) (\HQFX80.DRAWARC 157841 . 158199)) (158800 187712 ( \HQFX80.DRAWCURVE 158810 . 160703) (\HQFX80.DRAWCURVE2 160705 . 172341) (\HQFX80.DRAWCURVE3 172343 . 177985) (\HQFX80.LINEWITHBRUSH 177987 . 187710)) (187713 191170 (\HQFX80.BBTCURVEPT 187723 . 191168)) (196235 200273 (\HQFX80.OUTCHAR 196245 . 198172) (\HQFX80.BLT-CHAR 198174 . 200271)) (200304 204819 ( \HQFX80.DUMP-PAGE-BUFFER 200314 . 204475) (\HQFX80.ADVANCE-8-LINES 204477 . 204817)) (210073 213672 ( \HQFX80.BITMAP-FILE 210083 . 213303) (\HQFX80.CONVERT-TEDIT 213305 . 213670)) (213720 214019 ( \HQFX80.BOUT 213730 . 214017)) (214071 217696 (\HQFX80.FIX-LINE-LENGTH 214081 . 214882) ( \HQFX80.FIX-FONT 214884 . 215200) (\HQFX80.FIX-Y 215202 . 217694)) (219246 222132 ( \HQFX80.PRINTER-MODE 219256 . 222130))))) STOP \ No newline at end of file diff --git a/library/GCHAX b/library/GCHAX new file mode 100644 index 00000000..f05f5f77 --- /dev/null +++ b/library/GCHAX @@ -0,0 +1,387 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "20-Oct-94 10:19:00" {DSK}library>GCHAX.;6 61574 + + changes to%: (FNS \SEE-GC-ENTRY \SFLHASHLOOKUP \MAPGC) + + previous date%: "19-Oct-94 13:22:23" {DSK}library>GCHAX.;4) + + +(* ; " +Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1992, 1994 by Syntelligence Systems, Inc. This program or documentation contains confidential information and trade secrets of Syntelligence Systems, Inc. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Syntelligence Systems, Inc. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets. All rights reserved. +") + +(PRETTYCOMPRINT GCHAXCOMS) + +(RPAQQ GCHAXCOMS [(COMS (* ; "Looking at gc table") + (FNS \MAPGC \SHOWGC \GCENTRIES.BY.TYPE \#COLLISIONS \#OVERFLOWS + \GCSTATS.AUX \SEE-GC-ENTRY)) + (COMS (* ; "Hacking free lists") + (FNS \PRINTFREELIST \SHOWFREELISTS \SCANFREELIST \ISONFREELIST) + (FNS PFL SFL) + (FNS \COLLECTINUSE \SORTFREELIST \SFLHASHLOOKUP)) + (COMS (* ; "finding circularities") + (FNS \SHOWCIRCULARITY \SHOWCIRCULARITY1 \SHOWCIRCULARLIST + \SHOWCIRCULARPATH)) + (COMS (* ; + "special window storage leak finder") + (FNS \SHOW.CLOSED.WINDOWS \WINDOW.ACCOUNTED.FOR?)) + (COMS (* ; + "Brute force search for raw pointers") + (FNS \FINDPOINTER \FINDPOINTERS.OF.TYPE \FINDPOINTER.FOUND + \FINDPOINTER.NEWITEM \FINDPOINTER.LISTP \FINDPOINTER.LISTP.FREE + \FINDPOINTER.TYPE \FINDPOINTER.INTERPRET.RECORD \FINDPOINTER.STACK + \FINDPOINTER.PARSE.STACK \FINDPOINTER.FOUND.ON.STACK)) + (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \COERCETOTYPENUMBER + .ALLOCATED.PER.PAGE. MDSTYPE#) + (FILES (LOADCOMP) + LLGC LLBASIC) + (LOCALVARS . T) + (GLOBALVARS SYSTEMRECLST)) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + (ADDVARS (NLAMA SFL PFL) + (NLAML) + (LAMA]) + + + +(* ; "Looking at gc table") + +(DEFINEQ + +(\MAPGC + [LAMBDA (MAPFN INCLUDEZEROCNT) (* ; "Edited 20-Oct-94 10:04 by sybalsky") + (PROG ((I 0) + ENTRY LINK OVENTRY CNT) + LP (SETQ ENTRY (\ADDBASE \HTMAIN (LLSH I 1))) + [COND + ((fetch (GC EMPTY) of ENTRY)) + [(NOT (fetch (GC LINKP) of ENTRY)) + (COND + ((OR INCLUDEZEROCNT (NEQ (fetch (GC CNT) of ENTRY) + 0)) + (APPLY* MAPFN (\VAG2 (fetch (GC HIBITS) of ENTRY) + (LLSH I 1)) + [COND + ((ILESSP (SETQ CNT (fetch (GC CNT) of ENTRY)) + \MAXHTCNT) + CNT) + (T (\GC.LOOKUP.BIGREFCNT (\VAG2 (fetch (GC HIBITS) of ENTRY) + (LLSH I 1] + NIL] + (T (SETQ LINK (fetch (GC LINKPTR) of ENTRY)) + (do (SETQ OVENTRY (\ADDBASE \HTCOLL (LLSH LINK 1))) + (SETQ LINK (fetch (GC NXTPTR) of OVENTRY)) + (COND + ((OR (NEQ (SETQ CNT (fetch (GC CNT) of OVENTRY)) + 0) + INCLUDEZEROCNT) + (APPLY* MAPFN (\VAG2 (fetch (GC HIBITS) of OVENTRY) + (LLSH I 1)) + [COND + ((ILESSP CNT \MAXHTCNT) + CNT) + (T (\GC.LOOKUP.BIGREFCNT (\VAG2 (fetch (GC HIBITS) + of OVENTRY) + (LLSH I 1] + T))) repeatuntil (EQ LINK 0] + (COND + ((ILESSP (add I 1) + 32768) + (GO LP]) + +(\SHOWGC [LAMBDA (ONLYTYPES COLLECT FILE CARLVL CDRLVL MINCNT) (* ; "Edited 23-Jan-87 16:44 by jop") (OR CARLVL (SETQ CARLVL 2)) (OR CDRLVL (SETQ CDRLVL 6)) (OR MINCNT (SETQ MINCNT 2)) [COND (ONLYTYPES (SETQ ONLYTYPES (for TYPE inside ONLYTYPES collect (\COERCETOTYPENUMBER TYPE] (RESETLST [RESETSAVE (OUTPUT (COND ((NULL FILE) T) ((OPENP FILE 'OUTPUT)) (T [RESETSAVE NIL (LIST 'CLOSEF (SETQ FILE (OPENFILE FILE 'OUTPUT] FILE] (printout NIL " cnt datum" T) (PROG [(TOTALCNT 0) (COLLCNT 0) (MAXCNT 0) (SELECTEDITEMS (AND COLLECT (CONS] (DECLARE (SPECVARS TOTALCNT COLLCNT MAXCNTSELECTEDITEMS)) (SETQ RESULT SELECTEDITEMS) (\MAPGC [FUNCTION (LAMBDA (PTR CNT COLL?) (COND ((AND (OR (NOT ONLYTYPES) (FMEMB (NTYPX PTR) ONLYTYPES)) (IGEQ CNT MINCNT)) (printout NIL (COND (COLL? '*) (T '% )) CNT %,,) (LVLPRINT PTR NIL CARLVL CDRLVL) (COND (COLLECT [SETQ SELECTEDITEMS (CDR (FRPLACD SELECTEDITEMS (CONS PTR NIL] (* ;  "Use RPLCONS to minimize refcnt operations") )) (add TOTALCNT 1) (COND (COLL? (add COLLCNT 1))) (COND ((IGEQ CNT \MAXHTCNT) (* ; "Means its a big ref count case") (add MAXCNT 1] (ILESSP MINCNT 1)) (printout NIL TOTALCNT " items with reference cnt greater than or equal to " MINCNT T) (COND ((AND (ILESSP MINCNT \MAXHTCNT) (NEQ MAXCNT 0)) (printout NIL MAXCNT " items with overflowed reference cnt" T))) (printout NIL COLLCNT " collision entries" T) (RETURN (COND (COLLECT (CDR RESULT)) (T FILE]) + +(\GCENTRIES.BY.TYPE [LAMBDA (MINREFCNT MINFRACTION) (DECLARE (SPECVARS MINREFCNT \#COLLISIONS \#OFENTRIES TYPETABLE)) (* ; "Edited 26-Jan-87 16:46 by jop") (OR MINREFCNT (SETQ MINREFCNT 0)) (OR MINFRACTION (SETQ MINFRACTION 0.002)) (PROG ((TYPECOUNTS (ARRAY (ADD1 \MaxTypeNumber) 'WORD 0 0)) (TYPECOLLISIONS (ARRAY (ADD1 \MaxTypeNumber) 'WORD 0 0)) (\#OFENTRIES 0) (\#COLLISIONS 0) (PRINTEDENTRIES 0) (PRINTEDCOLLISIONS 0) (MAXWIDTH 0) CNT FRAC) (DECLARE (SPECVARS \#OFENTRIES TYPECOUNTS \#COLLISIONS TYPECOLLISIONS)) [\MAPGC (FUNCTION (LAMBDA (PTR REFCNT COLL?) (PROG (TYPE) (COND ((IGEQ REFCNT MINREFCNT) (add \#OFENTRIES 1) (add (ELT TYPECOUNTS (NTYPX PTR)) 1) (COND (COLL? (add \#COLLISIONS 1) (add (ELT TYPECOLLISIONS (NTYPX PTR)) 1] [for I from 0 to \MaxTypeNumber bind N do (COND ((IGREATERP (SETQ N (NCHARS ( \TYPENAMEFROMNUMBER I))) MAXWIDTH) (SETQ MAXWIDTH N] (COND ((IGREATERP MINREFCNT 0) (printout T " with reference count at least " |.P2| MINREFCNT))) (printout T T .FR MAXWIDTH "Type" " all entries collisions" T T) (for TYPE# from 0 to \MaxTypeNumber when (AND (NEQ (SETQ CNT (ELT TYPECOUNTS TYPE#)) 0) (FGREATERP (SETQ FRAC (FQUOTIENT CNT \#OFENTRIES)) MINFRACTION)) do (printout T .FR MAXWIDTH (OR (\TYPENAMEFROMNUMBER TYPE#) (CONCAT "Type " TYPE#)) |.I7| CNT |.F6.1| (FTIMES 100.0 FRAC) "%%") (add PRINTEDENTRIES CNT) (COND ([NOT (EQ 0 (SETQ CNT (ELT TYPECOLLISIONS TYPE#] (add PRINTEDCOLLISIONS CNT) (printout T |.I10| CNT |.F6.1| (FTIMES 100.0 (FQUOTIENT CNT \#COLLISIONS)) "%%"))) (TERPRI T)) (printout T .FR MAXWIDTH "All other types" |.I7| (SETQ CNT (IDIFFERENCE \#OFENTRIES PRINTEDENTRIES)) |.F6.1| (FTIMES 100.0 (FQUOTIENT CNT \#OFENTRIES)) "%%") (printout T |.I10| (SETQ CNT (IDIFFERENCE \#COLLISIONS PRINTEDCOLLISIONS)) |.F6.1| (FTIMES 100.0 (FQUOTIENT CNT \#COLLISIONS)) "%%" T) (printout T T .FR MAXWIDTH "Total" |.I7| \#OFENTRIES |.I17| \#COLLISIONS T T]) + +(\#COLLISIONS [LAMBDA NIL (* JonL "28-Jan-84 04:20") (\GCSTATS.AUX '\#COLLISIONS]) + +(\#OVERFLOWS [LAMBDA NIL (* JonL "28-Jan-84 04:20") (\GCSTATS.AUX '\#OVERFLOWS]) + +(\GCSTATS.AUX [LAMBDA (\GCTYPE.AUX) (* ; "Edited 26-Jan-87 16:47 by jop") (LET ((\#GCENTRIES 0) (\#GCLOSERS 0)) (DECLARE (SPECVARS \#GCENTRIES \#GCLOSERS \GCTYPE.AUX)) [\MAPGC (FUNCTION (LAMBDA (PTR REFCNT COLLISIONP) (add \#GCENTRIES 1) (SELECTQ \GCTYPE.AUX (\#OVERFLOWS (COND ((IGEQ REFCNT \MAXHTCNT) (add \#GCLOSERS 1)))) (\#COLLISIONS (COND (COLLISIONP (add \#GCLOSERS 1)))) (SHOULDNT] (LIST \#GCENTRIES \#GCLOSERS (QUOTIENT (FLOAT \#GCLOSERS) \#GCENTRIES) (QUOTIENT (FLOAT \#GCENTRIES) \HTMAINSIZE]) + +(\SEE-GC-ENTRY + [LAMBDA (OFFSET) (* ; "Edited 20-Oct-94 10:15 by sybalsky") + (LET ((ENTRY (\ADDBASE \HTMAIN (LLSH OFFSET 1))) + POINTER LINK OVENTRY CNT) + (COND + ((fetch (GC EMPTY) of ENTRY) + "EMPTY") + [(NOT (fetch (GC LINKP) of ENTRY)) + (COND + ((NEQ (fetch (GC CNT) of ENTRY) + 0) + (SETQ POINTER (\VAG2 (fetch (GC HIBITS) of ENTRY) + (LLSH OFFSET 1))) + (SETQ CNT (fetch (GC CNT) of ENTRY)) + [COND + ((>= CNT \MAXHTCNT) + (SETQ CNT (\GC.LOOKUP.BIGREFCNT POINTER] + (CL:FORMAT T "ENTRY: ~O POINTER ~S CNT: ~A ~%%" ENTRY POINTER CNT] + (T (SETQ LINK (fetch (GC LINKPTR) of ENTRY)) + (do (SETQ OVENTRY (\ADDBASE \HTCOLL (LLSH LINK 1))) + (SETQ LINK (fetch (GC NXTPTR) of OVENTRY)) + (COND + ((NEQ (SETQ CNT (fetch (GC CNT) of OVENTRY)) + 0) + (SETQ POINTER (\VAG2 (fetch (GC HIBITS) of OVENTRY) + (LLSH OFFSET 1))) + (SETQ CNT (fetch (GC CNT) of OVENTRY)) + [COND + ((>= CNT \MAXHTCNT) + (SETQ CNT (\GC.LOOKUP.BIGREFCNT POINTER] + (CL:FORMAT T "OVENTRY: ~O LINKPOINTER: ~S CNT: ~A LINK: ~A~%%" OVENTRY + POINTER CNT LINK))) repeatuntil (EQ LINK 0]) +) + + + +(* ; "Hacking free lists") + +(DEFINEQ + +(\PRINTFREELIST + [LAMBDA (TYPE DETAILS FILE) (* ; "Edited 19-Oct-94 12:27 by sybalsky") + (SETQ TYPE (\COERCETOTYPENUMBER TYPE)) + (SETQ FILE (\GETSTREAM FILE 'OUTPUT)) + (PROG ((SIZE (fetch DTDSIZE of (\GETDTD TYPE))) + INFO TOTALPAGES MAXFREE TOTALLYFREE FREE) + (CL:FORMAT FILE "Type ~S: " (\TYPENAMEFROMNUMBER TYPE)) + (if (EQ SIZE 0) + then (printout FILE "not an allocated type" T T) + (RETURN)) + (if [AND (SETQ INFO (\SCANFREELIST TYPE DETAILS FILE)) + (NOT (FIXP (CDAR INFO] + then (* ; "Silly LISTP case") + (printout FILE T (pop INFO) + T T) + (RETURN)) + (if (EQ (SETQ FREE (for X in INFO sum (CDR X))) + 0) + then (printout FILE "Free list is empty" T T) + (RETURN)) + (CL:FORMAT FILE "~D cells free~%%Free list covers ~D Pages with ~D extra hops~%%" FREE + [SETQ TOTALPAGES (LENGTH (for X in INFO do (pushnew $$VAL + (CAR X] + (- (LENGTH INFO) + TOTALPAGES)) + (SETQ MAXFREE (IQUOTIENT \MDSIncrement SIZE)) + (SETQ TOTALLYFREE 0) + (for PAIR in (SORT (APPEND INFO) + T) bind (PREVPAGE _ 0) + PREVFREE + do (if [NOT (OR (EQ (CAR PAIR) + PREVPAGE) + (EQ (CAR PAIR) + (+ PREVPAGE 1] + then (* ; + "not part of same page pair previously counted") + (SETQ PREVPAGE (CAR PAIR)) + (SETQ PREVFREE 0)) + (if (EQ (add PREVFREE (CDR PAIR)) + MAXFREE) + then (* ; "completely free page pair") + (add TOTALLYFREE 2) + (SETQ PREVPAGE 0))) + (if (> TOTALLYFREE 0) + then (CL:FORMAT FILE "~D pages are reclaimable~%%" TOTALLYFREE)) + (COND + (DETAILS (printout FILE "Details (page/#free):" T) + [for TAIL on (REVERSE INFO) + bind (I _ 0) + (N _ (SUB1 (IQUOTIENT (LINELENGTH NIL FILE) + 12))) do (printout FILE .TAB (ITIMES I 12) + .I6.8 + (CAR (CAR TAIL)) + "/" .I3 (CDR (CAR TAIL))) + [COND + ((ASSOC (CAAR TAIL) + (CDR TAIL)) + (printout FILE '+] + (COND + ((> (add I 1) + N) + (SETQ I 0] + (TERPRI FILE))) + (TERPRI FILE) + (RETURN TOTALLYFREE]) + +(\SHOWFREELISTS [LAMBDA (DETAILS FILE) (* ; "Edited 5-Feb-87 15:01 by bvm:") (SETQ FILE (\GETSTREAM FILE 'OUTPUT)) (for I from 2 to \MaxTypeNumber sum (OR (\PRINTFREELIST I DETAILS FILE) 0) unless [OR (EQ I \LISTP) (NULL (fetch DTDFREE of (\GETDTD I] finally (RETURN (CONCAT $$VAL " total free pages"]) + +(\SCANFREELIST + [LAMBDA (TYPE DETAILS FILE) (* ; "Edited 19-Oct-94 12:27 by sybalsky") + + (* ;; "Scans free list of type TYPE and returns a list of pairs (page# . freecount) indicating how many free items are on each page") + + (PROG (RESULT FREE (LASTPAGE -1) + LASTPAGECOUNT THISPAGE) + (SETQ TYPE (\COERCETOTYPENUMBER TYPE)) + [COND + ((EQ TYPE \LISTP) + (RETURN (CONS (LIST "LISTP scan not implemented"] + (SETQ FREE (fetch DTDFREE of (\GETDTD TYPE))) + (while FREE do (AND DETAILS (PRINT FREE FILE)) + (SETQ THISPAGE (fetch (POINTER PAGE#) of FREE)) + (COND + ((IEQP THISPAGE LASTPAGE) + (add LASTPAGECOUNT 1)) + (T [COND + (LASTPAGE (push RESULT (CONS LASTPAGE LASTPAGECOUNT] + (COND + ((NEQ (NTYPX FREE) + TYPE) + (push RESULT (LIST "Bad free list at" (\HILOC FREE) + (\LOLOC FREE))) + (RETURN))) + (SETQ LASTPAGE THISPAGE) + (SETQ LASTPAGECOUNT 1))) + (SETQ FREE (fetch FREELINK of FREE))) + [COND + (LASTPAGE (push RESULT (CONS LASTPAGE LASTPAGECOUNT] + (RETURN RESULT]) + +(\ISONFREELIST [LAMBDA (OBJECT) (* bvm%: " 6-Dec-83 17:44") (PROG ((TYPE (NTYPX OBJECT)) FREE) (COND ((EQ TYPE \LISTP) (RETURN "LISTP scan not implemented"))) (SETQ FREE (fetch DTDFREE of (\GETDTD TYPE))) (RETURN (while FREE do (COND ((EQ OBJECT FREE) (RETURN T))) (SETQ FREE (fetch FREELINK of FREE]) +) +(DEFINEQ + +(PFL [NLAMBDA X (* bvm%: " 5-Dec-83 18:46") (\PRINTFREELIST X T]) + +(SFL [NLAMBDA X (* bvm%: " 5-Dec-83 18:47") (\SORTFREELIST X) (\PRINTFREELIST X T]) +) +(DEFINEQ + +(\COLLECTINUSE [LAMBDA (TYPE PRED) (* ; "Edited 5-Feb-87 15:46 by bvm:") (SETQ TYPE (\COERCETOTYPENUMBER TYPE)) (RPTQ 20 (RECLAIM)) (RESETFORM (RECLAIMMIN MAX.SMALLP) (UNINTERRUPTABLY (PROG ((HASHTABLE (\SORTFREELIST TYPE T)) (SIZE (fetch DTDSIZE of (\GETDTD TYPE))) RESULT FIRSTFREE LASTFREE HASHENT LASTPAGE LIMIT) (OR HASHTABLE (RETURN)) (OR (EVENP SIZE) (SHOULDNT "Odd size?")) (COND ((.ALLOCATED.PER.PAGE. SIZE) (SETQ LASTPAGE (SUB1 \PagesPerMDSUnit)) (SETQ LIMIT WORDSPERPAGE)) (T (SETQ LASTPAGE 0) (SETQ LIMIT \MDSIncrement))) [for MDSPAGE# from 0 by \PagesPerMDSUnit while (<= MDSPAGE# \MAXVMPAGE) when (EQ (MDSTYPE# MDSPAGE#) TYPE) do [COND ([SETQ FIRSTFREE (COND ((SETQ HASHENT (OR (\SFLHASHLOOKUP MDSPAGE# HASHTABLE) (\SFLHASHLOOKUP (LOGOR MDSPAGE# 1) HASHTABLE))) (\VAG2 (FOLDLO MDSPAGE# PAGESPERSEGMENT) (fetch HASHFIRSTOFFSET of HASHENT] (SETQ LASTFREE (fetch HASHLASTFREE of (OR (AND (EVENP (fetch HASHPAGE# of HASHENT)) (\SFLHASHLOOKUP (LOGOR MDSPAGE# 1) HASHTABLE)) HASHENT] (* ;; "Now collect all pointers not on free list. This code parallels \INITMDSPAGE") (for N from 0 to LASTPAGE do (for (DISP _ 0) while (<= (add DISP SIZE) LIMIT) as (DATUMBASE _ (create POINTER PAGE# _ (IPLUS N MDSPAGE#))) by (\ADDBASE DATUMBASE SIZE) when (AND (OR (NOT FIRSTFREE) (for (X _ FIRSTFREE) by (fetch FREELINK of X) never (EQ X DATUMBASE) repeatuntil (EQ X LASTFREE))) (OR (NOT PRED) (CL:FUNCALL PRED DATUMBASE))) do (push RESULT DATUMBASE] (RETURN RESULT)))]) + +(\SORTFREELIST [LAMBDA (TYPE FLG READONLY) (* ; "Edited 5-Feb-87 15:47 by bvm:") (SETQ TYPE (\COERCETOTYPENUMBER TYPE)) (PROG ((DTD (\GETDTD TYPE)) NPAGES HASHTABLE HASHENT HSIZE NEXTFREE NEXTPAGE LASTPAGE FIRSTFREE LASTFREE OTHERLASTFREE PREVPAGELASTFREE PROBE MASK) (COND ((EQ TYPE \LISTP) (RETURN))) (SETQ NPAGES (ITIMES (for I from 0 to \MAXVMPAGE by 2 count (EQ (MDSTYPE# I) TYPE)) 2)) (SETQ HSIZE (FIX (TIMES NPAGES 1.4))) (* ;  "Good size of hashtable for hashing pages of this type into") (SETQ HSIZE (find I from 8 by I suchthat (IGREATERP I HSIZE))) (* ; "Get a power of 2") (SETQ HASHTABLE (\ALLOCBLOCK (ITIMES HSIZE 2))) (replace HASHMASK of HASHTABLE with (SUB1 (ITIMES HSIZE 4))) (SETQ NEXTFREE (fetch DTDFREE of DTD)) [do (COND ((NEQ (SETQ NEXTPAGE (fetch (POINTER PAGE#) of NEXTFREE)) LASTPAGE) (* ; "Cell on a new page") [COND ((AND NEXTFREE (NEQ (NTYPX NEXTFREE) TYPE)) (RETURN (RAID "Bad free list" NEXTFREE] (COND (LASTPAGE (* ;  "Hash LASTPAGE and see if we have already seen cells free on this page") (SETQ HASHENT (\SFLHASHLOOKUP LASTPAGE HASHTABLE T)) (COND [(SETQ OTHERLASTFREE (fetch HASHLASTFREE of HASHENT)) (* ;  "Yes, we have seen others. Link this section of the free list into it") (COND ((EQ (fetch FREELINK of OTHERLASTFREE) FIRSTFREE) (* ;; "Aha, already in order. This happens when we have a sequence LASTPAGE -> x ... -> LASTPAGE where everything in between the two LASTPAGE's got moved to earlier in the freelist") (SETQ PREVPAGELASTFREE LASTFREE)) ((NOT READONLY) (UNINTERRUPTABLY [replace FREELINK of OTHERLASTFREE with (PROG1 FIRSTFREE (replace FREELINK of (OR PREVPAGELASTFREE (RETURN (RAID "No PREVPAGELASTFREE" ))) with NEXTFREE) (replace FREELINK of LASTFREE with (fetch FREELINK of OTHERLASTFREE])] (T (replace HASHFIRSTOFFSET of HASHENT with (\LOLOC FIRSTFREE)) (SETQ PREVPAGELASTFREE LASTFREE))) (replace HASHLASTFREE of HASHENT with LASTFREE))) (OR (SETQ FIRSTFREE NEXTFREE) (RETURN)) (SETQ LASTPAGE NEXTPAGE))) (SETQ NEXTFREE (fetch FREELINK of (SETQ LASTFREE NEXTFREE] (SETQ LASTPAGE (SETQ PREVPAGELASTFREE)) (SETQ NEXTFREE (fetch DTDFREE of DTD)) (* ;; "Now take a quick second pass to link all odd pages immediately after the corresponding even pages. Might possibly have done this in the previous loop, but the logic gets pretty messy") [do (COND ((NEQ (SETQ NEXTPAGE (fetch (POINTER PAGE#) of NEXTFREE)) LASTPAGE) (* ; "Cell on a new page") [COND (LASTPAGE (COND [(AND (ODDP LASTPAGE) (SETQ HASHENT (\SFLHASHLOOKUP (LOGXOR LASTPAGE 1) HASHTABLE)) (NEQ (fetch FREELINK of (SETQ OTHERLASTFREE (fetch HASHLASTFREE of HASHENT))) FIRSTFREE)) (* ;  "There is an entry for our partner even page, and it is not immediately followed by its odd partner") (OR READONLY (UNINTERRUPTABLY [replace FREELINK of OTHERLASTFREE with (PROG1 FIRSTFREE (COND (PREVPAGELASTFREE (replace FREELINK of PREVPAGELASTFREE with NEXTFREE)) (T (OR (EQ FIRSTFREE (fetch DTDFREE of DTD)) (RAID "No PREVPAGELASTFREE")) (replace DTDFREE of DTD with NEXTFREE ))) (replace FREELINK of LASTFREE with (fetch FREELINK of OTHERLASTFREE])] (T (SETQ PREVPAGELASTFREE LASTFREE] (OR (SETQ FIRSTFREE NEXTFREE) (RETURN)) (SETQ LASTPAGE NEXTPAGE))) (SETQ NEXTFREE (fetch FREELINK of (SETQ LASTFREE NEXTFREE] (RETURN (AND FLG HASHTABLE]) + +(\SFLHASHLOOKUP + [LAMBDA (PAGE# HASHTABLE INSERT) (* JonL "28-Dec-84 19:33") + (bind (MASK _ (fetch HASHMASK of HASHTABLE)) + PROBE HASHENT first (SETQ PROBE (LOGAND (LLSH PAGE# 2) + MASK)) + do [COND + ((IEQP (fetch HASHPAGE# of (SETQ HASHENT (\ADDBASE HASHTABLE PROBE))) + PAGE#) + (RETURN HASHENT)) + ((EQ 0 (fetch HASHPAGE# of HASHENT)) + (RETURN (COND + (INSERT (replace HASHPAGE# of HASHENT with PAGE#) + HASHENT] + (SETQ PROBE (LOGAND (IPLUS PROBE 4) + MASK]) +) + + + +(* ; "finding circularities") + +(DEFINEQ + +(\SHOWCIRCULARITY [LAMBDA (OBJECT MAXLEVEL) (* bvm%: "13-Dec-83 12:57") (DECLARE (SPECVARS CIRCLEHASH OBJECT MAXLEVEL)) (PROG [(CIRCLEHASH (LIST (HARRAY 100] (OR (AND (FIXP MAXLEVEL) (IGREATERP MAXLEVEL 0)) (SETQ MAXLEVEL 1000)) (\SHOWCIRCULARITY1 OBJECT]) + +(\SHOWCIRCULARITY1 [LAMBDA (OBJ PATH) (* bvm%: "13-Dec-83 12:09") (DECLARE (USEDFREE OBJECT CIRCLEHASH MAXLEVEL)) (COND ((AND (EQ OBJ OBJECT) PATH) (\SHOWCIRCULARPATH PATH)) (T (PROG ((TYPE (NTYPX OBJ)) PTRS B) (SELECTC TYPE (\LISTP (push PATH OBJ) (\SHOWCIRCULARLIST (CAR OBJ) PATH MAXLEVEL) (\SHOWCIRCULARLIST (CDR OBJ) PATH MAXLEVEL)) (\STRINGP (* ;  "No circularity possible, although it does have one pointer field")) (0 [COND ((AND (type? ARRAYBLOCK OBJ) [IEQ \ArrayBlockPassword (fetch PASSWORD of (SETQ B (\ADDBASE OBJ (IMINUS \ArrayBlockHeaderWords ] (fetch (ARRAYBLOCK INUSE) of B) (EQ (fetch (ARRAYBLOCK GCTYPE) of B) PTRBLOCK.GCT) (NOT (GETHASH OBJ CIRCLEHASH))) (* ;  "B points to arrayblock header, OBJ to first and subsequent data words") (PUTHASH OBJ T CIRCLEHASH) (push PATH OBJ) (for old OBJ (TRAILER _ (fetch (ARRAYBLOCK TRAILER) of B)) by (\ADDBASE OBJ WORDSPERCELL) until (EQ OBJ TRAILER) do (\SHOWCIRCULARITY1 (\GETBASEPTR OBJ 0) PATH]) (COND ((AND (SETQ PTRS (fetch DTDPTRS of (\GETDTD TYPE))) (NOT (GETHASH OBJ CIRCLEHASH))) (PUTHASH OBJ T CIRCLEHASH) (push PATH OBJ) (for I in PTRS do (\SHOWCIRCULARITY1 (\GETBASEPTR OBJ I) PATH]) + +(\SHOWCIRCULARLIST [LAMBDA (LST PATH DEPTH) (* bvm%: " 6-Dec-83 16:53") (DECLARE (USEDFREE OBJECT)) (COND ((NLISTP LST) (\SHOWCIRCULARITY1 LST PATH)) ((EQ LST OBJECT) (\SHOWCIRCULARITY PATH)) ((NEQ DEPTH 0) (\SHOWCIRCULARLIST (CAR LST) PATH (SUB1 DEPTH)) (\SHOWCIRCULARLIST (CDR LST) PATH (SUB1 DEPTH]) + +(\SHOWCIRCULARPATH [LAMBDA (PATH) (* bvm%: " 6-Dec-83 16:39") (TERPRI T) [for X in (REVERSE (CONS OBJECT PATH)) bind PREFIX do (COND (PREFIX (PRIN1 " -> " T)) (T (SETQ PREFIX T))) (COND ((LISTP X) (LVLPRIN2 X T 1 3)) (T (PRIN2 X] (TERPRI T]) +) + + + +(* ; "special window storage leak finder") + +(DEFINEQ + +(\SHOW.CLOSED.WINDOWS [LAMBDA NIL (* bvm%: "11-Oct-84 21:42") (for (TAIL _ (\COLLECTINUSE 'WINDOW)) while TAIL bind (OPEN _ (OPENWINDOWS)) W MAIN unless (\WINDOW.ACCOUNTED.FOR? (SETQ W (pop TAIL))) sum (OPENW W) (CURSORPOSITION '(0 . 0) W) (if (MOUSECONFIRM "Click LEFT to close window, RIGHT to save" T) then (CLOSEW W) elseif (MOUSECONFIRM "Find pointers? Click LEFT to search, RIGHT to leave window open and go on" T) then (CLOSEW W) (RPTQ 10 (RECLAIM)) (\FINDPOINTER W)) 1]) + +(\WINDOW.ACCOUNTED.FOR? [LAMBDA (WINDOW) (* bvm%: "30-Jul-84 14:57") (OR (OPENWP WINDOW) (OPENWP (WINDOWPROP WINDOW 'ICONWINDOW)) (OPENWP (WINDOWPROP WINDOW 'ICONFOR)) (PROG [(MAIN (WINDOWPROP WINDOW 'MAINWINDOW] (RETURN (AND MAIN (\WINDOW.ACCOUNTED.FOR? MAIN]) +) + + + +(* ; "Brute force search for raw pointers") + +(DEFINEQ + +(\FINDPOINTER [LAMBDA (PTR COLLECT/INSPECT? ALLFLG MARGIN ALLBACKFLG) (* ; "Edited 13-Mar-87 14:55 by bvm:") (DECLARE (SPECVARS MARGIN REFSFOUND COLLECT/INSPECT?)) (OR MARGIN (SETQ MARGIN 0)) (PROG ((*PRINT-BASE* 10) (REFCNT (\REFCNT PTR)) (SAFESEGMENTS (SELECTQ ALLFLG ((NIL :STACK) [LIST (\HILOC \FPTOVP) (\HILOC \PAGEMAP) (\HILOC \PageMapTBL) (\HILOC \AtomHashTable) (\HILOC \PNPSPACE) (ADD1 (\HILOC \PNPSPACE)) (\HILOC \SMALLPOSPSPACE) (\HILOC \SMALLNEGSPACE) (\HILOC \HTMAIN) (\HILOC \HTCOLL) (\HILOC (fetch BITMAPBASE of (SCREENBITMAP]) NIL)) (STACKSEG (\HILOC \STACKSPACE)) (REFSFOUND 0) RESULT ATOMSEGMENTS SEGBASE POINTERSOURCE) (COND ((OR (NEQ REFCNT 1) (NOT ALLBACKFLG)) (printout T .TAB0 MARGIN "Reference count = " REFCNT T))) (COND ((AND (EQ REFCNT 0) (NOT ALLFLG)) (* ;  "if zero ref count, only reasonable hope is to find it on stack") (\FINDPOINTER.STACK PTR) (GO DONE))) (IF (NULL ALLFLG) THEN (* ;  "Don't scan stack unless allflg = :stack") (PUSH SAFESEGMENTS (\HILOC \STACKSPACE))) [for DTDPAGESONLY in '(T NIL) do (* ;  "More likely to find on typed pages first") (for SEGMENT from 1 to \MAXVMSEGMENT unless (FMEMB SEGMENT SAFESEGMENTS) do (SETQ SEGBASE (\VAG2 SEGMENT 0)) (for PAGEINSEG from 0 to (SUB1 PAGESPERSEGMENT) as PAGE# from (UNFOLD SEGMENT PAGESPERSEGMENT) as (PAGEBASE _ SEGBASE) by (\ADDBASE PAGEBASE WORDSPERPAGE) bind TYPE DTD STR when [COND [DTDPAGESONLY (AND (NEQ (SETQ TYPE (NTYPX PAGEBASE)) 0) (fetch DTDPTRS of (SETQ DTD (\GETDTD TYPE] (T (AND (EQ (SETQ TYPE (NTYPX PAGEBASE)) 0) (NEQ (\LOOKUPPAGEMAP PAGE#) 0) (OR (NEQ SEGMENT STACKSEG) (PROGN (* ;  "Don't look at released stack pages, even though they exist in the vmem -- could get stack fault") (ILESSP (\LOLOC PAGEBASE) (fetch (IFPAGE EndOfStack) of \InterfacePage] do (* ;  "Page exists and might contain pointers") (to CELLSPERPAGE as (BASE _ PAGEBASE) by (\ADDBASE BASE WORDSPERCELL) when (EQ (\GETBASEPTR BASE 0) PTR) do (COND ((SETQ POINTERSOURCE (SELECTC TYPE (0 (COND ([SETQ STR (CADR (ASSOC (FLOOR SEGMENT 2) (OR ATOMSEGMENTS (SETQ ATOMSEGMENTS (LIST (LIST (\HILOC \VALSPACE) "value") (LIST (\HILOC \DEFSPACE) "function definition" ) (LIST (\HILOC \PLISTSPACE) "property list"] (\FINDPOINTER.NEWITEM T) (printout T "as " STR " of atom " |.P2| [SETQ STR (\INDEXATOMPNAME (+ (LRSH (\LOLOC BASE) 1) (IF (ODDP SEGMENT) THEN (* ; "Second generation of symbols...") (LLSH 1 15) ELSE 0] T) STR) ((EQ SEGMENT STACKSEG) (* ; "Interpret stack") (\FINDPOINTER.FOUND.ON.STACK BASE)) (T (\FINDPOINTER.FOUND BASE) NIL))) (\LISTP (\FINDPOINTER.LISTP BASE ALLBACKFLG ALLFLG)) (\FINDPOINTER.TYPE BASE DTD ALLFLG))) (* ; "Accounted for a valid reference") (COND (COLLECT/INSPECT? (push RESULT POINTERSOURCE))) (COND ((AND (NOT ALLFLG) (EQ REFCNT REFSFOUND)) (GO DONE] DONE (COND ((AND COLLECT/INSPECT? (NEQ COLLECT/INSPECT? 'COLLECT)) (INSPECT RESULT) (SETQ RESULT NIL))) (RETURN (OR RESULT REFSFOUND]) + +(\FINDPOINTERS.OF.TYPE [LAMBDA (TYPE FILTER) (* bvm%: "28-Jun-84 11:51") (for (TAIL _ (\COLLECTINUSE TYPE)) while TAIL bind PTR (FILTERFNP _ (FNTYP FILTER)) declare (SPECVARS PTR) when [PROGN (SETQ PTR (pop TAIL)) (OR (NULL FILTER) (COND (FILTERFNP (APPLY* FILTER PTR)) (T (EVAL FILTER] do (* ;; "This odd control structure so that we get rid of the extra pointer from the list returned by \COLLECTINUSE") (RECLAIM) (RECLAIM) (\FINDPOINTER (PRINT PTR T)) (TERPRI T]) + +(\FINDPOINTER.FOUND [LAMBDA (BASE MSG) (* bvm%: "20-Jan-84 16:22") (\FINDPOINTER.NEWITEM NIL) (COND (MSG (printout T MSG))) (printout T "at location " |.I2.8| (\HILOC BASE) '%, |.I6.8| (\LOLOC BASE) T]) + +(\FINDPOINTER.NEWITEM [LAMBDA (COUNTIT) (DECLARE (USEDFREE MARGIN REFSFOUND)) (* bvm%: "20-Jan-84 16:13") (printout T .TAB0 MARGIN) (IF COUNTIT THEN (printout T (add REFSFOUND 1) ". ")) (printout T "Found ") COUNTIT]) + +(\FINDPOINTER.LISTP [LAMBDA (BASE ALLBACKFLG ALLFLG) (* ; "Edited 2-Feb-87 12:46 by bvm:") (DECLARE (USEDFREE REFSFOUND MARGIN)) (PROG ((PAGEBASE (fetch (POINTER PAGEBASE) of BASE)) (WORDOFFSET (fetch (POINTER WORDINPAGE) of BASE)) (NEWMARGIN MARGIN) CDRCODE TYPE DESIREDCDRCODE) (COND ((\FINDPOINTER.LISTP.FREE PAGEBASE WORDOFFSET) (if ALLFLG then (\FINDPOINTER.FOUND BASE "in freed list cell ")) (RETURN NIL))) (SETQ DESIREDCDRCODE (LRSH WORDOFFSET 1)) LP (* ; "Track this listp back on page") (for I from 2 to (IDIFFERENCE WORDSPERPAGE WORDSPERCELL) by WORDSPERCELL when (AND (EQ (LOGAND (SETQ CDRCODE (fetch (LISTP CDRCODE) of (\ADDBASE PAGEBASE I))) 127) DESIREDCDRCODE) (NOT (\FINDPOINTER.LISTP.FREE PAGEBASE I))) do [OR TYPE (SETQ TYPE (COND ((IGREATERP CDRCODE \CDR.MAXINDIRECT) (* ; "CDR on page") "an element") (T (* ; "CDR indirect on page") "a tail"] (SETQ BASE (\ADDBASE PAGEBASE I)) (SETQ DESIREDCDRCODE (LRSH I 1)) (GO LP)) (COND ((AND (NULL TYPE) (EQ 0 (\GETBASEBYTE BASE 0))) (* ;; "What we found was a full indirect cell pointing at a LISTP cell that (probably) someone told us to chase. So just chase it explicitly now.") (add REFSFOUND 1) (GO SEARCHMORE)) [ALLBACKFLG (COND ((EQ (\REFCNT BASE) 1) (add ALLBACKFLG 1) (add REFSFOUND 1) (printout T '%.) (GO SEARCHMORE)) (T (\FINDPOINTER.NEWITEM T) (printout T "somewhere inside list "] (T (\FINDPOINTER.NEWITEM T) (printout T "as " (OR TYPE 'CAR) " of list "))) (LVLPRINT BASE T 1 3) (TAB NEWMARGIN 0 T) (SELECTQ (PROG1 [ASKUSER DWIMWAIT 'N "Shall I search for pointers to this list? " '((Y "es") (N "o") (A "ll the way back"] (TERPRI T)) (N (RETURN BASE)) (A (SETQ ALLBACKFLG 1)) NIL) (add NEWMARGIN 3) SEARCHMORE (RETURN (COND ((NLISTP (SETQ TYPE (\FINDPOINTER BASE 'COLLECT NIL NEWMARGIN ALLBACKFLG))) BASE) ((CDR TYPE) TYPE) (T (CAR TYPE]) + +(\FINDPOINTER.LISTP.FREE [LAMBDA (PAGEBASE WORDOFFSET) (* bvm%: "20-Jan-84 11:39") (* ;; "True if the cell at WORDOFFSET after PAGEBASE is a free list cell") (for (FREE _ (fetch (CONSPAGE NEXTCELL) of PAGEBASE)) by (fetch (LISTP CDRCODE) of (\ADDBASE PAGEBASE FREE)) as I to (fetch (CONSPAGE CNT) of PAGEBASE) thereis (EQ FREE WORDOFFSET]) + +(\FINDPOINTER.TYPE [LAMBDA (BASE DTD ALLFLG) (* bvm%: " 3-Jan-85 21:21") (DECLARE (USEDFREE MARGIN COLLECT/INSPECT?)) (PROG ((SIZE (fetch DTDSIZE of DTD)) WORDINPAGEGROUP SEGMENTBASE VALIDPOINTERP FREEP ORIGIN OFFSET OBJECT TYPENAME DEC) [COND ((.ALLOCATED.PER.PAGE. SIZE) (SETQ WORDINPAGEGROUP (IMOD (\LOLOC BASE) WORDSPERPAGE)) (SETQ SEGMENTBASE (FLOOR (\LOLOC BASE) WORDSPERPAGE))) (T (SETQ WORDINPAGEGROUP (IMOD (\LOLOC BASE) \MDSIncrement)) (SETQ SEGMENTBASE (FLOOR (\LOLOC BASE) \MDSIncrement] (SETQ ORIGIN (ITIMES (IQUOTIENT WORDINPAGEGROUP SIZE) SIZE)) (SETQ OBJECT (\VAG2 (\HILOC BASE) (IPLUS SEGMENTBASE ORIGIN))) (SETQ VALIDPOINTERP (MEMB (SETQ OFFSET (IDIFFERENCE WORDINPAGEGROUP ORIGIN)) (fetch DTDPTRS of DTD))) (IF (AND (SETQ FREEP (\ISONFREELIST OBJECT)) (NOT ALLFLG)) THEN (RETURN)) (\FINDPOINTER.NEWITEM (AND VALIDPOINTERP (NOT FREEP))) (printout T "at offset " |.P2| OFFSET) (COND ([SETQ DEC (OR [RECLOOK (SETQ TYPENAME (\VAG2 0 (fetch DTDNAME of DTD] (find X in SYSTEMRECLST suchthat (EQ (CADR X) TYPENAME] (\FINDPOINTER.INTERPRET.RECORD DEC OFFSET))) (COND ((NOT VALIDPOINTERP) (printout T " (not a pointer field)"))) (printout T " in" (COND (FREEP " freed ") (T " ")) "object " OBJECT T) (RETURN (COND ((AND VALIDPOINTERP (NOT FREEP)) (OR (SELECTQ (PROG1 [ASKUSER DWIMWAIT 'N "Shall I search for pointers to this object? " '((Y "es") (N "o") (I "nspect it"] (TERPRI T)) (Y (\FINDPOINTER OBJECT COLLECT/INSPECT? NIL (IPLUS MARGIN 3))) (N NIL) (PROGN (INSPECT OBJECT) NIL)) OBJECT]) + +(\FINDPOINTER.INTERPRET.RECORD [LAMBDA (DEC OFFSET) (* bvm%: "21-Feb-86 12:11") (* ;;; "Figures out the field name associated with word offset OFFSET in record declaration DEC. Is simpleminded, gives up easily") (for FIELD in (CADDR DEC) bind (N _ 0) BITCOUNT unless (EQ (CAR (LISTP FIELD)) '*) do (SELECTQ (COND ((LISTP FIELD) (CADR FIELD)) (T 'POINTER)) ((XPOINTER POINTER FULLXPOINTER) (COND (BITCOUNT (COND ((OR (AND (LISTP FIELD) (EQ (CADR FIELD) 'FULLXPOINTER)) (IGREATERP BITCOUNT BITSPERBYTE)) (RETURN))) (SETQ BITCOUNT NIL))) (COND ((EQ N OFFSET) (printout T " (" (OR (CAR (LISTP FIELD)) FIELD) ")") (RETURN))) (add N WORDSPERCELL)) (WORD [COND (BITCOUNT (COND ((EQ BITCOUNT BITSPERWORD) (SETQ BITCOUNT NIL) (add N 1)) (T (RETURN] (add N 1)) (BYTE (COND ((NOT BITCOUNT) (SETQ BITCOUNT BITSPERBYTE)) ((IGREATERP BITCOUNT BITSPERBYTE) (RETURN)) (T (add N 1) (SETQ BITCOUNT NIL)))) ((FLAG BITS) (SETQ BITCOUNT (IPLUS (OR BITCOUNT 0) (OR (CADDR FIELD) 1)))) (RETURN]) + +(\FINDPOINTER.STACK [LAMBDA (PTR) (FOR I FROM 0 TO (fetch (IFPAGE EndOfStack) of \InterfacePage) WHEN (EQ (\GETBASEPTR (STACKADDBASE I) 0) PTR) DO (\FINDPOINTER.FOUND.ON.STACK (STACKADDBASE I]) + +(\FINDPOINTER.PARSE.STACK [LAMBDA (BASE) (* bvm%: "18-AUG-83 12:05") (PROG ((SCANPTR (fetch StackBase of \InterfacePage)) (EASP (fetch EndOfStack of \InterfacePage)) (TARGET (\LOLOC BASE))) (if (< TARGET SCANPTR) then (RETURN "System context")) SCAN [SELECTC (fetch (STK FLAGS) of SCANPTR) ((LIST \STK.FSB \STK.GUARD) (* ;  "free block or guard block all the same to us") (if (< TARGET (add SCANPTR (fetch (FSB SIZE) of SCANPTR))) then (RETURN "Free block"))) (\STK.FX (* ; "frame extension") (if (< TARGET (fetch (FX NEXTBLOCK) of SCANPTR)) then (RETURN (fetch (FX FRAMENAME) of SCANPTR))) (if (>= SCANPTR (SETQ SCANPTR (fetch (FX NEXTBLOCK) of SCANPTR))) then (* ; "avoid looping in malformed stack") (RETURN))) (PROG ((ORIG SCANPTR) IVAR) (* ; "must be a basic frame") (while (EQ (fetch (STK FLAGS) of SCANPTR) \STK.NOTFLAG) do (add SCANPTR WORDSPERCELL)) (COND ((NOT (type? BF SCANPTR)) (* ; "stack is garbage, can't parse") (RETURN)) (T (add SCANPTR WORDSPERCELL) (if (< TARGET SCANPTR) then (* ;  "in this basic frame--locate fx to get name") (RETURN (if (EQ (fetch (STK FLAGS) of SCANPTR) \STK.FX) then (fetch (FX FRAMENAME) of SCANPTR) else "Argument"] (COND ((IGREATERP SCANPTR EASP) (RETURN))) (GO SCAN]) + +(\FINDPOINTER.FOUND.ON.STACK [LAMBDA (BASE) (LET ((WHERE (\MISCAPPLY* (FUNCTION \FINDPOINTER.PARSE.STACK) BASE))) (IF (OR (NULL WHERE) (NOT (STRPOS "FINDPOINTER" WHERE))) THEN (* ;  "be sure to filter out our own bindings!") (\FINDPOINTER.NEWITEM NIL) (CL:FORMAT *TERMINAL-IO* "in stack cell ~O " (\LOLOC BASE)) (IF WHERE THEN (CL:FORMAT *TERMINAL-IO* (IF (STRINGP WHERE) THEN "(~A)" ELSE "(~S)") WHERE)) (TERPRI T)) NIL]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +[PUTPROPS \COERCETOTYPENUMBER MACRO (OPENLAMBDA (TYPE) + (OR (FIXP TYPE) + (\TYPENUMBERFROMNAME TYPE) + (ERROR "Not a valid type" TYPE] + +[PUTPROPS .ALLOCATED.PER.PAGE. MACRO (OPENLAMBDA (SIZE) (* Maybe change this some day to a + fetch of a flag from the DTD) + (AND (IGEQ (LISPVERSION) + 37384) + (ILESSP (IREMAINDER WORDSPERPAGE SIZE) + (LRSH SIZE 1)) + (ILESSP SIZE WORDSPERPAGE] + +(PUTPROPS MDSTYPE# MACRO ((PAGE#) + (LOGAND (\GETBASE \MDSTypeTable (LRSH PAGE# 1)) + \TT.TYPEMASK))) +) + + +(FILESLOAD (LOADCOMP) + LLGC LLBASIC) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS SYSTEMRECLST) +) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA SFL PFL) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA ) +) +(PUTPROPS GCHAX COPYRIGHT ( +"Syntelligence Systems, Inc. This program or documentation contains confidential information and trade secrets of Syntelligence Systems, Inc. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Syntelligence Systems, Inc. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets" + 1982 1983 1984 1985 1986 1987 1990 1992 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (3088 15321 (\MAPGC 3098 . 5234) (\SHOWGC 5236 . 8482) (\GCENTRIES.BY.TYPE 8484 . 12247) + (\#COLLISIONS 12249 . 12400) (\#OVERFLOWS 12402 . 12551) (\GCSTATS.AUX 12553 . 13557) (\SEE-GC-ENTRY +13559 . 15319)) (15357 22000 (\PRINTFREELIST 15367 . 19195) (\SHOWFREELISTS 19197 . 19703) ( +\SCANFREELIST 19705 . 21437) (\ISONFREELIST 21439 . 21998)) (22001 22311 (PFL 22011 . 22146) (SFL +22148 . 22309)) (22312 33063 (\COLLECTINUSE 22322 . 25385) (\SORTFREELIST 25387 . 32256) ( +\SFLHASHLOOKUP 32258 . 33061)) (33102 37326 (\SHOWCIRCULARITY 33112 . 33484) (\SHOWCIRCULARITY1 33486 + . 36138) (\SHOWCIRCULARLIST 36140 . 36631) (\SHOWCIRCULARPATH 36633 . 37324)) (37378 38659 ( +\SHOW.CLOSED.WINDOWS 37388 . 38292) (\WINDOW.ACCOUNTED.FOR? 38294 . 38657)) (38712 59679 (\FINDPOINTER + 38722 . 45836) (\FINDPOINTERS.OF.TYPE 45838 . 46639) (\FINDPOINTER.FOUND 46641 . 46942) ( +\FINDPOINTER.NEWITEM 46944 . 47258) (\FINDPOINTER.LISTP 47260 . 50542) (\FINDPOINTER.LISTP.FREE 50544 + . 51071) (\FINDPOINTER.TYPE 51073 . 53845) (\FINDPOINTER.INTERPRET.RECORD 53847 . 56046) ( +\FINDPOINTER.STACK 56048 . 56329) (\FINDPOINTER.PARSE.STACK 56331 . 58786) ( +\FINDPOINTER.FOUND.ON.STACK 58788 . 59677))))) +STOP diff --git a/library/GRAPHER b/library/GRAPHER new file mode 100644 index 00000000..4d882c6e --- /dev/null +++ b/library/GRAPHER @@ -0,0 +1,3199 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "14-May-2018 10:24:38" {DSK}kaplan>Local>medley3.5>lispcore>library>GRAPHER.;5 213664 changes to%: (VARS GRAPHERCOMS) previous date%: "11-Apr-2018 09:14:28" {DSK}kaplan>Local>medley3.5>lispcore>library>GRAPHER.;3) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT GRAPHERCOMS) (RPAQQ GRAPHERCOMS [(COMS (* ; "Graph Editing") (FNS ADD/AND/DISPLAY/LINK APPLYTOSELECTEDNODE CALL.MOVENODEFN CHANGE.NODEFONT.SIZE DEFAULT.ADDNODEFN DELETE/AND/DISPLAY/LINK DISPLAY/NAME DISPLAYGRAPH DISPLAYLINK DISPLAYLINK/BT DISPLAYLINK/LR DISPLAYLINK/RL DISPLAYLINK/TB DISPLAYNODE ERASE/GRAPHNODE DISPLAYNODE DISPLAYNODELINKS DRAW/GRAPHNODE/BORDER DRAWAREABOX EDITADDLINK EDITADDNODE EDITAPPLYTOLINK EDITCHANGEFONT EDITCHANGELABEL EDITDELETELINK EDITDELETENODE EDITGRAPH EDITGRAPH1 EDITGRAPH2 EDITMOVENODE EDITTOGGLEBORDER EDITTOGGLELABEL FILL/GRAPHNODE/LABEL FIX/SCALE FLIPNODE FONTNAMELIST FROMLINKS GETNODEFROMID GN/BOTTOM GN/LEFT GN/RIGHT GN/TOP GRAPHADDLINK GRAPHADDNODE GRAPHBUTTONEVENTFN GRAPHCHANGELABEL GRAPHDELETELINK GRAPHDELETENODE GRAPHEDITCOMMANDFN GRAPHEDITEVENTFN GRAPHER/CENTERPRINTINAREA GRAPHERPROP GRAPHNODE/BORDER/WIDTH GRAPHREGION HARDCOPYGRAPH INTERSECT/REGIONP/LBWH INVERTED/GRAPHNODE/BORDER INVERTED/SHADE/FOR/GRAPHER LAYOUT/POSITION LINKPARAMETERS MAX/RIGHT MAX/TOP MEASUREGRAPHNODE MEMBTONODES MIN/BOTTOM MIN/LEFT MOVENODE NODECREATE NODELST/AS/MENU NODEREGION PRINTDISPLAYNODE PROMPTINWINDOW READ/NODE REDISPLAYGRAPH REMOVETONODES RESET/NODE/BORDER RESET/NODE/LABELSHADE SCALE/GRAPH SCALE/GRAPHNODE/BORDER SCALE/TONODES SET/LABEL/SIZE SET/LAYOUT/POSITION SHOWGRAPH SIZE/GRAPH/WINDOW TOGGLE/DIRECTEDFLG TOGGLE/SIDESFLG TOLINKS TRACKCURSOR TRACKNODE TRANSGRAPH) (* ;; "Support for EDITSUBGRAPH and EDITREGION") (FNS EDITMOVEREGION EDITMOVESUBTREE NOT.TRACKCURSOR RECURSIVE.COLLECTDESCENDENTS MOVEDESCENDENTS COLLECT.CHILD.NODES CREATE.NEW.NODEPOSITION GETBOXPOSITION.FROMINITIALREGION COLLECTDESCENDENTS)) (COMS (* ;  "functions for finding larger and smaller fonts") (FNS NEXTSIZEFONT DECREASING.FONT.LIST SCALE.FONT) [DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DECREASING.FONT.LIST (DECREASING.FONT.LIST] (GLOBALVARS DECREASING.FONT.LIST)) (* ;  "functions for LAYOUTGRAPH And LAYOUTLATTICE") (FNS BRH/LAYOUT BRH/LAYOUT/DAUGHTERS BRH/OFFSET BRHC/INTERTREE/SPACE BRHC/LAYOUT BRHC/LAYOUT/DAUGHTERS BRHC/LAYOUT/TERMINAL BRHC/OFFSET BRHL/LAYOUT BRHL/LAYOUT/DAUGHTERS BRHL/MOVE/RIGHT BROWSE/LAYOUT/HORIZ BROWSE/LAYOUT/HORIZ/COMPACTLY BROWSE/LAYOUT/LATTICE BRV/OFFSET EXTEND/TRANSITION/CHAIN FOREST/BREAK/CYCLES INIT/NODES/FOR/LAYOUT INTERPRET/MARK/FORMAT LATTICE/BREAK/CYCLES LAYOUTFOREST LAYOUTGRAPH LAYOUTLATTICE LAYOUTSEXPR LAYOUTSEXPR1 MARK/GRAPH/NODE NEW/INSTANCE/OF/GRAPHNODE RAISE/TRANSITION/CHAIN REFLECT/GRAPH/DIAGONALLY REFLECT/GRAPH/HORIZONTALLY REFLECT/GRAPH/VERTICALLY SWITCH/NODE/HEIGHT/WIDTH) (CONSTANTS (LINKPARAMS 'Link% Parameters)) [VARS (DEFAULT.GRAPH.NODEBORDER) (DEFAULT.GRAPH.NODEFONT) (DEFAULT.GRAPH.NODELABELSHADE) (ScalableLinkParameters '(LINEWIDTH)) (CACHE/NODE/LABEL/BITMAPS) (NODEBORDERWIDTH 1) (GRAPH/HARDCOPY/FORMAT '(MODE PORTRAIT PAGENUMBERS T TRANS NIL] [INITVARS (DEFAULT.GRAPH.WINDOWSIZE (LIST (TIMES SCREENWIDTH 0.7) (TIMES SCREENHEIGHT 0.4))) (EDITGRAPHMENUCOMMANDS '((Move% Node 'MOVENODE "Moves a single node in the graph." (SUBITEMS (|Move Single Node| 'MOVENODE "Moves a single node in the graph.") (|Move Node and Subtree| (EDITMOVESUBTREE GRAPHWINDOW) "Moves a subtree of nodes relative to the movement of their root." ) (Move% Region (EDITMOVEREGION GRAPHWINDOW) "Moves a group of nodes within a specified region to another region." ))) ("Add Node" 'ADDNODE) ("Delete Node" 'DELETENODE) ("Add Link" 'ADDLINK) ("Delete Link" 'DELETELINK) ("Change label" 'CHANGELABEL) ("label smaller" 'SMALLER) ("label larger" 'LARGER) ("<-> Directed" 'DIRECTED) ("<-> Sides" 'SIDES) ("<-> Border" 'BORDER) ("<-> Shade" 'SHADE) STOP] (LOCALVARS . T) (RECORDS GRAPHNODE GRAPH) (DECLARE%: DONTCOPY (MACROS HALF)) (COMS (* ; "Grapher image objects") (FNS GRAPHERIMAGEFNS) (FNS GRAPHERCOPYBUTTONEVENTFN GRAPHOBJ.FINDGRAPH) (FNS ALIGNMENTNODE GRAPHOBJ.CHECKALIGN) (FNS GRAPHEROBJ GRAPHOBJ.BUTTONEVENTINFN GRAPHOBJ.COPYBUTTONEVENTFN GRAPHOBJ.COPYFN GRAPHOBJ.DISPLAYFN GRAPHOBJ.GETALIGN GRAPHOBJ.GETFN GRAPHOBJ.IMAGEBOXFN GRAPHOBJ.PUTALIGN GRAPHOBJ.PUTFN) (FNS COPYGRAPH DUMPGRAPH READGRAPH) (INITVARS (GRAPHERIMAGEFNS)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (GRAPHERIMAGEFNS))) (ALISTS (IMAGEOBJGETFNS GRAPHOBJ.GETFN]) (* ; "Graph Editing") (DEFINEQ (ADD/AND/DISPLAY/LINK + [LAMBDA (FROMND TOND WIN G) (* ; "Edited 29-Apr-94 13:59 by sybalsky") + (* adds and displays a link.) + (COND + ((MEMBTONODES (fetch (GRAPHNODE NODEID) of TOND) + (TOLINKS FROMND)) + (printout PROMPTWINDOW "Link already exists. " T) + NIL) + (T (GRAPHADDLINK FROMND TOND G WIN) + (DISPLAYLINK FROMND TOND (CONSTANT (create POSITION + XCOORD _ 0 + YCOORD _ 0)) + WIN G) + T]) (APPLYTOSELECTEDNODE + [LAMBDA (WINDOW) (* rmk%: "20-Nov-85 16:33") + + (* applys a function whenever the node is selected. + Is used as BUTTONEVENTFN and gets called whenever cursor moves or button is + down.) + + (GRAPHBUTTONEVENTFN WINDOW (WINDOWPROP WINDOW 'GRAPH) + (WINDOWPROP WINDOW 'BROWSER/LEFTFN) + (WINDOWPROP WINDOW 'BROWSER/MIDDLEFN) + (WINDOWPROP WINDOW 'REGION]) (CALL.MOVENODEFN + [LAMBDA (NODE NEWPOS GRAPH WINDOW OLDPOS) (* BBB "13-Sep-85 15:37") + (* calls a graphs movenodefn.) + (PROG ((MOVEFN (fetch (GRAPH GRAPH.MOVENODEFN) of GRAPH))) + (AND MOVEFN (APPLY* MOVEFN NODE NEWPOS GRAPH WINDOW OLDPOS]) (CHANGE.NODEFONT.SIZE + [LAMBDA (HOW NODE GRAPH WINDOW) (* ; "Edited 22-Jul-87 16:32 by sye") + (* makes the label font of a node + larger.) + (PROG [(NEWFONT (NEXTSIZEFONT HOW (fetch (GRAPHNODE NODEFONT) of NODE] + (COND + (NEWFONT (DISPLAYNODE NODE (CONSTANT (create POSITION + XCOORD _ 0 + YCOORD _ 0)) + WINDOW GRAPH) + (PROG ((CHNGFN (fetch (GRAPH GRAPH.FONTCHANGEFN) of GRAPH))) + (AND CHNGFN (APPLY* CHNGFN HOW NODE GRAPH WINDOW))) + (replace (GRAPHNODE NODELABELBITMAP) of NODE with NIL) + (replace (GRAPHNODE NODEFONT) of NODE with NEWFONT) + (MEASUREGRAPHNODE NODE T) + (DISPLAYNODE NODE (CONSTANT (create POSITION + XCOORD _ 0 + YCOORD _ 0)) + WINDOW GRAPH]) (DEFAULT.ADDNODEFN + [LAMBDA (GRAPH WINDOW BOXED) (* ; "Edited 9-Jan-89 15:57 by sye") + (* ; + "reads a node label name from the user and puts a node at the current cursor position.") + (PROG (NODELABEL NODENAME) + (OR (SETQ NODELABEL (PROMPTINWINDOW "Node label? ")) + (RETURN)) + LP (COND + ((FASSOC (SETQ NODENAME (PACK* NODELABEL (GENSYM))) + (fetch (GRAPH GRAPHNODES) of GRAPH)) + (GO LP))) + (RETURN (NODECREATE NODENAME NODELABEL (CURSORPOSITION NIL WINDOW) + NIL NIL (OR DEFAULT.GRAPH.NODEFONT DEFAULTFONT) + BOXED]) (DELETE/AND/DISPLAY/LINK + [LAMBDA (FROMND TOND WIN G) (* ; "Edited 29-Apr-94 13:59 by sybalsky") + (* delete a link and updates the + display.) + + (* * rht 4/4/85%: Added temporary var LINKPARAMS to hold link parameters since + they'll get tossed by GRAPHDELETELINK.) + + (COND + ([NOT (OR (MEMBTONODES (fetch (GRAPHNODE NODEID) of TOND) + (TOLINKS FROMND)) + (AND (MEMBTONODES (fetch (GRAPHNODE NODEID) of FROMND) + (TOLINKS TOND)) + (NOT (fetch (GRAPH DIRECTEDFLG) of G)) + (PROG ((TMP FROMND)) (* editting graph, don't distinguish + between links.) + (SETQ FROMND TOND) + (SETQ TOND TMP) + (RETURN T] + (printout PROMPTWINDOW "Link does not exist. " T) + NIL) + (T (PROG ((LPARAMS (LINKPARAMETERS FROMND TOND))) + (GRAPHDELETELINK FROMND TOND G WIN) + (DISPLAYLINK FROMND TOND (CONSTANT (create POSITION + XCOORD _ 0 + YCOORD _ 0)) + WIN G NIL LPARAMS)) + T]) (DISPLAY/NAME + [LAMBDA (ND) (* ; "Edited 29-Apr-94 13:59 by sybalsky") + (fetch (GRAPHNODE NODELABEL) of ND]) (DISPLAYGRAPH + [LAMBDA (GRAPH STREAM CLIP/REG TRANS) (* ; "Edited 27-Jul-90 09:09 by tafel") + + (* ;; "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.") + + (PROG (SCALE (LINEWIDTH 1) + NNODES NODEHASHTABLE) + [OR (type? POSITION TRANS) + (SETQ TRANS (CONSTANT (create POSITION + XCOORD _ 0 + YCOORD _ 0] + (SETQ STREAM (\GETSTREAM STREAM '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 GRAPH (SCALE/GRAPH GRAPH STREAM SCALE)) + [SETQ TRANS (create POSITION + XCOORD _ (FIXR (FTIMES SCALE (fetch (POSITION XCOORD) + of TRANS))) + YCOORD _ (FIXR (FTIMES SCALE (fetch (POSITION YCOORD) + of TRANS] + (SETQ LINEWIDTH SCALE))) + + (* ;; "nhb, 23-Feb-89: modified to create hashtable for nodeid to node lookup for cases where hash tables provide better performance than A-Lists.") + + [COND + ((IGREATERP (SETQ NNODES (LENGTH (fetch (GRAPH GRAPHNODES) of GRAPH))) + 25) + (SETQ NODEHASHTABLE (HASHARRAY NNODES)) + (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) + do (PUTHASH (fetch (GRAPHNODE NODEID) of N) + N NODEHASHTABLE] + (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) + do (DISPLAYNODELINKS N TRANS STREAM GRAPH T LINEWIDTH NODEHASHTABLE)) + (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) + do (PRINTDISPLAYNODE N TRANS STREAM CLIP/REG]) (DISPLAYLINK + [LAMBDA (FRND TOND TRANS STREAM G LINEWIDTH PARAMS) (* rht%: "13-Mar-85 13:58") + (* draws in a link from FRND TO + TOND, translated by TRANS) + (COND + ((fetch (GRAPH SIDESFLG) of G) + (COND + ((OR (fetch (GRAPH DIRECTEDFLG) of G) + (IGREATERP (GN/LEFT TOND) + (GN/RIGHT FRND))) (* in the horizontal case of + LATTICE, always draw from right to + left.) + (DISPLAYLINK/RL TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) + ((IGREATERP (GN/LEFT FRND) + (GN/RIGHT TOND)) + (DISPLAYLINK/LR TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) + ((IGREATERP (GN/BOTTOM FRND) + (GN/TOP TOND)) + (DISPLAYLINK/BT TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) + ((IGREATERP (GN/BOTTOM TOND) + (GN/TOP FRND)) + (DISPLAYLINK/TB TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) + (T (* if on top of each other, don't + draw.) + NIL))) + (T (COND + ((OR (fetch (GRAPH DIRECTEDFLG) of G) + (IGREATERP (GN/BOTTOM FRND) + (GN/TOP TOND))) + + (* if LATTICE, always draw from FROMNODE BOTTOM to TONODE TOP. + Otherwise find the one that looks best.) + + (DISPLAYLINK/BT TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) + ((IGREATERP (GN/BOTTOM TOND) + (GN/TOP FRND)) + (DISPLAYLINK/TB TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) + ((IGREATERP (GN/LEFT TOND) + (GN/RIGHT FRND)) + (DISPLAYLINK/RL TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) + ((IGREATERP (GN/LEFT FRND) + (GN/RIGHT TOND)) + (DISPLAYLINK/LR TRANS FRND TOND LINEWIDTH NIL STREAM PARAMS)) + (T (* if on top of each other, don't + draw.) + NIL]) (DISPLAYLINK/BT + [LAMBDA (TRANS GNB GNT WIDTH OPERATION STREAM PARAMS) + (* ; "Edited 29-Apr-94 13:59 by sybalsky") + + (* draws a line from the bottom edge of GNB to the top edge of GNT translated + by TRANS) + + (APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN) + 'DRAWLINE) + (IPLUS (fetch XCOORD of TRANS) + (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNB))) + (IPLUS (fetch YCOORD of TRANS) + (SUB1 (GN/BOTTOM GNB))) + (IPLUS (fetch XCOORD of TRANS) + (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNT))) + (IPLUS (fetch YCOORD of TRANS) + (ADD1 (GN/TOP GNT))) + (OR (LISTGET PARAMS 'LINEWIDTH) + WIDTH 1) + OPERATION STREAM (LISTGET PARAMS 'COLOR) + (LISTGET PARAMS 'DASHING) + PARAMS]) (DISPLAYLINK/LR + [LAMBDA (TRANS GNL GNR WIDTH OPERATION STREAM PARAMS) + (* ; "Edited 29-Apr-94 13:59 by sybalsky") + + (* draws a line from the left edge of GNL to the right edge of GNR, translated + by TRANS) + + (APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN) + 'DRAWLINE) + (IPLUS (fetch XCOORD of TRANS) + (SUB1 (GN/LEFT GNL))) + (IPLUS (fetch YCOORD of TRANS) + (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNL))) + (IPLUS (fetch XCOORD of TRANS) + (ADD1 (GN/RIGHT GNR))) + (IPLUS (fetch YCOORD of TRANS) + (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNR))) + (OR (LISTGET PARAMS 'LINEWIDTH) + WIDTH 1) + OPERATION STREAM (LISTGET PARAMS 'COLOR) + (LISTGET PARAMS 'DASHING) + PARAMS]) (DISPLAYLINK/RL + [LAMBDA (TRANS GNR GNL WIDTH OPERATION STREAM PARAMS) + (* ; "Edited 29-Apr-94 13:59 by sybalsky") + + (* draws a line from the right edge of GNR, to the left edge of GNL translated + by TRANS) + + (APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN) + 'DRAWLINE) + (IPLUS (fetch XCOORD of TRANS) + (ADD1 (GN/RIGHT GNR))) + (IPLUS (fetch YCOORD of TRANS) + (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNR))) + (IPLUS (fetch XCOORD of TRANS) + (SUB1 (GN/LEFT GNL))) + (IPLUS (fetch YCOORD of TRANS) + (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNL))) + (OR (LISTGET PARAMS 'LINEWIDTH) + WIDTH 1) + OPERATION STREAM (LISTGET PARAMS 'COLOR) + (LISTGET PARAMS 'DASHING) + PARAMS]) (DISPLAYLINK/TB + [LAMBDA (TRANS GNT GNB WIDTH OPERATION STREAM PARAMS) + (* ; "Edited 29-Apr-94 13:59 by sybalsky") + + (* draws a line from the top edge of GNT to the bottom edge of GNR, translated + by TRANS) + + (APPLY* (OR (LISTGET PARAMS 'DRAWLINKFN) + 'DRAWLINE) + (IPLUS (fetch XCOORD of TRANS) + (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNT))) + (IPLUS (fetch YCOORD of TRANS) + (ADD1 (GN/TOP GNT))) + (IPLUS (fetch XCOORD of TRANS) + (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of GNB))) + (IPLUS (fetch YCOORD of TRANS) + (SUB1 (GN/BOTTOM GNB))) + (OR (LISTGET PARAMS 'LINEWIDTH) + WIDTH 1) + OPERATION STREAM (LISTGET PARAMS 'COLOR) + (LISTGET PARAMS 'DASHING) + PARAMS]) (DISPLAYNODE + [LAMBDA (NODE TRANS STREAM G TOSONLY) (* kvl "10-Aug-84 19:08") + + (* displays a node and its links. IF TOSONLY IS NON-NIL, DRAWS ONLY THE TO + LINKS.) + + (DISPLAYNODELINKS NODE TRANS STREAM G TOSONLY) + (PRINTDISPLAYNODE NODE TRANS STREAM (DSPCLIPPINGREGION NIL STREAM]) (ERASE/GRAPHNODE + [LAMBDA (NODE STREAM TRANS) (* ; "Edited 29-Apr-94 13:59 by sybalsky") + (* erases a node at its position + translated by TRANS) + (OR [NOT (OR (WINDOWP STREAM) + (IMAGESTREAMTYPEP STREAM 'DISPLAY] + (ZEROP (fetch (GRAPHNODE NODEHEIGHT) of NODE)) + (BITBLT NIL NIL NIL STREAM (COND + (TRANS (IPLUS (fetch (POSITION XCOORD) of TRANS) + (GN/LEFT NODE))) + (T (GN/LEFT NODE))) + (COND + (TRANS (IPLUS (fetch (POSITION YCOORD) of TRANS) + (GN/BOTTOM NODE))) + (T (GN/BOTTOM NODE))) + (fetch (GRAPHNODE NODEWIDTH) of NODE) + (fetch (GRAPHNODE NODEHEIGHT) of NODE) + 'TEXTURE + 'REPLACE WHITESHADE]) (DISPLAYNODE + [LAMBDA (NODE TRANS STREAM G TOSONLY) (* kvl "10-Aug-84 19:08") + + (* displays a node and its links. IF TOSONLY IS NON-NIL, DRAWS ONLY THE TO + LINKS.) + + (DISPLAYNODELINKS NODE TRANS STREAM G TOSONLY) + (PRINTDISPLAYNODE NODE TRANS STREAM (DSPCLIPPINGREGION NIL STREAM]) (DISPLAYNODELINKS + [LAMBDA (NODE TRANS STREAM G TOSONLY LINEWIDTH NODEHASHTABLE) + (* ; "Edited 24-Feb-89 11:56 by Briggs") + + (* ;; "displays a node links. If TOSONLY is non-NIL, draws only the TO links.") + + (* ;; + "nhb, 23-Feb-89: modified to accept a hash table of nodes by nodeid to assist GETNODEFROMID.") + + (PROG ((NODELST (fetch (GRAPH GRAPHNODES) of G))) + (for TONODEID TONODE in (TOLINKS NODE) + do (DISPLAYLINK NODE (SETQ TONODE (GETNODEFROMID TONODEID NODELST + NODEHASHTABLE)) + TRANS STREAM G LINEWIDTH (LINKPARAMETERS NODE TONODE))) + (OR TOSONLY (for FROMNDID FROMND in (FROMLINKS NODE) + do (DISPLAYLINK (SETQ FROMND (GETNODEFROMID FROMNDID NODELST + NODEHASHTABLE)) + NODE TRANS STREAM G LINEWIDTH (LINKPARAMETERS FROMND NODE]) (DRAW/GRAPHNODE/BORDER + [LAMBDA (BORDER LEFT BOTTOM WIDTH HEIGHT STREAM) (* lmm " 9-Jun-85 22:38") + + (* interprets the node border. If the border is a shade, then bitblt twice in + invert mode. This will look ugly if a link runs underneath the node, but at + least the label will be legible.) + + (COND + ((EQ BORDER NIL)) + ((EQ BORDER T) + (DRAWAREABOX LEFT BOTTOM WIDTH HEIGHT 1 NIL STREAM)) + ((FIXP BORDER) + (OR (ILEQ BORDER 0) + (DRAWAREABOX LEFT BOTTOM WIDTH HEIGHT BORDER NIL STREAM))) + ((LISTP BORDER) (* Extract the PROG after Intermezzo + is released) + (DRAWAREABOX LEFT BOTTOM WIDTH HEIGHT (CAR BORDER) + NIL STREAM (CADR BORDER))) + (T (ERROR "Illegal border:" BORDER]) (DRAWAREABOX + [LAMBDA (BOXLEFT BOXBOTTOM BOXWIDTH BOXHEIGHT BORDER OP W TEXTURE) + (* lmm " 9-Jun-85 22:36") + (OR TEXTURE (SETQ TEXTURE BLACKSHADE)) (* lmm " 9-Jun-85 22:04") + (* draws lines inside the region.) + (* draw left edge) + (BLTSHADE TEXTURE W BOXLEFT BOXBOTTOM BORDER BOXHEIGHT OP) + (* draw top) + (BLTSHADE TEXTURE W (PLUS BOXLEFT BORDER) + (DIFFERENCE (PLUS BOXBOTTOM BOXHEIGHT) + BORDER) + (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) + BORDER OP) (* draw bottom) + (BLTSHADE TEXTURE W (PLUS BOXLEFT BORDER) + BOXBOTTOM + (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) + BORDER OP) (* draw right edge) + (BLTSHADE TEXTURE W (DIFFERENCE (PLUS BOXLEFT BOXWIDTH) + BORDER) + BOXBOTTOM BORDER BOXHEIGHT OP]) (EDITADDLINK + [LAMBDA (W) (* kvl "20-APR-82 13:53") + (* reads and adds a link to the + graph) + (EDITAPPLYTOLINK (FUNCTION ADD/AND/DISPLAY/LINK) + 'added + (WINDOWPROP W 'GRAPH) + W]) (EDITADDNODE + [LAMBDA (W NewPosition MSGW NODELABELFN) (* ; "Edited 29-Apr-94 13:59 by sybalsky") + (* ; + "adds a node to the graph in the window W and displays it.") + + (* ;; "pmi 4/8/88: Added NewPosition argument so that the new position for a node may be specified programatically.") + + (* ;; "sye Jan/9/89: added MSGW & NODELABELFN args ") + + (DECLARE (GLOBALVARS PROMPTWINDOW)) + (PROG [NODE ORIGPOS NEWPOS NODELABEL (GRAPH (WINDOWPROP W 'GRAPH)) + (Stream (WINDOWPROP W 'DSP] + (OR (SETQ NODE (GRAPHADDNODE GRAPH W)) + (RETURN)) + (MEASUREGRAPHNODE NODE) + (if (POSITIONP NewPosition) + then (SETQ ORIGPOS (create POSITION using (fetch (GRAPHNODE + NODEPOSITION) + of NODE))) + (MOVENODE NODE ORIGPOS NewPosition GRAPH Stream) + (FLIPNODE NODE Stream) + (EXTENDEXTENT (WFROMDS Stream) + (NODEREGION NODE)) + (CALL.MOVENODEFN NODE NewPosition GRAPH (WFROMDS Stream) + ORIGPOS) + else (printout (OR MSGW PROMPTWINDOW) + "Position node " + (OR (AND NODELABELFN (APPLY* NODELABELFN NODE)) + (fetch (GRAPHNODE NODELABEL) + NODE))) + (PRINTDISPLAYNODE NODE (CONSTANT (create POSITION + XCOORD _ 0 + YCOORD _ 0)) + W + (DSPCLIPPINGREGION NIL W)) + (TRACKCURSOR NODE Stream GRAPH)) + (RETURN NODE]) (EDITAPPLYTOLINK + [LAMBDA (FN MSG GRAPH DS MSGW NODELABELFN) (* ; "Edited 9-Jan-89 09:10 by sye") + (SETQ MSGW (OR MSGW PROMPTWINDOW)) + (CLEARW MSGW) + (CLRPROMPT) + (COND + [(fetch (GRAPH GRAPHNODES) of GRAPH) + (PROG (FROM TO (ABORTMSG "No selection was made ... operation aborted.")) + (printout MSGW "Specify the link by selecting the FROM node, then the TO node." T + "FROM?" T) (* + "if no FROM node was selected, abort the operation") + (OR (SETQ FROM (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) + DS)) + (RETURN (printout PROMPTWINDOW ABORTMSG T))) + (FLIPNODE FROM DS) + (printout MSGW "TO?" T) + (COND + [(ERSETQ (SETQ TO (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) + DS] + (T (FLIPNODE FROM DS) + (ERROR!))) + (FLIPNODE FROM DS) (* + "if no TO node was selected, abort the operation") + (OR TO (RETURN (printout PROMPTWINDOW ABORTMSG T))) + (COND + ((APPLY* FN FROM TO DS GRAPH) (* return non-nil if changed + anything.) + (printout PROMPTWINDOW "Link from " (OR (AND NODELABELFN (APPLY* NODELABELFN FROM)) + (DISPLAY/NAME FROM)) + " to " + (OR (AND NODELABELFN (APPLY* NODELABELFN TO)) + (DISPLAY/NAME TO)) + %, MSG T) + (RETURN T] + (T (printout PROMPTWINDOW + "There are no nodes. You can create nodes with the Add Node command." T]) (EDITCHANGEFONT + [LAMBDA (HOW W) (* ; "Edited 7-Jan-89 13:14 by sye") + (* prompts the user for a node and + deletes it) + (PROG ((GRAPH (WINDOWPROP W 'GRAPH)) + (DS (WINDOWPROP W 'DSP)) + NODE) + (COND + ((NOT (fetch (GRAPH GRAPHNODES) of GRAPH)) + (PROMPTPRINT " No nodes in graph yet. ") + (RETURN))) + (CLRPROMPT) + (printout PROMPTWINDOW "Select node to be made " (COND + ((EQ HOW 'SMALLER) + "smaller.") + (T "larger."))) + (OR (SETQ NODE (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) + DS)) + (RETURN (printout PROMPTWINDOW T "No selection was made ... operation aborted." T))) + (CHANGE.NODEFONT.SIZE HOW NODE GRAPH W) + (RETURN NODE]) (EDITCHANGELABEL + [LAMBDA (W MSGW) (* ; "Edited 7-Jan-89 13:31 by sye") + (* prompts the user for a node and + deletes it) + (PROG ((GRAPH (WINDOWPROP W 'GRAPH)) + (DS (GETSTREAM W)) + (TRANS (CONSTANT (create POSITION + XCOORD _ 0 + YCOORD _ 0))) + NODE NEWLABEL) + (COND + ((NOT (fetch (GRAPH GRAPHNODES) of GRAPH)) + (PROMPTPRINT "No nodes in graph yet. ") + (RETURN))) + (CLRPROMPT) + (SETQ MSGW (OR MSGW PROMPTWINDOW)) + (CLEARW MSGW) + (printout MSGW "Select node to have label changed.") + (OR (SETQ NODE (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) + DS)) + (RETURN (printout PROMPTWINDOW T "No selection was made ... operation aborted." T))) + (if (NULL (SETQ NEWLABEL (GRAPHCHANGELABEL GRAPH W NODE))) + then (RETURN)) + (DISPLAYNODE NODE TRANS W GRAPH) + (ERASE/GRAPHNODE NODE DS TRANS) + (replace (GRAPHNODE NODELABEL) of NODE with NEWLABEL) + (replace (GRAPHNODE NODELABELBITMAP) of NODE with NIL) + (MEASUREGRAPHNODE NODE T) + (DISPLAYNODE NODE TRANS W GRAPH) + (RETURN NODE]) (EDITDELETELINK + [LAMBDA (W) (* kvl "20-APR-82 13:54") + (* reads and adds a link to the + graph) + (EDITAPPLYTOLINK (FUNCTION DELETE/AND/DISPLAY/LINK) + 'deleted + (WINDOWPROP W 'GRAPH) + W]) (EDITDELETENODE + [LAMBDA (W) (* ; "Edited 9-Jan-89 09:14 by sye") + (* prompts the user for a node and + deletes it) + (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) + (CLRPROMPT) + (PROG ((GRAPH (WINDOWPROP W 'GRAPH)) + (DS (WINDOWPROP W 'DSP)) + NODE NODELABEL) + (COND + ((NOT (fetch (GRAPH GRAPHNODES) of GRAPH)) + (PROMPTPRINT " No nodes to delete. ") + (RETURN))) + (PROMPTPRINT "Select node to be deleted. ") + (OR (SETQ NODE (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) + DS)) + (RETURN (printout T T "No selection was made ... operation aborted." T))) + (TERPRI T) + (FLIPNODE NODE DS) + (COND + ((EQ [ASKUSER NIL NIL (LIST "delete node " (SETQ NODELABEL (DISPLAY/NAME + NODE] + 'Y) + (FLIPNODE NODE DS) + (DISPLAYNODE NODE (CONSTANT (create POSITION + XCOORD _ 0 + YCOORD _ 0)) + DS GRAPH) + (for TOND in (APPEND (TOLINKS NODE)) + do (GRAPHDELETELINK NODE (GETNODEFROMID TOND (fetch + (GRAPH GRAPHNODES) + of GRAPH)) + GRAPH W)) + (for FROMND in (APPEND (FROMLINKS NODE)) + do (GRAPHDELETELINK (GETNODEFROMID FROMND (fetch (GRAPH + GRAPHNODES) + of GRAPH)) + NODE GRAPH W)) + (GRAPHDELETENODE NODE GRAPH W) + (printout T "Node " NODELABEL " deleted." T) + (RETURN NODE)) + (T (FLIPNODE NODE DS) + (printout T "nothing deleted." T) + (RETURN NIL]) (EDITGRAPH + [LAMBDA (G W) + (SHOWGRAPH G W NIL NIL T T]) (EDITGRAPH1 + [LAMBDA (GRAPH WINDOW) (* ; "Edited 19-Aug-88 08:30 by sye") + + (* ;; "top level function for editing a graph. If there is no graph, create one empty. IF there is no window, create on the right size for the graph. After getting the arguments right, put the right button functions on, display it and enter the main loop.") + + (OR GRAPH (SETQ GRAPH (create GRAPH))) + (SETQ WINDOW (SIZE/GRAPH/WINDOW GRAPH WINDOW)) + (WINDOWPROP WINDOW 'GRAPH GRAPH) + (WINDOWPROP WINDOW 'REPAINTFN (FUNCTION REDISPLAYGRAPH)) + (WINDOWPROP WINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) + (DSPOPERATION 'INVERT WINDOW) + (REDISPLAYGRAPH WINDOW) + (EDITGRAPH2 WINDOW) + GRAPH]) (EDITGRAPH2 + [LAMBDA (W) (* rrb " 7-NOV-83 14:51") + + (* Can also be called from top level if the given window W has a graph on its + GRAPH windowprop and the graph has been displayed by SHOWGRAPH or its + equivalent. It waits for mouse hits, does the comand, then waits for mouse + clear. Each edit command function takes only the window so that they can be + hung separately on button event functions. + However, the window must have INVERT as its display operation mode.) + + (PROG (VAL) + (CLRPROMPT) + (printout PROMPTWINDOW "Use the left button to move nodes." T + "Use the middle button to get a menu of edit commands." T + "During an edit command, the middle button can be used to abort.") + LP (until (MOUSESTATE (OR LEFT MIDDLE)) do) + (COND + [(LASTMOUSESTATE MIDDLE) + (SETQ VAL (ERSETQ (GRAPHEDITCOMMANDFN W))) + (COND + ((NULL VAL) (* aborted) + (printout PROMPTWINDOW T T "command aborted." T)) + ((EQ (CAR VAL) + 'STOP) + (RETURN (CLRPROMPT] + ((fetch (GRAPH GRAPHNODES) of (WINDOWPROP W 'GRAPH)) + (* track the nearest node.) + (TRACKNODE W)) + (T (printout PROMPTWINDOW T "There are no nodes to move yet." T + "Press the middle button and select the 'Add a node' command."))) + (until (MOUSESTATE UP) do) + (GO LP]) (EDITMOVENODE + [LAMBDA (WINDOW) (* ; "Edited 7-Jan-89 13:22 by sye") + (* hilite nodes until the cursor + goes down then move it) + (PROG ((DS (WINDOWPROP WINDOW 'DSP)) + (REG (WINDOWPROP WINDOW 'REGION)) + (GRAPH (WINDOWPROP WINDOW 'GRAPH)) + OLDPOS NOW NEAR NODELST) + (COND + (GRAPH (SETQ NODELST (fetch (GRAPH GRAPHNODES) of GRAPH))) + (T (RETURN))) + (CLRPROMPT) + (printout PROMPTWINDOW "Move the cursor to the node " "you want to move " + "and press any button.") + [SETQ NEAR (NODELST/AS/MENU NODELST (SETQ OLDPOS (CURSORPOSITION NIL DS] + FLIP + (AND NOW (FLIPNODE NOW DS)) + (AND NEAR (FLIPNODE NEAR DS)) + (SETQ NOW NEAR) + LP (GETMOUSESTATE) + (COND + ((LASTMOUSESTATE (NOT UP)) (* button up, process it.) + (AND NOW (FLIPNODE NOW DS)) (* NOW node has been selected.) + ) + ([EQ NOW (SETQ NEAR (NODELST/AS/MENU NODELST (CURSORPOSITION NIL DS OLDPOS] + (GO LP)) + (T (GO FLIP))) + (printout PROMPTWINDOW T "Holding the button down, " "move the node to its new position" + "and release the button.") + (TRACKCURSOR NOW DS GRAPH) + (printout PROMPTWINDOW T "Done."]) (EDITTOGGLEBORDER + [LAMBDA (W) (* ; "Edited 7-Jan-89 13:38 by sye") + (* ; + "prompts the user for a node and inverts its border") + (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) + (CLRPROMPT) + (PROG ((GRAPH (WINDOWPROP W 'GRAPH)) + (DS (WINDOWPROP W 'DSP)) + NODE) + (COND + ((NOT (fetch (GRAPH GRAPHNODES) of GRAPH)) + (PROMPTPRINT "No nodes to invert. ") + (RETURN))) + (PROMPTPRINT "Select node to have border inverted. ") + (OR (SETQ NODE (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) + DS)) + (RETURN (printout T T "No selection was made ... operation aborted." T))) + (TERPRI T) + (RESET/NODE/BORDER NODE 'INVERT W GRAPH) + (AND (fetch (GRAPH GRAPH.INVERTBORDERFN) of GRAPH) + (APPLY* (fetch (GRAPH GRAPH.INVERTBORDERFN) of GRAPH) + NODE GRAPH W)) + (RETURN NODE]) (EDITTOGGLELABEL + [LAMBDA (W) (* ; "Edited 7-Jan-89 13:17 by sye") + (* prompts the user for a node and + inverts its lable) + (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) + (CLRPROMPT) + (PROG ((GRAPH (WINDOWPROP W 'GRAPH)) + (DS (WINDOWPROP W 'DSP)) + NODE) + (COND + ((NOT (fetch (GRAPH GRAPHNODES) of GRAPH)) + (PROMPTPRINT " No nodes to invert.") + (RETURN))) + (PROMPTPRINT "Select node to have label inverted. ") + (OR (SETQ NODE (READ/NODE (fetch (GRAPH GRAPHNODES) of GRAPH) + DS)) + (RETURN (printout T T "No selection was made ... operation aborted." T))) + (TERPRI T) + (RESET/NODE/LABELSHADE NODE 'INVERT W) + (AND (fetch (GRAPH GRAPH.INVERTLABELFN) of GRAPH) + (APPLY* (fetch (GRAPH GRAPH.INVERTLABELFN) of GRAPH) + NODE GRAPH W)) + (RETURN NODE]) (FILL/GRAPHNODE/LABEL + [LAMBDA (SHADE LEFT BOTTOM WIDTH HEIGHT NBW STREAM) (* kvl "10-Sep-84 14:41") + (* NBW is the border, which must be + subtracted from the node's region) + (PROG ((NS SHADE)) + (OR (WINDOWP STREAM) + (DISPLAYSTREAMP STREAM) + (RETURN)) + (COND + ((EQ SHADE T) + (SETQ NS BLACKSHADE)) + ((NULL SHADE) + (SETQ NS WHITESHADE))) + (BITBLT NIL NIL NIL STREAM (IPLUS LEFT NBW) + (IPLUS BOTTOM NBW) + (IDIFFERENCE WIDTH (IPLUS NBW NBW)) + (IDIFFERENCE HEIGHT (IPLUS NBW NBW)) + 'TEXTURE + 'INVERT NS]) (FIX/SCALE + [LAMBDA (PARAMVALUE SCALE) (* dgb%: "28-Jan-85 10:01") + + (* * fixes PARAMVALUE by SCALE If PARAMVALUE is a list, then fixes the elements + of the list) + + (COND + ((LISTP PARAMVALUE) + (for V in PARAMVALUE collect (FIX/SCALE V SCALE))) + (T (* Note that some parameters may go + to zero) + (FIXR (FTIMES SCALE PARAMVALUE]) (FLIPNODE + [LAMBDA (NODE DS) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (* flips the region around a node.) + (BITBLT NIL NIL NIL DS (IDIFFERENCE (GN/LEFT NODE) + 1) + (IDIFFERENCE (GN/BOTTOM NODE) + 1) + (IPLUS (fetch (GRAPHNODE NODEWIDTH) of NODE) + 2) + (IPLUS (fetch (GRAPHNODE NODEHEIGHT) of NODE) + 2) + 'TEXTURE + 'INVERT BLACKSHADE]) (FONTNAMELIST + [LAMBDA (FONTDESC) (* rrb " 2-NOV-83 21:00") + (LIST (FONTPROP FONTDESC 'FAMILY) + (FONTPROP FONTDESC 'SIZE) + (FONTPROP FONTDESC 'FACE]) (FROMLINKS + [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (fetch (GRAPHNODE FROMNODES) of NODE]) (GETNODEFROMID + [LAMBDA (ID NODELST NODEHASHTABLE) (* ; "Edited 24-Feb-89 11:55 by Briggs") + + (* ;; "Allow Link parameters to be passed as a property list of the node description.") + + (* ;; "nhb, 23-Feb-89: modified -- If the (optional) NODEHASHTABLE is passed then we will use this rather than assoc'ing in the node list to find the node. Also switched order of listp check and bare FASSOC") + + (COND + (NODEHASHTABLE (OR (AND (LISTP ID) + (EQ 'Link% Parameters (CAR ID)) + (GETHASH (CADR ID) + NODEHASHTABLE)) + (GETHASH ID NODEHASHTABLE) + (ERROR "No graphnode for nodeid:" ID))) + (T (OR (AND (LISTP ID) + (EQ 'Link% Parameters (CAR ID)) + (FASSOC (CADR ID) + NODELST)) + (FASSOC ID NODELST) + (ERROR "No graphnode for nodeid:" ID]) (GN/BOTTOM + [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (IDIFFERENCE (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE)) + (HALF (fetch (GRAPHNODE NODEHEIGHT) of NODE]) (GN/LEFT + [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (IDIFFERENCE (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE)) + (HALF (fetch (GRAPHNODE NODEWIDTH) of NODE]) (GN/RIGHT + [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + + (* Assumes that the big-half of width is to the left of the center, for even + width) + + (IPLUS (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE)) + (SUB1 (HALF (ADD1 (fetch (GRAPHNODE NODEWIDTH) of NODE]) (GN/TOP + [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + + (* Assumes that big-half of height is under the center, for even height. + Result is -1 for height=0, which is correct.) + + (IPLUS (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE)) + (SUB1 (HALF (ADD1 (fetch (GRAPHNODE NODEHEIGHT) of NODE]) (GRAPHADDLINK + [LAMBDA (FROM TO GRAPH WINDOW) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (* links two nodes) + (PROG ((ADDFN (fetch (GRAPH GRAPH.ADDLINKFN) of GRAPH))) + (AND ADDFN (APPLY* ADDFN FROM TO GRAPH WINDOW))) + (push (fetch (GRAPHNODE FROMNODES) of TO) + (fetch (GRAPHNODE NODEID) of FROM)) + (push (fetch (GRAPHNODE TONODES) of FROM) + (fetch (GRAPHNODE NODEID) of TO]) (GRAPHADDNODE + [LAMBDA (GRAPH W) (* rrb " 2-NOV-83 20:29") + (* adds a node to the graph GRAPH) + (PROG (ADDFN NODE) + (OR [SETQ NODE (COND + ((SETQ ADDFN (fetch (GRAPH GRAPH.ADDNODEFN) of GRAPH)) + (APPLY* ADDFN GRAPH W)) + (T (DEFAULT.ADDNODEFN GRAPH W T] + (RETURN)) + (replace (GRAPH GRAPHNODES) of GRAPH with (NCONC1 (fetch (GRAPH GRAPHNODES) + of GRAPH) + NODE)) + (RETURN NODE]) (GRAPHBUTTONEVENTFN + [LAMBDA (WINDOW GRAPH LEFTFNOFNODE MIDDLEFNOFNODE REG) (* rmk%: "20-Nov-85 16:33") + + (* applys a function whenever the node is selected. + Is used as BUTTONEVENTFN and gets called whenever cursor moves or button is + down.) + + (TOTOPW WINDOW) + (PROG ((NODELST (fetch (GRAPH GRAPHNODES) of GRAPH)) + (DS (GETSTREAM WINDOW)) + BUTTON OLDPOS REG NOW NEAR) (* note which button is down.) + (COND + ((LASTMOUSESTATE LEFT) + (OR LEFTFNOFNODE (RETURN)) + (SETQ BUTTON 'LEFT)) + ((LASTMOUSESTATE MIDDLE) + (OR MIDDLEFNOFNODE (RETURN)) + (SETQ BUTTON 'MIDDLE)) + (T (* no button down, not interested.) + (RETURN))) (* get the region of this window.) + [SETQ NEAR (NODELST/AS/MENU NODELST (SETQ OLDPOS (CURSORPOSITION NIL DS] + FLIP + (AND NOW (FLIPNODE NOW DS)) + (AND NEAR (FLIPNODE NEAR DS)) + (SETQ NOW NEAR) + LP (* wait for a button up or move out + of region) + (GETMOUSESTATE) + (COND + ((NOT (LASTMOUSESTATE (OR LEFT MIDDLE))) (* button up, process it.) + (AND NOW (FLIPNODE NOW DS)) (* NOW node has been selected.) + (RETURN (APPLY* (SELECTQ BUTTON + (LEFT LEFTFNOFNODE) + (MIDDLE MIDDLEFNOFNODE) + (SHOULDNT)) + NOW WINDOW))) + ((NOT (INSIDE? (WINDOWPROP WINDOW 'REGION) + LASTMOUSEX LASTMOUSEY)) (* outside of region, return) + (AND NOW (FLIPNODE NOW DS)) + (RETURN)) + ([EQ NOW (SETQ NEAR (NODELST/AS/MENU NODELST (CURSORPOSITION NIL DS OLDPOS] + (GO LP)) + (T (GO FLIP]) (GRAPHCHANGELABEL + [LAMBDA (GRAPH W NODE) (* rmk%: "19-Sep-85 10:50") + (* Returns a new label for NODE) + (LET (CHANGEFN) + (COND + ((SETQ CHANGEFN (fetch (GRAPH GRAPH.CHANGELABELFN) of GRAPH)) + (APPLY* CHANGEFN GRAPH W NODE)) + (T (PROMPTINWINDOW "Node label? "]) (GRAPHDELETELINK + [LAMBDA (FROM TO GRAPH WINDOW) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (* deletes a link from a graph) + + (* * rht 4/4/85%: Changed to call REMOVETONODES to remove either nodeID or + paramlist thingie for nodeID.) + + (PROG ((DELFN (fetch (GRAPH GRAPH.DELETELINKFN) of GRAPH))) + (AND DELFN (APPLY* DELFN FROM TO GRAPH WINDOW))) + (replace (GRAPHNODE TONODES) of FROM with (REMOVETONODES (fetch (GRAPHNODE + NODEID) + of TO) + (fetch (GRAPHNODE TONODES) + of FROM))) + (replace (GRAPHNODE FROMNODES) of TO with (REMOVE (fetch (GRAPHNODE NODEID) + of FROM) + (fetch (GRAPHNODE FROMNODES) + of TO]) (GRAPHDELETENODE + [LAMBDA (NODE GRAPH WINDOW) (* kvl " 5-Sep-84 19:03") + (PROG ((DELFN (fetch (GRAPH GRAPH.DELETENODEFN) of GRAPH))) + (AND DELFN (APPLY* DELFN NODE GRAPH WINDOW)) + (replace (GRAPH GRAPHNODES) of GRAPH with (DREMOVE NODE (fetch (GRAPH + GRAPHNODES) + of GRAPH]) (GRAPHEDITCOMMANDFN + [LAMBDA (GRAPHWINDOW) (* rmk%: "19-Sep-85 11:12") + (DECLARE (SPECVARS GRAPHWINDOW)) (* So that window is available to + functions called from menu items) + (SELECTQ [MENU (COND + ((type? MENU EDITGRAPHMENU) + EDITGRAPHMENU) + (T (SETQ EDITGRAPHMENU (create MENU + ITEMS _ EDITGRAPHMENUCOMMANDS + CENTERFLG _ T + CHANGEOFFSETFLG _ T] + (STOP 'STOP) + (MOVENODE (EDITMOVENODE GRAPHWINDOW)) + (ADDNODE (EDITADDNODE GRAPHWINDOW)) + (DELETENODE (EDITDELETENODE GRAPHWINDOW)) + (ADDLINK (EDITADDLINK GRAPHWINDOW)) + (SMALLER (EDITCHANGEFONT 'SMALLER GRAPHWINDOW)) + (LARGER (EDITCHANGEFONT 'LARGER GRAPHWINDOW)) + (DELETELINK (EDITDELETELINK GRAPHWINDOW)) + (CHANGELABEL (EDITCHANGELABEL GRAPHWINDOW)) + (DIRECTED (TOGGLE/DIRECTEDFLG GRAPHWINDOW)) + (SIDES (TOGGLE/SIDESFLG GRAPHWINDOW)) + (BORDER (EDITTOGGLEBORDER GRAPHWINDOW)) + (SHADE (EDITTOGGLELABEL GRAPHWINDOW)) + NIL]) (GRAPHEDITEVENTFN + [LAMBDA (GRWINDOW) (* rmk%: "16-Feb-85 10:15") + (* implements a graph editor on the + right button transition of a window.) + (COND + ((NOT (INSIDE? (DSPCLIPPINGREGION NIL GRWINDOW) + (LASTMOUSEX GRWINDOW) + (LASTMOUSEY GRWINDOW))) + (DOWINDOWCOM GRWINDOW)) + ((SHIFTDOWNP 'CTRL) + (TRACKNODE GRWINDOW)) + ((EQ (GRAPHEDITCOMMANDFN GRWINDOW) + 'STOP) (* do menu) + (CLOSEW GRWINDOW]) (GRAPHER/CENTERPRINTINAREA + [LAMBDA (EXP X Y WIDTH HEIGHT STREAM) (* kvl "15-Aug-84 11:01") + + (* ;; "prints an expression in a box. The system CENTERPRINTINAREA on MENU worried about overflowing the right margin, which we ignore here.") + + (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT)) + (PROG (XPOS (STRWIDTH (STRINGWIDTH EXP STREAM))) + (MOVETO (SETQ XPOS (IPLUS X (IQUOTIENT (ADD1 (IDIFFERENCE WIDTH STRWIDTH)) + 2))) + (IPLUS Y (IQUOTIENT (IPLUS (IDIFFERENCE HEIGHT (FONTPROP STREAM 'ASCENT)) + (FONTPROP STREAM 'DESCENT)) + 2)) + STREAM) + (PRIN3 EXP STREAM]) (GRAPHERPROP + [LAMBDA (GRAPH PROP NEWVALUE) (* ; "Edited 19-Aug-88 14:09 by sye") + (LET (PROPLIST) + (SETPROPLIST PROPLIST (fetch (GRAPH GRAPH.PROPS) of GRAPH)) + (if NEWVALUE + then (PROG1 (PUTPROP PROPLIST PROP NEWVALUE) + (replace (GRAPH GRAPH.PROPS) of GRAPH with (GETPROPLIST + PROPLIST))) + else (GETPROP PROPLIST PROP]) (GRAPHNODE/BORDER/WIDTH + [LAMBDA (BORDER) (* kvl " 5-Sep-84 16:19") + (* returns a non-negative interger) + (COND + ((NULL BORDER) + 0) + ((EQ BORDER T) + 1) + ((FIXP BORDER) + (ABS BORDER)) + ((AND (LISTP BORDER) + (FIXP (CAR BORDER)) + (IGEQ (CAR BORDER) + 0)) + (CAR BORDER)) + (T (ERROR "Illegal border:" BORDER]) (GRAPHREGION + [LAMBDA (GRAPH) (* ; "Edited 29-Apr-94 14:01 by sybalsky") + (* Returns the minimum region + containing the graph.) + (PROG (LEFTOFFSET BOTTOMOFFSET (NODELST (fetch (GRAPH GRAPHNODES) of GRAPH))) + (RETURN (COND + [NODELST (* Determine the dimensions of the + node labels) + (for N in NODELST do (MEASUREGRAPHNODE N)) + (CREATEREGION (SETQ LEFTOFFSET (MIN/LEFT NODELST)) + (SETQ BOTTOMOFFSET (MIN/BOTTOM NODELST)) + (ADD1 (IDIFFERENCE (MAX/RIGHT NODELST) + LEFTOFFSET)) + (ADD1 (IDIFFERENCE (MAX/TOP NODELST) + BOTTOMOFFSET] + (T (CREATEREGION 0 0 0 0]) (HARDCOPYGRAPH + [LAMBDA (GRAPH/WINDOW FILE IMAGETYPE TRANS) (* ; "Edited 23-Apr-92 16:51 by jds") + (LET* + ((LANDSCAPE-FLAG (EQ (LISTGET GRAPH/HARDCOPY/FORMAT 'MODE) + 'LANDSCAPE)) + [PSTREAM (OR (AND FILE (OPENP FILE 'OUTPUT) + (GETSTREAM FILE)) + (OPENIMAGESTREAM FILE IMAGETYPE (APPEND '(CLIP.INCLUSIVE T) + (AND LANDSCAPE-FLAG '(LANDSCAPE T] + (PSCALE (DSPSCALE NIL PSTREAM)) + (ORIGINAL-CLIPREGION (DSPCLIPPINGREGION NIL PSTREAM)) + (GRAPH (COND + ((WINDOWP GRAPH/WINDOW) + (WINDOWPROP GRAPH/WINDOW 'GRAPH)) + (T GRAPH/WINDOW))) + (GRAPH-REGION (GRAPHREGION GRAPH)) + (GRAPH-LEFT (fetch (REGION LEFT) of GRAPH-REGION)) + (GRAPH-BOTTOM (fetch (REGION BOTTOM) of GRAPH-REGION)) + (GRAPH-WIDTH (fetch (REGION WIDTH) of GRAPH-REGION)) + (GRAPH-HEIGHT (fetch (REGION HEIGHT) of GRAPH-REGION)) + (SCREENPOINTS-PER-INCH 72) + (PAGENUMBERS-FLAG (LISTGET GRAPH/HARDCOPY/FORMAT 'PAGENUMBERS)) + [RIGHT-MARGIN (FIXR (TIMES 0 SCREENPOINTS-PER-INCH (OR (LISTGET GRAPH/HARDCOPY/FORMAT + 'RIGHTMARGIN) + 0.5] + [UPPER-MARGIN (FIXR (TIMES 0 SCREENPOINTS-PER-INCH (OR (LISTGET GRAPH/HARDCOPY/FORMAT + 'UPPERMARGIN) + 0.4] + (PAGE-WIDTH (- (FIXR (QUOTIENT (fetch (REGION WIDTH) of ORIGINAL-CLIPREGION) + PSCALE)) + RIGHT-MARGIN)) + (PAGE-HEIGHT (- (FIXR (QUOTIENT (fetch (REGION HEIGHT) of ORIGINAL-CLIPREGION) + PSCALE)) + UPPER-MARGIN)) + (NUMBER-OF-X-PAGES (CL:CEILING GRAPH-WIDTH PAGE-WIDTH)) + (NUMBER-OF-Y-PAGES (CL:CEILING GRAPH-HEIGHT PAGE-HEIGHT)) + [X-POSITION (FIXR (TIMES PSCALE (PLUS PAGE-WIDTH (TIMES 0.2 RIGHT-MARGIN] + [Y-POSITION (FIXR (TIMES PSCALE (PLUS PAGE-HEIGHT (TIMES 0.5 UPPER-MARGIN] + (BOTTOM-CENTERING-OFFSET NIL) + [LEFT-CENTERING-OFFSET (LET (TRAN) + (COND + ((type? POSITION TRANS) + (SETQ BOTTOM-CENTERING-OFFSET (fetch YCOORD of TRANS)) + (fetch XCOORD of TRANS)) + ([type? POSITION (SETQ TRAN (LISTGET GRAPH/HARDCOPY/FORMAT + 'TRANS] + (SETQ BOTTOM-CENTERING-OFFSET (fetch YCOORD of TRAN)) + (fetch XCOORD of TRAN)) + (T (SETQ BOTTOM-CENTERING-OFFSET + (QUOTIENT (PLUS UPPER-MARGIN (DIFFERENCE PAGE-HEIGHT + (REMAINDER GRAPH-HEIGHT + PAGE-HEIGHT))) + 2)) + (QUOTIENT (PLUS RIGHT-MARGIN (DIFFERENCE PAGE-WIDTH + (REMAINDER GRAPH-WIDTH + PAGE-WIDTH))) + 2] + [CLIPREGION (CREATEREGION 0 0 (FIXR (TIMES PSCALE PAGE-WIDTH)) + (FIXR (TIMES PSCALE PAGE-HEIGHT] + (SCALED-GRAPH (SCALE/GRAPH GRAPH PSTREAM))) + + (* ;; "") + + (* ;; " set up margins and clip/region for the print stream") + + (* ;; "") + + (DSPLEFTMARGIN 0 PSTREAM) + (DSPBOTTOMMARGIN 0 PSTREAM) + (DSPTOPMARGIN (fetch (REGION HEIGHT) of ORIGINAL-CLIPREGION) + PSTREAM) + (DSPRIGHTMARGIN (TIMES 2 (fetch (REGION WIDTH) of ORIGINAL-CLIPREGION)) + PSTREAM) + (DSPCLIPPINGREGION CLIPREGION PSTREAM) + + (* ;; "") + + (* ;; " print graph") + + (* ;; "") + + [for Y-PAGE-NUMBER from 1 to NUMBER-OF-Y-PAGES + do (for X-PAGE-NUMBER from 1 to NUMBER-OF-X-PAGES + do (LET [(PTRANS (create POSITION + XCOORD _ + [FIXR (FTIMES PSCALE (PLUS LEFT-CENTERING-OFFSET + (MINUS GRAPH-LEFT) + (MINUS (TIMES (SUB1 + X-PAGE-NUMBER + ) + PAGE-WIDTH] + YCOORD _ + (FIXR (FTIMES PSCALE (PLUS BOTTOM-CENTERING-OFFSET + (MINUS GRAPH-BOTTOM) + (MINUS (TIMES (SUB1 + Y-PAGE-NUMBER + ) + PAGE-HEIGHT] + + (* ;; "") + + (* ;; "write a page-full of graph to the print stream") + + (* ;; "") + + (for N in (fetch (GRAPH GRAPHNODES) of SCALED-GRAPH) + do (DISPLAYNODELINKS N PTRANS PSTREAM SCALED-GRAPH T PSCALE) + ) + (for N in (fetch (GRAPH GRAPHNODES) of SCALED-GRAPH) + do (PRINTDISPLAYNODE N PTRANS PSTREAM CLIPREGION)) + + (* ;; "") + + (* ;; " print the page number & start a new page") + + (* ;; "") + + (CL:UNLESS (AND (= X-PAGE-NUMBER NUMBER-OF-X-PAGES) + (= Y-PAGE-NUMBER NUMBER-OF-Y-PAGES)) + (COND + (PAGENUMBERS-FLAG (DSPCLIPPINGREGION ORIGINAL-CLIPREGION PSTREAM + ) + (MOVETO X-POSITION Y-POSITION PSTREAM) + (printout PSTREAM Y-PAGE-NUMBER "-" X-PAGE-NUMBER) + (DSPCLIPPINGREGION CLIPREGION PSTREAM))) + (DSPNEWPAGE PSTREAM))] + (CLOSEF PSTREAM]) (INTERSECT/REGIONP/LBWH + [LAMBDA (L B W H REG HOW NODE) (* ; "Edited 11-Jun-90 16:15 by mitani") + (* ; + "like intersect regions, but without requiring the consing") + (* + |how = partial :check if the nodelabel was partially intersect with REG|) + (* + |otherwise :check if the whole nodelabel was contained in REG|) + (SELECTQ HOW + (PARTIAL (NOT (OR (IGREATERP (fetch (REGION BOTTOM) of REG) + (IPLUS B H)) + (ILESSP (fetch (REGION PRIGHT) of REG) + L) + (IGREATERP (fetch (REGION LEFT) of REG) + (IPLUS L W)) + (ILESSP (fetch (REGION PTOP) of REG) + B)))) + (EQUAL (INTERSECTREGIONS REG (LIST L B W H)) + (LIST L B W H]) (INVERTED/GRAPHNODE/BORDER + [LAMBDA (BORDER) (* kvl " 5-Sep-84 18:49") + (* returns the right thing to invert + a graphnode's border) + (COND + ((EQ BORDER T) + NIL) + ((NULL BORDER) + T) + ((FIXP BORDER) + (IMINUS BORDER)) + ((AND (LISTP BORDER) + (FIXP (CAR BORDER))) + (LIST (CAR BORDER) + (INVERTED/SHADE/FOR/GRAPHER (CADR BORDER]) (INVERTED/SHADE/FOR/GRAPHER + [LAMBDA (SHADE) (* rmk%: "20-Sep-85 09:31") + (* funny name because hopefully will + become system function) + (COND + ((EQ SHADE T) + NIL) + ((NULL SHADE) + T) + ((FIXP SHADE) + (LOGNOT SHADE)) + ((BITMAPP SHADE) + (PROG ((NB (BITMAPCOPY SHADE))) + (BLTSHADE BLACKSHADE NB NIL NIL NIL NIL 'INVERT) + (RETURN NB))) + (T (ERROR "Illegal shade:" SHADE]) (LAYOUT/POSITION + [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (fetch (GRAPHNODE NODEPOSITION) of NODE]) (LINKPARAMETERS + [LAMBDA (FROMND TOND) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (PROG (TOPARAMS) + (RETURN (AND (SETQ TOPARAMS (MEMBTONODES (fetch (GRAPHNODE NODEID) of TOND) + (TOLINKS FROMND))) + (LISTP TOPARAMS) + (EQ 'Link% Parameters (CAR TOPARAMS)) + (CDDR TOPARAMS]) (MAX/RIGHT + [LAMBDA (NODES) (* rmk%: "20-Dec-84 09:33") + (for NODE in NODES largest (GN/RIGHT NODE) finally (RETURN $$EXTREME]) (MAX/TOP + [LAMBDA (NODES) (* rmk%: "20-Dec-84 09:34") + (for NODE in NODES largest (GN/TOP NODE) finally (RETURN $$EXTREME]) (MEASUREGRAPHNODE + [LAMBDA (NODE RESETFLG) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (* Measure the nodelabel image) + (SET/LABEL/SIZE NODE RESETFLG) + (SET/LAYOUT/POSITION NODE (OR (fetch (GRAPHNODE NODEPOSITION) of NODE) + (ERROR "This graphnode has not been given a position:" NODE]) (MEMBTONODES + [LAMBDA (TOND TONODES) (* dgb%: "24-Jan-85 08:05") + (for Z in TONODES do (COND + ([OR (EQ TOND Z) + (AND (LISTP Z) + (EQ (CAR Z) + 'Link% Parameters) + (EQ TOND (CADR Z] + (RETURN Z]) (MIN/BOTTOM + [LAMBDA (NODES) (* rmk%: "20-Dec-84 09:34") + (* returns the bottommost point of + the graph.) + (for NODE in NODES smallest (GN/BOTTOM NODE) finally (RETURN $$EXTREME]) (MIN/LEFT + [LAMBDA (NODES) (* rmk%: "20-Dec-84 09:34") + (* returns the leftmost point of the + graph.) + (for NODE in NODES smallest (GN/LEFT NODE) finally (RETURN $$EXTREME]) (MOVENODE + [LAMBDA (NODE OLDPOS POS GRAPH STREAM) (* rmk%: "10-Apr-84 12:31") + (* moves a node from its current + position to POS) + (COND + ((EQUAL OLDPOS POS) (* don't move if position hasn't + changed) + NIL) + (T (* node is flipped, flip it back.) + (FLIPNODE NODE STREAM) (* erase current position) + (DISPLAYNODE NODE (CONSTANT (create POSITION + XCOORD _ 0 + YCOORD _ 0)) + STREAM GRAPH) (* put it in new one.) + (SET/LAYOUT/POSITION NODE POS) + (DISPLAYNODE NODE (CONSTANT (create POSITION + XCOORD _ 0 + YCOORD _ 0)) + STREAM GRAPH) + (FLIPNODE NODE STREAM]) (NODECREATE + [LAMBDA (ID LABEL POS TONODEIDS FROMNODEIDS FONT BORDER LABELSHADE) + (* Randy.Gobbel "13-May-87 12:04") + (* creates a node for a grapher.) + (create GRAPHNODE + NODEID _ ID + NODEPOSITION _ POS + NODELABEL _ LABEL + NODEFONT _ (COND + (FONT) + ((IMAGEOBJP LABEL) + NIL) + (DEFAULT.GRAPH.NODEFONT) + (T (FONTNAMELIST DEFAULTFONT))) + TONODES _ TONODEIDS + FROMNODES _ FROMNODEIDS + NODEBORDER _ BORDER + NODELABELSHADE _ LABELSHADE]) (NODELST/AS/MENU + [LAMBDA (NODELST POS) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (* finds the node that is closest to + POS) + (for N in NODELST bind (X _ (fetch XCOORD of POS)) + (Y _ (fetch YCOORD of POS)) + T1 T2 + thereis (AND (ILESSP [IDIFFERENCE (SETQ T1 (fetch YCOORD of (fetch + (GRAPHNODE + NODEPOSITION) + of N))) + (SETQ T2 (HALF (fetch (GRAPHNODE NODEHEIGHT) of N] + Y) + (ILESSP Y (IPLUS T1 T2)) + (ILESSP [IDIFFERENCE (SETQ T1 (fetch XCOORD of (fetch + (GRAPHNODE + NODEPOSITION) + of N))) + (SETQ T2 (HALF (fetch (GRAPHNODE NODEWIDTH) of N] + X) + (ILESSP X (IPLUS T1 T2]) (NODEREGION + [LAMBDA (NODE) (* kvl "10-Aug-84 17:25") + (* returns the region taken up by + NODE) + (CREATEREGION (GN/LEFT NODE) + (GN/BOTTOM NODE) + (fetch (GRAPHNODE NODEWIDTH) of NODE) + (fetch (GRAPHNODE NODEHEIGHT) of NODE]) (PRINTDISPLAYNODE + [LAMBDA (NODE TRANS STREAM CLIP/REG) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (* ; "Edited 12-Aug-88 12:58 by sye") + + (* ;; "prints a node at its position translated by TRANS. Takes the operation from the stream so that when editor has set the operation to invert, this may erase as well as draw; but when the operation is paint, then nodes obliterate any link lines that they are drawn over.") + + (OR (ZEROP (fetch (GRAPHNODE NODEHEIGHT) of NODE)) + (PROG* [(LABEL (fetch (GRAPHNODE NODELABEL) of NODE)) + (LEFT (IPLUS (fetch (POSITION XCOORD) of TRANS) + (GN/LEFT NODE))) + (BOTTOM (IPLUS (fetch (POSITION YCOORD) of TRANS) + (GN/BOTTOM NODE))) + (WIDTH (fetch (GRAPHNODE NODEWIDTH) of NODE)) + (HEIGHT (fetch (GRAPHNODE NODEHEIGHT) of NODE)) + (FONT (fetch (GRAPHNODE NODEFONT) of NODE)) + (NBW (GRAPHNODE/BORDER/WIDTH (fetch (GRAPHNODE NODEBORDER) of NODE] + [AND (WINDOWP STREAM) + (SETQ STREAM (WINDOWPROP STREAM 'DSP] + (COND + ([AND CLIP/REG (NOT (INTERSECT/REGIONP/LBWH LEFT BOTTOM WIDTH HEIGHT CLIP/REG + 'PARTIAL] + (RETURN NODE)) + ((BITMAPP (fetch (GRAPHNODE NODELABELBITMAP) of NODE)) + (BITBLT (fetch (GRAPHNODE NODELABELBITMAP) of NODE) + 0 0 STREAM LEFT BOTTOM WIDTH HEIGHT 'INPUT)) + [(BITMAPP LABEL) + (COND + ((NEQ 0 NBW) + (DRAW/GRAPHNODE/BORDER (fetch (GRAPHNODE NODEBORDER) of NODE) + LEFT BOTTOM WIDTH HEIGHT STREAM) + (BITBLT LABEL 0 0 STREAM (IPLUS LEFT NBW) + (IPLUS BOTTOM NBW) + (BITMAPWIDTH LABEL) + (BITMAPHEIGHT LABEL) + 'INPUT)) + (T (BITBLT LABEL 0 0 STREAM LEFT BOTTOM WIDTH HEIGHT 'INPUT] + ((IMAGEOBJP LABEL) + (OR (ZEROP NBW) + (DRAW/GRAPHNODE/BORDER (fetch (GRAPHNODE NODEBORDER) of NODE) + LEFT BOTTOM WIDTH HEIGHT STREAM)) + + (* RMK--In order to place image objects properly, must take into account their + XKERN and YDESC) + + (LET ((IMAGEBOX (APPLY* (IMAGEOBJPROP LABEL 'IMAGEBOXFN) + LABEL STREAM 0 WIDTH))) + (* Formerly just LEFT and BOTTOM) + (MOVETO (IPLUS NBW LEFT (fetch XKERN of IMAGEBOX)) + (IPLUS NBW BOTTOM (fetch YDESC of IMAGEBOX)) + STREAM)) + + (* * End of modifications. RMK) + + (APPLY* (IMAGEOBJPROP LABEL 'DISPLAYFN) + LABEL STREAM)) + ((EQ FONT 'SHADE) (* so small just use texture) + (LET [(2SCALE (ITIMES 2 (DSPSCALE NIL STREAM] + (BLTSHADE BLACKSHADE STREAM LEFT BOTTOM 2SCALE 2SCALE))) + ((NULL FONT)) + (T (OR (FONTP FONT) + (SETQ FONT (FONTCREATE FONT NIL NIL NIL STREAM))) + (AND (NEQ NBW 0) + (DRAW/GRAPHNODE/BORDER (fetch (GRAPHNODE NODEBORDER) of NODE) + LEFT BOTTOM WIDTH HEIGHT STREAM)) + (DSPFONT FONT STREAM) + (GRAPHER/CENTERPRINTINAREA LABEL LEFT BOTTOM WIDTH HEIGHT STREAM) + (AND (fetch (GRAPHNODE NODELABELSHADE) of NODE) + (FILL/GRAPHNODE/LABEL (fetch (GRAPHNODE NODELABELSHADE) + of NODE) + LEFT BOTTOM WIDTH HEIGHT NBW STREAM)) + (COND + ((AND CACHE/NODE/LABEL/BITMAPS (DISPLAYSTREAMP STREAM) + CLIP/REG + (INTERSECT/REGIONP/LBWH LEFT BOTTOM WIDTH HEIGHT CLIP/REG + 'WHOLE)) + (replace (GRAPHNODE NODELABELBITMAP) of NODE with (BITMAPCREATE + WIDTH HEIGHT) + ) + (BITBLT STREAM LEFT BOTTOM (fetch (GRAPHNODE NODELABELBITMAP) + of NODE) + 0 0 WIDTH HEIGHT 'INPUT]) (PROMPTINWINDOW + [LAMBDA (PROMPTSTR POSITION WHICHCORNER BORDERSIZE) (* jds "18-Mar-86 17:49") + (* opens a small window for + prompting at a position and + PROMPTFORWORD's a word.) + + (* POSITION is the location in screen coordinate of the window. + Default is the cursor position.) + + (* WHICHCORNER can be a list of up to two of the atoms LEFT RIGHT TOP BOTTOM + which specify which corner position is intended to be. + Default is lower left.) + (* BORDERSIZE is the border size of + the prompt window. + Default is 6.0) + (PROG ((PROMPTWBORDER (OR (NUMBERP BORDERSIZE) + 6)) + (X (COND + (POSITION (fetch (POSITION XCOORD) of POSITION)) + (T LASTMOUSEX))) + (Y (COND + (POSITION (fetch (POSITION YCOORD) of POSITION)) + (T LASTMOUSEY))) + HGHT WDTH READSTR PREVTTY) + (SETQ HGHT (HEIGHTIFWINDOW (ITIMES (FONTPROP (DEFAULTFONT 'DISPLAY) + 'HEIGHT) + 2) + T PROMPTWBORDER)) + (SETQ WDTH (WIDTHIFWINDOW (IMAX (STRINGWIDTH PROMPTSTR WindowTitleDisplayStream) + 60) + PROMPTWBORDER)) + (SETQ PREVTTY (CREATEW (CREATEREGION (COND + ((MEMB 'RIGHT WHICHCORNER) + (DIFFERENCE X WDTH)) + (T X)) + (COND + ((MEMB 'TOP WHICHCORNER) + (DIFFERENCE Y HGHT)) + (T Y)) + WDTH HGHT) + PROMPTSTR PROMPTWBORDER)) + (DSPLEFTMARGIN (IMAX 0 (fetch (CURSOR CUHOTSPOTX) of (CARET))) + PREVTTY) + (MOVETOUPPERLEFT PREVTTY) + [SETQ READSTR (ERSETQ (PROMPTFORWORD NIL NIL NIL PREVTTY NIL NIL (LIST (CHARCODE EOL] + (CLOSEW PREVTTY) + (RETURN (COND + (READSTR (CAR READSTR)) + (T (* pass back the error.) + (ERROR!]) (READ/NODE + [LAMBDA (NODES DS) (* ; "Edited 23-Jul-87 18:20 by sye") + + (* * rht 8/20/85%: Modified "until" statement so it waits till user clicks + inside of window.) + + [bind (CR _ (DSPCLIPPINGREGION NIL DS)) until (AND (MOUSESTATE (OR LEFT MIDDLE RIGHT)) + (INSIDEP CR (CURSORPOSITION NIL DS] + (PROG (NEAR NOW OLDPOS) + [SETQ NEAR (NODELST/AS/MENU NODES (SETQ OLDPOS (CURSORPOSITION NIL DS] + FLIP + (* turn off old flip + (if one) and turn on new flip.) + (AND NOW (FLIPNODE NOW DS)) + (AND NEAR (FLIPNODE NEAR DS)) + (SETQ NOW NEAR) + LP (COND + ((MOUSESTATE UP) + (AND NOW (FLIPNODE NOW DS)) + (RETURN NOW)) + ([EQ NOW (SETQ NEAR (NODELST/AS/MENU NODES (CURSORPOSITION NIL DS OLDPOS] + (GO LP)) + (T (GO FLIP]) (REDISPLAYGRAPH + [LAMBDA (WINDOW REGION) (* kvl "10-Aug-84 19:52") + + (* displays the graph that is in a window. + REGION if given is the clipping region. + Later this could be used to make things run faster.) + + (DSPFILL NIL NIL 'REPLACE WINDOW) + (DISPLAYGRAPH (WINDOWPROP WINDOW 'GRAPH) + WINDOW + (OR REGION (DSPCLIPPINGREGION NIL WINDOW]) (REMOVETONODES + [LAMBDA (TOND TONODES) (* rht%: " 4-Apr-85 19:32") + + (* * Removes either TOND or a paramlist thingie for TOND.) + + (for Z in TONODES unless [OR (EQ Z TOND) + (AND (LISTP Z) + (EQ (CAR Z) + 'Link% Parameters) + (EQ TOND (CADR Z] collect Z]) (RESET/NODE/BORDER + [LAMBDA (NODE BORDER STREAM GRAPH TRANS) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + + (* ;; "gives the node a new border, and displays it if there is a stream. Might not be a stream if being called just to finagle a graph datastructure.") + + (PROG [(ONBW (GRAPHNODE/BORDER/WIDTH (fetch (GRAPHNODE NODEBORDER) of NODE] + [OR TRANS (SETQ TRANS (CONSTANT (create POSITION + XCOORD _ 0 + YCOORD _ 0] + (COND + (STREAM (ERASE/GRAPHNODE NODE STREAM TRANS) + [OR GRAPH (AND (WINDOWP STREAM) + (SETQ GRAPH (WINDOWPROP STREAM 'GRAPH] + (DISPLAYNODELINKS NODE TRANS STREAM GRAPH))) + (replace (GRAPHNODE NODEBORDER) of NODE with (COND + ((EQ BORDER 'INVERT) + (INVERTED/GRAPHNODE/BORDER + (fetch (GRAPHNODE + NODEBORDER) + of NODE))) + (T BORDER))) + (replace (GRAPHNODE NODELABELBITMAP) of NODE with NIL) + (OR (IEQP ONBW (GRAPHNODE/BORDER/WIDTH (fetch (GRAPHNODE NODEBORDER) of NODE))) + (SET/LABEL/SIZE NODE T)) + (AND STREAM (DISPLAYNODE NODE TRANS STREAM GRAPH)) + (RETURN NODE]) (RESET/NODE/LABELSHADE + [LAMBDA (NODE SHADE STREAM TRANS) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (* gives the node a new SHADE and + displays it if there is a stream) + (AND STREAM (ERASE/GRAPHNODE NODE STREAM TRANS)) + (replace (GRAPHNODE NODELABELSHADE) of NODE with (COND + ((EQ SHADE 'INVERT) + (INVERTED/SHADE/FOR/GRAPHER + (fetch (GRAPHNODE + NODELABELSHADE + ) + of NODE))) + (T SHADE))) + (replace (GRAPHNODE NODELABELBITMAP) of NODE with NIL) + (AND STREAM (PRINTDISPLAYNODE NODE (OR TRANS (CONSTANT (create POSITION + XCOORD _ 0 + YCOORD _ 0))) + STREAM + (DSPCLIPPINGREGION NIL STREAM))) + NODE]) (SCALE/GRAPH + [LAMBDA (GRAPH STREAM) (* ; "Edited 29-Apr-94 14:01 by sybalsky") + + (* ;; "Scale the graph GRAPH so it'll look right when rendered on the image stream STREAM. This involves both scaling all the coordinates, and fixing node positions (because we keep track of teh CENTER of each node, even though we really want the lower, left corner to be in the right place).") + + (LET ((SCALE (DSPSCALE NIL STREAM)) + [LAYOUT-IS-VERTICAL (EQMEMB 'VERTICAL (LISTGET (fetch (GRAPH GRAPH.PROPS) of GRAPH) + 'FORMAT] + HEIGHT WIDTH) + (create GRAPH + using + GRAPH GRAPHNODES _ + (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) + collect + + (* ;; "Move each node to its new position.") + + (* ;; "Start by finding the node's lower, left corner, then scaling that.") + + (SETQ WIDTH (fetch (GRAPHNODE NODEWIDTH) of N)) + (SETQ HEIGHT (fetch (GRAPHNODE NODEHEIGHT) of N)) + (SETQ N (create GRAPHNODE + using + N NODEPOSITION _ + [COND + [LAYOUT-IS-VERTICAL + + (* ;; "Layout is vertical, so make the center correct.") + + (create POSITION + XCOORD _ [FIXR (FTIMES SCALE (fetch XCOORD + of (fetch + (GRAPHNODE + NODEPOSITION + ) + of N] + YCOORD _ (FIXR (FTIMES SCALE (fetch YCOORD + of (fetch + (GRAPHNODE + NODEPOSITION + ) + of N] + (T + (* ;; "Horizontal layout, so make the left bottom correct.") + + (create POSITION + XCOORD _ [FIXR (FTIMES SCALE + (IDIFFERENCE + (fetch XCOORD + of (fetch (GRAPHNODE + + NODEPOSITION + ) + of N)) + (LRSH WIDTH 1] + YCOORD _ (FIXR (FTIMES SCALE + (IDIFFERENCE + (fetch YCOORD + of (fetch (GRAPHNODE + + NODEPOSITION + ) + of N)) + (LRSH HEIGHT 1] + NODEWIDTH _ NIL NODEHEIGHT _ NIL NODEFONT _ + (FONTCREATE (fetch (GRAPHNODE NODEFONT) + N) + NIL NIL NIL STREAM) + TONODES _ (SCALE/TONODES N SCALE) + NODEBORDER _ (SCALE/GRAPHNODE/BORDER (fetch (GRAPHNODE + NODEBORDER + ) + of N) + SCALE))) + + (* ;; "Now figure out the new width & height of the node:") + + (SET/LABEL/SIZE N NIL STREAM) + + (* ;; "Now find the new center point, so the node prints in the right place:") + + [COND + ((NOT LAYOUT-IS-VERTICAL) + + (* ;; "Only do this if the layout is horizontal.") + + (add (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) + of N)) + (LRSH (fetch (GRAPHNODE NODEHEIGHT) of N) + 1)) + (add (fetch XCOORD of (fetch (GRAPHNODE NODEPOSITION) + of N)) + (LRSH (fetch (GRAPHNODE NODEWIDTH) of N) + 1] + N]) (SCALE/GRAPHNODE/BORDER + [LAMBDA (BORDER SCALE) (* kvl " 5-Sep-84 18:06") + (* returns a new setting for the + border appropriate for the given + SCALE) + (COND + ((NULL BORDER) + 0) + ((EQ BORDER T) + (FIXR (FTIMES SCALE NODEBORDERWIDTH))) + ((FIXP BORDER) + (FIXR (FTIMES SCALE BORDER))) + ((AND (LISTP BORDER) + (FIXP (CAR BORDER))) + (CONS (FIXR (FTIMES SCALE (CAR BORDER))) + (CDR BORDER]) (SCALE/TONODES + [LAMBDA (NODE SCALE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (for NODEID in (fetch (GRAPHNODE TONODES) of NODE) + collect (* copy the property list so that + the scaling doesn't change the + original.) + (COND + [(AND (LISTP NODEID) + (EQ 'Link% Parameters (CAR NODEID)) + (SETQ NODEID (APPEND NODEID)) + (for prop val in ScalableLinkParameters + do (AND (SETQ val (LISTGET NODEID prop)) + (LISTPUT NODEID prop (FIX/SCALE val SCALE] + (T NODEID]) (SET/LABEL/SIZE + [LAMBDA (NODE RESET/FLG STREAM) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (* the SHADE and null font stuff is + for ZOOMGRAPH) + (OR (AND (NOT RESET/FLG) + (FIXP (fetch (GRAPHNODE NODEHEIGHT) of NODE)) + (FIXP (fetch (GRAPHNODE NODEWIDTH) of NODE))) + (PROG ((SCALE (DSPSCALE NIL STREAM)) + (FONT (fetch (GRAPHNODE NODEFONT) of NODE)) + (LAB (fetch (GRAPHNODE NODELABEL) of NODE)) + (NBW (GRAPHNODE/BORDER/WIDTH (fetch (GRAPHNODE NODEBORDER) of NODE))) + WIDTH HEIGHT) + [COND + [(BITMAPP LAB) (* (* ; + "set up appropriate width & height by checking the scale of stream")) + (SETQ WIDTH (OR [AND (NEQ SCALE 1) + (FIXR (FTIMES SCALE (BITMAPWIDTH LAB] + (BITMAPWIDTH LAB))) + (SETQ HEIGHT (OR [AND (NEQ SCALE 1) + (FIXR (FTIMES SCALE (BITMAPHEIGHT LAB] + (BITMAPHEIGHT LAB] + ((IMAGEOBJP LAB) + (SETQ WIDTH (APPLY* (IMAGEOBJPROP LAB 'IMAGEBOXFN) + LAB STREAM)) + (SETQ HEIGHT (fetch (IMAGEBOX YSIZE) of WIDTH)) + (SETQ WIDTH (fetch (IMAGEBOX XSIZE) of WIDTH))) + ((EQ FONT 'SHADE) (* node image is very small) + (SETQ WIDTH (SETQ HEIGHT 2))) + [(NULL FONT) (* FONT of NIL means that the node + is smaller than displays) + (SETQ NBW (SETQ WIDTH (SETQ HEIGHT 0] + (T (OR (FONTP FONT) + (SETQ FONT (FONTCREATE FONT NIL NIL NIL STREAM))) + [SETQ WIDTH (IPLUS (STRINGWIDTH (fetch (GRAPHNODE NODELABEL) of NODE) + FONT) + (FONTPROP FONT 'DESCENT] + (SETQ HEIGHT (IPLUS (FONTPROP FONT 'HEIGHT) + (FONTPROP FONT 'DESCENT] + (OR (AND (NOT RESET/FLG) + (FIXP (fetch (GRAPHNODE NODEWIDTH) of NODE))) + (replace (GRAPHNODE NODEWIDTH) of NODE with (IPLUS WIDTH NBW NBW))) + (OR (AND (NOT RESET/FLG) + (FIXP (fetch (GRAPHNODE NODEHEIGHT) of NODE))) + (replace (GRAPHNODE NODEHEIGHT) of NODE with (IPLUS HEIGHT NBW NBW))) + (RETURN NODE]) (SET/LAYOUT/POSITION + [LAMBDA (NODE POS) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (* sets a nodes position) + (replace XCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE) + with (fetch XCOORD of POS)) + (replace YCOORD of (fetch (GRAPHNODE NODEPOSITION) of NODE) + with (fetch YCOORD of POS)) + NODE]) (SHOWGRAPH + [LAMBDA (GRAPH WINDOW LEFTBUTTONFN MIDDLEBUTTONFN TOPJUSTIFYFLG ALLOWEDITFLG COPYBUTTONEVENTFN + CENTERFLG) (* ; "Edited 28-Sep-93 17:20 by jds") + + (* ;; "puts a graph in the given window, creating one if a window is not given.") + + (SETQ WINDOW (SIZE/GRAPH/WINDOW (COND + ((NULL GRAPH) + (SETQ GRAPH (create GRAPH))) + (T GRAPH)) + (COND + (WINDOW) + (ALLOWEDITFLG (* ; + "put on a title so there will be a place to get window commands.") + "Graph Editor Window")) + TOPJUSTIFYFLG CENTERFLG)) + (WINDOWPROP WINDOW 'GRAPH GRAPH) + (WINDOWPROP WINDOW 'REPAINTFN (FUNCTION REDISPLAYGRAPH)) + (WINDOWPROP WINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) + (WINDOWPROP WINDOW 'HARDCOPYFN (FUNCTION HARDCOPYGRAPH)) + (COND + (ALLOWEDITFLG (* ; + "change the mode to invert so lines can be erased by being redrawn.") + (DSPOPERATION 'INVERT WINDOW) + (WINDOWPROP WINDOW 'RIGHTBUTTONFN (FUNCTION GRAPHEDITEVENTFN))) + (T (WINDOWPROP WINDOW 'RIGHTBUTTONFN NIL))) + (WINDOWPROP WINDOW 'COPYBUTTONEVENTFN (OR COPYBUTTONEVENTFN (FUNCTION GRAPHERCOPYBUTTONEVENTFN))) + (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION APPLYTOSELECTEDNODE)) + (WINDOWPROP WINDOW 'BROWSER/LEFTFN LEFTBUTTONFN) + (WINDOWPROP WINDOW 'BROWSER/MIDDLEFN MIDDLEBUTTONFN) + (REDISPLAYGRAPH WINDOW) + WINDOW]) (SIZE/GRAPH/WINDOW + [LAMBDA (GRAPH WINDOW/TITLE TOPJUSTIFYFLG CENTERFLG) (* ; "Edited 28-Sep-93 17:21 by jds") + + (* ;; "returns a window sized to fit the given graph. WINDOW/TITLE can be either a window to be printed in or a title of a window to be created. If TOPJUSTIFYFLG is true, scrolls so top of graph is at top of window, else puts bottom of graph at bottom of window.") + + (PROG ((GRAPHREG (GRAPHREGION GRAPH)) + TITLE WINDOW) + (COND + ((WINDOWP WINDOW/TITLE) + (SETQ WINDOW WINDOW/TITLE)) + (T (SETQ TITLE WINDOW/TITLE))) + + (* ;; "if there is not already a window, ask the user for one to fit.") + + (COND + ((NULL WINDOW) + (SETQ WINDOW (CREATEW (GETBOXREGION (WIDTHIFWINDOW (IMIN (IMAX (fetch (REGION + WIDTH) + of GRAPHREG) + 100) + (FIXR (CAR + DEFAULT.GRAPH.WINDOWSIZE + )) + SCREENWIDTH)) + (HEIGHTIFWINDOW (IMIN (IMAX (fetch (REGION HEIGHT) + of GRAPHREG) + 60) + (FIXR (CADR DEFAULT.GRAPH.WINDOWSIZE + )) + SCREENHEIGHT) + TITLE)) + TITLE))) + (T (CLEARW WINDOW))) + (WINDOWPROP WINDOW 'EXTENT GRAPHREG) + (WXOFFSET [COND + [CENTERFLG (IDIFFERENCE (WXOFFSET NIL WINDOW) + (IDIFFERENCE (IPLUS (fetch (REGION LEFT) of GRAPHREG + ) + (LRSH (fetch (REGION WIDTH) + of GRAPHREG) + 1)) + (LRSH (WINDOWPROP WINDOW 'WIDTH) + 1] + (T (* ; "Put it at the left edge.") + (IDIFFERENCE (WXOFFSET NIL WINDOW) + (fetch (REGION LEFT) of GRAPHREG] + WINDOW) + (WYOFFSET [IDIFFERENCE (WYOFFSET NIL WINDOW) + (COND + [TOPJUSTIFYFLG (IDIFFERENCE (fetch (REGION PTOP) of GRAPHREG) + (WINDOWPROP WINDOW 'HEIGHT] + (T (fetch (REGION BOTTOM) of GRAPHREG] + WINDOW) + (RETURN WINDOW]) (TOGGLE/DIRECTEDFLG + [LAMBDA (WIN) (* kvl "20-APR-82 13:38") + (* flips the value of the flag that + indicates whether the graph is a + lattice.) + [replace (GRAPH DIRECTEDFLG) of (WINDOWPROP WIN 'GRAPH) + with (NOT (fetch (GRAPH DIRECTEDFLG) of (WINDOWPROP WIN 'GRAPH] + (DSPFILL NIL (DSPTEXTURE NIL WIN) + 'REPLACE WIN) + (REDISPLAYGRAPH WIN]) (TOGGLE/SIDESFLG + [LAMBDA (WIN) (* kvl "20-APR-82 13:15") + + (* flips the value of the flag that indicates whether the graph is to be layed + out vertically or horizontally.) + + [replace (GRAPH SIDESFLG) of (WINDOWPROP WIN 'GRAPH) + with (NOT (fetch (GRAPH SIDESFLG) of (WINDOWPROP WIN 'GRAPH] + (DSPFILL NIL (DSPTEXTURE NIL WIN) + 'REPLACE WIN) + (REDISPLAYGRAPH WIN]) (TOLINKS + [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (fetch (GRAPHNODE TONODES) of NODE]) (TRACKCURSOR + [LAMBDA (ND DS GRAPH) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (* causes ND to follow cursor.) + (PROG (OLDPOS ORIGPOS DOWNFLG) (* maybe there aren't any nodes) + (OR ND (RETURN)) + (SETQ ORIGPOS (create POSITION using (fetch (GRAPHNODE NODEPOSITION) + of ND))) + (SETQ OLDPOS (CURSORPOSITION (fetch (GRAPHNODE NODEPOSITION) of ND) + DS)) + (FLIPNODE ND DS) + (until (COND + (DOWNFLG (MOUSESTATE UP)) + ((SETQ DOWNFLG (MOUSESTATE (NOT UP))) + NIL)) do (MOVENODE ND (fetch (GRAPHNODE NODEPOSITION) + of ND) + (CURSORPOSITION NIL DS OLDPOS) + GRAPH DS)) + (FLIPNODE ND DS) + (COND + ([NOT (EQUAL ORIGPOS (SETQ OLDPOS (fetch (GRAPHNODE NODEPOSITION) of ND] + (EXTENDEXTENT (WFROMDS DS) + (NODEREGION ND)) + (CALL.MOVENODEFN ND OLDPOS GRAPH (WFROMDS DS) + ORIGPOS]) (TRACKNODE + [LAMBDA (W) (* ; "Edited 17-Jul-87 15:26 by sye") + + (* grabs the nearest nodes and hauls it around with the cursor, leaving it + where it is when the button goes up.) + + (TRACKCURSOR (NODELST/AS/MENU (fetch (GRAPH GRAPHNODES) of (WINDOWPROP + W + 'GRAPH)) + (CURSORPOSITION NIL W)) + (WINDOWPROP W 'DSP) + (WINDOWPROP W 'GRAPH]) (TRANSGRAPH + [LAMBDA (GRAPH X Y) (* ; "Edited 29-Apr-94 14:01 by sybalsky") + (create GRAPH reusing GRAPH GRAPHNODES _ + (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) + collect (create GRAPHNODE + reusing N NODEPOSITION _ + (create POSITION + XCOORD _ (PLUS X + (fetch XCOORD + of + (fetch (GRAPHNODE + NODEPOSITION + ) + of N))) + YCOORD _ (PLUS Y + (fetch YCOORD + of + (fetch (GRAPHNODE + NODEPOSITION + ) + of N]) ) (* ;; "Support for EDITSUBGRAPH and EDITREGION") (DEFINEQ (EDITMOVEREGION + [LAMBDA (Window) (* Newman "27-Jan-87 11:08") + + (* * This function moves all the nodes within a selected region to another + region of similar shape and size.) + + (if (NOT (WINDOWP Window)) + then (ERROR Window " not a window.") + else (PROMPTPRINT " Select the region containing the nodes you wish to move.") + (PROG* ((DisplayStream (WINDOWPROP Window 'DSP)) + (Region (GETWREGION Window)) + (Graph (WINDOWPROP Window 'GRAPH)) + (NodeList (for Node in (fetch (GRAPH GRAPHNODES) of Graph) + when (OR (INTERSECTREGIONS Region (NODEREGION Node)) + (SUBREGIONP Region (NODEREGION Node))) collect + Node))) + (if (NULL Graph) + then (ERROR Window " not a graph window.") + elseif (NULL NodeList) + then (PROMPTPRINT "No nodes in the region selected.")) + (for Node in NodeList do (FLIPNODE Node DisplayStream)) + (bind OldPos (NewRegionPosition _ (GETBOXPOSITION.FROMINITIALREGION Window + Region DisplayStream)) for + SelectedNode + in NodeList eachtime (SETQ OldPos (fetch (GRAPHNODE NODEPOSITION) + of SelectedNode)) + do (MOVENODE SelectedNode OldPos (CREATE.NEW.NODEPOSITION + SelectedNode + (DIFFERENCE (fetch (POSITION + XCOORD) + of + NewRegionPosition + ) + (fetch (REGION LEFT) + of Region)) + (DIFFERENCE (fetch (POSITION + YCOORD) + of + NewRegionPosition + ) + (fetch (REGION BOTTOM) + of Region))) + Graph DisplayStream) + (EXTENDEXTENT (WFROMDS DisplayStream) + (NODEREGION SelectedNode)) + (* extent the graph extent because + the node may be outside the old + extent.) + (FLIPNODE SelectedNode DisplayStream]) (EDITMOVESUBTREE + [LAMBDA (WINDOW) (* Newman "27-Jan-87 11:10") + + (* * Code derived from EDITMOVENODE by Richard Burton. + Changes to prompt strings, and changes the to TRACKCURSOR to a call to + NOT.TRACKCURSOR) + (* hilite nodes until the cursor + goes down then move it) + (PROG ((DS (WINDOWPROP WINDOW 'DSP)) + (REG (WINDOWPROP WINDOW 'REGION)) + (GRAPH (WINDOWPROP WINDOW 'GRAPH)) + OLDPOS NOW NEAR NODELST) + (COND + (GRAPH (SETQ NODELST (fetch (GRAPH GRAPHNODES) of GRAPH))) + (T (RETURN))) + (printout PROMPTWINDOW T "Move the cursor to the node " "that is the common root of " + "the subtree you want to move " "and press any button.") + [SETQ NEAR (NODELST/AS/MENU NODELST (SETQ OLDPOS (CURSORPOSITION NIL DS] + FLIP + (AND NOW (FLIPNODE NOW DS)) + (AND NEAR (FLIPNODE NEAR DS)) + (SETQ NOW NEAR) + LP (GETMOUSESTATE) + (COND + ((LASTMOUSESTATE (NOT UP)) (* button up, process it.) + (AND NOW (FLIPNODE NOW DS)) (* NOW node has been selected.) + ) + ([EQ NOW (SETQ NEAR (NODELST/AS/MENU NODELST (CURSORPOSITION NIL DS OLDPOS] + (GO LP)) + (T (GO FLIP))) + (printout PROMPTWINDOW T "Holding the button down, " "move the node to its new position" + "and release the button.") + (NOT.TRACKCURSOR NOW DS GRAPH) + (printout PROMPTWINDOW T "Done."]) (NOT.TRACKCURSOR + [LAMBDA (Node DisplayStream Graph) (* ; "Edited 3-Aug-88 14:50 by pmi") + + (* ;; "Gets an old, and a new region from the user, and uses these to calculate all the new positions for all the children of Node.") + + (* ;; + "rht 4/28/87: Changed from APPLY of UNIONREGIONS to for loop doing successive UNIONREGIONS calls.") + + (* ;; "pmi 8/3/88: Changed to call COLLECTDESCENDENTS instead of RECURSIVE.COLLECTDESCENDENTS.") + + (if (NULL Node) + then (PROMPTPRINT "No node selected.") + else (PROG* ((Children (COLLECTDESCENDENTS Node Graph)) + (OldRegion (for EachNode in (CONS Node Children) + bind (TotalRegion _ (NODEREGION Node)) + do (FLIPNODE EachNode DisplayStream) + (SETQ TotalRegion (UNIONREGIONS TotalRegion (NODEREGION + EachNode))) + finally (RETURN TotalRegion))) + (NewRegionPosition (GETBOXPOSITION.FROMINITIALREGION (WFROMDS + DisplayStream) + OldRegion DisplayStream)) + (deltaX (DIFFERENCE (fetch (POSITION XCOORD) of NewRegionPosition) + (fetch (REGION LEFT) of OldRegion))) + (deltaY (DIFFERENCE (fetch (POSITION YCOORD) of NewRegionPosition) + (fetch (REGION BOTTOM) of OldRegion))) + (OldPos (fetch (GRAPHNODE NODEPOSITION) of Node)) + (NewPos (CREATE.NEW.NODEPOSITION Node deltaX deltaY))) + [if (NOT (EQUAL OldPos NewPos)) + then (MOVENODE Node OldPos NewPos Graph DisplayStream) + (EXTENDEXTENT (WFROMDS DisplayStream) + (NODEREGION Node)) + (CALL.MOVENODEFN Node OldPos Graph (WFROMDS DisplayStream) + NewPos) + (if Children + then (PROG [(MovedNodes (LIST (fetch (GRAPHNODE NODEID) + of Node] + (MOVEDESCENDENTS Graph Node DisplayStream + deltaX deltaY] + (for EachNode in (CONS Node Children) do (FLIPNODE EachNode + DisplayStream]) (RECURSIVE.COLLECTDESCENDENTS + [LAMBDA (Node Graph) (* ; "Edited 5-Aug-88 16:06 by pmi") + + (* ;; "Collect all descendents of Node in Graph.") + + (* ;; + "pmi 8/2/88: Changed to break infinite recursion on circular graphs. Now marks nodes as visited.") + + (* ;; "pmi 8/5/88: FIxes bug introduced by previous fix.") + + (LET (NodeId) + + (* ;; "Node's NODEID may be a list if it is a virtual node. ") + + (if (LISTP (SETQ NodeId (fetch (GRAPHNODE NODEID) of Node))) + then (SETQ NodeId (CAR NodeId))) + (NC.GraphNodeIDPutProp NodeId 'Visited T) + (for ChildNode in (COLLECT.CHILD.NODES Node Graph) bind ChildNodeID + when [PROGN (SETQ ChildNodeID (fetch (GRAPHNODE NODEID) of ChildNode)) + + (* ;; "This node has not been visited, and it is not a virtual node.") + + (NOT (NC.GraphNodeIDGetProp (if (LISTP ChildNodeID) + then (CAR ChildNodeID) + else ChildNodeID) + 'Visited] join (CONS ChildNode ( + RECURSIVE.COLLECTDESCENDENTS + ChildNode Graph]) (MOVEDESCENDENTS + [LAMBDA (Graph Node DisplayStream deltaX deltaY) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + + (* ;; "Moves Node and all Children of Node by deltaX and deltaY.") + + (* ;; "first, finds all descendents of Node. For each of these, create a new position based on the old and the deltas. Then, if the child has not been moved yet, we add it to the list of moved nodes, move the node, and call the MOVENODEFN,") + + (* ;; "pmi 8/3/88: Changed to call COLLECTDESCENDENTS instead of RECURSIVE.COLLECTDESCENDENTS.") + + (bind (MovedNodes _ (LIST Node)) + NewPos for Child in (COLLECTDESCENDENTS Node Graph) + eachtime (SETQ NewPos (CREATE.NEW.NODEPOSITION Child deltaX deltaY)) + unless (MEMBER (fetch (GRAPHNODE NODEID) of Child) + MovedNodes) do (SETQ MovedNodes (CONS (fetch (GRAPHNODE NODEID) + of Child) + MovedNodes)) + (MOVENODE Child (fetch (GRAPHNODE NODEPOSITION) + of Child) + NewPos Graph DisplayStream) + (EXTENDEXTENT (WFROMDS DisplayStream) + (NODEREGION Child)) + + (* ;; "we must call EXTENDEXTENT to extend the graph extent in case we have moved a node outside the previous extent.") + + (CALL.MOVENODEFN Child NewPos Graph (WFROMDS + DisplayStream + ) + (fetch (GRAPHNODE NODEPOSITION) of Child]) (COLLECT.CHILD.NODES + [LAMBDA (Node Graph) (* Newman "27-Jan-87 11:16") + + (* * collect all immediate children (only one generation) of Node in Graph.) + + (bind (GraphNodes _ (fetch (GRAPH GRAPHNODES) of Graph)) for NodeID + in (fetch (GRAPHNODE TONODES) of Node) collect + (* ??? (ASSOC (if (AND + (LISTP NodeID) (EQUAL + (CAR NodeID) (QUOTE Link% Parameters))) + then (* Special case where the + second item in the list is the + NodeID) (CADR NodeID) else NodeID) + GraphNodes)) + (GETNODEFROMID NodeID GraphNodes]) (CREATE.NEW.NODEPOSITION + [LAMBDA (Node deltaX deltaY) (* Newman "27-Jan-87 11:06") + + (* * Creates a new position for Node by adding deltaX and deltaY to the + appropriate coordinates.) + + (PROG ((OldPos (fetch (GRAPHNODE NODEPOSITION) of Node))) + (RETURN (create POSITION + XCOORD _ (PLUS deltaX (fetch (POSITION XCOORD) of OldPos)) + YCOORD _ (PLUS deltaY (fetch (POSITION YCOORD) of OldPos]) (GETBOXPOSITION.FROMINITIALREGION + [LAMBDA (Window Region DisplayStream) (* Newman "26-Jan-87 11:38") + + (* * This function obtains a new region from the user, and it prompts the user + using the region passed in as Region. DisplayStream is the displaystream of + Window, and Region is considered to be a region within Window. + This function was written to be called from EDITMOVEREGION.) + + (* All of the garbage below to calculate the third and fourth arguments to + GETBOXPOSITION exists to put the ghost box prompting the user in exactly the + same place as the region passed in.) + + (GETBOXPOSITION (fetch (REGION WIDTH) of Region) + (fetch (REGION HEIGHT) of Region) + (DIFFERENCE (PLUS (fetch (REGION LEFT) of Region) + (fetch (REGION LEFT) of (WINDOWPROP Window 'REGION)) + (WINDOWPROP Window 'BORDER)) + (fetch (REGION LEFT) of (DSPCLIPPINGREGION NIL DisplayStream))) + (DIFFERENCE (PLUS (fetch (REGION BOTTOM) of Region) + (fetch (REGION BOTTOM) of (WINDOWPROP Window 'REGION)) + (WINDOWPROP Window 'BORDER)) + (fetch (REGION BOTTOM) of (DSPCLIPPINGREGION NIL DisplayStream))) + Window "Select new region for nodes."]) (COLLECTDESCENDENTS + [LAMBDA (Node Graph) (* ; "Edited 5-Aug-88 15:40 by pmi") + + (* ;; "pmi 8/3/88: Created to wrap RESETLST around call to RECURSIVE.COLLECTDESCENDENTS. Prevents infinite looping on circular graph structures by marking where we have been.") + + (* ;; "Clean up the Visited markers placed on the nodes traversed.") + + (* ;; "pmi 8/5/88: Now also cleans up Visited marker on Node.") + + (LET (NodeID Descendents) + (RESETLST + [RESETSAVE NIL + '(PROGN (for VisitedNode in (CONS Node Descendents) bind + VisitedNodeID + do (NC.GraphNodeIDPutProp + (if (LISTP (SETQ VisitedNodeID (fetch (GRAPHNODE + NODEID) + of VisitedNode))) + then (CAR VisitedNodeID) + else VisitedNodeID) + 'Visited NIL] + (SETQ Descendents (RECURSIVE.COLLECTDESCENDENTS Node Graph)))]) ) (* ; "functions for finding larger and smaller fonts") (DEFINEQ (NEXTSIZEFONT + [LAMBDA (WHICHDIR NOWFONT) (* rmk%: "15-Sep-84 00:14") + + (* returns the next sized font either SMALLER or LARGER that on of size FONT. + (NEXTSIZEFONT (QUOTE LARGER) DEFAULTFONT)) + + (PROG [(NOWSIZE (FONTPROP NOWFONT 'HEIGHT] + (RETURN (COND + [(EQ WHICHDIR 'LARGER) + (COND + ((IGEQ NOWSIZE (FONTPROP (CAR DECREASING.FONT.LIST) + 'HEIGHT)) (* nothing larger) + NIL) + (T (for FONTTAIL on DECREASING.FONT.LIST + when [AND (CDR FONTTAIL) + (IGEQ NOWSIZE (FONTPROP (CADR FONTTAIL) + 'HEIGHT] + do (RETURN (FONTNAMELIST (CAR FONTTAIL] + (T (for FONT in DECREASING.FONT.LIST + when (LESSP (FONTPROP FONT 'HEIGHT) + NOWSIZE) do (RETURN (FONTNAMELIST FONT]) (DECREASING.FONT.LIST + [LAMBDA NIL (* rrb "16-Dec-83 12:28") + + (* returns a list of the font descriptors for the fonts sketch windows are + willing to print in.) + + (for SIZE in '(18 14 12 10 8 5) collect (FONTCREATE 'HELVETICA SIZE]) (SCALE.FONT + [LAMBDA (WID STR) (* rrb " 7-NOV-83 11:35") + + (* returns the font that text should be printed in to have the text STR fit + into a region WID points wide) + + (COND + ((GREATERP WID (TIMES (STRINGWIDTH STR (CAR DECREASING.FONT.LIST)) + 1.5)) (* scale it too large for even the + largest font.) + NIL) + (T (for FONT in DECREASING.FONT.LIST when (NOT (GREATERP (STRINGWIDTH STR FONT) + WID)) + do (RETURN FONT) finally (RETURN 'SHADE]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ DECREASING.FONT.LIST (DECREASING.FONT.LIST)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DECREASING.FONT.LIST) ) (* ; "functions for LAYOUTGRAPH And LAYOUTLATTICE") (DEFINEQ (BRH/LAYOUT + [LAMBDA (N X Y MOMLST GN) (* kvl "26-DEC-83 16:44") + + (* X and Y are the lower left corner of the box that will surround the tree + headed by the browsenode N. MOMLST is the mother node inside a cons cell. + GN is the graphnode for the nodeid N. It is crucial that the NODEPOSITION be + set before recursion because this marks that the node has been + (is being) laid out already. BRH/OFFSET is used to raise the daughters in those + rare cases where the label is bigger than the daughters.) + + (DECLARE (USEDFREE MOTHERD PERSONALD NODELST)) + (PROG ((DS (fetch (GRAPHNODE TONODES) of GN)) + (W (fetch (GRAPHNODE NODEWIDTH) of GN)) + (YHEIGHT (IPLUS PERSONALD (fetch (GRAPHNODE NODEHEIGHT) of GN))) + DHEIGHT) + (replace (GRAPHNODE FROMNODES) of GN with MOMLST) + [replace (GRAPHNODE NODEPOSITION) of GN with (create POSITION + XCOORD _ + (IPLUS X (HALF W] + (COND + ((NULL DS)) + [[IGREATERP YHEIGHT (SETQ DHEIGHT (BRH/LAYOUT/DAUGHTERS DS (IPLUS X W MOTHERD) + Y + (LIST N] + (BRH/OFFSET DS (HALF (IDIFFERENCE YHEIGHT DHEIGHT] + (T (SETQ YHEIGHT DHEIGHT))) + (replace YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GN) + with (IPLUS Y (HALF YHEIGHT))) + (RETURN YHEIGHT]) (BRH/LAYOUT/DAUGHTERS + [LAMBDA (DS X Y MOMLST) (* rmk%: " 5-Feb-84 15:01") + + (* DS are the daughters of (CAR MOMLST)%. + X is where the left edge of their labels will be, and Y is the bottom of the + mother's box. Returns the height of the mother's box. + Tests to see if a node has been layout out already If so, it replaces the + daughter with one that has no descendents, and splices into the mother's + daughter list, side-effecting the graphnode structure.) + + (DECLARE (USEDFREE NODELST)) + (for D (FLOOR _ Y) in DS do [SETQ FLOOR (IPLUS FLOOR (BRH/LAYOUT D X FLOOR MOMLST + (GETNODEFROMID D + NODELST] + finally (RETURN (IDIFFERENCE FLOOR Y]) (BRH/OFFSET + [LAMBDA (NODEIDS YINC) + (DECLARE (USEDFREE NODELST)) (* kvl "11-Dec-84 14:35") + (for N in NODEIDS do (SETQ N (GETNODEFROMID N NODELST)) + (add (fetch YCOORD of (fetch (GRAPHNODE + NODEPOSITION) + of N)) + YINC) + (BRH/OFFSET (fetch (GRAPHNODE TONODES) of N) + YINC]) (BRHC/INTERTREE/SPACE + [LAMBDA (TTC BTC) (* kvl "21-DEC-83 10:23") + + (* Given the top transition chain of the old daughter and the bottom transition + chain of the new daughter, where BTC is sitting on the bottom of the box, + calculate how much the bottom must be raised so that it just clears the TTC. + OP is the top left corner of some label. + NP is the bottom left corner.) + + (PROG ((RAISE -1000) + NP DIST OP) + (SETQ OP (pop TTC)) + (SETQ NP (pop BTC)) + L (SETQ DIST (IDIFFERENCE (fetch YCOORD of OP) + (fetch YCOORD of NP))) + (AND (IGREATERP DIST RAISE) + (SETQ RAISE DIST)) + [COND + ((NULL BTC) + (RETURN RAISE)) + ((NULL TTC) + (RETURN RAISE)) + ((IEQP (fetch XCOORD of (CAR BTC)) + (fetch XCOORD of (CAR TTC))) + (SETQ NP (pop BTC)) + (SETQ OP (pop TTC))) + ((ILESSP (fetch XCOORD of (CAR BTC)) + (fetch XCOORD of (CAR TTC))) + (SETQ NP (pop BTC))) + (T (SETQ OP (pop TTC] + (GO L]) (BRHC/LAYOUT + [LAMBDA (N X MOMLST GN) (* rmk%: " 5-Feb-84 14:47") + + (* See comment on BRH/LAYOUT. Instead of keeping only the graphnode in layed + out node's position field, keep the offset as well. + The offset is how much this nodes box must be raised relative to the inclosing + box. Uses two free variables to return transition chains. + RETURNTTC is the top left corners of all the labels. + RETURNBTC is the bottom left corners.) + + (DECLARE (USEDFREE PERSONALD RETURNTTC RETURNBTC)) + (PROG ((DS (fetch (GRAPHNODE TONODES) of GN)) + (W (fetch (GRAPHNODE NODEWIDTH) of GN)) + (H (fetch (GRAPHNODE NODEHEIGHT) of GN)) + YCENTER X/SW H/2) + (SETQ H/2 (HALF H)) + (SETQ X/SW (IPLUS X W)) + (replace (GRAPHNODE FROMNODES) of GN with MOMLST) + (replace (GRAPHNODE NODEPOSITION) of GN with (LIST 0)) + [SETQ YCENTER (COND + (DS (BRHC/LAYOUT/DAUGHTERS DS X/SW (LIST N))) + (T (BRHC/LAYOUT/TERMINAL GN X/SW] + (RPLACD (fetch (GRAPHNODE NODEPOSITION) of GN) + (create POSITION + XCOORD _ (IPLUS X (HALF W)) + YCOORD _ YCENTER)) + [push RETURNTTC (create POSITION + XCOORD _ X + YCOORD _ (IPLUS PERSONALD (IPLUS (IDIFFERENCE YCENTER H/2) + H] + (push RETURNBTC (create POSITION + XCOORD _ X + YCOORD _ (IDIFFERENCE YCENTER H/2))) + (RETURN YCENTER]) (BRHC/LAYOUT/DAUGHTERS + [LAMBDA (DS X/SW MOMLST) + (DECLARE (USEDFREE MOTHERD FAMILYD NODELST RETURNTTC RETURNBTC)) + (* rmk%: " 5-Feb-84 14:52") + + (* see comment on BRH/LAYOUT/DAUGHTERS. + First daughter is always laid out on the bottom of the box. + Subsequent daughters have the amount that they are to be raised calculated by + comparing the top edge of the old daughter + (in TTC) with the bottom edge of the new daughter + (in RETURNBTC)%. TTC is update by adding the new daughter's transition chain to + the front, because the new daughter's front is guaranteed to be higher than the + old daughter's front. Conversely, BTC is updated by adding the new daughter's + transition chain to the back, because the old daughter's front is guaranteed to + be lower.) + + (for D in DS bind GN BTC TTC 1ST/DCENTER LST/DCENTER (OFFSET _ 0) + (X _ (IPLUS X/SW MOTHERD)) + do (SETQ GN (GETNODEFROMID D NODELST)) + (SETQ LST/DCENTER (BRHC/LAYOUT D X MOMLST GN)) + [COND + ((NULL TTC) (* first daughter) + (SETQ 1ST/DCENTER LST/DCENTER) + (SETQ TTC RETURNTTC) + (SETQ BTC RETURNBTC)) + (T (SETQ OFFSET (BRHC/INTERTREE/SPACE TTC RETURNBTC)) + (RPLACA (fetch (GRAPHNODE NODEPOSITION) of GN) + OFFSET) + (SETQ TTC (EXTEND/TRANSITION/CHAIN (RAISE/TRANSITION/CHAIN RETURNTTC + OFFSET) + TTC)) + (SETQ BTC (EXTEND/TRANSITION/CHAIN BTC (RAISE/TRANSITION/CHAIN RETURNBTC + OFFSET] + finally + + (* add a mythical top left corner at the height of the highest daughter because + diagnonal links are getting clobbered. Move lowest daughter's bottom left + corner to the left for the same reason.) + + (SETQ RETURNTTC (CONS (create POSITION + XCOORD _ X/SW + YCOORD _ (fetch YCOORD of (CAR TTC))) + TTC)) + (replace XCOORD of (CAR BTC) with X/SW) + (add (fetch YCOORD of (CAR TTC)) + FAMILYD) + (SETQ RETURNBTC BTC) + + (* center of mother is halfway between first and last daughter's label centers + using fact that offset of first daughter is zero and last daughter's offset is + OFFSET) + + (RETURN (HALF (IPLUS 1ST/DCENTER OFFSET LST/DCENTER]) (BRHC/LAYOUT/TERMINAL + [LAMBDA (GN X/SW) (* rmk%: " 3-Feb-84 09:55") + + (* initiallizes the transition chains to the right edge of the node label, and + returns the label's center.) + + (DECLARE (USEDFREE RETURNTTC RETURN/TBC)) + (SETQ RETURNTTC (LIST (create POSITION + XCOORD _ X/SW + YCOORD _ 0))) + [SETQ RETURNBTC (LIST (create POSITION + XCOORD _ X/SW + YCOORD _ (fetch (GRAPHNODE NODEHEIGHT) of GN] + (HALF (fetch (GRAPHNODE NODEHEIGHT) of GN]) (BRHC/OFFSET + [LAMBDA (N ABSY) (* dgb%: "22-Jan-85 07:17") + (* Adds in all the offsets. + See comment on + BRHC/LAYOUT/DAUGHTERS.) + (DECLARE (USEDFREE NODELST)) + (PROG ((GN (GETNODEFROMID N NODELST))) + [SETQ ABSY (IPLUS ABSY (pop (fetch (GRAPHNODE NODEPOSITION) of GN] + [replace YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GN) + with (IPLUS ABSY (fetch YCOORD of (fetch (GRAPHNODE NODEPOSITION) + of GN] + (for D in (fetch (GRAPHNODE TONODES) of GN) do (BRHC/OFFSET D ABSY]) (BRHL/LAYOUT + [LAMBDA (N X Y MOMLST GN) (* kvl "26-DEC-83 16:36") + + (* X and Y are the lower left corner of the box that will surround the tree + headed by the browsenode N. MOMLST is the mother node inside a cons cell. + GN is the graphnode for the nodeid N. It is crucial that the NODEPOSITION be + set before recursion because this marks that the node has been laid out + already. If in addition, the YCOORD is NIL, then the node is still in the + process of being laid out. BRHL/LAYOUT/DAUGHTERS uses this fact to break loops + by inserting boxed nodes.) + + (DECLARE (USEDFREE MOTHERD PERSONALD NODELST)) + (COND + ((fetch (GRAPHNODE NODEPOSITION) of GN) + + (* This case only occurs if this node has been put in the roots list, and has + already been visited by recursion. Value won't be used) + + 0) + (T (PROG [(DS (fetch (GRAPHNODE TONODES) of GN)) + (W (fetch (GRAPHNODE NODEWIDTH) of GN)) + (YHEIGHT (IPLUS PERSONALD (fetch (GRAPHNODE NODEHEIGHT) of GN] + (replace (GRAPHNODE FROMNODES) of GN with MOMLST) + (* This is first time for layout, so + set FROMNODES) + [replace (GRAPHNODE NODEPOSITION) of GN with (create + POSITION + XCOORD _ + (IPLUS X (HALF W] + (AND DS (SETQ YHEIGHT (IMAX (BRHL/LAYOUT/DAUGHTERS DS (IPLUS X W MOTHERD) + Y + (LIST N)) + YHEIGHT))) + (replace YCOORD of (fetch (GRAPHNODE NODEPOSITION) of GN) + with (IPLUS Y (HALF YHEIGHT))) + (RETURN YHEIGHT]) (BRHL/LAYOUT/DAUGHTERS + [LAMBDA (DS X Y MOMLST) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + + (* DS are the daughters of (CAR MOMLST)%. + X is where their the left edge of their labels will be, and Y is the bottom of + the mother's box. Returns the height of the mother's box. + Tests to see if a node has been laid out out already If so, it sees if the node + is far enought to the right; if not it moves the node and its daughters.) + + (DECLARE (USEDFREE NODELST YHEIGHT)) + (for DTAIL on DS bind D GN NP DELTA (FLOOR _ Y) finally (RETURN (IDIFFERENCE + FLOOR Y)) + do (SETQ GN (GETNODEFROMID (SETQ D (CAR DTAIL)) + NODELST)) + (COND + ((SETQ NP (fetch (GRAPHNODE NODEPOSITION) of GN)) + [COND + [(NULL (fetch YCOORD of NP)) + (SETQ GN (NEW/INSTANCE/OF/GRAPHNODE GN)) + (RPLACA DTAIL (fetch (GRAPHNODE NODEID) of GN)) + (SETQ FLOOR (IPLUS FLOOR (BRHL/LAYOUT (fetch (GRAPHNODE NODEID) + of GN) + X FLOOR MOMLST GN] + (T (BRHL/MOVE/RIGHT GN X NIL) + (push (fetch (GRAPHNODE FROMNODES) of GN) + (CAR MOMLST] (* Add this mother to the fromLinks) + ) + (T (SETQ FLOOR (IPLUS FLOOR (BRHL/LAYOUT D X FLOOR MOMLST GN]) (BRHL/MOVE/RIGHT + [LAMBDA (GN X STACK) (* ; "Edited 29-Apr-94 14:00 by sybalsky") + (* Move this node and its children + right) + (DECLARE (USEDFREE NODELST)) + (PROG ((W (fetch (GRAPHNODE NODEWIDTH) of GN)) + (NP (fetch (GRAPHNODE NODEPOSITION) of GN))) + (AND (FMEMB GN STACK) + (ERROR "Loop caught in BRHL/MOVE/RIGHT at" (fetch (GRAPHNODE NODELABEL) + of GN))) + (COND + ((ILESSP X (IDIFFERENCE (fetch XCOORD of NP) + (HALF W))) + (RETURN))) + (for D in (TOLINKS GN) bind (NEWX _ (IPLUS X W MOTHERD)) + (NSTACK _ (CONS GN STACK)) + do (BRHL/MOVE/RIGHT (GETNODEFROMID D NODELST) + NEWX NSTACK)) + (replace XCOORD of NP with (IPLUS X (HALF W]) (BROWSE/LAYOUT/HORIZ + [LAMBDA (ROOTIDS) (* ; "Edited 19-Aug-88 08:32 by sye") + + (* each subtree is given a box centered vertically on its label. + Sister boxes abut but do not intrude as they do in the compacting version.) + + (DECLARE (USEDFREE NODELST)) + [for N in ROOTIDS bind (Y _ 0) do (SETQ Y (IPLUS Y (BRH/LAYOUT N 0 Y NIL + (GETNODEFROMID + N NODELST] + (create GRAPH + GRAPHNODES _ NODELST + SIDESFLG _ T + DIRECTEDFLG _ NIL]) (BROWSE/LAYOUT/HORIZ/COMPACTLY + [LAMBDA (ROOTS) + (DECLARE (USEDFREE NODELST MOTHERD)) (* ; "Edited 19-Aug-88 08:33 by sye") + + (* See comments on BRH/LAYOUT and BRH/LAYOUT/DAUGHTERS first. + This differs in that it keeps (on the stack) a representation of the shape of + the tree that fills the node's box. The representation is a list of POSITIONs. + If one starts drawing a line from left to right starting at the CAR, each point + is a step in the line, and the point begins the new plateau + (or valley)%. The last point is where the line would turn around and head back + to the left.) + (* builds dummy top node for ROOTS + if necessary, and adjusts the + horizontal distance accordingly.) + [PROG (RETURNTTC RETURNBTC) + (DECLARE (SPECVARS RETURNTTC RETURNBTC)) + (COND + ((NLISTP ROOTS) + (BRHC/LAYOUT ROOTS 0 NIL (GETNODEFROMID ROOTS NODELST)) + (BRHC/OFFSET ROOTS 0)) + ((NULL (CDR ROOTS)) + (BRHC/LAYOUT (CAR ROOTS) + 0 NIL (GETNODEFROMID (CAR ROOTS) + NODELST)) + (BRHC/OFFSET (CAR ROOTS) + 0)) + (T (PROG ((GN (create GRAPHNODE + NODELABEL _ (PACK) + NODEID _ (CONS) + TONODES _ ROOTS + NODEWIDTH _ 0 + NODEHEIGHT _ 0)) + TOPNODE) + (push NODELST GN) + (SETQ TOPNODE (fetch (GRAPHNODE NODEID) of GN)) + (BRHC/LAYOUT TOPNODE (IMINUS MOTHERD) + NIL GN) + (BRHC/OFFSET TOPNODE 0) + [for N GN in ROOTS do (replace (GRAPHNODE FROMNODES) + of (SETQ GN (FASSOC N NODELST)) + with (DREMOVE TOPNODE + (fetch (GRAPHNODE + FROMNODES) + of GN] + (SETQ NODELST (DREMOVE GN NODELST] + (create GRAPH + GRAPHNODES _ NODELST + SIDESFLG _ T + DIRECTEDFLG _ NIL]) (BROWSE/LAYOUT/LATTICE + [LAMBDA (NS) (* ; "Edited 19-Aug-88 08:33 by sye") + + (* almost the same as BROWSE/LAYOUT/HORIZ, except that it doesn't box nodes + unless there are cycles. Instead, a single node is placed at the rightmost of + the positions that would be laid out by for all of its + (boxed) occurrences by BROWSE/LAYOUT/HORIZ.) + + (DECLARE (USEDFREE NODELST)) + [for N in NS bind (Y _ 0) do (SETQ Y (IPLUS Y (BRHL/LAYOUT N 0 Y NIL + (GETNODEFROMID N NODELST + ] + (create GRAPH + GRAPHNODES _ NODELST + SIDESFLG _ T + DIRECTEDFLG _ NIL]) (BRV/OFFSET + [LAMBDA (N ABSX) (* dgb%: "22-Jan-85 07:25") + + (* Adds in offset which are kept in car of NODEPOSITION. + TERMY is Y of lowest node. Adding it in raises tree so lowest node is at zero.) + + (DECLARE (USEDFREE NODELST TERMY)) + (PROG (P (GN (GETNODEFROMID N NODELST))) + [SETQ ABSX (IPLUS ABSX (pop (fetch (GRAPHNODE NODEPOSITION) of GN] + (replace XCOORD of (SETQ P (fetch (GRAPHNODE NODEPOSITION) of GN)) + with (IPLUS ABSX (fetch XCOORD of P))) + (replace YCOORD of P with (IDIFFERENCE (fetch YCOORD of P) + TERMY)) + (for D in (fetch (GRAPHNODE TONODES) of GN) do (BRV/OFFSET D ABSX]) (EXTEND/TRANSITION/CHAIN + [LAMBDA (LTC RTC) (* kvl "21-DEC-83 11:00") + + (* Extends the left transition chain by appending the part of the right + transition chain that is to the right of the end of the left transition chain. + End point of left transition chain is changed to intersect right transition + chain) + + (PROG ((LTAIL LTC) + (RTAIL RTC) + LX RX) + L [COND + ((NULL (CDR RTAIL)) + (replace YCOORD of (CAR (FLAST LTAIL)) with (fetch YCOORD + of (CAR RTAIL))) + (RETURN LTC)) + ((NULL (CDR LTAIL)) + (RPLACD LTAIL (CDR RTAIL)) + (replace YCOORD of (CAR LTAIL) with (fetch YCOORD of (CAR RTAIL))) + (RETURN LTC)) + ([IEQP (SETQ LX (fetch XCOORD of (CADR LTAIL))) + (SETQ RX (fetch XCOORD of (CADR RTAIL] + (SETQ LTAIL (CDR LTAIL)) + (SETQ RTAIL (CDR RTAIL))) + ((ILESSP LX RX) + (SETQ LTAIL (CDR LTAIL))) + (T (SETQ RTAIL (CDR RTAIL] + (GO L]) (FOREST/BREAK/CYCLES + [LAMBDA (NODE) (* kvl "14-Aug-84 09:19") + (* Breaks any cycles by inserting + new nodes and boxing) + (DECLARE (USEDFREE NODELST)) + (replace (GRAPHNODE NODEPOSITION) of NODE with T) + (for DTAIL DN on (fetch (GRAPHNODE TONODES) of NODE) + do (SETQ DN (GETNODEFROMID (CAR DTAIL) + NODELST)) + (COND + ((fetch (GRAPHNODE NODEPOSITION) of DN) + (* We've seen this before) + (SETQ DN (NEW/INSTANCE/OF/GRAPHNODE DN)) + (RPLACA DTAIL (fetch (GRAPHNODE NODEID) of DN))) + (T (FOREST/BREAK/CYCLES DN]) (INIT/NODES/FOR/LAYOUT + [LAMBDA (NS FORMAT ROOTIDS FONT) (* Randy.Gobbel " 8-May-87 16:22") + (for GN in NS do [replace (GRAPHNODE NODEPOSITION) of GN + with (NOT (NOT (FMEMB (fetch (GRAPHNODE NODEID) + of GN) + ROOTIDS] + (* T Used to indicate prior + visitation. Roots are already + visited) + (OR (IMAGEOBJP (fetch (GRAPHNODE NODELABEL) of GN)) + (fetch (GRAPHNODE NODEFONT) of GN) + (replace (GRAPHNODE NODEFONT) of GN with FONT))) + [for R in ROOTIDS do (COND + ((EQMEMB 'LATTICE FORMAT) + (LATTICE/BREAK/CYCLES (GETNODEFROMID R NODELST) + NIL)) + (T (FOREST/BREAK/CYCLES (GETNODEFROMID R NODELST] + (for GN in NODELST do (replace (GRAPHNODE NODEPOSITION) of GN with NIL) + (SET/LABEL/SIZE GN]) (INTERPRET/MARK/FORMAT + [LAMBDA (FORMAT) (* rmk%: "20-Sep-85 08:59") + (* sets specvars for + NEW/INSTANCE/OF/GRAPHNODE and + MARK/GRAPH/NODE) + (DECLARE (USEDFREE BOX.BOTH.FLG BOX.LEAVES.FLG BORDER.FOR.MARKING LABELSHADE.FOR.MARKING)) + (PROG (PL) + (AND (EQMEMB 'COPIES/ONLY FORMAT) + (SETQ BOX.BOTH.FLG NIL)) + (AND (EQMEMB 'NOT/LEAVES FORMAT) + (SETQ BOX.LEAVES.FLG NIL)) + (COND + ((NLISTP FORMAT) + (RETURN)) + ((EQ (CAR FORMAT) + 'MARK) + (SETQ PL (CDR FORMAT))) + ((SETQ PL (FASSOC 'MARK FORMAT)) + (SETQ PL (CDR PL))) + (T (RETURN))) + [COND + [(FMEMB 'BORDER PL) + (SETQ BORDER.FOR.MARKING (LISTGET PL 'BORDER] + (T (SETQ BORDER.FOR.MARKING 'DON'T] + (COND + [(FMEMB 'LABELSHADE PL) + (SETQ LABELSHADE.FOR.MARKING (LISTGET PL 'LABELSHADE] + (T (SETQ LABELSHADE.FOR.MARKING 'DON'T]) (LATTICE/BREAK/CYCLES + [LAMBDA (NODE STACK) (* ; "Edited 29-Apr-94 14:01 by sybalsky") + (replace (GRAPHNODE NODEPOSITION) of NODE with T) + (for DTAIL on (fetch (GRAPHNODE TONODES) of NODE) bind D GN + do (SETQ GN (GETNODEFROMID (SETQ D (CAR DTAIL)) + NODELST)) + (COND + ((FMEMB D STACK) + (SETQ GN (NEW/INSTANCE/OF/GRAPHNODE GN)) + (RPLACA DTAIL (fetch (GRAPHNODE NODEID) of GN))) + ((NULL (fetch (GRAPHNODE NODEPOSITION) of GN)) + (LATTICE/BREAK/CYCLES GN (CONS D STACK]) (LAYOUTFOREST + [LAMBDA (NODELST ROOTIDS FORMAT BOXING FONT MOTHERD PERSONALD FAMILYD) + (* ; "Edited 16-Apr-90 19:05 by gadener") + (* This is an older version of + LayoutGraph, kept around temporarily + but de-documented) + (LAYOUTGRAPH NODELST ROOTIDS (CL:IF (LISTP FORMAT) + (APPEND FORMAT BOXING) + (CONS FORMAT BOXING)) + FONT MOTHERD PERSONALD]) (LAYOUTGRAPH + [LAMBDA (NODELST ROOTIDS FORMAT FONT MOTHERD PERSONALD FAMILYD) + (* ; "Edited 29-Apr-94 14:01 by sybalsky") + + (* ;; "takes a list of GRAPHNODE records and a list node ids for the top level nodes, where the graphnodes have only the NODEID, NODELABEL and TONODES fields filled in. It fills in the other fields appropriately according the format switch and the boxing switch so that the graph becomes a forest. If there are loops in the graph, they are snapped and the NODELST is extended with Push This function returns a GRAPH record with the display slots filled in appropriately.") + + (DECLARE (SPECVARS NODELST MOTHERD PERSONALD FAMILYD)) + (PROG ((BOX.BOTH.FLG T) + (BOX.LEAVES.FLG T) + (BORDER.FOR.MARKING T) + (LABELSHADE.FOR.MARKING 'DON'T) + G) + (DECLARE (SPECVARS BOX.BOTH.FLG BOX.LEAVES.FLG BORDER.FOR.MARKING + LABELSHADE.FOR.MARKING)) + (OR (LISTP ROOTIDS) + (ERROR "LAYOUTGRAPH needs a LIST of root node ids")) + (for R in ROOTIDS unless (FASSOC R NODELST) do (ERROR R + "is in ROOTIDS but no GRAPHNODE for it in NODELST." + )) + (OR FONT (SETQ FONT (OR DEFAULT.GRAPH.NODEFONT DEFAULTFONT))) + (OR MOTHERD (SETQ MOTHERD (STRINGWIDTH "AAAAAA" FONT))) + [OR PERSONALD (SETQ PERSONALD (COND + ((EQMEMB 'VERTICAL FORMAT) + (STRINGWIDTH "AA" FONT)) + (T 0] + [OR FAMILYD (SETQ FAMILYD (HALF (FONTPROP FONT 'ASCENT] + (INTERPRET/MARK/FORMAT FORMAT) + (INIT/NODES/FOR/LAYOUT NODELST FORMAT ROOTIDS FONT) + (AND (EQMEMB 'VERTICAL FORMAT) + (SWITCH/NODE/HEIGHT/WIDTH NODELST)) + [SETQ G (COND + ((EQMEMB 'LATTICE FORMAT) + (BROWSE/LAYOUT/LATTICE ROOTIDS)) + ((EQMEMB 'FAST FORMAT) + (BROWSE/LAYOUT/HORIZ ROOTIDS)) + (T (BROWSE/LAYOUT/HORIZ/COMPACTLY ROOTIDS] + (replace (GRAPH GRAPH.PROPS) of G with (LIST 'FORMAT FORMAT)) + [for N in NODELST do (OR (type? POSITION (fetch (GRAPHNODE NODEPOSITION + ) of N)) + (ERROR + "Disconnected graph. Root(s) didn't connect to:" + (fetch (GRAPHNODE NODELABEL) of N] + [COND + ((EQMEMB 'VERTICAL FORMAT) + (SWITCH/NODE/HEIGHT/WIDTH NODELST) + (REFLECT/GRAPH/DIAGONALLY G) + (OR (EQMEMB 'REVERSE FORMAT) + (REFLECT/GRAPH/VERTICALLY G)) + (AND (EQMEMB 'REVERSE/DAUGHTERS FORMAT) + (REFLECT/GRAPH/HORIZONTALLY G))) + (T (AND (EQMEMB 'REVERSE FORMAT) + (REFLECT/GRAPH/HORIZONTALLY G)) + (AND (EQMEMB 'REVERSE/DAUGHTERS FORMAT) + (REFLECT/GRAPH/VERTICALLY G] + (RETURN G]) (LAYOUTLATTICE + [LAMBDA (NODELST ROOTIDS FORMAT FONT MOTHERD PERSONALD FAMILYD) + (* rmk%: " 6-Dec-85 12:19") + + (* takes a list of GRAPHNODE records and a list node ids for the top level + nodes, where the graphnodes have only the NODEID, NODELABEL and TONODES fields + filled in. It fills in the other fields appropriately according the format + switch If there are loops in the graph, they are detected in BRHL/MOVE/RIGHT + and an error occurs. This function returns a GRAPH record with the display + slots filled in appropriately.) + + (DECLARE (SPECVARS NODELST MOTHERD PERSONALD FAMILYD)) + (for R in ROOTIDS unless (FASSOC R NODELST) do (ERROR R + "is in ROOTIDS but no GRAPHNODE for it in NODELST." + )) + (SETQ FONT (OR FONT DEFAULTFONT)) + (INIT/NODES/FOR/LAYOUT NODELST FORMAT ROOTIDS FONT) + [OR FAMILYD (SETQ FAMILYD (HALF (FONTPROP FONT 'ASCENT] + (OR MOTHERD (SETQ MOTHERD (STRINGWIDTH "AAAAAA" FONT))) + [OR PERSONALD (SETQ PERSONALD (COND + ((EQ FORMAT 'VERTICAL) + (STRINGWIDTH "AA" FONT)) + (T 0] + (BROWSE/LAYOUT/LATTICE ROOTIDS]) (LAYOUTSEXPR + [LAMBDA (TREE FORMAT BOXING FONT MOTHERD PERSONALD FAMILYD) + (* ; "Edited 1-Sep-92 17:26 by jds") + + (* ;; "assumes CAR of tree is node label, CDR is daughter trees.") + + (COND + [TREE (PROG (RESULT) + (DECLARE (SPECVARS RESULT)) + (LAYOUTSEXPR1 TREE) + + (* ;; "Boxing arg will only be taken into account if they are valid Format arguments") + (* ; "otherwise, it is ignored") + (AND (OR (NLISTP BOXING) + (EQ (CAR BOXING) + 'MARK)) + (SETQ BOXING (CONS BOXING))) + (RETURN (LAYOUTGRAPH RESULT (LIST TREE) + (APPEND (MKLIST FORMAT) + BOXING) + FONT MOTHERD PERSONALD FAMILYD] + (T (ERROR "Cannot layout NIL as S-EXPRESSION"]) (LAYOUTSEXPR1 + [LAMBDA (TREE) (* dgb%: "22-Jan-85 07:07") + (DECLARE (SPECVARS RESULT)) + (COND + [(for R in RESULT thereis (EQ TREE (fetch (GRAPHNODE NODEID) of R] + ((NLISTP TREE) + (push RESULT (create GRAPHNODE + NODEID _ TREE + NODELABEL _ TREE))) + (T [push RESULT (create GRAPHNODE + NODEID _ TREE + NODELABEL _ (CAR TREE) + TONODES _ (APPEND (CDR TREE] + (for D in (CDR TREE) do (LAYOUTSEXPR1 D]) (MARK/GRAPH/NODE + [LAMBDA (NODE) (* ; "Edited 29-Apr-94 14:01 by sybalsky") + (* changes appearance of graph node + to indicate that a link has been + snapped.) + (DECLARE (USEDFREE BORDER.FOR.MARKING LABELSHADE.FOR.MARKING)) + (OR (EQ BORDER.FOR.MARKING 'DON'T) + (replace (GRAPHNODE NODEBORDER) of NODE with BORDER.FOR.MARKING)) + (OR (EQ LABELSHADE.FOR.MARKING 'DON'T) + (replace (GRAPHNODE NODELABELSHADE) of NODE with LABELSHADE.FOR.MARKING]) (NEW/INSTANCE/OF/GRAPHNODE + [LAMBDA (GN) + (DECLARE (USEDFREE NODELST BOX.LEAVES.FLG BOX.BOTH.FLG)) + (* ; "Edited 29-Apr-94 14:01 by sybalsky") + (* returns a second instance of the + node, boxing it appropriately. + No daughters.) + (PROG [(NEW (create GRAPHNODE + NODEID _ (LIST (fetch (GRAPHNODE NODEID) of GN)) + NODELABEL _ (fetch (GRAPHNODE NODELABEL) of GN) + NODEFONT _ (fetch (GRAPHNODE NODEFONT) of GN) + NODEWIDTH _ (fetch (GRAPHNODE NODEWIDTH) of GN) + NODEHEIGHT _ (fetch (GRAPHNODE NODEHEIGHT) of GN) + NODEBORDER _ (COPY (fetch (GRAPHNODE NODEBORDER) of GN)) + NODELABELSHADE _ (fetch (GRAPHNODE NODELABELSHADE) of GN] + (push NODELST NEW) + [COND + ((OR BOX.LEAVES.FLG (fetch (GRAPHNODE TONODES) of GN)) + (MARK/GRAPH/NODE NEW) + (COND + (BOX.BOTH.FLG (MARK/GRAPH/NODE GN] + (RETURN NEW]) (RAISE/TRANSITION/CHAIN + [LAMBDA (TC RAISE) (* kvl "21-DEC-83 10:25") + + (* raises a daughters transition chain by adding in the offset of the + daughter's box relative to the mother's box.) + + (for P in TC do (add (fetch YCOORD of P) + RAISE) finally (RETURN TC]) (REFLECT/GRAPH/DIAGONALLY + [LAMBDA (GRAPH) (* kvl "26-DEC-83 10:58") + (replace (GRAPH SIDESFLG) of GRAPH with (NOT (fetch (GRAPH SIDESFLG) of + GRAPH))) + [for N in (fetch (GRAPH GRAPHNODES) of GRAPH) + do (SETQ N (fetch (GRAPHNODE NODEPOSITION) of N)) + (replace XCOORD of N with (PROG1 (fetch YCOORD of N) + (replace YCOORD of N + with (fetch XCOORD of N)))] + GRAPH]) (REFLECT/GRAPH/HORIZONTALLY + [LAMBDA (GRAPH) (* kvl "10-Aug-84 17:23") + (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) + bind [W _ (IPLUS (MAX/RIGHT (fetch (GRAPH GRAPHNODES) of GRAPH)) + (MIN/LEFT (fetch (GRAPH GRAPHNODES) of GRAPH] + do (SETQ N (fetch (GRAPHNODE NODEPOSITION) of N)) + (replace XCOORD of N with (IDIFFERENCE W (fetch XCOORD of N]) (REFLECT/GRAPH/VERTICALLY + [LAMBDA (GRAPH) (* kvl "10-Aug-84 16:48") + (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) + bind [H _ (IPLUS (MAX/TOP (fetch (GRAPH GRAPHNODES) of GRAPH)) + (MIN/BOTTOM (fetch (GRAPH GRAPHNODES) of GRAPH] + do (SETQ N (fetch (GRAPHNODE NODEPOSITION) of N)) + (replace YCOORD of N with (IDIFFERENCE H (fetch YCOORD of N]) (SWITCH/NODE/HEIGHT/WIDTH + [LAMBDA (NL) (* rmk%: " 2-Feb-84 22:19") + (for N in NL do (swap (fetch (GRAPHNODE NODEWIDTH) of N) + (fetch (GRAPHNODE NODEHEIGHT) of N]) ) (DECLARE%: EVAL@COMPILE (RPAQQ LINKPARAMS Link% Parameters) (CONSTANTS (LINKPARAMS 'Link% Parameters)) ) (RPAQQ DEFAULT.GRAPH.NODEBORDER NIL) (RPAQQ DEFAULT.GRAPH.NODEFONT NIL) (RPAQQ DEFAULT.GRAPH.NODELABELSHADE NIL) (RPAQQ ScalableLinkParameters (LINEWIDTH)) (RPAQQ CACHE/NODE/LABEL/BITMAPS NIL) (RPAQQ NODEBORDERWIDTH 1) (RPAQQ GRAPH/HARDCOPY/FORMAT (MODE PORTRAIT PAGENUMBERS T TRANS NIL)) (RPAQ? DEFAULT.GRAPH.WINDOWSIZE (LIST (TIMES SCREENWIDTH 0.7) (TIMES SCREENHEIGHT 0.4))) (RPAQ? EDITGRAPHMENUCOMMANDS '((Move% Node 'MOVENODE "Moves a single node in the graph." (SUBITEMS (|Move Single Node| 'MOVENODE "Moves a single node in the graph.") (|Move Node and Subtree| (EDITMOVESUBTREE GRAPHWINDOW) "Moves a subtree of nodes relative to the movement of their root." ) (Move% Region (EDITMOVEREGION GRAPHWINDOW) "Moves a group of nodes within a specified region to another region." ))) ("Add Node" 'ADDNODE) ("Delete Node" 'DELETENODE) ("Add Link" 'ADDLINK) ("Delete Link" 'DELETELINK) ("Change label" 'CHANGELABEL) ("label smaller" 'SMALLER) ("label larger" 'LARGER) ("<-> Directed" 'DIRECTED) ("<-> Sides" 'SIDES) ("<-> Border" 'BORDER) ("<-> Shade" 'SHADE) STOP)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: EVAL@COMPILE (RECORD GRAPHNODE (NODEID NODEPOSITION NODELABELBITMAP NIL NODELABELSHADE NODEWIDTH NODEHEIGHT TONODES FROMNODES NODEFONT NODELABEL NODEBORDER) NODEBORDER _ DEFAULT.GRAPH.NODEBORDER NODELABELSHADE _ DEFAULT.GRAPH.NODELABELSHADE NODEFONT _ DEFAULT.GRAPH.NODEFONT) (RECORD GRAPH (GRAPHNODES SIDESFLG DIRECTEDFLG GRAPH.MOVENODEFN GRAPH.ADDNODEFN GRAPH.DELETENODEFN GRAPH.ADDLINKFN GRAPH.DELETELINKFN GRAPH.FONTCHANGEFN GRAPH.INVERTBORDERFN GRAPH.INVERTLABELFN GRAPH.CHANGELABELFN . GRAPH.PROPS)) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS HALF MACRO ((X) (LRSH X 1))) ) ) (* ; "Grapher image objects") (DEFINEQ (GRAPHERIMAGEFNS [LAMBDA NIL (* ; "Edited 11-Apr-2018 09:02 by rmk:") (* ; "Edited 11-Apr-2018 09:01 by rmk:") (DECLARE (USEDFREE GRAPHERIMAGEFNS)) (OR GRAPHERIMAGEFNS (SETQ GRAPHERIMAGEFNS (IMAGEFNSCREATE (FUNCTION GRAPHOBJ.DISPLAYFN) (FUNCTION GRAPHOBJ.IMAGEBOXFN) (FUNCTION GRAPHOBJ.PUTFN) (FUNCTION GRAPHOBJ.GETFN) (FUNCTION GRAPHOBJ.COPYFN) (FUNCTION GRAPHOBJ.BUTTONEVENTINFN) (FUNCTION GRAPHOBJ.COPYBUTTONEVENTFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) NIL 'GRAPHER]) ) (DEFINEQ (GRAPHERCOPYBUTTONEVENTFN + [LAMBDA (WINDOW) (* ; "Edited 1-Aug-87 14:54 by sye") + + (* ;; "Called on down transition in WINDOW. If GRAPHOBJ.FINDGRAPH locates a graph in window, it is copy inserted. Another callers of GRAPHOBJ.FINDGRAPH might also specify alignments to GRAPHEROBJ.") + + (PROG* [(GRAPH (OR (GRAPHOBJ.FINDGRAPH WINDOW) + (RETURN))) + (REG (GRAPHREGION GRAPH)) + (LEFT (MINUS (fetch (REGION LEFT) of REG))) + (BOTTOM (MINUS (fetch (REGION BOTTOM) of REG))) + (LEFTBUTTONFN (WINDOWPROP WINDOW 'BROWSER/LEFTFN)) + (MIDDLEBUTTONFN (WINDOWPROP WINDOW 'BROWSER/MIDDLEFN] + (if (NOT (AND (ZEROP LEFT) + (ZEROP BOTTOM))) + then (SETQ GRAPH (TRANSGRAPH GRAPH LEFT BOTTOM))) + (COPYINSERT (GRAPHEROBJ GRAPH NIL NIL LEFTBUTTONFN MIDDLEBUTTONFN]) (GRAPHOBJ.FINDGRAPH + [LAMBDA (WINDOW) (* rmk%: "22-Dec-84 11:29") + + (* Get control on down transition, track until key goes up or mouse leaves the + window) + + (bind (DS _ (GETSTREAM WINDOW)) + (REG _ (WINDOWPROP WINDOW 'REGION)) first (DSPFILL NIL BLACKSHADE 'INVERT DS) + do (GETMOUSESTATE) + (COND + ((NOT (INSIDE? REG LASTMOUSEX LASTMOUSEY)) + (DSPFILL NIL BLACKSHADE 'INVERT DS) + (RETURN)) + ((NOT (LASTMOUSESTATE (OR LEFT MIDDLE RIGHT))) + (DSPFILL NIL BLACKSHADE 'INVERT DS) + (RETURN (COPYGRAPH (WINDOWPROP WINDOW 'GRAPH]) ) (DEFINEQ (ALIGNMENTNODE + [LAMBDA (NODESPEC GRAPH) (* ; "Edited 29-Apr-94 14:01 by sybalsky") + (* Returns the alignment node + specified by NODESPEC) + + (* Early implementation had *TOP, but documentation says *TOP*. + Remove earlier ones (*TOP) at some point) + + (SELECTQ NODESPEC + ((*TOP* *TOP) + (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) largest (GN/TOP + N))) + ((*BOTTOM* *BOTTOM) + (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) smallest (GN/BOTTOM + N))) + ((*RIGHT* *RIGHT) + (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) largest (GN/RIGHT + N))) + ((*LEFT* *LEFT) + (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) smallest (GN/LEFT + N))) + (GETNODEFROMID NODESPEC (fetch (GRAPH GRAPHNODES) of GRAPH]) (GRAPHOBJ.CHECKALIGN + [LAMBDA (GRAPH ALIGNSPEC) (* ; "Edited 29-Apr-94 14:02 by sybalsky") + (* Makes sure that the ALIGNMENTSPEC + is valid, putting it into standard + form if necessary) + (OR (AND (NULL ALIGNSPEC) + (SETQ ALIGNSPEC 0)) + (NUMBERP ALIGNSPEC) + [AND (LISTP ALIGNSPEC) + (SELECTQ (CAR ALIGNSPEC) + ((*TOP* *BOTTOM* *LEFT* *RIGHT* *TOP *BOTTOM *LEFT *RIGHT) + T) + (GETNODEFROMID (CAR ALIGNSPEC) + (fetch (GRAPH GRAPHNODES) of GRAPH))) + (LISTP (CDR ALIGNSPEC)) + (OR (NUMBERP (CADR ALIGNSPEC)) + (EQ (CADR ALIGNSPEC) + 'BASELINE) + (AND (NULL (CADR ALIGNSPEC)) + (SETQ ALIGNSPEC (LIST (CAR ALIGNSPEC) + 0] + (ERROR "ILLEGAL GRAPH ALIGNMENT SPECIFICATION" ALIGNSPEC)) + ALIGNSPEC]) ) (DEFINEQ (GRAPHEROBJ [LAMBDA (GRAPH HALIGN VALIGN LEFTBUTTONFN MIDDLEBUTTONFN COPYBUTTONEVENTFN) (* ; "Edited 10-Apr-2018 11:01 by rmk:") (* rmk%: " 6-Dec-85 11:35") (* Constructs a Grapher image  object.) (* HALIGN and VALIGN specify the horizontal or vertical alignment.  Each can be a floating point number between 0 and 1, specifying that the  alignment point is located at that portion of the width/height of the  graphregion, or a list of the form (nodespec align)%, where nodespec is a node  ID or one of the atoms LEFT, RIGHT, BOTTOM, TOP, and align is either a floating  point number bewtween 0 and 1, or the atom BASELINE) (LET ((REG (GRAPHREGION GRAPH)) (OBJ (IMAGEOBJCREATE (LIST GRAPH (GRAPHOBJ.CHECKALIGN GRAPH HALIGN) (GRAPHOBJ.CHECKALIGN GRAPH VALIGN)) GRAPHERIMAGEFNS))) [IMAGEOBJPROP OBJ 'OBJECTORIGIN (CREATEPOSITION (MINUS (fetch (REGION LEFT) of REG)) (MINUS (fetch (REGION BOTTOM) of REG] (AND LEFTBUTTONFN (IMAGEOBJPROP OBJ 'LEFTBUTTONFN LEFTBUTTONFN)) (AND MIDDLEBUTTONFN (IMAGEOBJPROP OBJ 'MIDDLEBUTTONFN MIDDLEBUTTONFN)) (AND COPYBUTTONEVENTFN (IMAGEOBJPROP OBJ 'COPYBUTTONEVENTFN COPYBUTTONEVENTFN)) OBJ]) (GRAPHOBJ.BUTTONEVENTINFN + [LAMBDA (GROBJ WINDOW) (* ; "Edited 1-Aug-87 16:16 by sye") + (* the user has pressed a button + inside the grapher object IMAGEOBJ.) + (LET [(LEFT (IMAGEOBJPROP GROBJ 'LEFTBUTTONFN)) + (MIDDLE (IMAGEOBJPROP GROBJ 'MIDDLEBUTTONFN] + (if (OR LEFT MIDDLE) + then (GRAPHBUTTONEVENTFN WINDOW (CAR (IMAGEOBJPROP GROBJ 'OBJECTDATUM)) + LEFT MIDDLE) + elseif [MENU (create MENU + ITEMS _ '((Edit% graph T " Opens a window to edit this graph"] + then (PROG [W (DATUM (IMAGEOBJPROP GROBJ 'OBJECTDATUM] + (SETQ W (SIZE/GRAPH/WINDOW (CAR DATUM) + NIL T)) + (IMAGEOBJPROP GROBJ 'OBJECTDATUM (LIST (EDITGRAPH1 + (COPYGRAPH (CAR DATUM)) + W) + (CADR DATUM) + (CADDR DATUM))) + (CLOSEW W)) + 'CHANGED]) (GRAPHOBJ.COPYBUTTONEVENTFN + [LAMBDA (GROBJ WINDOW) (* rmk%: " 6-Dec-85 11:42") + + (* the user has pressed a button inside the grapher object IMAGEOBJ while a + copy key was down) + + (LET [(CBEFN (IMAGEOBJPROP GROBJ 'COPYBUTTONEVENTFN] + (if CBEFN + then (APPLY* CBEFN GROBJ WINDOW) + else (COPYINSERT (GRAPHOBJ.COPYFN GROBJ]) (GRAPHOBJ.COPYFN + [LAMBDA (GROBJ) (* rmk%: " 6-Dec-85 12:07") + (* makes a copy of a grapher image + object.) + (LET* [(DATUM (IMAGEOBJPROP GROBJ 'OBJECTDATUM)) + (NEW (GRAPHEROBJ (COPYGRAPH (CAR DATUM)) + (CADR DATUM) + (CADDR DATUM] + [IMAGEOBJPROP NEW 'OBJECTORIGIN (create POSITION using (IMAGEOBJPROP GROBJ + 'OBJECTORIGIN] + (IMAGEOBJPROP NEW 'LEFTBUTTONFN (IMAGEOBJPROP GROBJ 'LEFTBUTTONFN)) + (IMAGEOBJPROP NEW 'MIDDLEBUTTONFN (IMAGEOBJPROP GROBJ 'MIDDLEBUTTONFN)) + (IMAGEOBJPROP NEW 'COPYBUTTONEVENTFN (IMAGEOBJPROP GROBJ 'COPYBUTTONEVENTFN)) + NEW]) (GRAPHOBJ.DISPLAYFN + [LAMBDA (GROBJ STREAM) (* rmk%: " 2-Apr-85 10:56") + (* display function for a grapher + image object) + + (* Scale the streams position back to display coordinates, since DISPLAYGRAPH + translates the translation. Might be simplest to define DISPLAYGRAPH without a + translation, as locating the graph coordinate system at the current X,Y + position) + + (PROG [REG (BOX (IMAGEOBJPROP GROBJ 'BOUNDBOX)) + (SCALE (DSPSCALE NIL STREAM)) + (GRAPH (CAR (IMAGEOBJPROP GROBJ 'OBJECTDATUM] + (OR BOX (SETQ BOX (APPLY* (IMAGEOBJPROP GROBJ 'IMAGEBOXFN) + GROBJ STREAM))) + [SETQ REG (GRAPHREGION (COND + ((EQP SCALE 1) + GRAPH) + (T (SCALE/GRAPH GRAPH STREAM SCALE] + + (* Kludgy%: we have to scale the graph to get the real region, but then + DISPLAYGRAPH will do it again, cause it assumes screen points.) + (* Other kludge is that the + translation is also in screen points) + (DISPLAYGRAPH GRAPH STREAM NIL (CREATEPOSITION (QUOTIENT (DIFFERENCE + (DIFFERENCE (DSPXPOSITION + NIL STREAM) + (fetch XKERN + of BOX)) + (fetch (REGION LEFT) + of REG)) + SCALE) + (QUOTIENT (DIFFERENCE (DIFFERENCE (DSPYPOSITION + NIL STREAM) + (fetch YDESC + of BOX)) + (fetch (REGION BOTTOM) + of REG)) + SCALE]) (GRAPHOBJ.GETALIGN + [LAMBDA (STREAM GRAPH) (* ; "Edited 29-Apr-94 14:02 by sybalsky") + (PROG ((ALIGN (READ STREAM FILERDTBL))) + [if [AND (LISTP ALIGN) + (NOT (MEMB (CAR ALIGN) + '(*TOP* *BOTTOM* *LEFT* *RIGHT* *TOP *BOTTOM *LEFT *RIGHT] + then (SETQ ALIGN (CONS [fetch (GRAPHNODE NODEID) + of (CAR (NTH (CAR ALIGN) + (fetch (GRAPH GRAPHNODES) + of GRAPH] + (CDR ALIGN] + (RETURN ALIGN]) (GRAPHOBJ.GETFN + [LAMBDA (STREAM) (* ; "Edited 7-Dec-88 18:38 by sye") + (* ; + "reads a grapher image object from a file.") + (OR (EQ (SKIPSEPRCODES STREAM FILERDTBL) + (CHARCODE %()) + (ERROR "ILLEGAL GRAPHOBJECT FORMAT")) + (READCCODE STREAM) (* Read the paren) + (PROG ((GRAPH (READGRAPH STREAM)) + IMAGEOBJ) + (SETQ IMAGEOBJ (GRAPHEROBJ GRAPH (GRAPHOBJ.GETALIGN STREAM GRAPH) + (GRAPHOBJ.GETALIGN STREAM GRAPH))) + + (* ;; "read leftbuttonfn & middlebuttonfn & copybuttoneventfn") + + [COND + ((NEQ (SKIPSEPRCODES STREAM FILERDTBL) + (CHARCODE %))) (* ; ") means extra props don't exist") + (IMAGEOBJPROP IMAGEOBJ 'LEFTBUTTONFN (HREAD STREAM)) + (IMAGEOBJPROP IMAGEOBJ 'MIDDLEBUTTONFN (HREAD STREAM)) + (IMAGEOBJPROP IMAGEOBJ 'COPYBUTTONEVENTFN (HREAD STREAM)) + + (* ;; "read imageobject origin") + + (IMAGEOBJPROP IMAGEOBJ 'OBJECTORIGIN (CREATEPOSITION (READ STREAM) + (READ STREAM] + (RATOM STREAM FILERDTBL) (* ; "Skip the closing paren") + (RETURN IMAGEOBJ]) (GRAPHOBJ.IMAGEBOXFN + [LAMBDA (GROBJ STREAM) (* ; "Edited 29-Apr-94 14:01 by sybalsky") + (* size function for a tedit bitmap + object.) + (PROG (REGION GRAPH HALIGN VALIGN ALNODE (DATUM (IMAGEOBJPROP GROBJ 'OBJECTDATUM)) + (SCALE (DSPSCALE NIL STREAM)) + BMW BMH) + (SETQ GRAPH (CAR DATUM)) + (SETQ HALIGN (CADR DATUM)) + (SETQ VALIGN (CADDR DATUM)) + (OR (EQ 1 SCALE) + (SETQ GRAPH (SCALE/GRAPH GRAPH STREAM SCALE))) + (SETQ REGION (GRAPHREGION GRAPH)) + (RETURN (create IMAGEBOX + XSIZE _ (fetch (REGION WIDTH) of REGION) + YSIZE _ (fetch (REGION HEIGHT) of REGION) + YDESC _ [COND + ((NUMBERP VALIGN) + (TIMES VALIGN (fetch (REGION HEIGHT) of REGION))) + (T (* Must be a list, cause of checks + in GRAPHEROBJ) + (SETQ ALNODE (ALIGNMENTNODE (CAR VALIGN) + GRAPH)) + (PLUS (GN/BOTTOM ALNODE) + (COND + ((EQ (CADR VALIGN) + 'BASELINE) + (IQUOTIENT (IPLUS (IDIFFERENCE + (fetch (GRAPHNODE NODEHEIGHT) + of ALNODE) + (FONTPROP (fetch (GRAPHNODE + NODEFONT) + of ALNODE) + 'ASCENT)) + (FONTPROP (fetch (GRAPHNODE + NODEFONT) + of ALNODE) + 'DESCENT)) + 2)) + (T (TIMES (CADR VALIGN) + (fetch (GRAPHNODE NODEHEIGHT) + of ALNODE] + XKERN _ (COND + ((NUMBERP HALIGN) + (TIMES HALIGN (fetch (REGION WIDTH) of REGION))) + (T (* Must be a list, cause of checks + in GRAPHEROBJ) + (SETQ ALNODE (ALIGNMENTNODE (CAR HALIGN) + GRAPH)) + (PLUS (GN/LEFT ALNODE) + (TIMES (COND + ((EQ (CADR HALIGN) + 'BASELINE) + 0) + (T (CADR HALIGN))) + (fetch (GRAPHNODE NODEWIDTH) of ALNODE]) (GRAPHOBJ.PUTALIGN + [LAMBDA (STREAM GRAPH ALIGN) (* ; "Edited 29-Apr-94 14:02 by sybalsky") + (PRIN2 [COND + ([OR (NLISTP ALIGN) + (MEMB (CAR ALIGN) + '(*TOP* *BOTTOM* *LEFT* *RIGHT* *TOP *BOTTOM *LEFT *RIGHT] + ALIGN) + (T (* Convert node ID to node index) + (CONS (for I from 1 as N in (fetch (GRAPH GRAPHNODES) + of GRAPH) + when (EQ (CAR ALIGN) + (fetch (GRAPHNODE NODEID) of N)) + do (RETURN I)) + (CDR ALIGN] + STREAM FILERDTBL]) (GRAPHOBJ.PUTFN + [LAMBDA (GROBJ STREAM) (* rmk%: "31-Dec-84 12:25") + (* Put a description of a grapher + object into the file.) + (PROG [ALIGN GRAPH (DATUM (IMAGEOBJPROP GROBJ 'OBJECTDATUM)) + (OBJORIGIN (IMAGEOBJPROP GROBJ 'OBJECTORIGIN] + (PRIN1 "(" STREAM) + + (* ;; " dump graph") + + (SETQ GRAPH (CAR DATUM)) + (DUMPGRAPH GRAPH STREAM) + (TERPRI STREAM) + + (* ;; " dump halign and valign") + + (GRAPHOBJ.PUTALIGN STREAM GRAPH (CADR DATUM)) + (SPACES 1 STREAM) + (GRAPHOBJ.PUTALIGN STREAM GRAPH (CADDR DATUM)) + (TERPRI STREAM) + + (* ;; " dump leftbuttonfn & middlebuttonfn & copybuttoneventfn ") + + (HPRINT (IMAGEOBJPROP GROBJ 'LEFTBUTTONFN) + STREAM) + (HPRINT (IMAGEOBJPROP GROBJ 'MIDDLEBUTTONFN) + STREAM) + (HPRINT (IMAGEOBJPROP GROBJ 'COPYBUTTONEVENTFN) + STREAM) + + (* ;; "dump objectorigin") + + (PRIN1 (fetch XCOORD of OBJORIGIN) + STREAM) + (SPACES 1 STREAM) + (PRIN1 (fetch YCOORD of OBJORIGIN) + STREAM) + (printout STREAM ")" T]) ) (DEFINEQ (COPYGRAPH + [LAMBDA (GRAPH) (* ; "Edited 29-Apr-94 14:02 by sybalsky") + (create GRAPH using GRAPH GRAPHNODES _ + (for N L in (fetch (GRAPH GRAPHNODES) of GRAPH) + collect (create GRAPHNODE + using N NODEPOSITION _ (create POSITION + using + (fetch (GRAPHNODE + NODEPOSITION) + of N)) + NODELABEL _ + (CL:TYPECASE (SETQ L (fetch (GRAPHNODE + NODELABEL) + of N)) + (BITMAP (BITMAPCOPY L)) + (IMAGEOBJ (APPLY* (IMAGEOBJPROP L + 'COPYFN) + L)) + (T L))]) (DUMPGRAPH + [LAMBDA (GRAPH STREAM) (* ; "Edited 29-Apr-94 14:02 by sybalsky") + (* Put a description of a graph into + a file.) + (RESETLST + (RESETSAVE (SETREADTABLE FILERDTBL)) + (PROG (BORDERS FONTS IDS SHADES (%#BORDERS 0) + (%#FONTS 0) + (%#SHADES 0) + (%#IDS 0)) + (printout STREAM "(" T "FIELDS (") + (if (fetch (GRAPH SIDESFLG) of GRAPH) + then (printout STREAM 2 "SIDESFLG " .P2 (fetch (GRAPH SIDESFLG) + of GRAPH))) + (if (fetch (GRAPH DIRECTEDFLG) of GRAPH) + then (printout STREAM 2 "DIRECTEDFLG " .P2 (fetch (GRAPH DIRECTEDFLG) + of GRAPH))) + (if (fetch (GRAPH GRAPH.MOVENODEFN) of GRAPH) + then (printout STREAM 2 "MOVENODEFN " .P2 (fetch (GRAPH GRAPH.MOVENODEFN) + of GRAPH))) + (if (fetch (GRAPH GRAPH.ADDNODEFN) of GRAPH) + then (printout STREAM 2 "ADDNODEFN " .P2 (fetch (GRAPH GRAPH.ADDNODEFN) + of GRAPH))) + (if (fetch (GRAPH GRAPH.DELETENODEFN) of GRAPH) + then (printout STREAM 2 "DELETENODEFN " .P2 (fetch (GRAPH + GRAPH.DELETENODEFN + ) of GRAPH))) + (if (fetch (GRAPH GRAPH.ADDLINKFN) of GRAPH) + then (printout STREAM 2 "ADDLINKFN " .P2 (fetch (GRAPH GRAPH.ADDLINKFN) + of GRAPH))) + (if (fetch (GRAPH GRAPH.DELETELINKFN) of GRAPH) + then (printout STREAM 2 "DELETELINKFN " .P2 (fetch (GRAPH + GRAPH.DELETELINKFN + ) of GRAPH))) + (if (fetch (GRAPH GRAPH.FONTCHANGEFN) of GRAPH) + then (printout STREAM 2 "FONTCHANGEFN " .P2 (fetch (GRAPH + GRAPH.FONTCHANGEFN + ) of GRAPH))) + (if (fetch (GRAPH GRAPH.INVERTBORDERFN) of GRAPH) + then (printout STREAM 2 "INVERTBORDERFN " .P2 (fetch (GRAPH + GRAPH.INVERTBORDERFN + ) of GRAPH) + )) + (if (fetch (GRAPH GRAPH.INVERTLABELFN) of GRAPH) + then (printout STREAM 2 "INVERTLABELFN " .P2 (fetch (GRAPH + GRAPH.INVERTLABELFN + ) of GRAPH)) + ) + (if (fetch (GRAPH GRAPH.CHANGELABELFN) of GRAPH) + then (printout STREAM 2 "CHANGELABELFN " .P2 (fetch (GRAPH + GRAPH.CHANGELABELFN + ) of GRAPH)) + ) + (if (fetch (GRAPH GRAPH.PROPS) of GRAPH) + then (printout STREAM 2 "PROPS ") + (HPRINT (fetch (GRAPH GRAPH.PROPS) of GRAPH) + STREAM)) + (PRIN1 ")" STREAM) + [for N TEMP in (fetch (GRAPH GRAPHNODES) of GRAPH) + do [OR (ASSOC (fetch (GRAPHNODE NODEID) of N) + IDS) + (push IDS (CONS (fetch (GRAPHNODE NODEID) of N) + (add %#IDS 1] + [AND (SETQ TEMP (fetch (GRAPHNODE NODELABELSHADE) of N)) + (OR (ASSOC TEMP SHADES) + (push SHADES (CONS TEMP (add %#SHADES 1] + [OR (ASSOC (fetch (GRAPHNODE NODEFONT) of N) + FONTS) + (push FONTS (CONS (fetch (GRAPHNODE NODEFONT) of N) + (add %#FONTS 1] + (SELECTQ (SETQ TEMP (fetch (GRAPHNODE NODEBORDER) of N)) + ((T NIL)) + (OR (ASSOC TEMP BORDERS) + (push BORDERS (CONS TEMP (add %#BORDERS 1] + (printout STREAM T "IDS " %#IDS %,) + (for X in (SETQ IDS (DREVERSE IDS)) do (PRIN2 (CAR X) + STREAM) + (SPACES 1 STREAM)) + (printout STREAM T "FONTS " %#FONTS %,) + (for X in (SETQ FONTS (DREVERSE FONTS)) + do (SETQ X (CAR X)) + (PRIN2 (if (LISTP X) + elseif (type? FONTDESCRIPTOR X) + then (FONTUNPARSE X) + elseif (FONTP X) + then (* Mark it as a class) + (CONS 'CLASS (FONTCLASSUNPARSE X))) + STREAM) + (SPACES 1 STREAM)) + [COND + (BORDERS (printout STREAM T "BORDERS " %#BORDERS %,) + (for X (POS _ (POSITION STREAM)) in (SETQ BORDERS (DREVERSE BORDERS)) + do (TAB POS 1 STREAM) + (HPRINT (CAR X) + STREAM] + [COND + (SHADES (printout STREAM T "SHADES " %#SHADES %,) + (for X (POS _ (POSITION STREAM)) in (SETQ SHADES (DREVERSE SHADES)) + do (TAB POS 1 STREAM) + (HPRINT (CAR X) + STREAM] + (printout STREAM T "NODES (") + (for N POS in (fetch (GRAPH GRAPHNODES) of GRAPH) + do (printout STREAM 2 "(" .P2 (CDR (ASSOC (fetch (GRAPHNODE NODEID) + of N) + IDS)) + %,) + (SETQ POS (POSITION STREAM)) + (HPRINT (fetch (GRAPHNODE NODELABEL) of N) + STREAM) + (printout STREAM %, .TAB POS .P2 (fetch (GRAPHNODE NODEPOSITION) + of N) + %, .P2 (CDR (ASSOC (fetch (GRAPHNODE NODEFONT) of N) + FONTS)) + %, .P2 (SELECTQ (fetch (GRAPHNODE NODEBORDER) of N) + ((NIL T) + (fetch (GRAPHNODE NODEBORDER) of N)) + (CDR (ASSOC (fetch (GRAPHNODE NODEBORDER) of N) + BORDERS))) + %, .P2 (AND (fetch (GRAPHNODE NODELABELSHADE) of N) + (CDR (ASSOC (fetch (GRAPHNODE NODELABELSHADE) + of N) + SHADES))) + %,) + (if (fetch (GRAPHNODE TONODES) of N) + then (PRIN1 "(" STREAM) + (for X in (fetch (GRAPHNODE TONODES) of N) + do (printout STREAM .P2 + [COND + [(EQ (CAR (LISTP X)) + 'Link% Parameters) + (CONS (CAR X) + (CONS (CDR (ASSOC (CADR X) + IDS)) + (CDDR X] + (T (CDR (ASSOC X IDS] + %,)) + (PRIN1 ") " STREAM) + else (PRIN1 "NIL " STREAM)) + (if (fetch (GRAPHNODE FROMNODES) of N) + then (PRIN1 "(" STREAM) + (for X in (fetch (GRAPHNODE FROMNODES) of N) + do (printout STREAM .P2 (CDR (ASSOC X IDS)) + %,)) + (PRIN1 ")" STREAM) + else (PRIN1 NIL STREAM)) + (printout STREAM ")" T)) + (PRIN1 "))" STREAM)))]) (READGRAPH + [LAMBDA (STREAM) (* ; "Edited 29-Apr-94 14:02 by sybalsky") + (* reads a graph from a file.) + (OR (EQ (SKIPSEPRS STREAM FILERDTBL) + '%() + (ERROR "ILLEGAL GRAPH FORMAT")) + (READC STREAM) (* Read the paren) + (bind NUM TEMP FONTS BORDERS SHADES IDS (GRAPH _ (create GRAPH)) + do + (SELECTQ (SETQ TEMP (RATOM STREAM FILERDTBL)) + (FIELDS [for F on (READ STREAM FILERDTBL) by (CDDR F) + do (SELECTQ (CAR F) + (SIDESFLG (replace (GRAPH SIDESFLG) of GRAPH + with (CADR F))) + (DIRECTEDFLG (replace (GRAPH DIRECTEDFLG) of GRAPH + with (CADR F))) + (MOVENODEFN (replace (GRAPH GRAPH.MOVENODEFN) of GRAPH + with (CADR F))) + (ADDNODEFN (replace (GRAPH GRAPH.ADDNODEFN) of GRAPH + with (CADR F))) + (DELETENODEFN (replace (GRAPH GRAPH.DELETENODEFN) of GRAPH + with (CADR F))) + (ADDLINKFN (replace (GRAPH GRAPH.ADDLINKFN) of GRAPH + with (CADR F))) + (DELETELINKFN (replace (GRAPH GRAPH.DELETELINKFN) of GRAPH + with (CADR F))) + (FONTCHANGEFN (replace (GRAPH GRAPH.FONTCHANGEFN) of GRAPH + with (CADR F))) + (INVERTBORDERFN + (replace (GRAPH GRAPH.INVERTBORDERFN) of GRAPH + with (CADR F))) + (INVERTLABELFN (replace (GRAPH GRAPH.INVERTLABELFN) of + GRAPH + with (CADR F))) + (CHANGELABELFN (replace (GRAPH GRAPH.CHANGELABELFN) of + GRAPH + with (CADR F))) + (PROPS (replace (GRAPH GRAPH.PROPS) of GRAPH + with (CADR F))) + (ERROR "UNRECOGNIZED GRAPH FIELD" (CAR F]) + (IDS (SETQ NUM (RATOM STREAM FILERDTBL)) + (SETQ IDS (ARRAY NUM)) + (for I to NUM do (SETA IDS I (READ STREAM FILERDTBL)))) + (BORDERS (SETQ NUM (RATOM STREAM FILERDTBL)) + (SETQ BORDERS (ARRAY NUM)) + (for I to NUM do (SETA BORDERS I (HREAD STREAM)))) + (FONTS (SETQ NUM (RATOM STREAM FILERDTBL)) + (SETQ FONTS (ARRAY NUM)) + [for I to NUM do (SETA FONTS I (COND + ((EQ (SETQ TEMP (READ STREAM + FILERDTBL)) + 'C) + (* A font class) + (SETQ TEMP (READ STREAM FILERDTBL)) + (FONTCLASS (CAR TEMP) + (CDR TEMP))) + ((EQ (CAR (LISTP TEMP)) + 'CLASS) + (FONTCLASS (CADR TEMP) + (CDDR TEMP))) + (T TEMP]) + (NODES (RATOM STREAM) (* Skip paren) + [replace (GRAPH GRAPHNODES) of GRAPH + with + (while (EQ (SKIPSEPRS STREAM FILERDTBL) + '%() + collect (READC STREAM) + (PROG1 (create GRAPHNODE + NODEID _ (ELT IDS (RATOM STREAM FILERDTBL)) + NODELABEL _ (HREAD STREAM) + NODEPOSITION _ (READ STREAM FILERDTBL) + NODEFONT _ (ELT FONTS (RATOM STREAM FILERDTBL)) + NODEBORDER _ (SELECTQ (SETQ TEMP (RATOM STREAM FILERDTBL) + ) + ((NIL T) + TEMP) + (ELT BORDERS TEMP)) + NODELABELSHADE _ (AND (SETQ TEMP (RATOM STREAM FILERDTBL) + ) + (ELT SHADES TEMP)) + TONODES _ + [for X in (READ STREAM FILERDTBL) + collect (COND + [(EQ (CAR (LISTP X)) + 'Link% Parameters) + (CONS (CAR X) + (CONS (ELT IDS (CADR X)) + (CDDR X] + (T (ELT IDS X] + FROMNODES _ (for X in (READ STREAM FILERDTBL) + collect (ELT IDS X))) + (* Skip the closing paren) + (RATOM STREAM FILERDTBL))] (* Skip the closing paren) + (RATOM STREAM FILERDTBL)) + (SHADES (SETQ NUM (RATOM STREAM FILERDTBL)) + (SETQ SHADES (ARRAY NUM)) + (for I to NUM do (SETA SHADES I (HREAD STREAM)))) + (%) (* The closing paren) + (RETURN GRAPH)) + (ERROR "INVALID GRAPHER IMAGE OBJECT" STREAM]) ) (RPAQ? GRAPHERIMAGEFNS ) (DECLARE%: DONTEVAL@LOAD DOCOPY (GRAPHERIMAGEFNS) ) (ADDTOVAR IMAGEOBJGETFNS (GRAPHOBJ.GETFN)) (PUTPROPS GRAPHER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7100 111149 (ADD/AND/DISPLAY/LINK 7110 . 7812) (APPLYTOSELECTEDNODE 7814 . 8302) ( CALL.MOVENODEFN 8304 . 8653) (CHANGE.NODEFONT.SIZE 8655 . 9967) (DEFAULT.ADDNODEFN 9969 . 10767) ( DELETE/AND/DISPLAY/LINK 10769 . 12336) (DISPLAY/NAME 12338 . 12509) (DISPLAYGRAPH 12511 . 14882) ( DISPLAYLINK 14884 . 17437) (DISPLAYLINK/BT 17439 . 18461) (DISPLAYLINK/LR 18463 . 19486) ( DISPLAYLINK/RL 19488 . 20511) (DISPLAYLINK/TB 20513 . 21536) (DISPLAYNODE 21538 . 21886) ( ERASE/GRAPHNODE 21888 . 22995) (DISPLAYNODE 22997 . 23345) (DISPLAYNODELINKS 23347 . 24491) ( DRAW/GRAPHNODE/BORDER 24493 . 25412) (DRAWAREABOX 25414 . 26615) (EDITADDLINK 26617 . 27015) ( EDITADDNODE 27017 . 29106) (EDITAPPLYTOLINK 29108 . 31187) (EDITCHANGEFONT 31189 . 32361) ( EDITCHANGELABEL 32363 . 33904) (EDITDELETELINK 33906 . 34312) (EDITDELETENODE 34314 . 37015) ( EDITGRAPH 37017 . 37084) (EDITGRAPH1 37086 . 37844) (EDITGRAPH2 37846 . 39577) (EDITMOVENODE 39579 . 41156) (EDITTOGGLEBORDER 41158 . 42454) (EDITTOGGLELABEL 42456 . 43753) (FILL/GRAPHNODE/LABEL 43755 . 44583) (FIX/SCALE 44585 . 45141) (FLIPNODE 45143 . 45747) (FONTNAMELIST 45749 . 45968) (FROMLINKS 45970 . 46140) (GETNODEFROMID 46142 . 47161) (GN/BOTTOM 47163 . 47439) (GN/LEFT 47441 . 47714) ( GN/RIGHT 47716 . 48107) (GN/TOP 48109 . 48533) (GRAPHADDLINK 48535 . 49094) (GRAPHADDNODE 49096 . 49885) (GRAPHBUTTONEVENTFN 49887 . 52067) (GRAPHCHANGELABEL 52069 . 52512) (GRAPHDELETELINK 52514 . 53822) (GRAPHDELETENODE 53824 . 54356) (GRAPHEDITCOMMANDFN 54358 . 55742) (GRAPHEDITEVENTFN 55744 . 56455) (GRAPHER/CENTERPRINTINAREA 56457 . 57221) (GRAPHERPROP 57223 . 57767) (GRAPHNODE/BORDER/WIDTH 57769 . 58290) (GRAPHREGION 58292 . 59461) (HARDCOPYGRAPH 59463 . 66845) (INTERSECT/REGIONP/LBWH 66847 . 68123) (INVERTED/GRAPHNODE/BORDER 68125 . 68709) (INVERTED/SHADE/FOR/GRAPHER 68711 . 69343) ( LAYOUT/POSITION 69345 . 69524) (LINKPARAMETERS 69526 . 69978) (MAX/RIGHT 69980 . 70182) (MAX/TOP 70184 . 70382) (MEASUREGRAPHNODE 70384 . 70833) (MEMBTONODES 70835 . 71360) (MIN/BOTTOM 71362 . 71743) ( MIN/LEFT 71745 . 72120) (MOVENODE 72122 . 73365) (NODECREATE 73367 . 74147) (NODELST/AS/MENU 74149 . 75749) (NODEREGION 75751 . 76211) (PRINTDISPLAYNODE 76213 . 81271) (PROMPTINWINDOW 81273 . 84082) ( READ/NODE 84084 . 85198) (REDISPLAYGRAPH 85200 . 85642) (REMOVETONODES 85644 . 86165) ( RESET/NODE/BORDER 86167 . 87954) (RESET/NODE/LABELSHADE 87956 . 89471) (SCALE/GRAPH 89473 . 95759) ( SCALE/GRAPHNODE/BORDER 95761 . 96456) (SCALE/TONODES 96458 . 97339) (SET/LABEL/SIZE 97341 . 100287) ( SET/LAYOUT/POSITION 100289 . 100774) (SHOWGRAPH 100776 . 102575) (SIZE/GRAPH/WINDOW 102577 . 106061) ( TOGGLE/DIRECTEDFLG 106063 . 106693) (TOGGLE/SIDESFLG 106695 . 107183) (TOLINKS 107185 . 107351) ( TRACKCURSOR 107353 . 108760) (TRACKNODE 108762 . 109398) (TRANSGRAPH 109400 . 111147)) (111207 127824 (EDITMOVEREGION 111217 . 115020) (EDITMOVESUBTREE 115022 . 116799) (NOT.TRACKCURSOR 116801 . 119779) ( RECURSIVE.COLLECTDESCENDENTS 119781 . 121269) (MOVEDESCENDENTS 121271 . 123333) (COLLECT.CHILD.NODES 123335 . 124451) (CREATE.NEW.NODEPOSITION 124453 . 124993) (GETBOXPOSITION.FROMINITIALREGION 124995 . 126467) (COLLECTDESCENDENTS 126469 . 127822)) (127888 130177 (NEXTSIZEFONT 127898 . 129088) ( DECREASING.FONT.LIST 129090 . 129416) (SCALE.FONT 129418 . 130175)) (130401 169553 (BRH/LAYOUT 130411 . 132155) (BRH/LAYOUT/DAUGHTERS 132157 . 133103) (BRH/OFFSET 133105 . 133783) (BRHC/INTERTREE/SPACE 133785 . 135103) (BRHC/LAYOUT 135105 . 136961) (BRHC/LAYOUT/DAUGHTERS 136963 . 139917) ( BRHC/LAYOUT/TERMINAL 139919 . 140600) (BRHC/OFFSET 140602 . 141498) (BRHL/LAYOUT 141500 . 143724) ( BRHL/LAYOUT/DAUGHTERS 143726 . 145484) (BRHL/MOVE/RIGHT 145486 . 146629) (BROWSE/LAYOUT/HORIZ 146631 . 147355) (BROWSE/LAYOUT/HORIZ/COMPACTLY 147357 . 150163) (BROWSE/LAYOUT/LATTICE 150165 . 151021) ( BRV/OFFSET 151023 . 151886) (EXTEND/TRANSITION/CHAIN 151888 . 153159) (FOREST/BREAK/CYCLES 153161 . 154091) (INIT/NODES/FOR/LAYOUT 154093 . 155588) (INTERPRET/MARK/FORMAT 155590 . 156857) ( LATTICE/BREAK/CYCLES 156859 . 157563) (LAYOUTFOREST 157565 . 158266) (LAYOUTGRAPH 158268 . 161735) ( LAYOUTLATTICE 161737 . 163190) (LAYOUTSEXPR 163192 . 164263) (LAYOUTSEXPR1 164265 . 164967) ( MARK/GRAPH/NODE 164969 . 165699) (NEW/INSTANCE/OF/GRAPHNODE 165701 . 167070) (RAISE/TRANSITION/CHAIN 167072 . 167473) (REFLECT/GRAPH/DIAGONALLY 167475 . 168204) (REFLECT/GRAPH/HORIZONTALLY 168206 . 168732) (REFLECT/GRAPH/VERTICALLY 168734 . 169258) (SWITCH/NODE/HEIGHT/WIDTH 169260 . 169551)) (172675 174026 (GRAPHERIMAGEFNS 172685 . 174024)) (174027 175755 (GRAPHERCOPYBUTTONEVENTFN 174037 . 175016) ( GRAPHOBJ.FINDGRAPH 175018 . 175753)) (175756 178376 (ALIGNMENTNODE 175766 . 177188) ( GRAPHOBJ.CHECKALIGN 177190 . 178374)) (178377 194227 (GRAPHEROBJ 178387 . 180133) ( GRAPHOBJ.BUTTONEVENTINFN 180135 . 181562) (GRAPHOBJ.COPYBUTTONEVENTFN 181564 . 182001) ( GRAPHOBJ.COPYFN 182003 . 182927) (GRAPHOBJ.DISPLAYFN 182929 . 185744) (GRAPHOBJ.GETALIGN 185746 . 186485) (GRAPHOBJ.GETFN 186487 . 187992) (GRAPHOBJ.IMAGEBOXFN 187994 . 192010) (GRAPHOBJ.PUTALIGN 192012 . 192842) (GRAPHOBJ.PUTFN 192844 . 194225)) (194228 213380 (COPYGRAPH 194238 . 195786) ( DUMPGRAPH 195788 . 206044) (READGRAPH 206046 . 213378))))) STOP \ No newline at end of file diff --git a/library/GRAPHZOOM b/library/GRAPHZOOM new file mode 100644 index 00000000..5daa2c8b --- /dev/null +++ b/library/GRAPHZOOM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "11-Jun-90 16:20:36" {DSK}local>lde>lispcore>library>GRAPHZOOM.;2 24143 changes to%: (VARS GRAPHZOOMCOMS) previous date%: " 6-Sep-85 08:52:00" {DSK}local>lde>lispcore>library>GRAPHZOOM.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT GRAPHZOOMCOMS) (RPAQQ GRAPHZOOMCOMS ((FILES GRAPHER) (RECORDS ZOOMGRAPH ZOOMGRAPHNODE) (FNS MAKE.ZOOM.GRAPH ORIG.NODE.OF.GRAPH SCALE.GRAPH.FONT SCALE.GRAPH.NODE SCALE.GRAPH.NODES SCALE.GRAPH RESET.GRAPH.EXTENT ZOOM.GRAPH.WINDOW ADJUST.EXTENT ZOOM.GRAPH.ADDLINKFN ZOOM.GRAPH.ADDNODEFN ZOOM.GRAPH.DELETELINKFN ZOOM.GRAPH.DELETENODEFN ZOOM.GRAPH.FONTCHANGEFN ZOOM.GRAPH.MOVENODEFN SHOWZOOMGRAPH ZOOM.TO.CENTER) (COMS (* general functions for scaling) (FNS ABSWXOFFSET ABSWYOFFSET SCALE.REGION UNSCALE.POSITION SCALE.POSITION WINDOW.SCALE) ) (COMS (FNS PRESS.DECREASING.FONT.LIST IP.DECREASING.FONT.LIST) (GLOBALVARS PRESS.DECREASING.FONT.LIST IP.DECREASING.FONT.LIST) (INITVARS PRESS.DECREASING.FONT.LIST IP.DECREASING.FONT.LIST)))) (FILESLOAD GRAPHER) (DECLARE%: EVAL@COMPILE (RECORD ZOOMGRAPH (NODELST DISPLAYGRAPH SG.MOVENODEFN SG.ADDNODEFN SG.DELETENODEFN SG.ADDLINKFN SG.DELETELINKFN)) (RECORD ZOOMGRAPHNODE (SG.POSITION SG.FONT SG.LABEL SG.USERDATA SG.)) ) (DEFINEQ (MAKE.ZOOM.GRAPH [LAMBDA (GRAPH SCALE) (* rrb " 6-NOV-83 12:07") (* returns a graph that is a scaled  version of GRAPH) (create GRAPH GRAPHNODES _ (SCALE.GRAPH.NODES (fetch (GRAPH GRAPHNODES) of GRAPH) SCALE) SIDESFLG _ (fetch (GRAPH SIDESFLG) of GRAPH) DIRECTEDFLG _ (fetch (GRAPH DIRECTEDFLG) of GRAPH) GRAPH.MOVENODEFN _ (FUNCTION ZOOM.GRAPH.MOVENODEFN) GRAPH.ADDNODEFN _ (FUNCTION ZOOM.GRAPH.ADDNODEFN) GRAPH.DELETENODEFN _ (FUNCTION ZOOM.GRAPH.DELETENODEFN) GRAPH.ADDLINKFN _ (FUNCTION ZOOM.GRAPH.ADDLINKFN) GRAPH.DELETELINKFN _ (FUNCTION ZOOM.GRAPH.DELETELINKFN) GRAPH.FONTCHANGEFN _ (FUNCTION ZOOM.GRAPH.FONTCHANGEFN]) (ORIG.NODE.OF.GRAPH [LAMBDA (NODE INGRAPH CORRESGRAPH) (* rrb " 1-NOV-83 19:02") (* returns the node in CORRESGRAPH  corresponding to NODE in INGRAPH.) (bind (NODEID _ (fetch (GRAPHNODE NODEID) of NODE)) for INND in (fetch (GRAPH GRAPHNODES) of INGRAPH) as CORND in (fetch (GRAPH GRAPHNODES) of CORRESGRAPH) when (EQ (fetch (GRAPHNODE NODEID) of INND) NODEID) do (RETURN CORND]) (SCALE.GRAPH.FONT [LAMBDA (FONT SCALE) (* rrb " 1-NOV-83 18:23") (* returns the closest font for this  scale.) (* "LABEL" is an approximation of the label string.  A fixed one is used rather than the label of the node so that all labels in the  same font will scale to the same font.) (SCALE.FONT (QUOTIENT (STRINGWIDTH "LABEL" FONT) SCALE) "LABEL"]) (SCALE.GRAPH.NODE [LAMBDA (NODE SCALE) (* rrb " 6-Sep-85 08:51") (* returns a node that has been  scaled.) (* keeps the same id's so that the  links don't have to change.) (* SCALE is the reciprocal of  scaling done in SCALE/GRAPH) (* this used to be create copying but this fails in the case where the nodeid  is a list structure because node checks are done with EQ.  -  rrb) (create GRAPHNODE using NODE NODEPOSITION _ (SCALE.POSITION (fetch (GRAPHNODE NODEPOSITION) of NODE) SCALE) NODEFONT _ (SCALE.GRAPH.FONT (fetch (GRAPHNODE NODEFONT) of NODE) SCALE]) (SCALE.GRAPH.NODES [LAMBDA (NODELST SCALE) (* rrb " 1-NOV-83 11:05") (* scales a list of nodes) (for NODE in NODELST collect (SCALE.GRAPH.NODE NODE SCALE]) (SCALE.GRAPH [LAMBDA (SGWINDOW) (* rrb " 8-NOV-83 12:35") (* takes the SKETCH.GRAPH in  SGWINDOW and recomputes it to its  current scale) (PROG [(SCALEDGRAPH (MAKE.ZOOM.GRAPH (WINDOWPROP SGWINDOW 'SKETCH.GRAPH) (WINDOWPROP SGWINDOW 'SCALE] (WINDOWPROP SGWINDOW 'GRAPH SCALEDGRAPH) (RESET.GRAPH.EXTENT SCALEDGRAPH SGWINDOW) (RETURN SCALEDGRAPH]) (RESET.GRAPH.EXTENT [LAMBDA (GRAPH WINDOW) (* sets the extent of the graph onto  the extent window property) (WINDOWPROP WINDOW 'EXTENT (GRAPHREGION GRAPH]) (ZOOM.GRAPH.WINDOW [LAMBDA (ITEM MENU BUTTON) (* rrb " 8-NOV-83 13:47") (* zooms the main sketch graph  window.) (PROG ((MAINW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (SMALLOUTFACTOR 1.1) (LARGEOUTFACTOR 1.8) SMALLINFACTOR LARGEINFACTOR) (* factors are reciprocals so that IN followed by small OUT should return to  the same place.) (SETQ SMALLINFACTOR (FQUOTIENT 1.0 SMALLOUTFACTOR)) (SETQ LARGEINFACTOR (FQUOTIENT 1.0 LARGEOUTFACTOR))(* set the SCALE and offsets) (ZOOM.TO.CENTER MAINW (SELECTQ (CADR (CADR ITEM)) (IN (SELECTQ BUTTON (MIDDLE LARGEINFACTOR) SMALLINFACTOR)) (SELECTQ BUTTON (MIDDLE LARGEOUTFACTOR) SMALLOUTFACTOR)))(* rescale the graph) (SCALE.GRAPH MAINW) (ADJUST.EXTENT MAINW) (REDISPLAYGRAPH MAINW]) (ADJUST.EXTENT [LAMBDA (WINDOW) (* rrb " 8-NOV-83 13:51") (* adjust the offsets of WINDOW so that the visible region of the window is all  extent. If there is more visible region than extent, it centers the extent.) (PROG ((EXTENT (WINDOWPROP WINDOW 'EXTENT)) (REG (DSPCLIPPINGREGION NIL WINDOW)) REGOFF REGEXT EXTOFF EXTEXT) (COND ((GREATERP (SETQ REGEXT (fetch (REGION WIDTH) of REG)) (SETQ EXTEXT (fetch (REGION WIDTH) of EXTENT))) (* center in X) (ABSWXOFFSET (DIFFERENCE (fetch (REGION LEFT) of EXTENT) (IQUOTIENT (IDIFFERENCE REGEXT EXTEXT) 2)) WINDOW)) ((GREATERP (SETQ EXTOFF (fetch (REGION LEFT) of EXTENT)) (SETQ REGOFF (fetch (REGION LEFT) of REG))) (* move it to the left) (ABSWXOFFSET EXTOFF WINDOW)) ((GREATERP (IPLUS REGOFF REGEXT) (SETQ EXTOFF (IPLUS EXTOFF EXTEXT))) (* move it to the right) (ABSWXOFFSET (DIFFERENCE EXTOFF REGEXT) WINDOW))) (COND ((GREATERP (SETQ REGEXT (fetch (REGION HEIGHT) of REG)) (SETQ EXTEXT (fetch (REGION HEIGHT) of EXTENT))) (* center in Y) (ABSWYOFFSET (DIFFERENCE (fetch (REGION BOTTOM) of EXTENT) (IQUOTIENT (IDIFFERENCE REGEXT EXTEXT) 2)) WINDOW)) ((GREATERP (SETQ EXTOFF (fetch (REGION BOTTOM) of EXTENT)) (SETQ REGOFF (fetch (REGION BOTTOM) of REG))) (* move it up) (ABSWYOFFSET EXTOFF WINDOW)) ((GREATERP (IPLUS REGOFF REGEXT) (SETQ EXTOFF (IPLUS EXTOFF EXTEXT))) (* move it down) (ABSWYOFFSET (DIFFERENCE EXTOFF REGEXT) WINDOW]) (ZOOM.GRAPH.ADDLINKFN [LAMBDA (FROM TO GRAPH WINDOW) (* rrb " 6-NOV-83 12:08") (* the link adding function for a  sketch graph.) (PROG [(ORGGRAPH (WINDOWPROP WINDOW 'SKETCH.GRAPH] (GRAPHADDLINK (ORIG.NODE.OF.GRAPH FROM GRAPH ORGGRAPH) (ORIG.NODE.OF.GRAPH TO GRAPH ORGGRAPH) ORGGRAPH WINDOW]) (ZOOM.GRAPH.ADDNODEFN [LAMBDA (GRAPH WINDOW) (* rrb " 1-NOV-83 17:46") (* the node adding function for a  sketch graph.) (PROG (NEWNODE) (COND ((SETQ NEWNODE (GRAPHADDNODE (WINDOWPROP WINDOW 'SKETCH.GRAPH) WINDOW)) (* calls the graphs addnode function to create the node then scale it to the  sketch window.) (RETURN (SCALE.GRAPH.NODE NEWNODE (WINDOWPROP WINDOW 'SCALE]) (ZOOM.GRAPH.DELETELINKFN [LAMBDA (FROM TO GRAPH WINDOW) (* rrb " 6-NOV-83 12:08") (* the link adding function for a  sketch graph.) (PROG [(ORGGRAPH (WINDOWPROP WINDOW 'SKETCH.GRAPH] (GRAPHDELETELINK (ORIG.NODE.OF.GRAPH FROM GRAPH ORGGRAPH) (ORIG.NODE.OF.GRAPH TO GRAPH ORGGRAPH) ORGGRAPH WINDOW]) (ZOOM.GRAPH.DELETENODEFN [LAMBDA (NODE GRAPH WINDOW) (* rrb " 6-NOV-83 12:08") (* the node deleting function for a  sketch graph.) (PROG [(ORGGRAPH (WINDOWPROP WINDOW 'SKETCH.GRAPH] (RETURN (GRAPHDELETENODE (ORIG.NODE.OF.GRAPH NODE GRAPH ORGGRAPH) ORGGRAPH WINDOW]) (ZOOM.GRAPH.FONTCHANGEFN [LAMBDA (HOW NODE GRAPH WINDOW) (* rrb " 6-NOV-83 12:08") (* the node deleting function for a  sketch graph.) (PROG (NEWFONT ORIGNODE) [SETQ NEWFONT (NEXTSIZEFONT HOW (fetch (GRAPHNODE NODEFONT) of (SETQ ORIGNODE (ORIG.NODE.OF.GRAPH NODE GRAPH (WINDOWPROP WINDOW 'SKETCH.GRAPH] (COND (NEWFONT (replace (GRAPHNODE NODEFONT) of ORIGNODE with NEWFONT]) (ZOOM.GRAPH.MOVENODEFN [LAMBDA (NODE NEWPOS GRAPH WINDOW) (* rrb " 6-NOV-83 12:08") (* the move function for a sketch graph.  Moves the original node and calls its move fn if any.) (PROG [(ORGGRAPH (WINDOWPROP WINDOW 'SKETCH.GRAPH)) (SCALE (WINDOWPROP WINDOW 'SCALE] (GRAPHMOVENODE (ORIG.NODE.OF.GRAPH NODE GRAPH ORGGRAPH) (UNSCALE.POSITION NEWPOS SCALE) ORGGRAPH WINDOW]) (SHOWZOOMGRAPH [LAMBDA (GRAPH WINDOW LEFTBUTTONFN MIDDLEBUTTONFN TOPJUSTIFYFLG ALLOWEDITFLG INITSCALE) (* edited%: "14-Feb-84 13:30") (* puts a zoomable graph in the given window, creating one if a window is not  given.) (PROG (SKETCH.GRAPH (INITSCALE (OR INITSCALE 1.0))) (COND ((LISTP GRAPH) (* should be a GRAPHP check but since it is a list there is no easy test.) NIL) ((NULL GRAPH) (SETQ GRAPH (create GRAPH))) (T (\ILLEGAL.ARG GRAPH))) (SETQ SKETCH.GRAPH (MAKE.ZOOM.GRAPH GRAPH INITSCALE)) (* put a title on so that there will  be a place to right button.) (SETQ WINDOW (SIZE/GRAPH/WINDOW SKETCH.GRAPH (OR WINDOW (AND ALLOWEDITFLG "")) TOPJUSTIFYFLG)) (bind MENU for ATW in (ATTACHEDWINDOWS WINDOW) when (AND (SETQ MENU (WINDOWPROP ATW 'MENU)) (EQ (fetch (MENU WHENSELECTEDFN) of (CAR MENU)) (FUNCTION ZOOM.GRAPH.WINDOW))) do (* a zoom menu is already attached  to this window.) (RETURN) finally (ATTACHMENU (create MENU ITEMS _ '((LARGER 'IN "increases the size of the graph elements." ) (smaller 'OUT "decreases the size of the graph elements" )) CENTERFLG _ T WHENSELECTEDFN _ (FUNCTION ZOOM.GRAPH.WINDOW) MENUROWS _ 1 MENUBORDERSIZE _ 1) WINDOW 'TOP)) (WINDOWPROP WINDOW 'SKETCH.GRAPH GRAPH) (WINDOWPROP WINDOW 'SCALE INITSCALE) (WINDOWPROP WINDOW 'GRAPH SKETCH.GRAPH) (WINDOWADDPROP WINDOW 'REPAINTFN (FUNCTION REDISPLAYGRAPH)) (WINDOWADDPROP WINDOW 'RESHAPEFN (FUNCTION RESHAPEBYREPAINTFN)) (WINDOWPROP WINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) [COND (ALLOWEDITFLG (* change the mode to invert so  lines can be erased by being  redrawn.) (DSPOPERATION 'INVERT WINDOW) (WINDOWPROP WINDOW 'RIGHTBUTTONFN (FUNCTION GRAPHEDITEVENTFN] (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION APPLYTOSELECTEDNODE)) (WINDOWPROP WINDOW 'BROWSER/LEFTFN LEFTBUTTONFN) (WINDOWPROP WINDOW 'BROWSER/MIDDLEFN MIDDLEBUTTONFN) (OPENW WINDOW) (REDISPLAYGRAPH WINDOW) (RETURN WINDOW]) (ZOOM.TO.CENTER [LAMBDA (WINDOW FACTOR) (* rrb " 6-NOV-83 11:46") (* adjusts the SCALE window property and the offsets of WINDOW so that they  correspond to zooming by FACTOR towards the center.) (PROG ((OLDSCALE (WINDOW.SCALE WINDOW)) (REG (DSPCLIPPINGREGION NIL WINDOW)) NEWSCALE) (WINDOWPROP WINDOW 'SCALE (SETQ NEWSCALE (FTIMES OLDSCALE FACTOR))) (ABSWXOFFSET (FIX (FQUOTIENT [FTIMES OLDSCALE (FPLUS (fetch (REGION LEFT) of REG) (FTIMES (fetch (REGION WIDTH) of REG) (FQUOTIENT (FDIFFERENCE 1.0 FACTOR) 2] NEWSCALE)) WINDOW) (ABSWYOFFSET (FIX (FQUOTIENT [FTIMES OLDSCALE (FPLUS (fetch (REGION BOTTOM) of REG) (FTIMES (fetch (REGION HEIGHT) of REG) (FQUOTIENT (FDIFFERENCE 1.0 FACTOR) 2] NEWSCALE)) WINDOW) (* scale the EXTENT also.) (AND (SETQ REG (WINDOWPROP WINDOW 'EXTENT)) (WINDOWPROP WINDOW 'EXTENT (SCALE.REGION REG FACTOR]) ) (* general functions for scaling) (DEFINEQ (ABSWXOFFSET [LAMBDA (NEWX W) (* rrb "29-MAR-83 11:27") (* sets the offset of a window.) (WXOFFSET (IDIFFERENCE (WXOFFSET NIL W) NEWX) W]) (ABSWYOFFSET [LAMBDA (NEWY W) (* rrb "29-MAR-83 11:28") (* sets the offset of a window.) (WYOFFSET (IDIFFERENCE (WYOFFSET NIL W) NEWY) W]) (SCALE.REGION [LAMBDA (REGION SCALE) (* rrb "15-AUG-83 17:30") (* scales a region into a windows  coordinate space.) (CREATEREGION (FIXR (QUOTIENT (fetch (REGION LEFT) of REGION) SCALE)) (FIXR (QUOTIENT (fetch (REGION BOTTOM) of REGION) SCALE)) (FIXR (QUOTIENT (fetch (REGION WIDTH) of REGION) SCALE)) (FIXR (QUOTIENT (fetch (REGION HEIGHT) of REGION) SCALE]) (UNSCALE.POSITION [LAMBDA (POSITION SCALE) (* rrb " 1-APR-83 16:05") (* unscales a point in a window out  into the larger coordinate space.) (create POSITION XCOORD _ (TIMES (fetch (POSITION XCOORD) of POSITION) SCALE) YCOORD _ (TIMES (fetch (POSITION YCOORD) of POSITION) SCALE]) (SCALE.POSITION [LAMBDA (POS SCALE) (* rrb "29-APR-83 08:27") (* scales a position from window  coordinates into global coordinates.) (create POSITION XCOORD _ (QUOTIENT (fetch (POSITION XCOORD) of POS) SCALE) YCOORD _ (QUOTIENT (fetch (POSITION YCOORD) of POS) SCALE]) (WINDOW.SCALE [LAMBDA (SKETCHW) (* rrb "14-MAR-83 10:31") (* returns the scale of a sketch  window.) (WINDOWPROP SKETCHW 'SCALE]) ) (DEFINEQ (PRESS.DECREASING.FONT.LIST [LAMBDA NIL (* rrb "10-Jun-85 14:35") (* calculates, caches, and returns a list of the font descriptors for the fonts  sketch windows are willing to print in.) (OR (LISTP PRESS.DECREASING.FONT.LIST) (PROG (FONT) (RETURN (SETQ PRESS.DECREASING.FONT.LIST (APPEND (AND (SETQ FONT (FONTCREATE 'HELVETICA 36 NIL NIL NIL T)) (CONS FONT)) (AND (SETQ FONT (FONTCREATE 'HELVETICAD 24 NIL NIL NIL T)) (CONS FONT)) (for SIZE in '(18 14 12 10 8 5 4 3) when (SETQ FONT (FONTCREATE 'HELVETICA SIZE NIL NIL NIL T)) collect FONT]) (IP.DECREASING.FONT.LIST [LAMBDA NIL (* rrb " 8-Jun-85 10:22") (* * calculates, caches, returns a list of the font descriptors for the fonts  sketch windows are willing to print in.) (* this is calculated upon demand so  that loading doesn't need fonts.) (OR (LISTP IP.DECREASING.FONT.LIST) (SETQ IP.DECREASING.FONT.LIST (bind FONT for SIZE in '(36 30 24 18 14 12 10 8 6) when (SETQ FONT (FONTCREATE 'MODERN SIZE NIL NIL NIL T)) join (CONS FONT]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PRESS.DECREASING.FONT.LIST IP.DECREASING.FONT.LIST) ) (RPAQ? PRESS.DECREASING.FONT.LIST NIL) (RPAQ? IP.DECREASING.FONT.LIST NIL) (PUTPROPS GRAPHZOOM COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1559 19359 (MAKE.ZOOM.GRAPH 1569 . 2535) (ORIG.NODE.OF.GRAPH 2537 . 3182) ( SCALE.GRAPH.FONT 3184 . 3784) (SCALE.GRAPH.NODE 3786 . 5239) (SCALE.GRAPH.NODES 5241 . 5526) ( SCALE.GRAPH 5528 . 6186) (RESET.GRAPH.EXTENT 6188 . 6457) (ZOOM.GRAPH.WINDOW 6459 . 7783) ( ADJUST.EXTENT 7785 . 10206) (ZOOM.GRAPH.ADDLINKFN 10208 . 10721) (ZOOM.GRAPH.ADDNODEFN 10723 . 11373) (ZOOM.GRAPH.DELETELINKFN 11375 . 11894) (ZOOM.GRAPH.DELETENODEFN 11896 . 12373) ( ZOOM.GRAPH.FONTCHANGEFN 12375 . 13248) (ZOOM.GRAPH.MOVENODEFN 13250 . 13748) (SHOWZOOMGRAPH 13750 . 17257) (ZOOM.TO.CENTER 17259 . 19357)) (19402 22121 (ABSWXOFFSET 19412 . 19703) (ABSWYOFFSET 19705 . 19996) (SCALE.REGION 19998 . 20703) (UNSCALE.POSITION 20705 . 21257) (SCALE.POSITION 21259 . 21805) ( WINDOW.SCALE 21807 . 22119)) (22122 23852 (PRESS.DECREASING.FONT.LIST 22132 . 23052) ( IP.DECREASING.FONT.LIST 23054 . 23850))))) STOP \ No newline at end of file diff --git a/library/HASH b/library/HASH new file mode 100644 index 00000000..0662a6f3 --- /dev/null +++ b/library/HASH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "11-Jun-90 16:23:11" {DSK}local>lde>lispcore>library>HASH.;2 32944 changes to%: (VARS HASHCOMS) previous date%: " 1-Nov-86 23:03:01" {DSK}local>lde>lispcore>library>HASH.;1) (* ; " Copyright (c) 1984, 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT HASHCOMS) (RPAQQ HASHCOMS ((COMS (* ; "User Functions") (FNS CLEARHASHFILES CLOSEHASHFILE COLLECTKEYS COPYHASHFILE COPYHASHITEM CREATEHASHFILE GETHASHFILE GETHASHTEXT HASHBEFORECLOSE HASHFILEDATA HASHFILENAME HASHFILEP HASHFILEPROP HASHFILESPLST LOOKUPHASHFILE MAPHASHFILE OPENHASHFILE PUTHASHFILE PUTHASHTEXT REHASHFILE)) (COMS (* ; "Internal Functions") (FNS DELETEHASHKEY FIND1STPRIME GETHASHKEY GETPROBE GTHASHFILE HASHFILESPLST1 INSERTHASHKEY MAKEHASHKEY REPLACEHASHKEY SETHASHSTATUS SPLITKEY)) (COMS (* ; "System Variables") (INITVARS (HFGROWTHFACTOR 3) (HASHLOADFACTOR 0.875) (HASHFILEDEFAULTSIZE 512) (HASHSCRATCHCONSCELL (CONS)) (HASHTEXTCHAR (CHARACTER (CHARCODE ^A))) (HASHFILERDTBL (COPYREADTABLE 'ORIG)) (HASHSCRATCHLST (CONSTANT (to 40 collect NIL))) (HASHBITTABLE (MAKEBITTABLE (LIST HASHTEXTCHAR))) (REHASHGAG T) SYSHASHFILE SYSHASHFILELST) (VARS PROBELST HASHACCESSTYPES) (ADDVARS (AFTERSYSOUTFORMS (CLEARHASHFILES))) (OPTIMIZERS GETHASHFILE HASHFILENAME)) [COMS (* ; "System Macros") (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS ANYEQ CREATEKEY PRINTPTR PRINTSTBYTE READPTR READSTBYTE REHASHKEY) (* ;; "etc.") (RECORDS HashFile HashTextPtr HashFileEntry DoubleKey) (CONSTANTS (HASH.HEADER.SIZE 8) (HASH.KEY.SIZE 4)) (GLOBALVARS HFGROWTHFACTOR HASHLOADFACTOR HASHFILEDEFAULTSIZE HASHSCRATCHCONSCELL HASHTEXTCHAR HASHSCRATCHLST HASHBITTABLE SYSHASHFILE SYSHASHFILELST PROBELST HASHACCESSTYPES HASHFILERDTBL MAX.INTEGER) (* ; "For MASTERSCOPE") (GLOBALVARS HASH.HEADER.SIZE HASH.KEY.SIZE) (SPECVARS REHASHGAG) (BLOCKS (LOOKUPHASHFILEBLOCK (ENTRIES LOOKUPHASHFILE GETHASHFILE PUTHASHFILE) LOOKUPHASHFILE GETHASHFILE PUTHASHFILE DELETEHASHKEY GETHASHKEY GETPROBE INSERTHASHKEY MAKEHASHKEY REPLACEHASHKEY) (OPENHASHFILEBLOCK (ENTRIES CREATEHASHFILE OPENHASHFILE) CREATEHASHFILE OPENHASHFILE FIND1STPRIME SETHASHSTATUS) (MAPHASHFILEBLOCK (ENTRIES COLLECTKEYS COPYHASHFILE COPYHASHITEM HASHFILESPLST MAPHASHFILE REHASHFILE) (SPECVARS REHASHGAG) COLLECTKEYS COPYHASHFILE COPYHASHITEM HASHFILESPLST HASHFILESPLST1 MAPHASHFILE REHASHFILE SPLITKEY] (PROP FILETYPE HASH))) (* ; "User Functions") (DEFINEQ (CLEARHASHFILES [LAMBDA (CLOSE RELEASE) (* cdl "21-May-86 19:55") (* ;; "Called after SYSOUT returns, to clean up any spurious items. Can also be called to close all hashfiles.") (if CLOSE then [while SYSHASHFILELST do (* ; "Do it this way, so the DREMOVE in HASHBEFORECLOSE doesn't screw up this iteration") (with HashFileEntry (pop SYSHASHFILELST) (with HashFile HASHFILE (CLOSEF? Stream) (SETQ Valid? NIL] (* ; "Invalidate anything that was open before the sysout") (SETQ SYSHASHFILE NIL]) (CLOSEHASHFILE [LAMBDA (HASHFILE REOPEN) (* cdl "21-May-86 08:18") (if (SETQ HASHFILE (HASHFILEP (OR HASHFILE SYSHASHFILE))) then (with HashFile HASHFILE (SETQ File (CLOSEF? Stream)) (if REOPEN then (* ; "This flag forces contents of file to exist on disk if we crash, reuse hashfile datum") (OPENHASHFILE File REOPEN NIL NIL HASHFILE) else File]) (COLLECTKEYS [LAMBDA (HASHFILE DOUBLE MKSTRING?) (* cdl "14-Mar-85 17:01") (DECLARE (SPECVARS MKSTRING?)) (PROG (KEYLST) (DECLARE (SPECVARS KEYLST)) [if DOUBLE then (MAPHASHFILE HASHFILE [FUNCTION (LAMBDA (KEY1 KEY2) (push KEYLST (CONS (if MKSTRING? then (MKSTRING KEY1) else KEY1) (if MKSTRING? then (MKSTRING KEY2) else KEY2] T) else (MAPHASHFILE HASHFILE (FUNCTION (LAMBDA (KEY) (push KEYLST (if MKSTRING? then (MKSTRING KEY) else KEY] (RETURN KEYLST]) (COPYHASHFILE [LAMBDA (HASHFILE NEWNAME FN VALUETYPE LEAVEOPEN) (* cdl "18-Mar-85 09:01") (DECLARE (SPECVARS HASHFILE FN)) (* ; "Copy HashFile by mapping over file hashing items into new file, slow but lisp independent") (with HashFile (SETQ HASHFILE (GTHASHFILE HASHFILE)) (PROG ((ACCESS (HASHFILEPROP HASHFILE 'ACCESS)) (NEWHASHFILE (CREATEHASHFILE NEWNAME (OR VALUETYPE ValueType) ItemLength %#Entries NIL ItemCopyFn))) (DECLARE (SPECVARS NEWHASHFILE)) (if (NEQ ACCESS 'INPUT) then (* ; "Close and reopen the hashfile to make sure it is up to date on the disk") (SETQ HASHFILE (CLOSEHASHFILE HASHFILE ACCESS))) [MAPHASHFILE HASHFILE (FUNCTION (LAMBDA (KEY) (COPYHASHITEM KEY HASHFILE NEWHASHFILE FN] (RETURN (if (NOT LEAVEOPEN) then (CLOSEHASHFILE NEWHASHFILE) else NEWHASHFILE]) (COPYHASHITEM [LAMBDA (KEY HASHFILE NEWHASHFILE USERFN) (* cdl "21-May-86 08:18") (* ;; "Copy single hash item from old to new hashfile, applying userfn if supplied") (PROG ((VALUE (GETHASHFILE KEY HASHFILE))) (if USERFN then (SETQ VALUE (APPLY* USERFN KEY VALUE HASHFILE NEWHASHFILE))) (if (type? HashTextPtr VALUE) then (with HashTextPtr VALUE (with HashFile HASHFILE (PUTHASHTEXT KEY Stream NEWHASHFILE Start End))) else (LOOKUPHASHFILE KEY VALUE NEWHASHFILE 'INSERT]) (CREATEHASHFILE [LAMBDA (FILE VALUETYPE ITEMLENGTH %#ENTRIES SMASH COPYFN) (* cdl "21-May-86 09:32") (PROG (STREAM SIZE HASHFILE) [SETQ SIZE (FIND1STPRIME (FIX (FTIMES (if %#ENTRIES then (MAX %#ENTRIES HASHFILEDEFAULTSIZE) else HASHFILEDEFAULTSIZE) HFGROWTHFACTOR] [SETQ STREAM (OPENSTREAM FILE 'OUTPUT 'NEW 8 '((TYPE BINARY] (PRINTPTR STREAM 0) (PRINTPTR STREAM SIZE) (* Put other arguments on file for future expansion) [BOUT STREAM (SELECTQ VALUETYPE (TEXT (CHARCODE T)) (EXPR (CHARCODE E)) (PROGN (SETQ VALUETYPE 'EXPR) (CHARCODE E] (BOUT STREAM (SETQ ITEMLENGTH (if (NUMBERP ITEMLENGTH) then (LOGAND ITEMLENGTH 255) else 0))) (* Fill the KEY section with zeros and mark end of KEYS, start of DATA) (to (ADD1 (ITIMES SIZE HASH.KEY.SIZE)) do (BOUT STREAM 0)) (* Close file and reopen to ensure existance) [SELECTQ (SYSTEMTYPE) ((TENEX TOPS20) (SETQ FILE (CLOSEF (with STREAM STREAM FULLNAME)))) (PROGN (SETQ FILE (CLOSEF STREAM] (with HashFile (SETQ HASHFILE (if (type? HashFile SMASH) then SMASH else (create HashFile))) [SETQ ByteStream (OPENSTREAM FILE 'BOTH 'OLD 8 '((TYPE BINARY] [SELECTQ (SYSTEMTYPE) ((TENEX TOPS20) (SETQ File (SETQ Stream (with STREAM ByteStream FULLNAME)))) (SETQ File (FULLNAME (SETQ Stream ByteStream] (SETQ Size SIZE) (SETQ %#Entries 0) (SETQ Write? T) (SETQ ValueType VALUETYPE) (SETQ ItemCopyFn COPYFN) (SETQ ItemLength ITEMLENGTH)) (RETURN (SETHASHSTATUS HASHFILE]) (GETHASHFILE [LAMBDA (KEY HASHFILE KEY2) (* cdl " 3-Aug-83 15:04") (LOOKUPHASHFILE (CREATEKEY KEY KEY2) NIL HASHFILE 'RETRIEVE]) (GETHASHTEXT [LAMBDA (KEY HASHFILE DSTFIL) (* cdl "21-May-86 08:19") (PROG ((HASHTEXTPTR (GETHASHFILE KEY HASHFILE))) (if (type? HashTextPtr HASHTEXTPTR) then (with HashTextPtr HASHTEXTPTR (with HashFile HASHFILE (RETURN (COPYBYTES Stream DSTFIL Start End]) (HASHBEFORECLOSE [LAMBDA (FILE) (* cdl "18-Mar-85 10:27") (* Called before a hashfile is actually closed) (PROG ((ENTRY (ASSOC (FULLNAME FILE) SYSHASHFILELST))) (if ENTRY then (with HashFileEntry ENTRY (if (EQ HASHFILE SYSHASHFILE) then (SETQ SYSHASHFILE NIL)) (* Mark this datum defunct) (with HashFile HASHFILE (SETQ Valid? NIL))) (* Remove from table of open hash files) (SETQ SYSHASHFILELST (DREMOVE ENTRY SYSHASHFILELST]) (HASHFILEDATA [LAMBDA (HASHFILE) (* cdl "22-Aug-83 12:12") (with HashFile (GTHASHFILE HASHFILE) (LIST File ValueType ItemLength %#Entries]) (HASHFILENAME [LAMBDA (HASHFILE) (* gbn " 7-Nov-84 16:34") (HASHFILEPROP HASHFILE 'NAME]) (HASHFILEP [LAMBDA (HASHFILE WRITE) (* cdl "18-Mar-85 10:52") (if [AND [OR (type? HashFile HASHFILE) (AND HASHFILE (LITATOM HASHFILE) (SETQ HASHFILE (FULLNAME HASHFILE)) (SETQ HASHFILE (CDR (ASSOC HASHFILE SYSHASHFILELST] (with HashFile HASHFILE (AND Valid? (OR (NOT WRITE) Write?] then HASHFILE]) (HASHFILEPROP [LAMBDA (HASHFILE PROP VALUE) (* cdl "21-May-86 09:43") (with HashFile (GTHASHFILE HASHFILE) (SELECTQ PROP (VALUETYPE ValueType) (ACCESS (GETFILEINFO Stream 'ACCESS)) (NAME File) (COPYFN (PROG1 ItemCopyFn (if VALUE then (SETQ ItemCopyFn VALUE)))) (STREAM Stream) (SIZE Size) (%#ENTRIES %#Entries) (ITEMLENGTH ItemLength) NIL]) (HASHFILESPLST [LAMBDA (HASHFILE XWORD) (* cdl "15-Mar-85 08:51") (DECLARE (SPECVARS . T)) (* Just create an Interlisp generator that returns each hash key) (if (SETQ HASHFILE (GTHASHFILE HASHFILE)) then (GENERATOR (HASHFILESPLST1 HASHFILE XWORD]) (LOOKUPHASHFILE [LAMBDA (KEY VALUE HASHFILE CALLTYPE KEY2) (* Pavel "24-Sep-86 12:31") (PROG (RETVAL RETFLG (KEYVAL MAX.INTEGER) (INDEX (CREATEKEY KEY KEY2))) (SETQ HASHFILE (GTHASHFILE HASHFILE (ANYEQ '(REPLACE DELETE INSERT) CALLTYPE))) (SETQ KEYVAL (GETHASHKEY INDEX HASHFILE (EQMEMB 'INSERT CALLTYPE) KEYVAL)) (COND ((MINUSP KEYVAL) (if (EQMEMB 'INSERT CALLTYPE) then (INSERTHASHKEY (SETQ KEYVAL (IMINUS KEYVAL)) INDEX VALUE HASHFILE))) (T (if (EQMEMB 'RETRIEVE CALLTYPE) then (SETQ RETFLG T) (SETQ RETVAL (READ (fetch Stream of HASHFILE) HASHFILERDTBL))) (if (EQMEMB 'REPLACE CALLTYPE) then (REPLACEHASHKEY KEYVAL INDEX VALUE HASHFILE) elseif (EQMEMB 'DELETE CALLTYPE) then (DELETEHASHKEY KEYVAL HASHFILE)) (RETURN (if RETFLG then RETVAL elseif KEYVAL then T]) (MAPHASHFILE [LAMBDA (HASHFILE MAPFN DOUBLE) (* Pavel "24-Sep-86 12:30") (with HashFile (SETQ HASHFILE (GTHASHFILE HASHFILE)) (bind KEY VALUE HASHKEY (BOTH _ (IGREATERP (OR (NARGS MAPFN) 0) (if DOUBLE then 2 else 1))) to Size as ADR from HASH.HEADER.SIZE by HASH.KEY.SIZE when (PROGN (SETFILEPTR Stream ADR) (READSTBYTE ByteStream 'USED)) do (SETQ HASHKEY (READPTR ByteStream)) (SETFILEPTR Stream HASHKEY) (SETQ KEY (READ Stream HASHFILERDTBL)) (if BOTH then (SETQ VALUE (READ Stream HASHFILERDTBL))) (if DOUBLE then (* ; "Two key hashing so split up key, userfn takes two key arguments") (with DoubleKey (SPLITKEY KEY) (APPLY* MAPFN Key1 Key2 VALUE)) else (APPLY* MAPFN KEY VALUE]) (OPENHASHFILE [LAMBDA (FILE ACCESS ITEMLENGTH %#ENTRIES SMASH) (* cdl "21-May-86 11:30") [SETQ ACCESS (for ENTRY in HASHACCESSTYPES thereis (MEMB ACCESS ENTRY) finally (RETURN (CAR ENTRY] (if (OR ITEMLENGTH %#ENTRIES (EQ ACCESS 'CREATE)) then (* This is really a createhashfile call, the original hash package used openhashfile for both) (CREATEHASHFILE FILE NIL ITEMLENGTH %#ENTRIES SMASH) else (PROG [(HASHFILE (CDR (ASSOC (FULLNAME FILE) SYSHASHFILELST] [if HASHFILE then (with HashFile HASHFILE (if (EQ ACCESS (GETFILEINFO Stream 'ACCESS)) then (* This is the NO-OP case) (RETURN HASHFILE] [with HashFile (SETQ HASHFILE (if (type? HashFile SMASH) then SMASH else (create HashFile))) [SETQ ByteStream (OPENSTREAM FILE ACCESS 'OLD 8 '((TYPE BINARY] (SETQ %#Entries (READPTR ByteStream)) (SETQ Size (READPTR ByteStream)) (SETQ ValueType (SELCHARQ (BIN ByteStream) (T 'TEXT) (E 'EXPR) 'EXPR)) (SETQ ItemLength (BIN ByteStream)) (SETQ Write? (EQ ACCESS 'BOTH)) (SELECTQ (SYSTEMTYPE) ((TENEX TOPS20) (SETQ File (SETQ Stream (with STREAM ByteStream FULLNAME)))) (SETQ File (FULLNAME (SETQ Stream ByteStream] (RETURN (SETHASHSTATUS HASHFILE]) (PUTHASHFILE [LAMBDA (KEY VALUE HASHFILE KEY2) (* cdl "15-Mar-85 08:55") (LOOKUPHASHFILE (CREATEKEY KEY KEY2) VALUE HASHFILE (if VALUE then '(REPLACE INSERT) else 'DELETE)) VALUE]) (PUTHASHTEXT [LAMBDA (KEY SRCFIL HASHFILE START END) (* cdl "21-May-86 08:54") (SETQ HASHFILE (GTHASHFILE HASHFILE T)) (PROG (HASHTEXTPTR) [with HashFile HASHFILE (SETFILEPTR Stream -1) (with HashTextPtr (SETQ HASHTEXTPTR (create HashTextPtr Start _ (GETEOFPTR Stream))) (COPYBYTES SRCFIL Stream START END) (SETQ End (GETEOFPTR Stream] (RETURN (PUTHASHFILE KEY HASHTEXTPTR HASHFILE]) (REHASHFILE [LAMBDA (HASHFILE NEWNAME VALUETYPE) (* cdl "21-May-86 08:23") (SETQ HASHFILE (GTHASHFILE HASHFILE)) (PROG [[NAME (OR NEWNAME (PACKFILENAME 'VERSION NIL 'BODY (HASHFILENAME HASHFILE] (ACCESS (HASHFILEPROP HASHFILE 'ACCESS] (* If rehashgag = T then print out old and new file) [with HashFile HASHFILE (if (NOT REHASHGAG) then (printout NIL "Rehashing" %, File " ... ")) (SETQ NAME (COPYHASHFILE HASHFILE NAME ItemCopyFn (OR VALUETYPE ValueType] (CLOSEHASHFILE HASHFILE) (with HashFile (OPENHASHFILE NAME ACCESS NIL NIL HASHFILE) (if (NOT REHASHGAG) then (printout NIL File T))) (RETURN HASHFILE]) ) (* ; "Internal Functions") (DEFINEQ (DELETEHASHKEY [LAMBDA (HASHKEY HASHFILE) (* cdl "21-May-86 19:57") (with HashFile HASHFILE (SETFILEPTR Stream 0) (PRINTPTR ByteStream (SETQ %#Entries (SUB1 %#Entries))) (SETFILEPTR Stream HASHKEY) (PRINTSTBYTE ByteStream 'DELETED) (FORCEOUTPUT Stream]) (FIND1STPRIME [LAMBDA (N) (* cdl "11-Aug-83 08:12") (find P from (LOGOR N 1) by 2 suchthat (for I from 3 by 2 never (AND (ILESSP I P) (ZEROP (IREMAINDER P I))) repeatuntil (ILESSP P (ITIMES I I]) (GETHASHKEY [LAMBDA (INDEX HASHFILE DELOK? HASHKEY) (* Pavel "24-Sep-86 12:30") (with HashFile HASHFILE (bind PROBE DELETED? first (SETQ HASHKEY (MAKEHASHKEY INDEX Size)) (SETFILEPTR Stream HASHKEY) until (SELCHARQ (BIN ByteStream) (D (SETQ DELETED? T) DELOK?) (NULL 'FREE) NIL) do (if DELETED? then (SETQ DELETED? NIL) else (SETFILEPTR Stream (READPTR ByteStream)) (if (EQUAL INDEX (READ Stream HASHFILERDTBL)) then (RETURN HASHKEY))) (if (NULL PROBE) then (SETQ PROBE (GETPROBE INDEX))) (SETQ HASHKEY (REHASHKEY HASHKEY PROBE Size)) (SETFILEPTR Stream HASHKEY) finally (RETURN (SETQ HASHKEY (IMINUS HASHKEY]) (GETPROBE [LAMBDA (KEY) (* cdl "15-Mar-85 09:06") (* Get the value to probe by. Probelst contains all the probe primes.) (CAR (FNTH PROBELST (ADD1 (LOGAND 31 (NTHCHARCODE KEY (ADD1 (LRSH (NCHARS KEY) 1]) (GTHASHFILE [LAMBDA (HASHFILE WRITE) (* cdl "18-Mar-85 09:55") (if (NULL HASHFILE) then (SETQ HASHFILE SYSHASHFILE)) (* ;; "Return hashfile datum for HF, which is a filename or a hashfile datum. Special cases: if HASHFILE is a filename which is not open, it is opened; if HASHFILE is an invalidated hashfile datum (because it was closed), it is reopened; if HASHFILE is already open for read, but WRITE is set, will attempt to close and then open for write") (if (HASHFILEP HASHFILE WRITE) then HASHFILE elseif (type? HashFile HASHFILE) then (OPENHASHFILE (fetch File of HASHFILE) WRITE NIL NIL HASHFILE) elseif (LITATOM HASHFILE) then (OPENHASHFILE HASHFILE WRITE) else (HELP HASHFILE "NOT A HASHFILE"]) (HASHFILESPLST1 [LAMBDA (HASHFILE XWORD) (* cdl "15-Mar-85 09:10") (DECLARE (SPECVARS XWORD)) (MAPHASHFILE HASHFILE (FUNCTION (LAMBDA (KEY) (if (OR (NULL XWORD) (STRPOS XWORD KEY 1 NIL T)) then (PRODUCE KEY]) (INSERTHASHKEY [LAMBDA (HASHKEY INDEX VALUE HASHFILE) (* cdl "21-May-86 09:33") (with HashFile HASHFILE (if (GREATERP %#Entries (TIMES Size HASHLOADFACTOR)) then (REHASHFILE HASHFILE)) (SETFILEPTR Stream 0) (SETQ %#Entries (ADD1 %#Entries)) (PRINTPTR ByteStream %#Entries) (REPLACEHASHKEY HASHKEY INDEX VALUE HASHFILE]) (MAKEHASHKEY [LAMBDA (KEY RANGE) (* cdl "21-May-86 11:28") (IPLUS HASH.HEADER.SIZE (ITIMES (for CHARCODE in (DCHCON KEY HASHSCRATCHLST) bind (INDEX _ 1) do (SETQ INDEX (IMOD (ITIMES INDEX CHARCODE) RANGE)) finally (RETURN INDEX)) HASH.KEY.SIZE]) (REPLACEHASHKEY [LAMBDA (HASHKEY INDEX VALUE HASHFILE) (* bvm%: " 1-Nov-86 22:28") (with HashFile HASHFILE (SETFILEPTR Stream HASHKEY) (PRINTSTBYTE ByteStream 'USED) (PRINTPTR ByteStream (GETEOFPTR Stream)) (SETFILEPTR Stream -1) (PRIN2 INDEX Stream HASHFILERDTBL) (SPACES 1 Stream) (PRINT VALUE Stream HASHFILERDTBL) (FORCEOUTPUT Stream]) (SETHASHSTATUS [LAMBDA (HASHFILE) (* cdl "21-May-86 09:13") (with HashFile HASHFILE (* Fix data structures to know about this file so they get updated when it closes) (WHENCLOSE Stream 'BEFORE (FUNCTION HASHBEFORECLOSE)) (SETQ Valid? T) (push SYSHASHFILELST (CONS File HASHFILE))) (SETQ SYSHASHFILE HASHFILE]) (SPLITKEY [LAMBDA (KEY) (* cdl "14-Mar-85 16:55") (PROG ((PTR (STRPOSL HASHBITTABLE KEY))) (RETURN (if PTR then (FRPLNODE HASHSCRATCHCONSCELL (SUBATOM KEY 1 (SUB1 PTR)) (SUBATOM KEY (ADD1 PTR))) else (FRPLNODE HASHSCRATCHCONSCELL KEY NIL]) ) (* ; "System Variables") (RPAQ? HFGROWTHFACTOR 3) (RPAQ? HASHLOADFACTOR 0.875) (RPAQ? HASHFILEDEFAULTSIZE 512) (RPAQ? HASHSCRATCHCONSCELL (CONS)) (RPAQ? HASHTEXTCHAR (CHARACTER (CHARCODE ^A))) (RPAQ? HASHFILERDTBL (COPYREADTABLE 'ORIG)) (RPAQ? HASHSCRATCHLST (CONSTANT (to 40 collect NIL))) (RPAQ? HASHBITTABLE (MAKEBITTABLE (LIST HASHTEXTCHAR))) (RPAQ? REHASHGAG T) (RPAQ? SYSHASHFILE NIL) (RPAQ? SYSHASHFILELST NIL) (RPAQQ PROBELST (1 3 5 7 11 11 13 17 17 19 23 23 29 29 29 31 37 37 37 41 41 43 47 47 53 53 53 59 59 59 61 67)) (RPAQQ HASHACCESSTYPES ((INPUT READ OLD NIL RETRIEVE) (BOTH WRITE OUTPUT T INSERT DELETE REPLACE) (CREATE DOUBLE NUMBER STRING PRINT FULLPRINT))) (ADDTOVAR AFTERSYSOUTFORMS (CLEARHASHFILES)) (DEFOPTIMIZER GETHASHFILE (&REST X) [if (CADDR X) then 'IGNOREMACRO else `(LOOKUPHASHFILE ,(CAR X) NIL ,(CADR X) 'RETRIEVE]) (DEFOPTIMIZER HASHFILENAME (HASHFILE) `(HASHFILEPROP ,HASHFILE 'NAME)) (* ; "System Macros") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS ANYEQ MACRO [LAMBDA (X Y) (for Z in X thereis (EQMEMB Z Y]) (PUTPROPS CREATEKEY MACRO [LAMBDA (KEY1 KEY2) (if (NULL KEY2) then KEY1 else (PACK* KEY1 HASHTEXTCHAR KEY2]) (PUTPROPS PRINTPTR MACRO [X `(PROGN ,@(for I from 2 to 0 by -1 collect `(BOUT ,(CAR X) (LOGAND 255 ,(if (ZEROP I) then (CADR X) else `(RSH ,(CADR X) ,(ITIMES 8 I]) (PUTPROPS PRINTSTBYTE MACRO [X `(BOUT ,(CAR X) ,(SELECTQ (CADR (CADR X)) ((U USED) (CHARCODE U)) ((D DELETED) (CHARCODE D)) ((F FREE) (CHARCODE F)) NIL]) (PUTPROPS READPTR MACRO [X `(IPLUS ,@(for I from 2 to 0 by -1 collect (if (ZEROP I) then `(BIN ,(CAR X)) else `(LLSH (BIN ,(CAR X)) ,(ITIMES 8 I]) (PUTPROPS READSTBYTE MACRO [X `(EQ (BIN ,(CAR X)) (CHARCODE ,(SELECTQ (CADR (CADR X)) (FREE 'NULL) (USED 'U) (DELETED 'D) NIL]) (PUTPROPS REHASHKEY MACRO [LAMBDA (HKEY PROBE RANGE) (* ;; "There is a slight conceptual glitch here in that we should subtract off HASH.HEADER.SIZE from HKEY but it would affect existing hashfiles and does not cause any real error due to the IMOD") (IPLUS HASH.HEADER.SIZE (ITIMES (IMOD (IPLUS PROBE (IQUOTIENT HKEY HASH.KEY.SIZE )) RANGE) HASH.KEY.SIZE]) ) (DECLARE%: EVAL@COMPILE (ARRAYRECORD HashFile (File Stream Size %#Entries ValueType ItemLength Valid? Write? ItemCopyFn ByteStream)) (TYPERECORD HashTextPtr (Start . End)) (RECORD HashFileEntry (FILE . HASHFILE)) (RECORD DoubleKey (Key1 . Key2)) ) (DECLARE%: EVAL@COMPILE (RPAQQ HASH.HEADER.SIZE 8) (RPAQQ HASH.KEY.SIZE 4) (CONSTANTS (HASH.HEADER.SIZE 8) (HASH.KEY.SIZE 4)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS HFGROWTHFACTOR HASHLOADFACTOR HASHFILEDEFAULTSIZE HASHSCRATCHCONSCELL HASHTEXTCHAR HASHSCRATCHLST HASHBITTABLE SYSHASHFILE SYSHASHFILELST PROBELST HASHACCESSTYPES HASHFILERDTBL MAX.INTEGER) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS HASH.HEADER.SIZE HASH.KEY.SIZE) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS REHASHGAG) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: LOOKUPHASHFILEBLOCK (ENTRIES LOOKUPHASHFILE GETHASHFILE PUTHASHFILE) LOOKUPHASHFILE GETHASHFILE PUTHASHFILE DELETEHASHKEY GETHASHKEY GETPROBE INSERTHASHKEY MAKEHASHKEY REPLACEHASHKEY) (BLOCK%: OPENHASHFILEBLOCK (ENTRIES CREATEHASHFILE OPENHASHFILE) CREATEHASHFILE OPENHASHFILE FIND1STPRIME SETHASHSTATUS) (BLOCK%: MAPHASHFILEBLOCK (ENTRIES COLLECTKEYS COPYHASHFILE COPYHASHITEM HASHFILESPLST MAPHASHFILE REHASHFILE) (SPECVARS REHASHGAG) COLLECTKEYS COPYHASHFILE COPYHASHITEM HASHFILESPLST HASHFILESPLST1 MAPHASHFILE REHASHFILE SPLITKEY) ) ) (PUTPROPS HASH FILETYPE CL:COMPILE-FILE) (PUTPROPS HASH COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3822 20744 (CLEARHASHFILES 3832 . 4732) (CLOSEHASHFILE 4734 . 5293) (COLLECTKEYS 5295 . 6551) (COPYHASHFILE 6553 . 7773) (COPYHASHITEM 7775 . 8527) (CREATEHASHFILE 8529 . 11024) ( GETHASHFILE 11026 . 11210) (GETHASHTEXT 11212 . 11611) (HASHBEFORECLOSE 11613 . 12567) (HASHFILEDATA 12569 . 12776) (HASHFILENAME 12778 . 12921) (HASHFILEP 12923 . 13415) (HASHFILEPROP 13417 . 13992) ( HASHFILESPLST 13994 . 14339) (LOOKUPHASHFILE 14341 . 15638) (MAPHASHFILE 15640 . 16963) (OPENHASHFILE 16965 . 18999) (PUTHASHFILE 19001 . 19309) (PUTHASHTEXT 19311 . 19886) (REHASHFILE 19888 . 20742)) ( 20780 26810 (DELETEHASHKEY 20790 . 21129) (FIND1STPRIME 21131 . 21568) (GETHASHKEY 21570 . 22936) ( GETPROBE 22938 . 23288) (GTHASHFILE 23290 . 24183) (HASHFILESPLST1 24185 . 24583) (INSERTHASHKEY 24585 . 25026) (MAKEHASHKEY 25028 . 25532) (REPLACEHASHKEY 25534 . 25977) (SETHASHSTATUS 25979 . 26414) ( SPLITKEY 26416 . 26808))))) STOP \ No newline at end of file diff --git a/library/HASH-FILE b/library/HASH-FILE new file mode 100644 index 00000000..fd209506 --- /dev/null +++ b/library/HASH-FILE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "HASH-FILE" (USE "LISP" "XCL") (IMPORT WITH-READER-ENVIRONMENT MAKE-READER-ENVIRONMENT FIND-READTABLE UNINTERRUPTABLY WITH.MONITOR CREATE.MONITORLOCK MONITORLOCK))) (IL:FILECREATED "11-Jun-90 16:24:56" IL:|{DSK}local>lde>lispcore>library>HASH-FILE.;2| 31647 IL:|changes| IL:|to:| (IL:VARS IL:HASH-FILECOMS) IL:|previous| IL:|date:| " 1-Mar-88 14:55:31" IL:|{DSK}local>lde>lispcore>library>HASH-FILE.;1|) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:HASH-FILECOMS) (IL:RPAQQ IL:HASH-FILECOMS ((IL:P (PROVIDE "HASH-FILE") (EXPORT '(MAKE-HASH-FILE OPEN-HASH-FILE CLOSE-HASH-FILE COPY-HASH-FILE MAP-HASH-FILE GET-HASH-FILE REM-HASH-FILE HASH-FILE-P HASH-FILE-COUNT HASH-FILE) "HASH-FILE")) (IL:STRUCTURES HASH-FILE) (IL:FUNCTIONS %PRINT-HASH-FILE) (IL:VARIABLES BITS-PER-BYTE BYTES-PER-POINTER SIZE-POSITION COUNT-POSITION TABLE-POSITION THE-NULL-POINTER) (IL:COMS (IL:* IL:|;;;| "public code") (IL:FUNCTIONS MAKE-HASH-FILE OPEN-HASH-FILE CLOSE-HASH-FILE COPY-HASH-FILE MAP-HASH-FILE GET-HASH-FILE PUT-HASH-FILE REM-HASH-FILE) (IL:SETFS GET-HASH-FILE) (IL:VARIABLES *DELETE-OLD-VERSION-ON-REHASH* *REHASH-SIZE* *REHASH-THRESHOLD*) (IL:* IL:|;;;| "internal code") (IL:FUNCTIONS REHASH? REHASH KEY->TABLE-POINTER ADD-ENTRY ENSURE-STREAM-IS-OPEN NEXT-PRIME WRITE-SIZE READ-SIZE WRITE-COUNT READ-COUNT WRITE-POINTER READ-POINTER NULL-POINTER?) (IL:* IL:|;;| "conveniences") (IL:FUNCTIONS HISTOGRAM CONVERT)) (IL:COMS (IL:* IL:|;;;| "default user code") (IL:FUNCTIONS HASH-OBJECT HASH-OBJECT-INTERNAL COMBINE) (IL:VARIABLES *HASH-DEPTH*) (IL:FUNCTIONS DEFAULT-READ-FN DEFAULT-PRINT-FN) (IL:VARIABLES *READER-ENVIRONMENT*)) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:HASH-FILE))) (PROVIDE "HASH-FILE") (EXPORT '(MAKE-HASH-FILE OPEN-HASH-FILE CLOSE-HASH-FILE COPY-HASH-FILE MAP-HASH-FILE GET-HASH-FILE REM-HASH-FILE HASH-FILE-P HASH-FILE-COUNT HASH-FILE) "HASH-FILE") (DEFSTRUCT (HASH-FILE (:COPIER COPY-HASH-FILE-INTERNAL) (:CONSTRUCTOR MAKE-HASH-FILE-INTERNAL) (:PRINT-FUNCTION %PRINT-HASH-FILE)) "Like a hash-table but on a file instead of in memory" (STREAM NIL :TYPE STREAM) (IL:* IL:|;;| "open stream on the backing file") (DIRECTION :INPUT :TYPE (MEMBER :INPUT :IO)) (IL:* IL:|;;| "the direction that stream is open in") (MONITOR (CREATE.MONITORLOCK "HASH-FILE") :TYPE MONITORLOCK) (IL:* IL:|;;| "should always be obtained before changing STREAM's position") (SIZE NIL :TYPE INTEGER) (IL:* IL:|;;| "size of the table -- determines the range for key hashing") (COUNT 0 :TYPE :INTEGER) (IL:* IL:|;;| "number of entries currently in the hash file") (REHASH-SIZE *REHASH-SIZE* :TYPE FLOAT) (IL:* IL:|;;| "factor to increase size by when re-hashing") (REHASH-THRESHOLD *REHASH-THRESHOLD* :TYPE FLOAT) (IL:* IL:|;;| "rehash when (= ENTRIES (* SIZE REHASH-THRESHOLD)") (KEY-PRINT-FN 'DEFAULT-PRINT-FN :TYPE FUNCTION) (IL:* IL:|;;| "called with KEY and STREAM to write keys on the file") (KEY-READ-FN 'DEFAULT-READ-FN :TYPE FUNCTION) (IL:* IL:|;;| "called with STREAM to read a key from the file") (KEY-HASH-FN 'HASH-OBJECT :TYPE FUNCTION) (IL:* IL:|;;| "called with KEY and SIZE to obtain an integer in {0 .. SIZE-1}") (KEY-COMPARE-FN 'EQUAL :TYPE FUNCTION) (IL:* IL:|;;| "called with two keys with same hash value to resolve collisions") (VALUE-PRINT-FN 'DEFAULT-PRINT-FN :TYPE FUNCTION) (IL:* IL:|;;| "called with VALUE and STREAM to print values on file") (VALUE-READ-FN 'DEFAULT-READ-FN :TYPE FUNCTION) (IL:* IL:|;;| "called with STREAM to read a value from the file") ) (DEFUN %PRINT-HASH-FILE (HASH-FILE STREAM DEPTH) (FORMAT STREAM "#" (LET* ((STREAM (HASH-FILE-STREAM HASH-FILE)) (NAMESTRING (NAMESTRING (PATHNAME STREAM)))) (IF NAMESTRING NAMESTRING STREAM)))) (DEFCONSTANT BITS-PER-BYTE 8) (DEFCONSTANT BYTES-PER-POINTER 4) (DEFCONSTANT SIZE-POSITION (* BYTES-PER-POINTER 0)) (DEFCONSTANT COUNT-POSITION (* BYTES-PER-POINTER 1)) (DEFCONSTANT TABLE-POSITION (* BYTES-PER-POINTER 2)) (DEFCONSTANT THE-NULL-POINTER 0) (IL:* IL:|;;;| "public code") (DEFUN MAKE-HASH-FILE (IL:* IL:|;;| "MAKE-HASH-TABLE equivalent for hash files") (IL:* IL:|;;| "creates and returns a new hash file.") (FILE-NAME SIZE &KEY (REHASH-SIZE *REHASH-SIZE*) (REHASH-THRESHOLD *REHASH-THRESHOLD*) (KEY-PRINT-FN 'DEFAULT-PRINT-FN) (KEY-READ-FN 'DEFAULT-READ-FN) (KEY-COMPARE-FN 'EQUAL) (KEY-HASH-FN 'HASH-OBJECT) (VALUE-PRINT-FN 'DEFAULT-PRINT-FN) (VALUE-READ-FN 'DEFAULT-READ-FN)) (LET ((STREAM (OPEN FILE-NAME :DIRECTION :IO :IF-EXISTS :NEW-VERSION :ELEMENT-TYPE `(UNSIGNED-BYTE ,BITS-PER-BYTE))) (REAL-SIZE (NEXT-PRIME SIZE))) (IL:* IL:|;;| "write the size & entries") (WRITE-SIZE REAL-SIZE STREAM) (WRITE-COUNT 0 STREAM) (IL:* IL:|;;| "initialize table -- fill it with null pointers") (DOTIMES (N REAL-SIZE) (WRITE-POINTER THE-NULL-POINTER STREAM)) (IL:* IL:|;;| "make & return a HASH-FILE structure") (MAKE-HASH-FILE-INTERNAL :STREAM STREAM :DIRECTION :IO :SIZE REAL-SIZE :COUNT 0 :REHASH-SIZE REHASH-SIZE :REHASH-THRESHOLD REHASH-THRESHOLD :KEY-PRINT-FN KEY-PRINT-FN :KEY-READ-FN KEY-READ-FN :KEY-COMPARE-FN KEY-COMPARE-FN :KEY-HASH-FN KEY-HASH-FN :VALUE-PRINT-FN VALUE-PRINT-FN :VALUE-READ-FN VALUE-READ-FN))) (DEFUN OPEN-HASH-FILE (IL:* IL:|;;| "open an existing hash file") (FILE-NAME &KEY (DIRECTION :INPUT) (REHASH-SIZE *REHASH-SIZE*) (REHASH-THRESHOLD *REHASH-THRESHOLD*) (KEY-PRINT-FN 'DEFAULT-PRINT-FN) (KEY-READ-FN 'DEFAULT-READ-FN) (KEY-COMPARE-FN 'EQUAL) (KEY-HASH-FN 'HASH-OBJECT) (VALUE-PRINT-FN 'DEFAULT-PRINT-FN) (VALUE-READ-FN 'DEFAULT-READ-FN)) (CASE DIRECTION ((:INPUT :IO) ) (OTHERWISE (ERROR "~S illegal arg. Must be :INPUT or :IO" DIRECTION))) (LET ((STREAM (OPEN FILE-NAME :DIRECTION DIRECTION :IF-EXISTS :OVERWRITE :ELEMENT-TYPE `(UNSIGNED-BYTE ,BITS-PER-BYTE)))) (IL:* IL:|;;| "make & return a HASH-FILE structure") (MAKE-HASH-FILE-INTERNAL :STREAM STREAM :DIRECTION DIRECTION :SIZE (READ-SIZE STREAM) :COUNT (READ-COUNT STREAM) :REHASH-SIZE REHASH-SIZE :REHASH-THRESHOLD REHASH-THRESHOLD :KEY-PRINT-FN KEY-PRINT-FN :KEY-READ-FN KEY-READ-FN :KEY-COMPARE-FN KEY-COMPARE-FN :KEY-HASH-FN KEY-HASH-FN :VALUE-PRINT-FN VALUE-PRINT-FN :VALUE-READ-FN VALUE-READ-FN))) (DEFUN CLOSE-HASH-FILE (HASH-FILE &KEY ABORT) (IL:* IL:|;;| "close the stream") (WITH.MONITOR (HASH-FILE-MONITOR HASH-FILE) (LET ((STREAM (HASH-FILE-STREAM HASH-FILE))) (CLOSE STREAM :ABORT ABORT) (PATHNAME STREAM)))) (DEFUN COPY-HASH-FILE (OLD-HASH-FILE NEW-FILE-NAME &OPTIONAL (NEW-SIZE NIL NEW-SIZE-SPECIFIED?)) (IL:* IL:|;;| "make a new hashfile in NEW-FILE-NAME with the same contents as OLD-HASH-FILE. this will reclaim space lost in OLD-HASH-FILE. also used by REHASH. ") (LET ((NEW-HASH-FILE (MAKE-HASH-FILE NEW-FILE-NAME (IF NEW-SIZE-SPECIFIED? NEW-SIZE (IL:* IL:|;;|  "default NEW-SIZE to the size of OLD-HASH-FILE") (HASH-FILE-SIZE OLD-HASH-FILE)) (IL:* IL:|;;| "sure wish common lisp had a \"using\" construct...") :REHASH-SIZE (HASH-FILE-REHASH-SIZE OLD-HASH-FILE) :REHASH-THRESHOLD (HASH-FILE-REHASH-THRESHOLD OLD-HASH-FILE) :KEY-PRINT-FN (HASH-FILE-KEY-PRINT-FN OLD-HASH-FILE) :KEY-READ-FN (HASH-FILE-KEY-READ-FN OLD-HASH-FILE) :KEY-COMPARE-FN (HASH-FILE-KEY-COMPARE-FN OLD-HASH-FILE) :KEY-HASH-FN (HASH-FILE-KEY-HASH-FN OLD-HASH-FILE) :VALUE-PRINT-FN (HASH-FILE-VALUE-PRINT-FN OLD-HASH-FILE) :VALUE-READ-FN (HASH-FILE-VALUE-READ-FN OLD-HASH-FILE)))) (MAP-HASH-FILE #'(LAMBDA (KEY VALUE) (SETF (GET-HASH-FILE KEY NEW-HASH-FILE) VALUE)) OLD-HASH-FILE) (IL:* IL:|;;| "write it out for safety") (CLOSE-HASH-FILE NEW-HASH-FILE) (IL:* IL:|;;| "return the new hash file") NEW-HASH-FILE)) (DEFUN MAP-HASH-FILE (FN HASH-FILE) (IL:* IL:|;;| "calls FN on every KEY & VALUE pair in HASH-FILE") (WITH.MONITOR (HASH-FILE-MONITOR HASH-FILE) (LET* ((STREAM (ENSURE-STREAM-IS-OPEN HASH-FILE)) (SIZE (HASH-FILE-SIZE HASH-FILE)) (LAST-POINTER (+ TABLE-POSITION (* BYTES-PER-POINTER (1- SIZE)))) NEXT-POINTER) (IL:* IL:|;;| "loop over table") (DO ((TABLE-POINTER TABLE-POSITION (+ TABLE-POINTER BYTES-PER-POINTER))) ((> TABLE-POINTER LAST-POINTER)) (IL:* IL:|;;| "loop down bucket") (DO ((POINTER (READ-POINTER STREAM TABLE-POINTER) NEXT-POINTER)) ((NULL-POINTER? POINTER) (IL:* IL:\;  "end of bucket or empty bucket") ) (IL:* IL:|;;| "read & save next pointer") (SETQ NEXT-POINTER (READ-POINTER STREAM POINTER)) (IL:* IL:|;;| "call FN on KEY and VALUE read from file") (FUNCALL FN (FUNCALL (HASH-FILE-KEY-READ-FN HASH-FILE) STREAM) (FUNCALL (HASH-FILE-VALUE-READ-FN HASH-FILE) STREAM))))))) (DEFUN GET-HASH-FILE (KEY HASH-FILE &OPTIONAL (DEFAULT NIL)) (IL:* IL:|;;| "GETHASH for hash files") (IL:* IL:|;;| "returns the value stored under KEY in HASH-FILE, or DEFAULT if there is no value stored. second value is T iff a value was found") (WITH.MONITOR (HASH-FILE-MONITOR HASH-FILE) (LET ((STREAM (ENSURE-STREAM-IS-OPEN HASH-FILE)) NEXT-POINTER) (IL:* IL:|;;| "loop down linked list in bucket") (DO ((POINTER (READ-POINTER STREAM (KEY->TABLE-POINTER KEY HASH-FILE)) NEXT-POINTER)) ((NULL-POINTER? POINTER) (IL:* IL:|;;| "end of bucket (or empty bucket) - we lost") (VALUES DEFAULT NIL)) (IL:* IL:|;;| "read & save next pointer") (SETQ NEXT-POINTER (READ-POINTER STREAM POINTER)) (WHEN (IL:* IL:|;;| "read key from file and compare with KEY ") (FUNCALL (HASH-FILE-KEY-COMPARE-FN HASH-FILE) KEY (FUNCALL (HASH-FILE-KEY-READ-FN HASH-FILE) STREAM)) (IL:* IL:|;;| "they match -- we won!") (RETURN (IL:* IL:|;;| "read & return value") (VALUES (FUNCALL (HASH-FILE-VALUE-READ-FN HASH-FILE) STREAM) T))))))) (DEFUN PUT-HASH-FILE (KEY HASH-FILE VALUE) (IL:* IL:|;;| "SETF method for GET-HASH-FILE") (IL:* IL:|;;| "stores a VALUE under KEY in HASH-FILE") (WITH.MONITOR (HASH-FILE-MONITOR HASH-FILE) (LET ((TABLE-POINTER (KEY->TABLE-POINTER KEY HASH-FILE)) (STREAM (ENSURE-STREAM-IS-OPEN HASH-FILE)) NEXT-POINTER) (IL:* IL:|;;| "loop down bucket") (DO* ((LAST-POINTER TABLE-POINTER POINTER) (IL:* IL:|;;| "LAST-POINTER is location of POINTER") (POINTER (READ-POINTER STREAM TABLE-POINTER) NEXT-POINTER)) ((NULL-POINTER? POINTER) (IL:* IL:|;;| "end of bucket (or empty bucket) - nothing hashed under this key") (IL:* IL:|;;| "time to add a new entry to the hash file ") (COND ((REHASH? HASH-FILE) (IL:* IL:|;;| "pointers are off if we rehashed -- have to start over") (PUT-HASH-FILE KEY HASH-FILE VALUE)) (T (IL:* IL:|;;| "just nconc a new entry onto the end of the bucket") (ADD-ENTRY HASH-FILE KEY VALUE LAST-POINTER THE-NULL-POINTER) (IL:* IL:|;;| "increment and write out the count of objects") (WRITE-COUNT (INCF (HASH-FILE-COUNT HASH-FILE)) STREAM)))) (IL:* IL:|;;| "read & save the pointer to next in bucket") (SETQ NEXT-POINTER (READ-POINTER STREAM POINTER)) (WHEN (IL:* IL:|;;| "read key from file & compare with KEY") (FUNCALL (HASH-FILE-KEY-COMPARE-FN HASH-FILE) KEY (FUNCALL (HASH-FILE-KEY-READ-FN HASH-FILE) STREAM)) (IL:* IL:|;;| "they match - already something hashed under this key") (IL:* IL:|;;| "splice new entry into bucket, old entry out") (ADD-ENTRY HASH-FILE KEY VALUE LAST-POINTER NEXT-POINTER) (RETURN))) (IL:* IL:|;;| "return VALUE") VALUE))) (DEFUN REM-HASH-FILE (KEY HASH-FILE) (IL:* IL:|;;| "REMHASH for hash files") (IL:* IL:|;;|  "removes the entry (if any) for KEY from HASH-FILE. returns T if there was one to remove. ") (WITH.MONITOR (HASH-FILE-MONITOR HASH-FILE) (LET ((TABLE-POINTER (KEY->TABLE-POINTER KEY HASH-FILE)) (STREAM (ENSURE-STREAM-IS-OPEN HASH-FILE)) NEXT-POINTER) (IL:* IL:|;;| "loop down bucket") (DO* ((LAST-POINTER TABLE-POINTER POINTER) (IL:* IL:|;;| "LAST-POINTER is location of POINTER") (POINTER (READ-POINTER STREAM TABLE-POINTER) NEXT-POINTER)) ((NULL-POINTER? POINTER) (IL:* IL:|;;| "end of bucket (or empty bucket) - nothing hashed under this key") 'NIL) (IL:* IL:|;;| "read & save the pointer to next in bucket") (SETQ NEXT-POINTER (READ-POINTER STREAM POINTER)) (WHEN (IL:* IL:|;;| "read key from file & compare with KEY") (FUNCALL (HASH-FILE-KEY-COMPARE-FN HASH-FILE) KEY (FUNCALL (HASH-FILE-KEY-READ-FN HASH-FILE) STREAM)) (IL:* IL:|;;| "they match") (IL:* IL:|;;| "smash NEXT-POINTER into LAST-POINTER") (WRITE-POINTER NEXT-POINTER STREAM LAST-POINTER) (IL:* IL:|;;| "decrement the count of entries in HASH-FILE") (WRITE-COUNT (DECF (HASH-FILE-COUNT HASH-FILE)) STREAM) (RETURN 'T)))))) (DEFSETF GET-HASH-FILE PUT-HASH-FILE) (DEFVAR *DELETE-OLD-VERSION-ON-REHASH* NIL "if non-NIL then delete the old version of a hash file when rehashing") (DEFVAR *REHASH-SIZE* 2.0 "default REHASH-SIZE for hash files") (DEFVAR *REHASH-THRESHOLD* 0.875 "default REHASH-THRESHOLD for hash files") (IL:* IL:|;;;| "internal code") (DEFUN REHASH? (HASH-FILE) (IL:* IL:|;;| "check if it's time to rehash HASH-FILE. if it is, then do so and return non-NIL") (WHEN (>= (1+ (HASH-FILE-COUNT HASH-FILE)) (* (HASH-FILE-SIZE HASH-FILE) (HASH-FILE-REHASH-THRESHOLD HASH-FILE))) (REHASH HASH-FILE (ROUND (* (HASH-FILE-SIZE HASH-FILE) (HASH-FILE-REHASH-SIZE HASH-FILE)))) T)) (DEFUN REHASH (HASH-FILE NEW-SIZE) (IL:* IL:|;;| "caution: assumes we're under hash file monitor") (LET* ((OLD-PATHNAME (PATHNAME (HASH-FILE-STREAM HASH-FILE))) (TEMP-HASH-FILE (COPY-HASH-FILE HASH-FILE (MAKE-PATHNAME :VERSION :NEWEST :DEFAULTS (PATHNAME OLD-PATHNAME)) NEW-SIZE))) (IL:* IL:|;;| "close the old stream (before we lose pointer to it)") (CLOSE-HASH-FILE HASH-FILE) (IL:* IL:|;;| "smash TEMP-HASH-FILE into HASH-FILE") (UNINTERRUPTABLY (SETF (HASH-FILE-SIZE HASH-FILE) (IL:* IL:\;  "note: probably not the same as NEW-SIZE") (HASH-FILE-SIZE TEMP-HASH-FILE)) (SETF (HASH-FILE-COUNT HASH-FILE) (HASH-FILE-COUNT TEMP-HASH-FILE)) (SETF (HASH-FILE-STREAM HASH-FILE) (HASH-FILE-STREAM TEMP-HASH-FILE))) (IL:* IL:|;;| "our caller [PUT-HASH-FILE] expects the stream to be open") (ENSURE-STREAM-IS-OPEN HASH-FILE) (IF *DELETE-OLD-VERSION-ON-REHASH* (DELETE-FILE OLD-PATHNAME)) (IL:* IL:|;;| "return the hash file") HASH-FILE)) (DEFMACRO KEY->TABLE-POINTER (KEY HASH-FILE) (IL:* IL:|;;| "return the file position for the head of the bucket which key hashes into. this is the guy who does the hashing. ") (IL:* IL:|;;| "caution: HASH-FILE is evaluated twice") `(+ TABLE-POSITION (* BYTES-PER-POINTER (FUNCALL (HASH-FILE-KEY-HASH-FN ,HASH-FILE) ,KEY (HASH-FILE-SIZE ,HASH-FILE))))) (DEFUN ADD-ENTRY (HASH-FILE KEY VALUE LAST-POINTER LINK-POINTER) (IL:* IL:|;;| "write an entry at end of file, putting a pointer to it in LAST-POINTER and make it point to LINK-POINTER as next in bucket.") (IL:* IL:|;;| "caution: we presume we've got the hash-file-monitor.") (LET* ((STREAM (HASH-FILE-STREAM HASH-FILE)) (EOF-POINTER (FILE-LENGTH STREAM))) (IL:* IL:|;;| "first overwrite LAST-POINTER with a pointer to EOF ") (WRITE-POINTER EOF-POINTER STREAM LAST-POINTER) (IL:* IL:|;;| "write link to next bucket ") (WRITE-POINTER LINK-POINTER STREAM EOF-POINTER) (IL:* IL:|;;| "write the key") (FUNCALL (HASH-FILE-KEY-PRINT-FN HASH-FILE) KEY STREAM) (IL:* IL:|;;| "write the value") (FUNCALL (HASH-FILE-VALUE-PRINT-FN HASH-FILE) VALUE STREAM) (IL:* IL:|;;| "return value") VALUE)) (DEFUN ENSURE-STREAM-IS-OPEN (HASH-FILE) (IL:* IL:|;;| "makes sure HASH-FILE's stream is open") (IL:* IL:|;;| "caution: assumes we're under hash file monitor") (LET ((STREAM (HASH-FILE-STREAM HASH-FILE))) (IF (OPEN-STREAM-P STREAM) STREAM (SETF (HASH-FILE-STREAM HASH-FILE) (OPEN STREAM :DIRECTION (HASH-FILE-DIRECTION HASH-FILE) :IF-EXISTS :OVERWRITE))))) (DEFUN NEXT-PRIME (N) (IL:* IL:|;;| "return the next prime number greater than N") (IL:* IL:|;;| "algorithm stolen from CDL's FIND1STPRIME in old HASH library") (LET (FOUND?) (DO ((P (LOGIOR N 1) (+ P 2))) ((DO* ((I 3 (+ I 2))) ((OR (AND (< I P) (ZEROP (REM P I))) (SETQ FOUND? (< P (* I I)))) FOUND?)) P)))) (DEFUN WRITE-SIZE (SIZE STREAM) (IL:* IL:|;;| "write SIZE to file as a pointer sized number") (WRITE-POINTER SIZE STREAM SIZE-POSITION)) (DEFUN READ-SIZE (STREAM) (IL:* IL:|;;| "read size from file as written by WRITE-SIZE") (READ-POINTER STREAM SIZE-POSITION)) (DEFUN WRITE-COUNT (COUNT STREAM) (IL:* IL:|;;| "write COUNT to file as a pointer sized number") (WRITE-POINTER COUNT STREAM COUNT-POSITION)) (DEFUN READ-COUNT (STREAM) (IL:* IL:|;;| "read count as written by WRITE-COUNT") (READ-POINTER STREAM COUNT-POSITION)) (DEFUN WRITE-POINTER (POINTER STREAM &OPTIONAL POSITION) (IL:* IL:|;;| "write POINTER (a non-negative integer) as BYTES-PER-POINTER bytes on STREAM s.t. READ-POINTER can reconstruct it. if POSITION is specified then set STREAM's file position to it first.") (WHEN (> (INTEGER-LENGTH POINTER) (* BYTES-PER-POINTER BITS-PER-BYTE)) (ERROR "~S : pointer too large" POINTER)) (WHEN POSITION (FILE-POSITION STREAM POSITION)) (DOTIMES (N BYTES-PER-POINTER) (WRITE-BYTE (LDB (BYTE BITS-PER-BYTE (* N BITS-PER-BYTE)) POINTER) STREAM)) (IL:* IL:|;;| "return POINTER") POINTER) (DEFUN READ-POINTER (STREAM &OPTIONAL POSITION) (IL:* IL:|;;| "read from STREAM a positive integer written by WRITE-POINTER. if POSITION is specified the file position will be set to it first.") (IL:* IL:|;;| "read BYTES-PER-POINTER bytes from stream and return them as an integer. this is the inverse of WRITE-P ") (WHEN POSITION (FILE-POSITION STREAM POSITION)) (LET ((VALUE 0) BYTE) (DOTIMES (N BYTES-PER-POINTER) (SETQ BYTE (READ-BYTE STREAM)) (WHEN (NOT (ZEROP BYTE)) (IL:* IL:|;;| "optimization: DPB is really slow w/ high bytes") (SETQ VALUE (DPB BYTE (BYTE BITS-PER-BYTE (* N BITS-PER-BYTE)) VALUE)))) VALUE)) (DEFMACRO NULL-POINTER? (POINTER) `(EQL ,POINTER THE-NULL-POINTER)) (IL:* IL:|;;| "conveniences") (DEFUN HISTOGRAM (HASH-FILE) (IL:* IL:|;;| "return an ALIST of bucket depths dotted with number of occurences") (WITH.MONITOR (HASH-FILE-MONITOR HASH-FILE) (LET* ((STREAM (ENSURE-STREAM-IS-OPEN HASH-FILE)) (SIZE (HASH-FILE-SIZE HASH-FILE)) (LAST-POINTER (+ TABLE-POSITION (* BYTES-PER-POINTER (1- SIZE)))) NEXT-POINTER RESULT) (IL:* IL:|;;| "loop over table") (DO ((TABLE-POINTER TABLE-POSITION (+ TABLE-POINTER BYTES-PER-POINTER))) ((> TABLE-POINTER LAST-POINTER)) (IL:* IL:|;;| "loop down bucket") (DO ((POINTER (READ-POINTER STREAM TABLE-POINTER) NEXT-POINTER) (BUCKET-LENGTH 0 (1+ BUCKET-LENGTH))) ((NULL-POINTER? POINTER) (IL:* IL:|;;| "end of bucket or empty bucket") (IL:* IL:|;;| "increment count for buckets of this length") (INCF (CDR (OR (ASSOC BUCKET-LENGTH RESULT) (CAR (PUSH (CONS BUCKET-LENGTH 0) RESULT)))))) (SETQ NEXT-POINTER (READ-POINTER STREAM POINTER)))) (SORT RESULT #'(LAMBDA (PAIR-1 PAIR-2) (< (CAR PAIR-1) (CAR PAIR-2))))))) (DEFUN CONVERT (IL-HASH-FILE CL-HASH-FILE) "convert a HASH hash file into a HASH-FILE hash file" (IL:* IL:|;;| "first make sure HASH is loaded") (IL:FILESLOAD (IL:SYSLOAD IL:FROM IL:LISPUSERS) HASH) (LET* ((OLD-HASH-FILE (IL:OPENHASHFILE IL-HASH-FILE)) (NEW-HASH-FILE (MAKE-HASH-FILE CL-HASH-FILE (IL:HASHFILEPROP OLD-HASH-FILE 'IL:SIZE))) (ABORT 'T)) (UNWIND-PROTECT (PROGN (IL:MAPHASHFILE OLD-HASH-FILE #'(LAMBDA (KEY VALUE) (PUT-HASH-FILE KEY NEW-HASH-FILE VALUE))) (SETQ ABORT 'NIL)) (IL:CLOSEHASHFILE OLD-HASH-FILE) (CLOSE-HASH-FILE NEW-HASH-FILE :ABORT ABORT)))) (IL:* IL:|;;;| "default user code") (DEFUN HASH-OBJECT (OBJECT RANGE) (IL:* IL:|;;;| "return an integer between 0 and (1- RANGE), inclusive") (IL:* IL:|;;;| "objects which are EQUAL will return the same integer") (1- (HASH-OBJECT-INTERNAL OBJECT RANGE 0))) (DEFUN HASH-OBJECT-INTERNAL (OBJECT RANGE DEPTH) (IL:* IL:|;;| "recursively descend OBJECT, combining characters & integers at leaves with multiplication modulo RANGE. never descend more than *HASH-DEPTH* into a structure.") (IL:* IL:|;;| "return an integer between 1 and RANGE, inclusive") (IF (EQL DEPTH *HASH-DEPTH*) 1 (TYPECASE OBJECT (STRING (LET ((VALUE 1) (LENGTH (LENGTH OBJECT))) (DOTIMES (N (MIN LENGTH (- *HASH-DEPTH* DEPTH)) (COMBINE RANGE VALUE LENGTH)) (SETF VALUE (COMBINE RANGE VALUE (CHAR-CODE (CHAR OBJECT N))))))) (SYMBOL (IL:* IL:|;;| "combine hash values of name and package name") (COMBINE RANGE (HASH-OBJECT-INTERNAL (LET ((PKG (SYMBOL-PACKAGE OBJECT))) (AND PKG (PACKAGE-NAME PKG))) RANGE (1+ DEPTH)) (HASH-OBJECT-INTERNAL (SYMBOL-NAME OBJECT) RANGE (1+ DEPTH)))) (CONS (IL:* IL:|;;| "combine hash values of CAR and CDR") (COMBINE RANGE (HASH-OBJECT-INTERNAL (CAR OBJECT) RANGE (1+ DEPTH)) (HASH-OBJECT-INTERNAL (CDR OBJECT) RANGE (1+ DEPTH)))) (NUMBER (TYPECASE OBJECT (INTEGER (COMBINE RANGE (ABS OBJECT))) (FLOAT (MULTIPLE-VALUE-BIND (SIG EXPON) (INTEGER-DECODE-FLOAT OBJECT) (COMBINE RANGE SIG (ABS EXPON)))) (RATIO (COMBINE RANGE (ABS (NUMERATOR OBJECT)) (DENOMINATOR OBJECT))) (COMPLEX (COMBINE RANGE (HASH-OBJECT-INTERNAL (REALPART OBJECT) RANGE (1+ DEPTH)) (HASH-OBJECT-INTERNAL (IMAGPART OBJECT) RANGE (1+ DEPTH)))))) (CHARACTER (COMBINE RANGE (CHAR-CODE OBJECT))) (PATHNAME (HASH-OBJECT-INTERNAL (NAMESTRING OBJECT) RANGE (1+ DEPTH))) (BIT-VECTOR (LET ((VALUE 1) (LENGTH (LENGTH OBJECT))) (DOTIMES (N (MIN LENGTH (- *HASH-DEPTH* DEPTH)) (COMBINE RANGE VALUE LENGTH)) (SETF VALUE (COMBINE RANGE VALUE (IF (ZEROP (BIT OBJECT N)) 0 (EXPT 2 N))))))) (T (IL:* IL:|;;| "can't dependably read/print other objects") (ERROR "Can't hash a(n) ~S" (TYPE-OF OBJECT)))))) (DEFMACRO COMBINE (RANGE &REST INTEGERS) (IL:* IL:|;;;| "combine non-negative integers returning an integer between 1 and RANGE inclusive (zeros are bad when combining with multiplication). we don't do the obvious (1+ (mod (* . integers) range)) to avoid making bignums. ") (IL:* IL:|;;;| " caution: RANGE may be evaluated many times.") `(1+ (MOD ,(IF (ENDP (REST INTEGERS)) (FIRST INTEGERS) `(* ,(FIRST INTEGERS) (COMBINE ,RANGE ,@(REST INTEGERS)))) ,RANGE))) (DEFVAR *HASH-DEPTH* 17) (DEFUN DEFAULT-READ-FN (STREAM) (IL:* IL:|;;| "default reader for hash files") (WITH-READER-ENVIRONMENT *READER-ENVIRONMENT* (READ STREAM))) (DEFUN DEFAULT-PRINT-FN (OBJECT STREAM) (IL:* IL:|;;| "default printer for hash files") (WITH-READER-ENVIRONMENT *READER-ENVIRONMENT* (LET ((*PRINT-PRETTY* 'NIL)) (PRINT OBJECT STREAM))) OBJECT) (DEFVAR *READER-ENVIRONMENT* (MAKE-READER-ENVIRONMENT (FIND-PACKAGE "XCL") (FIND-READTABLE "XCL") 10)) (IL:PUTPROPS IL:HASH-FILE IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:HASH-FILE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "HASH-FILE" (:USE "LISP" "XCL") (:IMPORT WITH-READER-ENVIRONMENT MAKE-READER-ENVIRONMENT FIND-READTABLE UNINTERRUPTABLY WITH.MONITOR CREATE.MONITORLOCK MONITORLOCK)))) (IL:PUTPROPS IL:HASH-FILE IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/library/HRULE b/library/HRULE new file mode 100644 index 00000000..8438643e --- /dev/null +++ b/library/HRULE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 8-Oct-92 16:50:21" "{Pele:mv:envos}library>HRULE.;11" 23325 changes to%: (FNS VRULE.CREATE VRULE.GETFN2) previous date%: "29-Sep-92 21:06:13" "{Pele:mv:envos}library>HRULE.;10") (* ; " Copyright (c) 1985, 1990, 1991, 1992 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT HRULECOMS) (RPAQQ HRULECOMS [[COMS (* ;; "Horizontal rules") (FNS HRULE.CREATE HRULE.DISPLAYFN HRULE.GETFN HRULE.IMAGEBOXFN HRULE.PUTFN HRULE.COPYFN HRULE.WHENOPERATEDONFN) (INITVARS (HRULE.DEFAULT.WIDTH 2)) (VARS (HRULEFNS '(HRULE.CREATE HRULE.DISPLAYFN HRULE.GETFN HRULE.IMAGEBOXFN HRULE.PUTFN HRULE.COPYFN HRULE.WHENOPERATEDONFN)) (HRULE.IMAGEFNS (IMAGEFNSCREATE (FUNCTION HRULE.DISPLAYFN) (FUNCTION HRULE.IMAGEBOXFN) (FUNCTION HRULE.PUTFN) (FUNCTION HRULE.GETFN) (FUNCTION HRULE.COPYFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION HRULE.WHENOPERATEDONFN) (FUNCTION NILL] [COMS (* ;; "Vertical rules") (FNS VRULE.CREATE VRULE.DISPLAYFN VRULE.GETFN VRULE.GETFN2 VRULE.IMAGEBOXFN VRULE.PUTFN VRULE.COPYFN VRULE.WHENOPERATEDONFN) (INITVARS (VRULE.DEFAULT.HEIGHT 12)) [VARS (VRULE.IMAGEFNS (IMAGEFNSCREATE (FUNCTION VRULE.DISPLAYFN) (FUNCTION VRULE.IMAGEBOXFN) (FUNCTION VRULE.PUTFN) (FUNCTION VRULE.GETFN2) (FUNCTION VRULE.COPYFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION VRULE.WHENOPERATEDONFN) (FUNCTION NILL] (* ;; "Old fixed-width-rule reader:") (ADDVARS (IMAGEOBJGETFNS (VRULE.GETFN] (COMS (* ;; "Cropping marks") (FNS CROPMARK.CREATE CROPMARK.DISPLAYFN CROPMARK.GETFN CROPMARK.IMAGEBOXFN CROPMARK.PUTFN CROPMARK.COPYFN CROPMARK.WHENOPERATEDONFN) (BITMAPS CROPMARK.IMAGE) (INITVARS (CROPMARK.DEFAULT.PAGESIZE (LIST 612 792))) (VARS (CROPMARK.IMAGEFNS (IMAGEFNSCREATE (FUNCTION CROPMARK.DISPLAYFN) (FUNCTION CROPMARK.IMAGEBOXFN) (FUNCTION CROPMARK.PUTFN) (FUNCTION CROPMARK.GETFN) (FUNCTION CROPMARK.COPYFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION CROPMARK.WHENOPERATEDONFN) (FUNCTION NILL]) (* ;; "Horizontal rules") (DEFINEQ (HRULE.CREATE [LAMBDA (WIDTH) (* jds "11-Sep-85 16:36") (* * Create a Horizontal-Rule image object.  WIDTH may be NIL to default, a number, for a single rule with its width in  points (and fractions thereof)%, or a list of alternating black and white  widths. E.g., to get a hairline over 1pt white over 3pt rule, specify  (0.5 1 3)) (PROG ((HRULE (IMAGEOBJCREATE NIL HRULE.IMAGEFNS))) (COND ((NOT WIDTH) (* USe the default width) (IMAGEOBJPROP HRULE 'RULE.WIDTH HRULE.DEFAULT.WIDTH) (RETURN HRULE)) ((NUMBERP WIDTH) (IMAGEOBJPROP HRULE 'RULE.WIDTH WIDTH) (RETURN HRULE)) ((AND (LISTP WIDTH) (EVERY WIDTH (FUNCTION NUMBERP))) (* It's a list of numbers.  Add (QUOTE em) up) (IMAGEOBJPROP HRULE 'RULE.WIDTH WIDTH) (RETURN HRULE)) (T (* Something was specified, and  there was a non-number in it...) (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "Non-numeric widths not desirable: " WIDTH) T]) (HRULE.DISPLAYFN [LAMBDA (HRULE IMAGE.STREAM) (* jds "17-Oct-85 11:35") (* function which displays the bitmap of the hrule on the display or calls an  {inter}press function to draw the rule on a file) (LET* ((RULEWIDTH (IMAGEOBJPROP HRULE 'RULE.WIDTH)) (WIDTHS (COND ((LISTP RULEWIDTH) (REVERSE RULEWIDTH)) (T RULEWIDTH))) (SCALE (DSPSCALE NIL IMAGE.STREAM)) (X (DSPXPOSITION NIL IMAGE.STREAM)) (Y (DSPYPOSITION NIL IMAGE.STREAM))) (bind [RULING _ (OR (NLISTP WIDTHS) (ODDP (FLENGTH WIDTHS] for THICKNESS inside WIDTHS do (* * Run thru the list of alternating rules and spaces %.  Display the rules, and skip over the spaces) [SETQ WIDTH (IMAX 1 (FIXR (FTIMES SCALE THICKNESS] (* Compute the width of this piece,  in stream units.) [COND (RULING (* If we're supposed to be drawing,  draw the line) (SELECTQ (IMAGESTREAMTYPE IMAGE.STREAM) (DISPLAY (BITBLT NIL 0 0 IMAGE.STREAM X Y (fetch XSIZE of (IMAGEOBJPROP HRULE 'BOUNDBOX)) WIDTH 'TEXTURE 'PAINT BLACKSHADE)) (DRAWLINE X (IPLUS Y (LRSH WIDTH 1)) [IPLUS X (fetch XSIZE of (IMAGEOBJPROP HRULE 'BOUNDBOX] (IPLUS Y (LRSH WIDTH 1)) WIDTH 'PAINT IMAGE.STREAM] (add Y WIDTH) (SETQ RULING (NOT RULING]) (HRULE.GETFN [LAMBDA (INPUT.STREAM TEXTSTREAM) (* gbn "10-Jan-85 02:56") (* reads the width and creates an  HRULE) (HRULE.CREATE (READ INPUT.STREAM]) (HRULE.IMAGEBOXFN [LAMBDA (HRULE IMAGE.STREAM CURRENT.X RIGHT.MARGIN) (* jds "11-Sep-85 17:12") (* returns an imagebox describing  the size of the scaled bitmap.  without caching) (LET [(SCALE (DSPSCALE NIL IMAGE.STREAM)) (WIDTHS (IMAGEOBJPROP HRULE 'RULE.WIDTH] (create IMAGEBOX XSIZE _ (IMAX (IDIFFERENCE RIGHT.MARGIN CURRENT.X) 0) YSIZE _ [for THICKNESS inside WIDTHS sum (IMAX 1 (FIXR (FTIMES SCALE THICKNESS] YDESC _ 0 XKERN _ 0]) (HRULE.PUTFN [LAMBDA (HRULE OUTPUT.STREAM) (* gbn "13-May-84 14:21") (* prints only the rule.width to the  file, the rest can be discovered) (PRINT (IMAGEOBJPROP HRULE 'RULE.WIDTH) OUTPUT.STREAM]) (HRULE.COPYFN [LAMBDA (IMAGEOBJ FROMSTREAM TOSTREAM) (* jds "22-Feb-85 13:56") (* This function does not build the  bitmap but lets the imageboxfn cache  a bitmap) (HRULE.CREATE (IMAGEOBJPROP IMAGEOBJ 'RULE.WIDTH) TOSTREAM]) (HRULE.WHENOPERATEDONFN [LAMBDA (A B C C) (* gbn " 6-Jan-85 13:23") (* DUMMY) ]) ) (RPAQ? HRULE.DEFAULT.WIDTH 2) (RPAQQ HRULEFNS (HRULE.CREATE HRULE.DISPLAYFN HRULE.GETFN HRULE.IMAGEBOXFN HRULE.PUTFN HRULE.COPYFN HRULE.WHENOPERATEDONFN)) (RPAQ HRULE.IMAGEFNS (IMAGEFNSCREATE (FUNCTION HRULE.DISPLAYFN) (FUNCTION HRULE.IMAGEBOXFN) (FUNCTION HRULE.PUTFN) (FUNCTION HRULE.GETFN) (FUNCTION HRULE.COPYFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION HRULE.WHENOPERATEDONFN) (FUNCTION NILL))) (* ;; "Vertical rules") (DEFINEQ (VRULE.CREATE [LAMBDA (WIDTH HEIGHT DASHING) (* ;  "Edited 8-Oct-92 16:46 by sybalsky:mv:envos") (* ;; "Create a Vertical-Rule image object. HEIGHT may be NIL to default, a number, for a single rule with its width in points (and fractions thereof), or a list of alternating black and white widths. E.g., to get a hairline over 1pt white over 3pt rule, specify (0.5 1 3)") (PROG ((VRULE (IMAGEOBJCREATE NIL VRULE.IMAGEFNS))) (COND ((NOT WIDTH) (* ; "Use the default width") (IMAGEOBJPROP VRULE 'RULE.WIDTH 0.5)) ((NUMBERP WIDTH) (IMAGEOBJPROP VRULE 'RULE.WIDTH WIDTH)) ((AND (LISTP WIDTH) (EVERY WIDTH (FUNCTION NUMBERP))) (* ;  "It's a list of numbers. Add 'em up") (IMAGEOBJPROP VRULE 'RULE.WIDTH WIDTH))) (COND ((NOT HEIGHT) (* ; "Use the default width") (IMAGEOBJPROP VRULE 'RULE.HEIGHT VRULE.DEFAULT.HEIGHT) (RETURN VRULE)) ((NUMBERP HEIGHT) (IMAGEOBJPROP VRULE 'RULE.HEIGHT HEIGHT) (RETURN VRULE)) ((AND (LISTP HEIGHT) (EVERY HEIGHT (FUNCTION NUMBERP))) (* ;  "It's a list of numbers. Add 'em up") (IMAGEOBJPROP VRULE 'RULE.HEIGHT HEIGHT) (RETURN VRULE)) (T (* ;  "Something was specified, and there was a non-number in it...") (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "Non-numeric widths not desirable: " HEIGHT) T))) (IMAGEOBJPROP VRULE 'RULE.DASHING DASHING]) (VRULE.DISPLAYFN [LAMBDA (HRULE IMAGE.STREAM) (* ; "Edited 29-Sep-92 21:01 by jds") (* ;; "function which displays the bitmap of the hrule on the display or calls an {inter}press function to draw the rule on a file") (LET* ((RULEHEIGHT (IMAGEOBJPROP HRULE 'RULE.HEIGHT)) (WIDTHS (OR (IMAGEOBJPROP HRULE 'RULE.WIDTH) 0.5)) (SCALE (DSPSCALE NIL IMAGE.STREAM)) (REALHEIGHT (FIXR (FTIMES SCALE RULEHEIGHT))) (X (DSPXPOSITION NIL IMAGE.STREAM)) (Y (DSPYPOSITION NIL IMAGE.STREAM))) (bind [RULING _ (OR (NLISTP WIDTHS) (ODDP (FLENGTH WIDTHS] WIDTH for THICKNESS inside WIDTHS do (* ;;; "Run thru the list of alternating rules and spaces . Display the rules, and skip over the spaces") [SETQ WIDTH (IMAX 1 (FIXR (FTIMES SCALE THICKNESS] (* ;  "Compute the width of this piece, in stream units.") [COND (RULING (* ;  "If we're supposed to be drawing, draw the line") (SELECTQ (IMAGESTREAMTYPE IMAGE.STREAM) (DISPLAY (BITBLT NIL 0 0 IMAGE.STREAM X Y 1 6 'TEXTURE 'PAINT BLACKSHADE)) (DRAWLINE (IPLUS X (LRSH WIDTH 1)) Y (IPLUS X (LRSH WIDTH 1)) (IDIFFERENCE Y (CL:IF (>= REALHEIGHT 0) (IMAX 1 REALHEIGHT) (IMIN -1 REALHEIGHT))) WIDTH 'PAINT IMAGE.STREAM] (add X WIDTH) (SETQ RULING (NOT RULING]) (VRULE.GETFN [LAMBDA (INPUT.STREAM TEXTSTREAM) (* ; "Edited 15-May-91 13:20 by jds") (* ;; "reads the width and creates a VRULE") (VRULE.CREATE 0.5 (READ INPUT.STREAM]) (VRULE.GETFN2 [LAMBDA (INPUT.STREAM TEXTSTREAM) (* ;  "Edited 8-Oct-92 16:46 by sybalsky:mv:envos") (* ;; "reads the width and creates a VRULE") (VRULE.CREATE (READ INPUT.STREAM) (READ INPUT.STREAM) (READ INPUT.STREAM]) (VRULE.IMAGEBOXFN [LAMBDA (HRULE IMAGE.STREAM CURRENT.X RIGHT.MARGIN) (* ; "Edited 30-Apr-91 00:06 by jds") (* ;; "returns an imagebox describing the size of the scaled bitmap. without caching") (LET ((SCALE (DSPSCALE NIL IMAGE.STREAM)) (WIDTHS 0.5)) (create IMAGEBOX XSIZE _ 0 YSIZE _ 1 YDESC _ 0 XKERN _ 0]) (VRULE.PUTFN [LAMBDA (HRULE OUTPUT.STREAM) (* ; "Edited 6-Jul-92 07:02 by jds") (* ;; "prints WIDTH, HEIGHT and DASHING to the file.") (PRINT (IMAGEOBJPROP HRULE 'RULE.WIDTH) OUTPUT.STREAM) (PRINT (IMAGEOBJPROP HRULE 'RULE.HEIGHT) OUTPUT.STREAM) (PRINT (IMAGEOBJPROP HRULE 'RULE.DASHING) OUTPUT.STREAM]) (VRULE.COPYFN [LAMBDA (IMAGEOBJ FROMSTREAM TOSTREAM) (* ; "Edited 5-Jul-92 17:03 by jds") (* ;  "This function does not build the bitmap but lets the imageboxfn cache a bitmap") (VRULE.CREATE (IMAGEOBJPROP IMAGEOBJ 'RULE.WIDTH) (IMAGEOBJPROP IMAGEOBJ 'RULE.HEIGHT]) (VRULE.WHENOPERATEDONFN [LAMBDA (A B C C) (* gbn " 6-Jan-85 13:23") (* DUMMY) ]) ) (RPAQ? VRULE.DEFAULT.HEIGHT 12) (RPAQ VRULE.IMAGEFNS (IMAGEFNSCREATE (FUNCTION VRULE.DISPLAYFN) (FUNCTION VRULE.IMAGEBOXFN) (FUNCTION VRULE.PUTFN) (FUNCTION VRULE.GETFN2) (FUNCTION VRULE.COPYFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION VRULE.WHENOPERATEDONFN) (FUNCTION NILL))) (* ;; "Old fixed-width-rule reader:") (ADDTOVAR IMAGEOBJGETFNS (VRULE.GETFN)) (* ;; "Cropping marks") (DEFINEQ (CROPMARK.CREATE [LAMBDA (WIDTH HEIGHT) (* ; "Edited 5-Jun-91 14:56 by jds") (* ;; "Create a CROPMARK, that prints crop-marks for a page that is WIDTH points wide and HEIGHT points high.") (PROG ((CROPMARK (IMAGEOBJCREATE NIL CROPMARK.IMAGEFNS))) (COND ((NOT HEIGHT) (* ; "Use the default width") (IMAGEOBJPROP CROPMARK 'PAGE.SIZE CROPMARK.DEFAULT.PAGESIZE) (RETURN CROPMARK)) ((NUMBERP HEIGHT) (IMAGEOBJPROP CROPMARK 'PAGE.SIZE (LIST WIDTH HEIGHT)) (RETURN CROPMARK)) ((AND (LISTP HEIGHT) (EVERY HEIGHT (FUNCTION NUMBERP))) (* ;  "It's a list of numbers. Add 'em up") (IMAGEOBJPROP CROPMARK 'PAGE.SIZE (LIST WIDTH HEIGHT)) (RETURN CROPMARK)) (T (* ;  "Something was specified, and there was a non-number in it...") (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "Non-numeric widths not desirable: " HEIGHT) T]) (CROPMARK.DISPLAYFN [LAMBDA (CROPMARK IMAGE.STREAM) (* ; "Edited 5-Jun-91 15:05 by jds") (* ;; "function which displays the bitmap of the hrule on the display or calls an {inter}press function to draw the rule on a file") (LET* [(PAGESIZE (IMAGEOBJPROP CROPMARK 'PAGE.SIZE)) (WIDTH (CAR PAGESIZE)) (HEIGHT (CADR PAGESIZE)) (SCALE (DSPSCALE NIL IMAGE.STREAM)) (THICK (IMAX 1 (FIXR (FTIMES SCALE 0.5] (SELECTQ (IMAGESTREAMTYPE IMAGE.STREAM) (DISPLAY (BITBLT CROPMARK.IMAGE 0 0 IMAGE.STREAM (DSPXPOSITION NIL IMAGE.STREAM) (DSPYPOSITION NIL IMAGE.STREAM) 9 9 'INPUT 'PAINT)) (PROGN (DRAWLINE -12 0 0 0 THICK 'PAINT IMAGE.STREAM) (DRAWLINE 0 -12 0 0 THICK 'PAINT IMAGE.STREAM) (DRAWLINE -12 HEIGHT 0 HEIGHT THICK 'PAINT IMAGE.STREAM) (DRAWLINE 0 (+ 12 HEIGHT) 0 HEIGHT THICK 'PAINT IMAGE.STREAM) (DRAWLINE (+ WIDTH 12) 0 WIDTH 0 THICK 'PAINT IMAGE.STREAM) (DRAWLINE WIDTH -12 WIDTH 0 THICK 'PAINT IMAGE.STREAM) (DRAWLINE (+ WIDTH 12) HEIGHT WIDTH HEIGHT THICK 'PAINT IMAGE.STREAM) (DRAWLINE WIDTH (+ 12 HEIGHT) WIDTH HEIGHT THICK 'PAINT IMAGE.STREAM]) (CROPMARK.GETFN [LAMBDA (INPUT.STREAM TEXTSTREAM) (* ; "Edited 5-Jun-91 15:06 by jds") (* ;; "reads the width and creates a VRULE") (LET ((PAGESIZE (READ INPUT.STREAM))) (VRULE.CREATE (CAR PAGESIZE) (CADR PAGESIZE]) (CROPMARK.IMAGEBOXFN [LAMBDA (HRULE IMAGE.STREAM CURRENT.X RIGHT.MARGIN) (* ; "Edited 5-Jun-91 15:07 by jds") (* ;; "returns an imagebox describing the size of the scaled bitmap. without caching") (LET ((SCALE (DSPSCALE NIL IMAGE.STREAM)) (WIDTHS 0.5)) (SELECTQ (IMAGESTREAMTYPE IMAGE.STREAM) (DISPLAY (create IMAGEBOX XSIZE _ 9 YSIZE _ 9 YDESC _ 0 XKERN _ 0)) (create IMAGEBOX XSIZE _ 0 YSIZE _ 0 YDESC _ 0 XKERN _ 0]) (CROPMARK.PUTFN [LAMBDA (HRULE OUTPUT.STREAM) (* ; "Edited 5-Jun-91 15:08 by jds") (* ;; "prints only the rule.width to the file, the rest can be discovered") (PRINT (IMAGEOBJPROP HRULE 'PAGE.SIZE) OUTPUT.STREAM]) (CROPMARK.COPYFN [LAMBDA (IMAGEOBJ FROMSTREAM TOSTREAM) (* ; "Edited 5-Jun-91 15:09 by jds") (* ;  "This function does not build the bitmap but lets the imageboxfn cache a bitmap") (CROPMARK.CREATE (IMAGEOBJPROP IMAGEOBJ 'RULE.HEIGHT) TOSTREAM]) (CROPMARK.WHENOPERATEDONFN [LAMBDA (A B C C) (* gbn " 6-Jan-85 13:23") (* DUMMY) ]) ) (RPAQQ CROPMARK.IMAGE #*(9 9)CN@@DI@@HHH@HHH@OOH@HHH@HHH@DI@@CN@@) (RPAQ? CROPMARK.DEFAULT.PAGESIZE (LIST 612 792)) (RPAQ CROPMARK.IMAGEFNS (IMAGEFNSCREATE (FUNCTION CROPMARK.DISPLAYFN) (FUNCTION CROPMARK.IMAGEBOXFN) (FUNCTION CROPMARK.PUTFN) (FUNCTION CROPMARK.GETFN) (FUNCTION CROPMARK.COPYFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION CROPMARK.WHENOPERATEDONFN) (FUNCTION NILL))) (PUTPROPS HRULE COPYRIGHT ("Venue & Xerox Corporation" 1985 1990 1991 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4225 10404 (HRULE.CREATE 4235 . 5657) (HRULE.DISPLAYFN 5659 . 8228) (HRULE.GETFN 8230 . 8550) (HRULE.IMAGEBOXFN 8552 . 9354) (HRULE.PUTFN 9356 . 9734) (HRULE.COPYFN 9736 . 10200) ( HRULE.WHENOPERATEDONFN 10202 . 10402)) (11107 17312 (VRULE.CREATE 11117 . 13116) (VRULE.DISPLAYFN 13118 . 15312) (VRULE.GETFN 15314 . 15535) (VRULE.GETFN2 15537 . 15873) (VRULE.IMAGEBOXFN 15875 . 16303) (VRULE.PUTFN 16305 . 16703) (VRULE.COPYFN 16705 . 17108) (VRULE.WHENOPERATEDONFN 17110 . 17310) ) (17951 22601 (CROPMARK.CREATE 17961 . 19228) (CROPMARK.DISPLAYFN 19230 . 20730) (CROPMARK.GETFN 20732 . 21026) (CROPMARK.IMAGEBOXFN 21028 . 21729) (CROPMARK.PUTFN 21731 . 22009) (CROPMARK.COPYFN 22011 . 22394) (CROPMARK.WHENOPERATEDONFN 22396 . 22599))))) STOP \ No newline at end of file diff --git a/library/IMAGEOBJ b/library/IMAGEOBJ new file mode 100644 index 00000000..5f32808d --- /dev/null +++ b/library/IMAGEOBJ @@ -0,0 +1,542 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED " 7-Dec-95 13:21:56" {DSK}LIBRARY/IMAGEOBJ.;1 35602 + + changes to%: (FNS BMOBJ.DISPLAYFN BMOBJ.IMAGEBOXFN) + + previous date%: " 6-Dec-95 15:18:32" {DSK}LIBRARY/IMAGEOBJ.;1) + + +(* ; " +Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1995 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT IMAGEOBJCOMS) + +(RPAQQ IMAGEOBJCOMS + ((COMS + (* ;; "Bit-map image objects") + + (FNS BITMAPTEDITOBJ COERCETOBITMAP WINDOWTITLEFONT \PRINTBINARYBITMAP \READBINARYBITMAP + ) + + (* ;; "fns for the bitmap tedit object.") + + (FNS BMOBJ.BUTTONEVENTINFN BMOBJ.COPYFN BMOBJ.DISPLAYFN BMOBJ.IMAGEBOXFN BMOBJ.PUTFN + BMOBJ.INIT BMOBJ.GETFN5 BMOBJ.CREATE.MENU) + (INITVARS (*SMALLSCREEN* (ILESSP SCREENWIDTH 700)) + (*SMALLSCREENFACTOR* 0.5)) + (FNS SCALED.BITMAP.GETFN BMOBJ.GETFN BMOBJ.GETFN2 BMOBJ.GETFN3 BMOBJ.GETFN4) + (* ; + "GETFNs for backward compatibility with older objects.") + (RECORDS BITMAPOBJ) + [INITVARS (DEFAULT.BITMAP.SCALE '(0.75 (DISPLAY 1] + + (* ;; "make ^O be a character that inserts an object read from the user.") + + (GLOBALVARS (BITMAP.OBJ.MENU)) + (ADDVARS (BackgroundCopyMenuCommands (SNAP (FUNCTION (BITMAPOBJ.SNAPW)) + + "prompts for an area of the screen to insert." + ) + ("Snap 50%%" (FUNCTION (BITMAPOBJ.SNAPW 0.5)) + + "prompts for an area of the screen to insert, scaled down by 50%%." + ) + ("Snap 50%% & Save" (FUNCTION (BITMAPOBJ.SNAPW 0.5 T)) + + "prompts for an area of the screen to save in *INSERT-BITMAP*, scaled down by 50." + ) + ("Insert saved" (FUNCTION (COPYINSERT *INSERT-BITMAP*)) + "Inserts *INSERT-BITMAP* in a document")) + (IMAGEOBJGETFNS (BMOBJ.GETFN)) + (IMAGEOBJGETFNS (BMOBJ.GETFN2)) + (IMAGEOBJGETFNS (BMOBJ.GETFN3)) + (IMAGEOBJGETFNS (BMOBJ.GETFN4)) + (IMAGEOBJGETFNS (BMOBJ.GETFN5)) + (IMAGEOBJGETFNS (SCALED.BITMAP.GETFN))) + (VARS (BackgroundCopyMenu)) + (FNS GET.OBJ.FROM.USER BITMAPOBJ.SNAPW PROMPTFOREVALED) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (BMOBJ.INIT))) + (FILES EDITBITMAP)))) + + + +(* ;; "Bit-map image objects") + +(DEFINEQ + +(BITMAPTEDITOBJ [LAMBDA (BITMAP SCALEFACTOR ROTATION DESCENT) (* ; "Edited 13-Aug-93 17:17 by rmk:") (* ; "Edited 6-Jan-89 16:34 by jds") (* ;;  "returns the IMAGEOBJ which gives the functional information for a bitmap object in a tedit file.") (IMAGEOBJCREATE (CREATE BITMAPOBJ BITMAP _ BITMAP BMOBJSCALEFACTOR _ (OR SCALEFACTOR 1) BMOBJROTATION _ (OR ROTATION 0) BMOBJDESCENT _ (OR DESCENT 0)) BITMAPIMAGEFNS]) + +(COERCETOBITMAP + [LAMBDA (BMSPEC) (* ; "Edited 11-Jun-90 16:28 by mitani") + (* tries to interpret X as a spec + for a bitmap.) + (PROG (BM CR) + (RETURN (COND + ((BITMAPP BMSPEC) + BMSPEC) + [(LITATOM BMSPEC) (* use value.) + (COND + ((BITMAPP (EVALV BMSPEC 'COERCETOBITMAP] + ((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] + (BITBLT (SCREENBITMAP) + (fetch (REGION LEFT) of BMSPEC) + (fetch (REGION BOTTOM) of BMSPEC) + BM 0 0 NIL NIL 'INPUT 'REPLACE) + BM) + ((WINDOWP BMSPEC) + [SETQ BM (BITMAPCREATE (WINDOWPROP BMSPEC 'WIDTH) + (WINDOWPROP BMSPEC 'HEIGHT] + (* 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)) + BM]) + +(WINDOWTITLEFONT + (LAMBDA (FONT) (* rrb " 1-Feb-84 15:26") + (* reset type of function that changes + the title font) + (DSPFONT FONT WindowTitleDisplayStream))) + +(\PRINTBINARYBITMAP + (LAMBDA (BITMAP STREAM) (* rrb "23-Jul-84 15:16") + + (* * prints the representation of a bitmap onto STREAM in a form that can be + read back by \READBINARYBITMAP.) + + (PROG ((STREAM (GETSTREAM STREAM 'OUTPUT)) + BMH) + (OR (BITMAPP BITMAP) + (\ILLEGAL.ARG BITMAP)) + (\WOUT STREAM (BITMAPWIDTH BITMAP)) + (\WOUT STREAM (SETQ BMH (BITMAPHEIGHT BITMAP))) + (\WOUT STREAM (BITSPERPIXEL BITMAP)) + (\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of BITMAP) + 0 + (ITIMES (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP) + BMH BYTESPERWORD)) + (RETURN BITMAP)))) + +(\READBINARYBITMAP + (LAMBDA (STREAM) (* rrb "23-Jul-84 15:17") + + (* * reads a bitmap printed on STREAM by \PRINTBINARYBITMAP.) + + (SETQ STREAM (GETSTREAM STREAM 'INPUT)) + (PROG ((BMW (\WIN STREAM)) + (BMH (\WIN STREAM)) + (BPP (\WIN STREAM)) + BITMAP) + (SETQ BITMAP (BITMAPCREATE BMW BMH BPP)) + (\BINS STREAM (fetch (BITMAP BITMAPBASE) of BITMAP) + 0 + (ITIMES (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP) + BMH BYTESPERWORD)) + (RETURN BITMAP)))) +) + + + +(* ;; "fns for the bitmap tedit object.") + +(DEFINEQ + +(BMOBJ.BUTTONEVENTINFN [LAMBDA (IMAGEOBJ WINDOW SELECTION X Y SELWINDOW TEXTSTREAM BUTTON OPERATION) (* ; "Edited 14-Aug-93 19:44 by rmk:") (* ; "Edited 13-Jan-89 17:41 by jds") (* ;;; "the user has pressed a button inside the bitmap object IMAGEOBJ. Bring up a menu of bitmap edit operations.") (PROG* ((OBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) (OLDSCALE (FETCH (BITMAPOBJ BMOBJSCALEFACTOR) OF OBJ)) NEW.BITMAP COMMAND.MENU COMMAND PREVIOUS.BITMAP NAME TEMP X Y) (COND ([OR (EQ BUTTON 'RIGHT) (AND OPERATION (NEQ OPERATION 'NORMAL] (* ; " If he's extending a selection, or is selecting for move/copy/delete, DON'T bring up the bitmap editing menu!") (RETURN))) (SETQ PREVIOUS.BITMAP (BITMAPCOPY (FETCH (BITMAPOBJ BITMAP) OF OBJ))) (SETQ NEW.BITMAP (SELECTQ [MENU (COND ((TYPE? MENU BITMAP.OBJ.MENU) BITMAP.OBJ.MENU) (T (SETQ BITMAP.OBJ.MENU (BMOBJ.CREATE.MENU] (CHANGE.SCALE (* ;; "Change the scale on the bitmap. Since scale can be a list, might be better to use list-reading instead of string-reading functions, but...") (LET [(NEWSCALE (COND ((TEDITWINDOWP WINDOW) (TEDIT.GETINPUT (TEXTOBJ WINDOW) "Scale Factor: " OLDSCALE)) (T (PROMPTFORWORD "Scale Factor: " OLDSCALE NIL PROMPTWINDOW] (IF [AND NEWSCALE [NLSETQ (SETQ NEWSCALE (READ (OPENSTRINGSTREAM NEWSCALE 'INPUT] (NOT (EQUAL NEWSCALE OLDSCALE)) (OR (NUMBERP NEWSCALE) (AND (NUMBERP (CAR (LISTP NEWSCALE))) (FOR X IN (CDR NEWSCALE) ALWAYS (NUMBERP (CADR X] THEN (REPLACE (BITMAPOBJ BMOBJSCALEFACTOR) OF OBJ WITH NEWSCALE) (* ;  "Return the prevous bitmap, so we don't change the bits.") PREVIOUS.BITMAP ELSE (RETURN NIL)))) (HAND.EDIT (EDITBM PREVIOUS.BITMAP)) (TRIM (TRIM.BITMAP PREVIOUS.BITMAP)) (INVERT.HORIZONTALLY (INVERT.BITMAP.HORIZONTALLY PREVIOUS.BITMAP)) (INVERT.VERTICALLY (INVERT.BITMAP.VERTICALLY PREVIOUS.BITMAP)) (INVERT.DIAGONALLY (INVERT.BITMAP.DIAGONALLY PREVIOUS.BITMAP)) (ROTATE.BITMAP.LEFT (ROTATE.BITMAP.LEFT PREVIOUS.BITMAP)) (ROTATE.BITMAP.RIGHT (ROTATE.BITMAP.RIGHT PREVIOUS.BITMAP)) (SHIFT.LEFT (INTERACT&SHIFT.BITMAP.LEFT PREVIOUS.BITMAP)) (SHIFT.RIGHT (INTERACT&SHIFT.BITMAP.RIGHT PREVIOUS.BITMAP)) (SHIFT.DOWN (INTERACT&SHIFT.BITMAP.DOWN PREVIOUS.BITMAP)) (SHIFT.UP (INTERACT&SHIFT.BITMAP.UP PREVIOUS.BITMAP)) (INTERCHANGE.BLACK/WHITE (INVERT.BITMAP.B/W PREVIOUS.BITMAP)) (ADD.BORDER (INTERACT&ADD.BORDER.TO.BITMAP PREVIOUS.BITMAP)) (RETURN NIL))) (REPLACE (BITMAPOBJ BITMAP) OF OBJ WITH NEW.BITMAP) (IMAGEOBJPROP IMAGEOBJ 'CACHED.BITMAP NIL) (* ;  "And clear any cached shrunk bitmaps so the display looks reasonable.") (RETURN 'CHANGED]) + +(BMOBJ.COPYFN [LAMBDA (IMAGEOBJ) (* ; "Edited 13-Aug-93 17:13 by rmk:") (* ; "Edited 6-Jan-89 16:19 by jds") (* ;; "makes a copy of a bitmap image object.") (LET [(BMOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (BITMAPTEDITOBJ (BITMAPCOPY (FETCH (BITMAPOBJ BITMAP) OF BMOBJ)) (FETCH (BITMAPOBJ BMOBJSCALEFACTOR) OF BMOBJ) (FETCH (BITMAPOBJ BMOBJROTATION) OF BMOBJ) (FETCH (BITMAPOBJ BMOBJDESCENT) OF BMOBJ]) + +(BMOBJ.DISPLAYFN + [LAMBDA (IMAGEOBJ IMAGE.STREAM) (* ; "Edited 7-Dec-95 13:20 by ") + (* ; "Edited 13-Aug-93 17:49 by rmk:") + (* ; "Edited 29-Mar-89 18:38 by snow") + + (* ;; "Display a bitmap IMAGEOBJ on IMAGE.STREAM. Scales and rotates it if appropriate, and moves it down by DESCENT.") + + (DECLARE (GLOBALVARS *SMALLSCREEN* *SMALLSCREENFACTOR*)) + (PROG ([FACTOR (fetch (BITMAPOBJ BMOBJSCALEFACTOR) of (IMAGEOBJPROP IMAGEOBJ + 'OBJECTDATUM] + [BITMAP (fetch (BITMAPOBJ BITMAP) of (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] + (CACHE (IMAGEOBJPROP IMAGEOBJ 'CACHED.BITMAP)) + [DESCENT (fetch (BITMAPOBJ BMOBJDESCENT) of (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] + (STREAM-SCALE (DSPSCALE NIL IMAGE.STREAM)) + (STREAMTYPE (IMAGESTREAMTYPE IMAGE.STREAM)) + SHRUNK.BITMAP) + (RELMOVETO 0 [IMINUS (FIXR (FTIMES STREAM-SCALE (OR DESCENT 0] + IMAGE.STREAM) + [IF (NUMBERP FACTOR) + ELSEIF (LISTP FACTOR) + THEN (SETQ FACTOR (OR (CADR (ASSOC STREAMTYPE (CDR FACTOR))) + (CAR FACTOR] + (IF (AND *SMALLSCREEN* *SMALLSCREENFACTOR* (GREATERP FACTOR 0.5) + (LEQ FACTOR 1.0) + (EQ 'DISPLAY STREAMTYPE)) + THEN + + (* ;; + "Shrink images on small screens, unless they are already small or specified to be big") + + (SETQ FACTOR *SMALLSCREENFACTOR*)) + (SELECTQ STREAMTYPE + ((DISPLAY PRESS) + (* ;; "PRESS and DISPLAY prints the junky shrunk bitmap. This is strange: this presumably should be handled in the device's bitblt method.") + + (COND + ((NOT (SETQ SHRUNK.BITMAP CACHE)) + [COND + [(LEQ FACTOR 1.0) (* ; + "We're shrinking the bitmap. Create a shrunk image for display") + (SETQ SHRUNK.BITMAP (SHRINKBITMAP BITMAP (FQUOTIENT 1.0 FACTOR) + (FQUOTIENT 1.0 FACTOR] + (T (* ; + "We're expanding it. Create a bigger one.") + (SETQ SHRUNK.BITMAP (EXPANDBITMAP BITMAP FACTOR FACTOR] + (IMAGEOBJPROP IMAGEOBJ 'CACHED.BITMAP SHRUNK.BITMAP))) + [BITBLT SHRUNK.BITMAP NIL NIL IMAGE.STREAM (DSPXPOSITION NIL IMAGE.STREAM) + (DSPYPOSITION NIL IMAGE.STREAM) + (FIXR (FTIMES FACTOR (BITMAPWIDTH BITMAP))) + (FIXR (FTIMES FACTOR (BITMAPHEIGHT BITMAP]) + (PROGN + (* ;; "This is the default case--Call SCALEDBITBLT") + + (* ;; "changed OPERATION from PAINT to REPLACE as PAINT doesn't work for all devices. --was. From rmk: if a device can't implement PAINT properly, then IT should coerce to REPLACE. Why is that done here?") + + (SCALEDBITBLT BITMAP 0 0 IMAGE.STREAM NIL NIL (BITMAPWIDTH BITMAP) + (BITMAPHEIGHT BITMAP) + 'INPUT + 'REPLACE NIL NIL FACTOR]) + +(BMOBJ.IMAGEBOXFN + [LAMBDA (IMAGEOBJ IMAGE.STREAM CURRENT.X RIGHT.MARGIN) (* ; "Edited 7-Dec-95 13:20 by ") + (* ; "Edited 6-Dec-95 15:17 by ") + (* ; "Edited 4-Dec-95 13:35 by ") + (* ; "Edited 4-Dec-95 13:29 by ") + (* ; "Edited 13-Aug-93 17:48 by rmk:") + (* ; "Edited 6-Jan-89 16:35 by jds") + + (* ;; "returns an imagebox describing the size of the scaled bitmap") + + (DECLARE (GLOBALVARS *SMALLSCREEN* *SMALLSCREENFACTOR*)) + (LET* ((BITMAPOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) + (FACTOR (FETCH (BITMAPOBJ BMOBJSCALEFACTOR) OF BITMAPOBJ)) + (BITMAP (FETCH (BITMAPOBJ BITMAP) OF BITMAPOBJ)) + (DESCENT (FETCH (BITMAPOBJ BMOBJDESCENT) OF BITMAPOBJ)) + (SCALE (DSPSCALE NIL IMAGE.STREAM)) + (STREAMTYPE (IMAGESTREAMTYPE IMAGE.STREAM)) + WIDTH HEIGHT) + [COND + ((EQ BITMAP 'NoneCached) + (SETQ WIDTH (SETQ HEIGHT 5))) + (T [IF (NUMBERP FACTOR) + ELSEIF (LISTP FACTOR) + THEN (SETQ FACTOR (OR (CADR (ASSOC STREAMTYPE (CDR FACTOR))) + (CAR FACTOR] + (IF (AND *SMALLSCREEN* *SMALLSCREENFACTOR* (GREATERP FACTOR 0.5) + (LEQ FACTOR 1.0) + (EQ 'DISPLAY STREAMTYPE)) + THEN + + (* ;; + "Shrink images on small screens, unless they are already small or specified to be big") + + (SETQ FACTOR *SMALLSCREENFACTOR*)) + [SETQ WIDTH (FIXR (FTIMES SCALE (TIMES (BITMAPWIDTH BITMAP) + FACTOR] + (SETQ HEIGHT (FIXR (FTIMES SCALE (TIMES (BITMAPHEIGHT BITMAP) + FACTOR] + (CREATE IMAGEBOX + XSIZE _ WIDTH + YSIZE _ HEIGHT + YDESC _ (OR DESCENT 0) + XKERN _ 0]) + +(BMOBJ.PUTFN [LAMBDA (BMOBJ STREAM) (* ; "Edited 13-Aug-93 15:41 by rmk:") (* ; "Edited 11-Jan-89 17:00 by jds") (* ;; "Put a description of a bitmap object into the file, including all fields as s-expressions. To be read by BMOBJ.GETFN5") (LET* [(BITMAPOBJ (IMAGEOBJPROP BMOBJ 'OBJECTDATUM] (\PRINTBINARYBITMAP (fetch (BITMAPOBJ BITMAP) of BITMAPOBJ) STREAM) (PRIN2 (fetch (BITMAPOBJ BMOBJSCALEFACTOR) of BITMAPOBJ) STREAM FILERDTBL) (SPACES 1 STREAM) (PRIN2 (fetch (BITMAPOBJ BMOBJROTATION) of BITMAPOBJ) STREAM FILERDTBL) (SPACES 1 STREAM) (PRIN2 (fetch (BITMAPOBJ BMOBJDESCENT) of BITMAPOBJ) STREAM FILERDTBL) (SPACES 1 STREAM]) + +(BMOBJ.INIT [LAMBDA NIL (* ; "Edited 13-Aug-93 14:27 by rmk:") (* ; "Edited 11-Jan-89 17:01 by jds") (* ;;  "returns the function vector which gives the functional information for a bitmap image object.") (SETQ BITMAPIMAGEFNS (IMAGEFNSCREATE (FUNCTION BMOBJ.DISPLAYFN) (FUNCTION BMOBJ.IMAGEBOXFN) (FUNCTION BMOBJ.PUTFN) (FUNCTION BMOBJ.GETFN5) (FUNCTION BMOBJ.COPYFN) (FUNCTION BMOBJ.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL]) + +(BMOBJ.GETFN5 [LAMBDA (INPUT.STREAM TEXTSTREAM) (* ; "Edited 13-Aug-93 15:40 by rmk:") (* jds "30-Oct-85 11:29") (* ; "reads in a scaled bitmap object with readbitmap and read. Gets scale, rotation, and descent as arbitrary s-expressions") (BITMAPTEDITOBJ (\READBINARYBITMAP INPUT.STREAM) (READ INPUT.STREAM FILERDTBL) (READ INPUT.STREAM FILERDTBL) (READ INPUT.STREAM FILERDTBL]) + +(BMOBJ.CREATE.MENU + [LAMBDA NIL (* ; "Edited 30-Jul-87 19:19 by jds") + + (* ;; "Creates the menu that comes up when you button in a bitmap image object.") + + (create MENU + TITLE _ "Operations on bitmaps" + ITEMS _ '((Change% Scale 'CHANGE.SCALE "Changes the scale factor used at output time.") + (Hand% Edit 'HAND.EDIT "Starts the bitmap editor on this bitmap.") + (Trim 'TRIM "removes the white space from the edges of the bitmap.") + (Reflect% Left-to-right 'INVERT.HORIZONTALLY + "inverts the bitmap about the vertical midline.") + (Reflect% Top-to-bottom 'INVERT.VERTICALLY + "inverts the bitmap about the horizontal midline.") + (Reflect% Diagonally 'INVERT.DIAGONALLY + "inverts the bitmap about the lower left to upper right diagonal.") + (Rotate% Left 'ROTATE.BITMAP.LEFT + "rotates the bitmap 90 degrees counter-clockwise.") + (Rotate% Right 'ROTATE.BITMAP.RIGHT "rotates the bitmap 90 degrees clockwise.") + (|Expand on Right| 'SHIFT.LEFT + "prompts for a number of bits to add on the right.") + (|Expand on Left| 'SHIFT.RIGHT + "prompts for a number of bits to add on the left.") + (|Expand on Bottom| 'SHIFT.UP "prompts for a number of bits to add on the top.") + (|Expand on Top| 'SHIFT.DOWN + "prompts for a number of bits to add on the bottom.") + (|Switch Black & White| 'INTERCHANGE.BLACK/WHITE + "changes all black bits to white and all white bits to black.") + (Add% Border 'ADD.BORDER "adds an arbitrary border in an arbitrary shade.")) + CENTERFLG _ T + CHANGEOFFSETFLG _ 'Y + MENUOFFSET _ (create POSITION + XCOORD _ -1 + YCOORD _ 0]) +) + +(RPAQ? *SMALLSCREEN* (ILESSP SCREENWIDTH 700)) + +(RPAQ? *SMALLSCREENFACTOR* 0.5) +(DEFINEQ + +(SCALED.BITMAP.GETFN + (LAMBDA (INPUT.STREAM TEXTSTREAM) (* jds "30-Oct-85 11:29") + + (* reads in a scaled bitmap object with readbitmap and read) + + (PROG (FACTOR BITMAP) + (SETQ BITMAP (READBITMAP INPUT.STREAM)) + (SETQ FACTOR (READ INPUT.STREAM)) + (RETURN (BITMAPTEDITOBJ BITMAP (FQUOTIENT 1.0 FACTOR) + 0))))) + +(BMOBJ.GETFN + (LAMBDA (STREAM) (* rrb "17-Jul-84 11:46") + + (* this is an old version of the get function for bitmap image objects. + It is left around so old tedit documents will still work. + |17/7/84|) + + (RESETFORM (INPUT STREAM) + (PROG ((FIELDS (READ STREAM)) + (BITMAP (READBITMAP))) + (RETURN (BITMAPTEDITOBJ BITMAP (CAR FIELDS) + (CADR FIELDS))))))) + +(BMOBJ.GETFN2 + (LAMBDA (STREAM) (* rrb "17-Jul-84 11:29") + + (* * reads a bitmap image object from a file. + This version stores the binary data rather than the character representation + used by READBITMAP.) + + (PROG ((SCALE (\WIN STREAM)) + (ROT (\WIN STREAM))) + (RETURN (BITMAPTEDITOBJ (\READBINARYBITMAP STREAM) + SCALE ROT))))) + +(BMOBJ.GETFN3 + [LAMBDA (STREAM) (* ; "Edited 11-Jan-89 17:03 by jds") + +(* ;;; "reads a bitmap image object from a file. This version stores the binary data rather than the character representation used by READBITMAP.") + + (COND + ((IEQP (\PEEKBIN STREAM) + (CHARCODE CR)) (* ; + "This is an old-format sketch with bitmap included. Skip the interfering CR.") + (BIN STREAM))) + (PROG ((SCALE (FPLUS (\WIN STREAM) + (FQUOTIENT (\WIN STREAM) + 32768))) + (DESC (\WIN STREAM))) + (RETURN (BITMAPTEDITOBJ (\READBINARYBITMAP STREAM) + SCALE 0 DESC]) + +(BMOBJ.GETFN4 + [LAMBDA (STREAM) (* ; "Edited 6-Jan-89 16:33 by jds") + +(* ;;; "reads a bitmap image object from a file. This version stores the binary data rather than the character representation used by READBITMAP.") + + (COND + ((IEQP (\PEEKBIN STREAM) + (CHARCODE CR)) (* ; + "This is an old-format sketch with bitmap included. Skip the interfering CR.") + (BIN STREAM))) + (LET ((SCALE (FPLUS (\WIN STREAM) + (FQUOTIENT (\WIN STREAM) + 32768))) + (ROT (\WIN STREAM)) + (DESCENT (\WIN STREAM))) + + (* ;; "Dummy words for later expansion:") + + (\WIN STREAM) + (\WIN STREAM) + (\WIN STREAM) + (\WIN STREAM) + + (* ;; "Now read the bitmap itself and construct the object:") + + (BITMAPTEDITOBJ (\READBINARYBITMAP STREAM) + SCALE ROT DESCENT]) +) + + + +(* ; "GETFNs for backward compatibility with older objects.") + +(DECLARE%: EVAL@COMPILE + +(RECORD BITMAPOBJ ( + (* ;; "Describes a bitmap imageobj") + + BITMAP (* ; "The bitmap itself") + BMOBJSCALEFACTOR (* ; + "The factor to scale it by when displaying") + BMOBJROTATION (* ; + "A rotation to apply when displaying") + BMOBJDESCENT (* ; + "How far below the base line to display it. NIL => 0.") + )) +) + +(RPAQ? DEFAULT.BITMAP.SCALE '(0.75 (DISPLAY 1))) + + + +(* ;; "make ^O be a character that inserts an object read from the user.") + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS (BITMAP.OBJ.MENU)) +) + +(ADDTOVAR BackgroundCopyMenuCommands + (SNAP (FUNCTION (BITMAPOBJ.SNAPW)) + "prompts for an area of the screen to insert.") + ("Snap 50%%" (FUNCTION (BITMAPOBJ.SNAPW 0.5)) + "prompts for an area of the screen to insert, scaled down by 50%%.") + ("Snap 50%% & Save" (FUNCTION (BITMAPOBJ.SNAPW 0.5 T)) + "prompts for an area of the screen to save in *INSERT-BITMAP*, scaled down by 50.") + ("Insert saved" (FUNCTION (COPYINSERT *INSERT-BITMAP*)) + "Inserts *INSERT-BITMAP* in a document")) + +(ADDTOVAR IMAGEOBJGETFNS (BMOBJ.GETFN)) + +(ADDTOVAR IMAGEOBJGETFNS (BMOBJ.GETFN2)) + +(ADDTOVAR IMAGEOBJGETFNS (BMOBJ.GETFN3)) + +(ADDTOVAR IMAGEOBJGETFNS (BMOBJ.GETFN4)) + +(ADDTOVAR IMAGEOBJGETFNS (BMOBJ.GETFN5)) + +(ADDTOVAR IMAGEOBJGETFNS (SCALED.BITMAP.GETFN)) + +(RPAQQ BackgroundCopyMenu NIL) +(DEFINEQ + +(GET.OBJ.FROM.USER + [LAMBDA (TEXTSTREAM TEXTOBJ) (* ; "Edited 26-Apr-91 10:54 by jds") + + (* ;; "reads an expression from the user and puts the result into the textstream.") + + (ERSETQ (PROG ((VAL (PROMPTFOREVALED "Form to eval:")) + (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + BM) + (CL:TYPECASE VAL + (STRINGP (* ; + "Atoms and strings get inserted as text.") + (AND VAL (TEDIT.INSERT TEXTSTREAM VAL SEL))) + (LITATOM (* ; + "Atoms and strings get inserted as text.") + (AND VAL (TEDIT.INSERT TEXTSTREAM (MKSTRING VAL T) + SEL))) + (IMAGEOBJ (* ; "IMAGEOBJs get inserted as is") + (TEDIT.INSERT.OBJECT VAL TEXTSTREAM (SELECTQ (fetch POINT of SEL) + (LEFT (fetch (SELECTION CH#) + of SEL)) + (RIGHT (fetch (SELECTION CHLIM) + of SEL)) + NIL))) + (T (COND + ((SETQ BM (COERCETOBITMAP VAL)) + (* ; + "If it can be coerced to a bitmap, do so, then wrap the bitmap up as a nobject") + (TEDIT.INSERT.OBJECT (BITMAPTEDITOBJ BM 1 0) + TEXTSTREAM + (SELECTQ (fetch POINT of SEL) + (LEFT (fetch (SELECTION CH#) of SEL)) + (RIGHT (fetch (SELECTION CHLIM) of SEL)) + NIL))) + (T (* ; + "Not a bitmap, nor one of the special cases above; complain") + (AND VAL (TEDIT.INSERT TEXTSTREAM (MKSTRING VAL T) + SEL)) (* ; + "(TEDIT.PROMPTPRINT TEXTOBJ (CONCAT 'Not implemented to have ' VAL ' in documents yet.') T)") + ))))]) + +(BITMAPOBJ.SNAPW [LAMBDA (SCALE SAVE) (* ; "Edited 14-Aug-93 19:54 by rmk:") (* ; "Edited 19-Jan-93 16:08 by jds") (* * makes an image object of a prompted for region of the screen.) (PROG ((REG (GETREGION)) BM) [SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG) (BITSPERPIXEL (SCREENBITMAP] (BITBLT (SCREENBITMAP) (fetch (REGION LEFT) of REG) (fetch (REGION BOTTOM) of REG) BM 0 0 NIL NIL 'INPUT 'REPLACE) [COND (SAVE (SETQ *INSERT-BITMAP* (BITMAPTEDITOBJ BM (OR SCALE (COPY DEFAULT.BITMAP.SCALE) ) 0))) (T (COPYINSERT (BITMAPTEDITOBJ BM (OR SCALE (COPY DEFAULT.BITMAP.SCALE)) 0] (RETURN]) + +(PROMPTFOREVALED + (LAMBDA (MSG WHERE FONT MINWIDTH MINHEIGHT) (* jds "26-Sep-85 16:46") + + (* opens a window with MSG in the title and returns the result of evaluating a + READ from that window. (PROMPTFOREVALED "HOW'S THIS?" + (QUOTE (600 . 600)) NIL 100)) + + (PROG (NEWVALUE WIN (FONT (OR FONT (FONTCREATE 'HELVETICA 12 'BOLD)))) + (RESETFORM (WINDOWTITLEFONT FONT) + (SETQ WIN (CREATEW (COND + ((REGIONP WHERE) + WHERE) + (T (CREATEREGION + (COND + (WHERE (fetch (POSITION XCOORD) of WHERE)) + (T LASTMOUSEX)) + (COND + (WHERE (fetch (POSITION YCOORD) of WHERE)) + (T LASTMOUSEY)) + (WIDTHIFWINDOW (MAX (STRINGWIDTH MSG FONT) + (OR MINWIDTH 0) + 125) + 8) + (HEIGHTIFWINDOW (MAX (ITIMES (FONTPROP (DEFAULTFONT + 'DISPLAY) + 'HEIGHT) + 3) + (OR MINHEIGHT 0) + 100) + T 8)))) + MSG 4)) + (CLEARW WIN)) + (RESETFORM (TTYDISPLAYSTREAM WIN) + (SETQ NEWVALUE (CAR (ERSETQ (LISPX (LISPXREAD T T) + '>))))) + (CLOSEW WIN) + (RETURN NEWVALUE)))) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(BMOBJ.INIT) +) + +(FILESLOAD EDITBITMAP) +(PUTPROPS IMAGEOBJ COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990 1991 1993 + 1995)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (3164 7671 (BITMAPTEDITOBJ 3176 . 3819) (COERCETOBITMAP 3823 . 5867) (WINDOWTITLEFONT +5871 . 6218) (\PRINTBINARYBITMAP 6222 . 7013) (\READBINARYBITMAP 7017 . 7668)) (7728 23863 ( +BMOBJ.BUTTONEVENTINFN 7740 . 12286) (BMOBJ.COPYFN 12290 . 12916) (BMOBJ.DISPLAYFN 12920 . 16649) ( +BMOBJ.IMAGEBOXFN 16653 . 19068) (BMOBJ.PUTFN 19072 . 20004) (BMOBJ.INIT 20008 . 21047) (BMOBJ.GETFN5 +21051 . 21641) (BMOBJ.CREATE.MENU 21645 . 23860)) (23958 27253 (SCALED.BITMAP.GETFN 23970 . 24396) ( +BMOBJ.GETFN 24400 . 24935) (BMOBJ.GETFN2 24939 . 25424) (BMOBJ.GETFN3 25428 . 26216) (BMOBJ.GETFN4 +26220 . 27250)) (29245 35381 (GET.OBJ.FROM.USER 29257 . 32020) (BITMAPOBJ.SNAPW 32024 . 33150) ( +PROMPTFOREVALED 33154 . 35378))))) +STOP diff --git a/library/INIT.MAIKO b/library/INIT.MAIKO new file mode 100644 index 00000000..a41f62e2 --- /dev/null +++ b/library/INIT.MAIKO @@ -0,0 +1 @@ +;; Copyright (c) 1988, 1989 Envos & Fuji Xerox ;; Generic Medley site initialization file. Edit for your site. ;; The environment variable LDEINIT should name this file if it is not ;; filed as /usr/local/lde/site-init.lisp. ;; Establish the Interlisp package for this file. (CL:IN-PACKAGE "INTERLISP") ;; Search path for (from valueof lispusersdirectories), includes library. (SETQ LISPUSERSDIRECTORIES '("{DSK}/usr/local/lde/lispusers/" "{DSK}/usr/local/lde/lisplibrary/")) ;; search path when file not found on current directory (SETQ DIRECTORIES (COPYALL LISPUSERSDIRECTORIES)) ;; paths for display fonts; list the ones that are installed (SETQ DISPLAYFONTDIRECTORIES '("{DSK}/usr/local/lde/fonts/display/presentation/" "{DSK}/usr/local/lde/fonts/display/publishing/" "{DSK}/usr/local/lde/fonts/display/printwheel/" "{DSK}/usr/local/lde/fonts/display/miscellaneous/" "{DSK}/usr/local/lde/fonts/display/jis1/" "{DSK}/usr/local/lde/fonts/display/jis2/" "{DSK}/usr/local/lde/fonts/display/chinese/")) ;; paths for interpress font widths; list the ones that are installed (SETQ INTERPRESSFONTDIRECTORIES '("{DSK}/usr/local/lde/fonts/interpress/presentation/" "{DSK}/usr/local/lde/fonts/interpress/publishing/" "{DSK}/usr/local/lde/fonts/interpress/printwheel/" "{DSK}/usr/local/lde/fonts/interpress/miscellaneous/" "{DSK}/usr/local/lde/fonts/interpress/jis1/" "{DSK}/usr/local/lde/fonts/interpress/jis2/" "{DSK}/usr/local/lde/fonts/interpress/chinese/")) ;; name/location of press font widths (SETQ PRESSFONTWIDTHFILES '("{DSK}/usr/local/lde/fonts/press/FONTS.WIDTHS")) ;; path patterns for individual initialization file (SETQ USERGREETFILES '(("{DSK}~/lde/INIT.LISP") ("{DSK}~/INIT.LISP"))) ;; only for chat, PUP and XNS services (SETQ DEFAULTOSTYPE 'UNIX) ;; can be reset for XNS/Interpress printers, or using other printer drivers (SETQ DEFAULTPRINTINGHOST NIL) (SETQ DEFAULTPRINTERTYPE NIL) ;; let any user with a valid UNIX login to exit Idle mode (LISTPUT IDLE.PROFILE 'AUTHENTICATE 'UNIX) (LISTPUT IDLE.PROFILE 'ALLOWED.LOGINS '(*)) ;; don't save VM while idling (LISTPUT IDLE.PROFILE 'SAVEVM NIL) ;; These values are for establishing where DST begins and ends. These are the ;; default for the US in 1988 (SETQ |\\BeginDST| 98) (SETQ |\\EndDST| 305) ;; edit to have your particular site parameters-- for standalone, short ;; site name is host name (SETQ XCL:*LONG-SITE-NAME* (SETQ XCL:*SHORT-SITE-NAME* (UNIX-GETPARM "HOSTNAME"))) \ No newline at end of file diff --git a/library/INIT.NONET b/library/INIT.NONET new file mode 100644 index 00000000..928970de --- /dev/null +++ b/library/INIT.NONET @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED "16-Jan-87 11:40:11" {ERIS}LIBRARY>INIT.NONET;2 2416 previous date%: "16-Jan-87 11:36:09" {ERIS}LIBRARY>INIT.NONET;1) (PRETTYCOMPRINT INITCOMS) (RPAQQ INITCOMS [(* This greeting file is appropriate for 1108 machines with no network connections) (VARS [USERGREETFILES '(({DSK}INIT. USER) ({DSK}INIT. COM) ({DSK}INIT] (DIRECTORIES '({DSK} {FLOPPY})) (LISPUSERSDIRECTORIES '({DSK} {FLOPPY})) (DEFAULTPRINTINGHOST NIL) (DEFAULTPRINTERTYPE NIL)) (* font vars) [VARS (DISPLAYFONTDIRECTORIES '({DSK} {FLOPPY})) (DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE AC)) (INTERPRESSFONTDIRECTORIES '({DSK} {FLOPPY})) (PRESSFONTWIDTHSFILES '({DSK}FONTS.WIDTHS {FLOPPY}FONTS.WIDTHS] (* Outdated font vars) (VARS (FONTDIRECTORIES '({DSK} {FLOPPY})) (NSFONTDIRECTORIES '({DSK} {FLOPPY})) (NSFONTWIDTHSDIRECTORIES '({DSK} {FLOPPY})) (STARFONTDIRECTORIES '({DSK} {FLOPPY})) (FONTWIDTHSFILES '({DSK}FONTS.WIDTHS {FLOPPY}FONTS.WIDTHS]) (* This greeting file is appropriate for 1108 machines with no network connections) (RPAQQ USERGREETFILES (({DSK}INIT. USER) ({DSK}INIT. COM) ({DSK}INIT))) (RPAQQ DIRECTORIES ({DSK} {FLOPPY})) (RPAQQ LISPUSERSDIRECTORIES ({DSK} {FLOPPY})) (RPAQQ DEFAULTPRINTINGHOST NIL) (RPAQQ DEFAULTPRINTERTYPE NIL) (* font vars) (RPAQQ DISPLAYFONTDIRECTORIES ({DSK} {FLOPPY})) (RPAQQ DISPLAYFONTEXTENSIONS (DISPLAYFONT STRIKE AC)) (RPAQQ INTERPRESSFONTDIRECTORIES ({DSK} {FLOPPY})) (RPAQQ PRESSFONTWIDTHSFILES ({DSK}FONTS.WIDTHS {FLOPPY}FONTS.WIDTHS)) (* Outdated font vars) (RPAQQ FONTDIRECTORIES ({DSK} {FLOPPY})) (RPAQQ NSFONTDIRECTORIES ({DSK} {FLOPPY})) (RPAQQ NSFONTWIDTHSDIRECTORIES ({DSK} {FLOPPY})) (RPAQQ STARFONTDIRECTORIES ({DSK} {FLOPPY})) (RPAQQ FONTWIDTHSFILES ({DSK}FONTS.WIDTHS {FLOPPY}FONTS.WIDTHS)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/library/INIT.SAMPLE b/library/INIT.SAMPLE new file mode 100644 index 00000000..9fd1768f --- /dev/null +++ b/library/INIT.SAMPLE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED "16-Jan-87 11:39:09" {ERIS}LIBRARY>INIT.SAMPLE;2 3194 previous date%: "29-Sep-84 18:10:19" {ERIS}KOTO>LIBRARY>INIT.SAMPLE;1) (* " Copyright (c) 1984, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT INITCOMS) (RPAQQ INITCOMS [(* This is a sample greeting file for a network site) (VARS [USERGREETFILES '(({fileserver}< USER >LISP>INIT. COM) ({fileserver}< USER >LISP>INIT) ({fileserver}< USER >INIT. COM) ({fileserver}< USER >INIT.LISP] (DIRECTORIES '({DSK} {fileserver})) (LISPUSERSDIRECTORIES '({fileserver})) (DEFAULTPRINTINGHOST 'name-of-printer) (DEFAULTPRINTERTYPE 'PRESS)) (* font vars) [VARS (DISPLAYFONTDIRECTORIES '({DSK} {fileserver})) (DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE AC)) (INTERPRESSFONTDIRECTORIES '({DSK} {fileserver})) (PRESSFONTWIDTHSFILES '({DSK}FONTS.WIDTHS {fileserver}FONTS.WIDTHS] (* Outdated font vars) [VARS (FONTDIRECTORIES '({DSK} {fileserver})) (NSFONTDIRECTORIES '({DSK} {fileserver})) (NSFONTWIDTHSDIRECTORIES '({DSK} {fileserver})) (STARFONTDIRECTORIES '({DSK} {fileserver})) (FONTWIDTHSFILES '({DSK}FONTS.WIDTHS {fileserver}FONTS.WIDTHS] (P (* LOGIN for subsequent access to user's personal GREET file) (LOGIN NIL 'QUIET]) (* This is a sample greeting file for a network site) (RPAQQ USERGREETFILES (({fileserver}< USER >LISP>INIT. COM) ({fileserver}< USER >LISP>INIT) ({fileserver}< USER >INIT. COM) ({fileserver}< USER >INIT.LISP))) (RPAQQ DIRECTORIES ({DSK} {fileserver})) (RPAQQ LISPUSERSDIRECTORIES ({fileserver})) (RPAQQ DEFAULTPRINTINGHOST name-of-printer) (RPAQQ DEFAULTPRINTERTYPE PRESS) (* font vars) (RPAQQ DISPLAYFONTDIRECTORIES ({DSK} {fileserver})) (RPAQQ DISPLAYFONTEXTENSIONS (DISPLAYFONT STRIKE AC)) (RPAQQ INTERPRESSFONTDIRECTORIES ({DSK} {fileserver})) (RPAQQ PRESSFONTWIDTHSFILES ({DSK}FONTS.WIDTHS {fileserver}FONTS.WIDTHS)) (* Outdated font vars) (RPAQQ FONTDIRECTORIES ({DSK} {fileserver})) (RPAQQ NSFONTDIRECTORIES ({DSK} {fileserver})) (RPAQQ NSFONTWIDTHSDIRECTORIES ({DSK} {fileserver})) (RPAQQ STARFONTDIRECTORIES ({DSK} {fileserver})) (RPAQQ FONTWIDTHSFILES ({DSK}FONTS.WIDTHS {fileserver}FONTS.WIDTHS)) (* LOGIN for subsequent access to user's personal GREET file) (LOGIN NIL 'QUIET) (PUTPROPS INIT.SAMPLE COPYRIGHT ("Xerox Corporation" 1984 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/library/KEYBOARDCONFIGS b/library/KEYBOARDCONFIGS new file mode 100644 index 00000000..806a2873 --- /dev/null +++ b/library/KEYBOARDCONFIGS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 7-Feb-97 12:13:28" {DSK}medley2.0>library>KEYBOARDCONFIGS.;8 61718 previous date%: "22-Jan-97 15:26:41" {DSK}medley2.0>library>KEYBOARDCONFIGS.;7) (* ; " Copyright (c) 1996, 1997 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT KEYBOARDCONFIGSCOMS) (RPAQQ KEYBOARDCONFIGSCOMS ( (* ;; "Configuration variables/values for VIRTUALKEYBOARDS package. Loaded when VIRTUALKEYBOARDS is loaded.") [INITVARS (DEFAULTVIRTUALKEYBOARDTYPE 'MAIKO) (DEFAULTKEYBOARDDISPLAYFONT '(CLASSIC 12)) (DEFAULTKEYBOARDLABELSFONT '(HELVETICA 5)) (KEYBOARDCONFIGCOERCIONS '((SUN4 MAIKO) (SUN5 FULL-IBMPC) (SUN3 MAIKO) (X MAIKO) (MAIKO DORADO) (FULL-IBMPC IBMPC] (VARS VKBD.COMMONCHARLABELS VKBD.COMMONKEYLABELS VKBD.COMMONDEFAULTASSIGNMENT) (INITVARS (VKBD.DEFAULT-CONFIGURATION-NAME (KEYBOARDTYPE))) (ALISTS (VKBD.CONFIGURATIONS MAIKO DORADO DANDELION DOVE FULL-IBMPC MAIKO-EUROPEAN)))) (* ;; "Configuration variables/values for VIRTUALKEYBOARDS package. Loaded when VIRTUALKEYBOARDS is loaded." ) (RPAQ? DEFAULTVIRTUALKEYBOARDTYPE 'MAIKO) (RPAQ? DEFAULTKEYBOARDDISPLAYFONT '(CLASSIC 12)) (RPAQ? DEFAULTKEYBOARDLABELSFONT '(HELVETICA 5)) (RPAQ? KEYBOARDCONFIGCOERCIONS '((SUN4 MAIKO) (SUN5 FULL-IBMPC) (SUN3 MAIKO) (X MAIKO) (MAIKO DORADO) (FULL-IBMPC IBMPC))) (RPAQQ VKBD.COMMONCHARLABELS ((1 BS) (2 BREAK) BS TAB LF CR ESC SPACE (21 ".") (23 DEL) HELP SCRL NUMLK CLEAR HOME PGUP END PGDN INS DOIT)) (RPAQQ VKBD.COMMONKEYLABELS ((ESC ESC) (F1 (F1 CENTER)) (F2 (F2 BOLD)) (F3 (F3 ITALIC)) (F4 (F4 UCASE)) (F5 (F5 STRIKE)) (F6 (F6 UNDER)) (F7 (F7 SUBSCR)) (F8 (F8 SMALL)) (F9 (F9 MARGIN)) (F10 (F10 LOOKS)) (F11 (F11 "")) (F12 (F12 "")) (LOCK ("CAPS" "LOCK")) (LSHIFT "LSHIFT") (RSHIFT "RSHIFT") (SPACE SPACE) (TAB "TAB") (NUMLOCK ("NUM" "LOCK")) (NUMERICENTER "ENTER") (LCTRL "CTRL") (LALT META) (BS BS) (LINEFEED ("LINE" "FEED")))) (RPAQQ VKBD.COMMONDEFAULTASSIGNMENT ((A (a A LS)) (B (b B LS)) (C (c C LS)) (D (d D LS)) (E (e E LS)) (F (f F LS)) (G (g G LS)) (H (h H LS)) (I (i I LS)) (J (j J LS)) (K (k K LS)) (L (l L LS)) (M (m M LS)) (N (n N LS)) (O (o O LS)) (P (p P LS)) (Q (q Q LS)) (R (r R LS)) (S (s S LS)) (T (t T LS)) (U (u U LS)) (V (v V LS)) (W (w W LS)) (X (x X LS)) (Y (y Y LS)) (Z (z Z LS)) (SPACE (SPACE SPACE)) (ESC (ESC ESC)) (TAB (TAB TAB)) (BS (BS BS)) (RSHIFT 2SHIFTDOWN . 2SHIFTUP) (LSHIFT 1SHIFTDOWN . 1SHIFTUP) (ZERO (|0| %) NLS)) (ONE (|1| ! NLS)) (TWO (|2| @ NLS)) (THREE (|3| %# NLS)) (FOUR (|4| $ NLS)) (FIVE (|5| %% NLS)) (SIX (|6| ^ NLS)) (SEVEN (|7| & NLS)) (EIGHT (|8| * NLS)) (NINE (|9| %( NLS)))) (RPAQ? VKBD.DEFAULT-CONFIGURATION-NAME (KEYBOARDTYPE)) (ADDTOVAR VKBD.CONFIGURATIONS (MAIKO NIL ((HELP (10 10 61 29)) (FIND (10 42 29 29)) (CUT (42 42 29 29)) (OPEN (10 74 29 29)) (PASTE (42 74 29 29)) (FRONT (10 106 29 29)) (COPY (42 106 29 29)) (PROPS (10 138 29 29)) (UNDO (42 138 29 29)) (STOP (10 170 29 29)) (AGAIN (42 170 29 29)) (INS (618 10 61 29)) (NUMERIC. (522 170 61 29)) (ENTER (714 10 29 61)) (NUMERIC1 (618 42 29 29)) (NUMERIC2 (650 42 29 29)) (NUMERIC3 (682 42 29 29)) (NUMERIC4 (618 74 29 29)) (NUMERIC5 (650 74 29 29)) (NUMERIC6 (682 74 29 29)) (NUMERIC+ (714 74 29 61)) (NUMERIC7 (618 106 29 29)) (NUMERIC8 (650 106 29 29)) (NUMERIC9 (682 106 29 29)) (NUMERIC= (618 138 29 29)) (NUMERIC/ (650 138 29 29)) (NUMERIC* (682 138 29 29)) (NUMERIC- (714 138 29 29)) (PAUSE (618 170 29 29)) (PRTSCR (650 170 29 29)) (SCRLLOCK (682 170 29 29)) (NUMLOCK (714 170 29 29)) (LOCK (106 10 29 29)) (ALT (138 10 29 29)) (LDIAMOND (170 10 29 29)) (SPACE (202 10 285 29)) (RDIAMOND (490 10 29 29)) (NEXT (522 10 29 29)) (ALTGRAPH (554 10 29 29)) (LSHIFT (106 42 69 29)) (Z (178 42 29 29)) (X (210 42 29 29)) (C (242 42 29 29)) (V (274 42 29 29)) (B (306 42 29 29)) (N (338 42 29 29)) (M (370 42 29 29)) (< (402 42 29 29)) (> (434 42 29 29)) (? (466 42 29 29)) (RSHIFT (498 42 53 29)) (LINEFEED (554 42 29 29)) (CONTROL (106 74 53 29)) (A (162 74 29 29)) (S (194 74 29 29)) (D (226 74 29 29)) (F (258 74 29 29)) (G (290 74 29 29)) (H (322 74 29 29)) (J (354 74 29 29)) (K (386 74 29 29)) (L (418 74 29 29)) (%: (450 74 29 29)) (%" (482 74 29 29)) (%` (514 74 29 29)) (RETURN (546 74 37 32) (538 106 45 29)) (=> (106 106 45 29)) (Q (154 106 29 29)) (W (186 106 29 29)) (E (218 106 29 29)) (R (250 106 29 29)) (T (282 106 29 29)) (Y (314 106 29 29)) (U (346 106 29 29)) (I (378 106 29 29)) (O (410 106 29 29)) (P (442 106 29 29)) ({ (474 106 29 29)) (} (506 106 29 29)) (ESC (106 138 29 29)) (! (138 138 29 29)) (@ (170 138 29 29)) (%# (202 138 29 29)) ($ (234 138 29 29)) (%% (266 138 29 29)) (|6| (298 138 29 29)) (& (330 138 29 29)) (* (362 138 29 29)) (%( (394 138 29 29)) (%) (426 138 29 29)) (- (458 138 29 29)) (+ (490 138 29 29)) (<- (522 138 61 29)) (F1 (106 170 29 29)) (F2 (138 170 29 29)) (F3 (170 170 29 29)) (F4 (202 170 29 29)) (F5 (234 170 29 29)) (F6 (266 170 29 29)) (F7 (298 170 29 29)) (F8 (330 170 29 29)) (F9 (362 170 29 29)) (F10 (394 170 29 29)) (F11 (426 170 29 29)) (F12 (458 170 29 29)) (\ (490 170 29 29)) (NUMERIC. (554 170 29 29))) NIL ((%" (%' %" NLS)) (+ (= + NLS)) (- (- _ NLS)) (%: (; %: NLS)) (< (%, < NLS)) (> (%. > NLS)) (? (/ ? NLS)) (LDIAMOND METADOWN . METAUP) (ALT IGNORE . IGNORE) (ALTGRAPH (2,24 2,64 NLS)) (LINEFEED (LF LF)) (LOCK LOCKTOGGLE) (CONTROL CTRLDOWN . CTRLUP) (ENTER (2,13 2,53 NLS)) (INS (INS |0| NLS)) (NEXT (2,22 2,62 NLS)) (NUMERIC* (* *)) (NUMERIC+ (+ +)) (NUMERIC- (- -)) (NUMERIC. (23 21 NLS)) (NUMERIC/ (/ /)) (NUMERIC0 (INS |0| NLS)) (NUMERIC1 (END |1| NLS)) (NUMERIC2 (¯ |2| NLS)) (NUMERIC3 (PGDN |3| NLS)) (NUMERIC4 (¬ |4| NLS)) (NUMERIC5 (|5| |5|)) (NUMERIC6 (® |6| NLS)) (NUMERIC7 (HOME |7| NLS)) (NUMERIC8 (­ |8| NLS)) (NUMERIC9 (PGUP |9| NLS)) (NUMERIC= (= =)) (RETURN (CR CR)) (%[ (%[ { NLS)) (\ (\ %| NLS)) (%` (%` ~ NLS)) (%] (%] } NLS)) (F1 (CENTER NOTCENTER NLS)) (F2 (BOLD NOTBOLD NLS)) (F3 (ITALIC NOTITALIC NLS)) (F4 (UCASE LCASE NLS)) (F5 (STRIKEOUT NOTSTRIKEOUT NLS)) (F6 (UNDERLINE NOTUNDERLINE NLS)) (F7 (SUBSCRIPT SUPERSCRIPT NLS)) (F8 (SMALLER LARGER NLS)) (F9 (MARGINS NOTMARGINS NLS)) (F10 (LOOKS NOTLOOKS NLS)) (F11 (F11 NOTF11 NLS)) (F12 (F12 NOTF12 NLS))) ((%` 45 B) (~ 45 T) (|6| 2 B) (^ 2 T) (%% 0 T) (|5| 0 B) ($ 1 T) (|4| 1 B) (E 3) (e 3) (& 4 T) (|7| 4 B) (D 5) (d 5) (U 6) (u 6) (V 7) (v 7) (%) 8 T) (|0| 8 B) (K 9) (k 9) (- 10 B) (P 11) (p 11) (? 12 T) (/ 12 B) (CUT 46) (NUMERIC. 13) (FRONT 14) (<- 15) (BS 15) (%# 16 T) (|3| 16 B) (@ 17 T) (|2| 17 B) (W 18) (w 18) (Q 19) (q 19) (S 20) (s 20) (A 21) (a 21) (%( 22 T) (|9| 22 B) (I 23) (i 23) (X 24) (x 24) (O 25) (o 25) (L 26) (l 26) (< 27 T) (%, 27 B) (%" 28 T) (%' 28 B) (} 29 T) (%] 29 B) (ALT 31) (! 32 T) (|1| 32 B) (ESC 33) (=> 34) (TAB 34) (F 35) (f 35) (CONTROL 36) (C 37) (c 37) (J 38) (j 38) (B 39) (b 39) (Z 40) (z 40) (LSHIFT 41) (> 42 T) (%. 42 B) (%: 43 T) (; 43 B) (RETURN 44) (CR 44) (NEXT 47) (SKIP 47) (R 48) (r 48) (T 49) (t 49) (G 50) (g 50) (Y 51) (y 51) (H 52) (h 52) (* 53 T) (|8| 53 B) (N 54) (n 54) (M 55) (m 55) (LOCK 56) (SPACE 57) ({ 58 T) (%[ 58 B) (+ 59 T) (= 59 B) (RSHIFT 60) (STOP 61) (PASTE 62) (UNDO 63) (NUMERIC= 64) (NUMERIC/ 65) (F7 66) (F4 67) (F5 68) (NUMERIC2 69) (NUMERIC3 70) (LINEFEED 71) (NUMLOCK 73) (SCRLLOCK 74) (PAUSE 75) (ENTER 76) (F9 80) (NUMERIC7 81) (NUMERIC8 82) (NUMERIC9 83) (NUMERIC4 84) (NUMERIC5 85) (LDIAMOND 86) (NUMERIC6 87) (RDIAMOND 88) (COPY 89) (FIND 90) (AGAIN 91) (HELP 92) (ALTGRAPH 93) (NUMERIC1 94) (NUMERIC* 95) (NUMERIC- 96) (F1 97) (INS 98) (NUMERIC0 98) (F2 99) (F3 100) (F6 101) (NUMERIC+ 102) (F8 104) (\ 105 B) (%| 105 T) (F10 106) (F11 107) (F12 108) (PROPS 109) (PRTSCR 110) (OPEN 111) (ZERO |0|) (ONE |1|) (TWO |2|) (THREE |3|) (FOUR |4|) (FIVE |5|) (SIX |6|) (SEVEN |7|) (EIGHT |8|) (NINE |9|)) MAIKO ((<- "BACK SPACE") (=> "TAB") (AGAIN "AGAIN") (ALT ALT) (ALTGRAPH NEXT) (CONTROL "CTRL") (COPY "COPY") (CUT "CUT") (ENTER "ENTER") (FIND "FIND") (FRONT SAME) (HELP "HELP") (LDIAMOND "META") (NEXT EXPAND) (NUMERIC. DELETE% WORD) (OPEN "OPEN") (PASTE MOVE) (PAUSE "PAUSE") (PROPS "PROPS") (PRTSCR "PR SC") (RDIAMOND "RDMND") (RETURN "RTRN") (SCRLLOCK ("SCRL" "LOCK")) (STOP "STOP") (UNDO "UNDO")) (HELVETICA 6) 23130 (CLASSIC 10) NIL) (DORADO NIL ((|5| (178 154 29 33)) (|4| (146 154 29 33)) (|6| (210 154 29 33)) (E (130 118 29 33)) (|7| (242 154 29 33)) (D (138 82 29 33)) (U (258 118 29 33)) (V (186 46 29 33)) (|0| (338 154 29 33)) (K (298 82 29 33)) (- (370 154 29 33)) (P (354 118 29 33)) (? (378 46 29 33)) (\ (434 154 29 33)) (LF (466 154 29 33)) (<- (482 118 29 33)) (|3| (114 154 29 33)) (|2| (82 154 29 33)) (W (98 118 29 33)) (Q (66 118 29 33)) (S (106 82 29 33)) (A (74 82 29 33)) (|9| (306 154 29 33)) (I (290 118 29 33)) (X (122 46 29 33)) (O (322 118 29 33)) (L (330 82 29 33)) (< (314 46 29 33)) (%" (394 82 29 33)) (} (418 118 29 33)) (BLANK-MIDDLE (492 82 29 33)) (BLANK-TOP (514 118 29 33)) (|1| (50 154 29 33)) (-> (18 154 29 33)) (=> (9 118 54 33)) (F (170 82 29 33)) (CTRL (18 82 52 33)) (C (154 46 29 33)) (J (266 82 29 33)) (B (218 46 29 33)) (Z (90 46 29 33)) (LSHIFT (38 46 49 33)) (> (346 46 29 33)) (%: (362 82 29 33)) (<-%| (426 82 63 33)) (^ (450 118 29 33)) (DEL (498 154 29 33)) (R (162 118 29 33)) (T (194 118 29 33)) (G (202 82 29 33)) (Y (226 118 29 33)) (H (234 82 29 33)) (|8| (274 154 29 33)) (N (250 46 29 33)) (M (282 46 29 33)) (LOCK (6 46 29 33)) (SPACE (110 10 279 33)) ({ (386 118 29 33)) (+ (402 154 29 33)) (RSHIFT (410 46 63 33)) (BLANK-BOTTOM (476 46 29 33))) NIL ((%" (%' %" NLS)) (+ (= + NLS)) (- (- -)) (%: (; %: NLS)) (< (%, < NLS)) (<-%| (CR CR)) (> (%. > NLS)) (? (/ ? NLS)) (BLANK-BOTTOM (% % )) (BLANK-MIDDLE (% % )) (BLANK-TOP (% % )) (CTRL CTRLDOWN . CTRLUP) (DEL (DEL DEL)) (LF (LF LF)) (LOCK LOCKDOWN . LOCKUP) (\ (\ %| NLS)) (^ (_ ^ NLS)) ({ (%[ { NLS)) (} (%] } NLS))) ((BLANK-MIDDLE 30) (BLANK-TOP 31) (BLANK-BOTTOM 61) (w 18) (W 18) (|5| 0) (%% 0) (|4| 1) ($ 1) (\ 13) (|6| 2) (~ 2) (e 3) (E 3) (|7| 4) (& 4) (d 5) (D 5) (u 6) (U 6) (v 7) (V 7) (|0| 8) (%) 8) (k 9) (K 9) (- 10) (p 11) (P 11) (/ 12) (? 12) (BS 15) (<- 15) (|3| 16) (%# 16) (|2| 17) (@ 17) (q 19) (Q 19) (s 20) (S 20) (a 21) (A 21) (|9| 22) (%( 22) (i 23) (I 23) (x 24) (X 24) (o 25) (O 25) (l 26) (L 26) (%, 27) (< 27) (%' 28) (%" 28) (%] 29) (} 29) (|1| 32) (! 32) (ESC 33) (ESCAPE 33) (-> 33) (TAB 34) (LF 14) (=> 34) (f 35) (F 35) (c 37) (C 37) (j 38) (J 38) (b 39) (B 39) (z 40) (Z 40) (LSHIFT 41) (%. 42) (> 42) (; 43) (%: 43) (CR 44) (<-%| 44) (_ 45) (^ 45) (r 48) (R 48) (t 49) (T 49) (g 50) (G 50) (y 51) (Y 51) (h 52) (H 52) (|8| 53) (* 53) (n 54) (N 54) (m 55) (M 55) (LOCK 56) (CTRL 36) (DEL 46) (SPACE 57) (%[ 58) ({ 58) (= 59) (+ 59) (RSHIFT 60) (ZERO |0|) (ONE |1|) (TWO |2|) (THREE |3|) (FOUR |4|) (FIVE |5|) (SIX |6|) (SEVEN |7|) (EIGHT |8|) (NINE |9|)) DORADO ((CTRL CONTROL)) (HELVETICA 5) 23130 (CLASSIC 10) NIL) (DANDELION NIL ((SPACE (110 10 279 33)) (<- (434 154 53 33)) (=> (18 118 45 33)) (<-%| (450 118 37 33) (458 82 29 36)) (-> (18 154 29 33)) (LSHIFT (18 46 69 33)) (RSHIFT (410 46 77 33)) (LOCK (18 82 53 33)) (|1| (50 154 29 33)) (|2| (82 154 29 33)) (|3| (114 154 29 33)) (|4| (146 154 29 33)) (|5| (178 154 29 33)) (|6| (210 154 29 33)) (|7| (242 154 29 33)) (|8| (274 154 29 33)) (|9| (306 154 29 33)) (|0| (338 154 29 33)) (- (370 154 29 33)) (+ (402 154 29 33)) (Q (66 118 29 33)) (W (98 118 29 33)) (E (130 118 29 33)) (R (162 118 29 33)) (T (194 118 29 33)) (Y (226 118 29 33)) (U (258 118 29 33)) (I (290 118 29 33)) (O (322 118 29 33)) (P (354 118 29 33)) ({ (386 118 29 33)) (} (418 118 29 33)) (A (74 82 29 33)) (S (106 82 29 33)) (D (138 82 29 33)) (F (170 82 29 33)) (G (202 82 29 33)) (H (234 82 29 33)) (J (266 82 29 33)) (K (298 82 29 33)) (L (330 82 29 33)) (%: (362 82 29 33)) (%" (394 82 29 33)) (~ (426 82 29 33)) (Z (90 46 29 33)) (X (122 46 29 33)) (C (154 46 29 33)) (V (186 46 29 33)) (B (218 46 29 33)) (N (250 46 29 33)) (M (282 46 29 33)) (< (314 46 29 33)) (> (346 46 29 33)) (? (378 46 29 33))) NIL ((%" (%' %" NLS)) (+ (= + NLS)) (- (- _ NLS)) (ESC (ESC %| NLS)) (%: (; %: NLS)) (< (%, < NLS)) (<-%| (CR CR)) (> (%. > NLS)) (? (/ ? NLS)) (LOCK LOCKDOWN . LOCKUP) ({ (%[ { NLS)) (} (%] } NLS)) (~ (%` ~ NLS))) ((%` 45) (~ 45) (^ 2) (|6| 2) (w 18) (W 18) (|5| 0) (%% 0) (|4| 1) ($ 1) (e 3) (E 3) (|7| 4) (& 4) (d 5) (D 5) (u 6) (U 6) (v 7) (V 7) (|0| 8) (%) 8) (k 9) (K 9) (- 10) (p 11) (P 11) (/ 12) (? 12) (BS 15) (<- 15) (|3| 16) (%# 16) (|2| 17) (@ 17) (q 19) (Q 19) (s 20) (S 20) (a 21) (A 21) (|9| 22) (%( 22) (i 23) (I 23) (x 24) (X 24) (o 25) (O 25) (l 26) (L 26) (%, 27) (< 27) (%' 28) (%" 28) (%] 29) (} 29) (|1| 32) (! 32) (ESC 33) (ESCAPE 33) (-> 33) (TAB 34) (=> 34) (f 35) (F 35) (c 37) (C 37) (j 38) (J 38) (b 39) (B 39) (z 40) (Z 40) (LSHIFT 41) (%. 42) (> 42) (; 43) (%: 43) (CR 44) (<-%| 44) (r 48) (R 48) (t 49) (T 49) (g 50) (G 50) (y 51) (Y 51) (h 52) (H 52) (|8| 53) (* 53) (n 54) (N 54) (m 55) (M 55) (LOCK 56) (SPACE 57) (%[ 58) ({ 58) (= 59) (+ 59) (RSHIFT 60) (ZERO |0|) (ONE |1|) (TWO |2|) (THREE |3|) (FOUR |4|) (FIVE |5|) (SIX |6|) (SEVEN |7|) (EIGHT |8|) (NINE |9|)) DANDELION NIL (HELVETICA 5) 23130 (CLASSIC 10) NIL) (DOVE NIL ((|5| (178 138 29 29)) (|4| (146 138 29 29)) (|6| (210 138 29 29)) (E (130 106 29 29)) (|7| (242 138 29 29)) (D (138 74 29 29)) (U (258 106 29 29)) (V (186 42 29 29)) (|0| (338 138 29 29)) (K (298 74 29 29)) (- (370 138 29 29)) (P (354 106 29 29)) (? (378 42 29 29)) (<- (434 138 53 29)) (|3| (114 138 29 29)) (|2| (82 138 29 29)) (W (98 106 29 29)) (Q (66 106 29 29)) (S (106 74 29 29)) (A (74 74 29 29)) (|9| (306 138 29 29)) (I (290 106 29 29)) (X (122 42 29 29)) (O (322 106 29 29)) (L (330 74 29 29)) (< (314 42 29 29)) (%" (394 74 29 29)) (} (418 106 29 29)) (|1| (50 138 29 29)) (=> (18 106 45 29)) (F (170 74 29 29)) (C (154 42 29 29)) (J (266 74 29 29)) (B (218 42 29 29)) (Z (90 42 29 29)) (LSHIFT (18 42 69 29)) (> (346 42 29 29)) (%: (362 74 29 29)) (<-%| (450 106 37 29) (458 74 29 32)) (%` (426 74 29 29)) (R (162 106 29 29)) (T (194 106 29 29)) (G (202 74 29 29)) (Y (226 106 29 29)) (H (234 74 29 29)) (|8| (274 138 29 29)) (N (250 42 29 29)) (M (282 42 29 29)) (LOCK (18 74 53 29)) (SPACE (110 10 279 29)) ({ (386 106 29 29)) (+ (402 138 29 29)) (RSHIFT (410 42 77 29)) (-> (18 138 29 29)) (NUMERIC+ (520 138 29 29)) (NUMERIC- (552 138 29 29)) (NUMERIC* (584 138 29 29)) (NUMERIC/ (616 138 29 29)) (CLEAR (520 106 29 29)) (NUMERIC7 (552 106 29 29)) (NUMERIC8 (584 106 29 29)) (NUMERIC9 (616 106 29 29)) (NEXT (520 42 29 61)) (NUMERIC4 (552 74 29 29)) (NUMERIC5 (584 74 29 29)) (NUMERIC6 (616 74 29 29)) (NUMERIC1 (552 42 29 29)) (NUMERIC2 (584 42 29 29)) (NUMERIC3 (616 42 29 29)) (NUMERIC0 (520 10 61 29)) (NUMERIC. (584 10 29 29)) (NUMERIC, (616 10 29 29)) (KEYBOARD (18 10 45 29)) (EXPAND (434 10 53 29))) NIL ((%" (%' %" NLS)) (+ (= + NLS)) (- (- _ NLS)) (%: (; %: NLS)) (< (%, < NLS)) (<-%| (CR CR)) (> (%. > NLS)) (? (/ ? NLS)) (CLEAR (CLEAR DOIT NLS)) (EXPAND (2,24 2,64 NLS)) (KEYBOARD METADOWN . METAUP) (LOCK LOCKDOWN . LOCKUP) (NEXT (2,22 2,62 NLS)) (NUMERIC* (NUMLK ´ NLS)) (NUMERIC+ (HELP 2,45 NLS)) (NUMERIC, (\ %, NLS)) (NUMERIC- (SCRL - NLS)) (NUMERIC. (%| 21 NLS)) (NUMERIC/ (BREAK ¸ NLS)) (NUMERIC0 (INS |0| NLS)) (NUMERIC1 (END |1| NLS)) (NUMERIC2 (¯ |2| NLS)) (NUMERIC3 (PGDN |3| NLS)) (NUMERIC4 (¬ |4| NLS)) (NUMERIC5 (% |5| NLS)) (NUMERIC6 (® |6| NLS)) (NUMERIC7 (HOME |7| NLS)) (NUMERIC8 (­ |8| NLS)) (NUMERIC9 (PGUP |9| NLS)) (%` (%` ~ NLS)) ({ (%[ { NLS)) (} (%] } NLS))) ((INS 98) (|5| 0) (%% 0) (|4| 1) ($ 1) (|6| 2) (^ 2) (e 3) (E 3) (|7| 4) (& 4) (d 5) (D 5) (u 6) (U 6) (v 7) (V 7) (|0| 8) (%) 8) (k 9) (K 9) (- 10) (p 11) (P 11) (/ 12) (? 12) (BS 15) (<- 15) (|3| 16) (%# 16) (|2| 17) (@ 17) (w 18) (W 18) (q 19) (Q 19) (s 20) (S 20) (a 21) (A 21) (|9| 22) (%( 22) (i 23) (I 23) (x 24) (X 24) (o 25) (O 25) (l 26) (L 26) (%, 27) (< 27) (%' 28) (%" 28) (%] 29) (} 29) (|1| 32) (! 32) (ESC 65) (ESCAPE 65) (-> 65) (TAB 34) (=> 34) (f 35) (F 35) (c 37) (C 37) (j 38) (J 38) (b 39) (B 39) (z 40) (Z 40) (LSHIFT 41) (%. 42) (> 42) (; 43) (%: 43) (CR 44) (<-%| 44) (~ 45) (%` 45) (r 48) (R 48) (t 49) (T 49) (g 50) (G 50) (y 51) (Y 51) (h 52) (H 52) (|8| 53) (* 53) (n 54) (N 54) (m 55) (M 55) (LOCK 56) (SPACE 57) (%[ 58) ({ 58) (= 59) (+ 59) (RSHIFT 60) (NUMERIC+ 72) (NUMERIC- 73) (NUMERIC* 74) (NUMERIC/ 75) (CLEAR 76) (NUMERIC7 81) (NUMERIC8 82) (NUMERIC9 83) (NUMERIC4 84) (NUMERIC5 85) (NUMERIC6 87) (SKIP 47) (NEXT 47) (NUMERIC1 94) (NUMERIC2 69) (NUMERIC3 70) (NUMERIC0 98) (NUMERIC. 105) (NUMERIC, 106) (KEYBOARD 31) (DEFINE 93) (EXPAND 93) (ZERO |0|) (ONE |1|) (TWO |2|) (THREE |3|) (FOUR |4|) (FIVE |5|) (SIX |6|) (SEVEN |7|) (EIGHT |8|) (NINE |9|)) DOVE ((-> ESC) (CLEAR "CLEAR") (EXPAND "EXPAND") (KEYBOARD META) (NEXT NEXT) (NUMERIC+ HELP)) (HELVETICA 5) 23130 (CLASSIC 10) NIL) (FULL-IBMPC NIL ((SPACE (198 10 242 29)) (BS (536 138 29 29)) (TAB (88 106 45 29)) (ENTER (496 74 69 29) (520 103 45 32)) (%` (88 138 29 29)) (LALT (160 10 36 29)) (RALT (443 10 36 29)) (LSHIFT (88 42 69 29)) (RSHIFT (480 42 85 29)) (LOCK (88 74 53 29)) (|1| (120 138 29 29)) (|2| (152 138 29 29)) (|3| (184 138 29 29)) (|4| (216 138 29 29)) (|5| (248 138 29 29)) (|6| (280 138 29 29)) (|7| (312 138 29 29)) (|8| (344 138 29 29)) (|9| (376 138 29 29)) (|0| (408 138 29 29)) (- (440 138 29 29)) (= (472 138 29 29)) (Q (136 106 29 29)) (W (168 106 29 29)) (E (200 106 29 29)) (R (232 106 29 29)) (T (264 106 29 29)) (Y (296 106 29 29)) (U (328 106 29 29)) (I (360 106 29 29)) (O (392 106 29 29)) (P (424 106 29 29)) (%[ (456 106 29 29)) (%] (488 106 29 29)) (A (144 74 29 29)) (S (176 74 29 29)) (D (208 74 29 29)) (F (240 74 29 29)) (G (272 74 29 29)) (H (304 74 29 29)) (J (336 74 29 29)) (K (368 74 29 29)) (L (400 74 29 29)) (; (432 74 29 29)) (%' (464 74 29 29)) (Z (160 42 29 29)) (X (192 42 29 29)) (C (224 42 29 29)) (V (256 42 29 29)) (B (288 42 29 29)) (N (320 42 29 29)) (M (352 42 29 29)) (%, (384 42 29 29)) (%. (416 42 29 29)) (/ (448 42 29 29)) (LCTRL (88 10 45 29)) (RCTRL (512 10 53 29)) (NUMLOCK (582 138 29 29)) (NUMERIC/ (614 138 29 29)) (NUMERIC* (646 138 29 29)) (NUMERIC- (678 138 29 29)) (NUMERIC7 (582 106 29 29)) (NUMERIC8 (614 106 29 29)) (NUMERIC9 (646 106 29 29)) (NUMERIC+ (678 74 29 61)) (NUMERIC4 (582 74 29 29)) (NUMERIC5 (614 74 29 29)) (NUMERIC6 (646 74 29 29)) (NUMERIC1 (582 42 29 29)) (NUMERIC2 (614 42 29 29)) (NUMERIC3 (646 42 29 29)) (NUMERIC0 (582 10 61 29)) (NUMERICENTER (678 10 29 61)) (NUMERIC. (646 10 29 29)) (\ (504 138 29 29)) ((201) (10 138 29 29)) ((202) (42 138 29 29)) ((203) (10 106 29 29)) ((204) (42 106 29 29)) ((205) (10 74 29 29)) ((206) (42 74 29 29)) ((207) (10 42 29 29)) ((208) (42 42 29 29)) ((209) (10 10 29 29)) ((210) (42 10 29 29))) NIL ((%' (%' %" NLS)) (; (; %: NLS)) (%, (%, < NLS)) (= (= + NLS)) (%. (%. > NLS)) (/ (/ ? NLS)) (\ (\ %| NLS)) (- (- _ NLS)) (%` (%` ~ NLS)) (%[ (%[ { NLS)) (%] (%] } NLS)) (ENTER (CR CR)) (LCTRL CTRLDOWN . CTRLUP) (RCTRL (2,22 2,62 NLS)) (LOCK LOCKTOGGLE) (LALT METADOWN . METAUP) (NUMERIC+ (+ +)) (NUMERIC- (- -)) (NUMERIC. (23 21)) (NUMERIC* (* *)) (NUMERIC/ (/ /)) (NUMERIC0 (INS |0| NLS)) (NUMERIC1 (END |1| NLS)) (NUMERIC2 (¯ |2| NLS)) (NUMERIC3 (PGDN |3| NLS)) (NUMERIC4 (¬ |4| NLS)) (NUMERIC5 (|5| |5|)) (NUMERIC6 (® |6| NLS)) (NUMERIC7 (HOME |7| NLS)) (NUMERIC8 (­ |8| NLS)) (NUMERIC9 (PGUP |9| NLS)) (NUMERICENTER (CR CR)) (RALT METADOWN . METAUP) (F1 (CENTER NOTCENTER NLS)) (F2 (BOLD NOTBOLD NLS)) (F3 (ITALIC NOTITALIC NLS)) (F4 (UCASE LCASE NLS)) (F5 (STRIKEOUT NOTSTRIKEOUT NLS)) (F6 (UNDERLINE NOTUNDERLINE NLS)) (F7 (SUBSCRIPT SUPERSCRIPT NLS)) (F8 (SMALLER LARGER NLS)) (F9 (MARGINS NOTMARGINS NLS)) (F10 (LOOKS NOTLOOKS NLS)) (F11 (F11 NOTF11 NLS)) (F12 (F12 NOTF12 NLS))) ((%' 28 B) (%" 28 T) (%, 27 B) (< 27 T) (- 10 B) (_ 10 T) (> 42 T) (%. 42 B) (/ 12 B) (? 12 T) (! 32 T) (@ 17 T) (%# 16 T) ($ 1 T) (%% 0 T) (^ 4 T) (* 53 T) (%( 22 T) (%) 8 T) (|1| 32 B) (ONE |1|) (|2| 17 B) (TWO |2|) (|3| 16 B) (THREE |3|) (|4| 1 B) (FOUR |4|) (|5| 0 B) (FIVE |5|) (|6| 2 B) (SIX |6|) (|7| 4 B) (SEVEN |7|) (|8| 53 B) (EIGHT |8|) (|9| 22 B) (NINE |9|) (|0| 8 B) (ZERO |0|) (; 43 B) (%: 43 T) (= 59 B) (+ 59 T) (A 21 T) (B 39 T) (C 37 T) (D 5 T) (E 3 T) (F 35 T) (G 50 T) (H 52 T) (I 23 T) (J 38 T) (K 9 T) (L 26 T) (M 55 T) (N 54 T) (O 25 T) (P 11 T) (Q 19 T) (R 48 T) (S 20 T) (T 49 T) (U 6 T) (V 7 T) (W 18 T) (X 24 T) (Y 51 T) (Z 40 T) (a 21 B) (b 39 B) (c 37 B) (d 5 B) (e 3 B) (f 35 B) (g 50 B) (h 52 B) (i 23 B) (j 38 B) (k 9 B) (l 26 B) (m 55 B) (n 54 B) (o 25 B) (p 11 B) (q 19 B) (r 48 B) (s 20 B) (t 49 B) (u 6 B) (v 7 B) (w 18 B) (x 24 B) (y 51 B) (z 40 B) (%[ 58 B) ({ 58 T) (%] 29 B) (} 29 T) (%` 45 B) (~ 45 T) (%| 105 T) (\ 105 B) (BS 15) (ENTER 44) (DELETE 46) (END 90) (ESC 33) (F1 97) (F10 106) (F11 107) (F12 108) (F2 99) (F3 100) (F4 67) (F5 68) (F6 101) (F7 66) (F8 104) (F9 80) (HOME 62) (INSERT 89) (LALT 31) (META LALT) (LCTRL 36) (LOCK 56) (LSHIFT 41) (NUMERIC* 95) (NUMERIC+ 102) (NUMERIC- 96) (NUMERIC. 13) (NUMERIC/ 65) (NUMERIC0 98) (NUMERIC1 94) (NUMERIC2 69) (NUMERIC3 70) (NUMERIC4 84) (NUMERIC5 85) (NUMERIC6 87) (NUMERIC7 81) (NUMERIC8 82) (NUMERIC9 83) (NUMERICENTER 76) (NUMLOCK 75) (PAGEDOWN 91) (PAGEUP 63) (PAUSE 61) (PRINTSCREEN 92) (RALT 47) (EXPAND RALT) (RCTRL 93) (NEXT RCTRL) (RSHIFT 60) (SCRLLOCK 14) (SPACE 57) (TAB 34)) IBMPC ((DELETE "CUT") (END "FIND") (ENTER "ENTER") (HOME MOVE) (INSERT "COPY") (PAGEDOWN "AGAIN") (PAGEUP "UNDO") (PAUSE "STOP") (PRINTSCREEN "HELP") (RALT EXPAND) (RCTRL NEXT) (SCRLLOCK SAME)) (HELVETICA 6) 23130 (CLASSIC 10) NIL) (MAIKO-EUROPEAN NIL ((HELP (10 10 61 29)) (FIND (10 42 29 29)) (CUT (42 42 29 29)) (OPEN (10 74 29 29)) (PASTE (42 74 29 29)) (FRONT (10 106 29 29)) (COPY (42 106 29 29)) (PROPS (10 138 29 29)) (UNDO (42 138 29 29)) (STOP (10 170 29 29)) (AGAIN (42 170 29 29)) (NUMERIC0 (618 10 61 29)) (NUMERIC. (682 10 29 29)) (ENTER (714 10 29 61)) (NUMERIC1 (618 42 29 29)) (NUMERIC2 (650 42 29 29)) (NUMERIC3 (682 42 29 29)) (NUMERIC4 (618 74 29 29)) (NUMERIC5 (650 74 29 29)) (NUMERIC6 (682 74 29 29)) (NUMERIC+ (714 74 29 61)) (NUMERIC7 (618 106 29 29)) (NUMERIC8 (650 106 29 29)) (NUMERIC9 (682 106 29 29)) (NUMERIC= (618 138 29 29)) (NUMERIC/ (650 138 29 29)) (NUMERIC* (682 138 29 29)) (NUMERIC- (714 138 29 29)) (PAUSE (618 170 29 29)) (PRTSCR (650 170 29 29)) (SCRLLOCK (682 170 29 29)) (NUMLOCK (714 170 29 29)) (CAPSLOCK (106 10 29 29)) (ALT (138 10 29 29)) (LDIAMOND (170 10 29 29)) (SPACE (202 10 285 29)) (RDIAMOND (490 10 29 29)) (COMPOSE (522 10 29 29)) (ALTGRAPH (554 10 29 29)) (LSHIFT (106 42 37 29)) (%[ (146 42 29 29)) (Y (178 42 29 29)) (X (210 42 29 29)) (C (242 42 29 29)) (V (274 42 29 29)) (B (306 42 29 29)) (N (338 42 29 29)) (M (370 42 29 29)) (; (402 42 29 29)) (%: (434 42 29 29)) (_ (466 42 29 29)) (RSHIFT (498 42 53 29)) (LINEFEED (554 42 29 29)) (CONTROL (106 74 53 29)) (A (162 74 29 29)) (S (194 74 29 29)) (D (226 74 29 29)) (F (258 74 29 29)) (G (290 74 29 29)) (H (322 74 29 29)) (J (354 74 29 29)) (K (386 74 29 29)) (L (418 74 29 29)) (OUMLAUT (450 74 29 29)) (AUMLAUT (482 74 29 29)) (DEADTILDE (514 74 29 29)) (CR (546 74 37 32) (538 106 45 29)) (TAB (106 106 45 29)) (Q (154 106 29 29)) (W (186 106 29 29)) (E (218 106 29 29)) (R (250 106 29 29)) (T (282 106 29 29)) (Z (314 106 29 29)) (U (346 106 29 29)) (I (378 106 29 29)) (O (410 106 29 29)) (P (442 106 29 29)) (UUMLAUT (474 106 29 29)) (DEADACUTE (506 106 29 29)) (ESC (106 138 29 29)) (|1| (138 138 29 29)) (|2| (170 138 29 29)) (|3| (202 138 29 29)) (|4| (234 138 29 29)) (|5| (266 138 29 29)) (|6| (298 138 29 29)) (|7| (330 138 29 29)) (|8| (362 138 29 29)) (|9| (394 138 29 29)) (|0| (426 138 29 29)) (? (458 138 29 29)) (DEADGRAVE (490 138 29 29)) (BACKSPACE (522 138 61 29)) (F1 (106 170 29 29)) (F2 (138 170 29 29)) (F3 (170 170 29 29)) (F4 (202 170 29 29)) (F5 (234 170 29 29)) (F6 (266 170 29 29)) (F7 (298 170 29 29)) (F8 (330 170 29 29)) (F9 (362 170 29 29)) (F10 (394 170 29 29)) (F11 (426 170 29 29)) (F12 (458 170 29 29)) ({ (490 170 29 29)) (} (522 170 29 29)) (DELETE (554 170 29 29))) NIL ((ZERO (|0| = NLS)) (ONE (|1| + NLS)) (TWO (|2| %" NLS)) (THREE (|3| * NLS)) (FOUR (|4| ‡ NLS)) (SIX (|6| & NLS)) (SEVEN (|7| / NLS)) (EIGHT (|8| %( NLS)) (NINE (|9| %) NLS)) (%: (%. %: NLS)) (; (%, ; NLS)) (? (%' ? NLS)) (AUMLAUT (… „ NLS)) (CAPSLOCK CTRLDOWN . CTRLUP) (CONTROL LOCKDOWN . LOCKUP) (CR (CR CR)) (DEADACUTE EVENT . EVENT) (DEADGRAVE EVENT . EVENT) (DEADTILDE ($ $)) (ENTER (CR CR)) (NUMERIC* (* *)) (NUMERIC+ (+ +)) (NUMERIC- (- -)) (NUMERIC. (23 21)) (NUMERIC/ (/ /)) (NUMERIC0 (|0| |0|)) (NUMERIC1 (|1| |1|)) (NUMERIC2 (|2| |2|)) (NUMERIC3 (|3| |3|)) (NUMERIC4 (|4| |4|)) (NUMERIC5 (|5| |5|)) (NUMERIC6 (|6| |6|)) (NUMERIC7 (|7| |7|)) (NUMERIC8 (|8| |8|)) (NUMERIC9 (|9| |9|)) (NUMERIC= (= =)) (OUMLAUT (‚ ” NLS)) (UUMLAUT (Š NLS)) (%[ (%] %[ NLS)) (_ (- _ NLS)) ({ (< { NLS)) (} (> } NLS))) ((HELP 0) (FIND 1) (CUT 2) (OPEN 3) (PASTE 4) (FRONT 5) (COPY 6) (PROPS 7) (UNDO 8) (STOP 9) (AGAIN 10) (NUMERIC0 11) (NUMERIC. 12) (ENTER 13) (NUMERIC1 14) (NUMERIC2 15) (NUMERIC3 16) (NUMERIC4 17) (NUMERIC5 18) (NUMERIC6 19) (NUMERIC+ 20) (NUMERIC7 21) (NUMERIC8 22) (NUMERIC9 23) (NUMERIC= 24) (NUMERIC/ 25) (NUMERIC* 26) (NUMERIC- 27) (PAUSE 28) (PRTSCR 29) (SCRLLOCK 30) (NUMLOCK 31) (CAPSLOCK 32) (ALT 33) (LDIAMOND 34) (SPACE 35) (RDIAMOND 36) (COMPOSE 37) (ALTGRAPH 38) (LSHIFT 39) (%] 40) (%[ 40) (y 41) (Y 41) (x 42) (X 42) (c 43) (C 43) (v 44) (V 44) (b 45) (B 45) (n 46) (N 46) (m 47) (M 47) (%, 48) (; 48) (%. 49) (%: 49) (- 50) (_ 50) (RSHIFT 51) (LINEFEED 52) (CONTROL 53) (a 54) (A 54) (s 55) (S 55) (d 56) (D 56) (f 57) (F 57) (g 58) (G 58) (h 59) (H 59) (j 60) (J 60) (k 61) (K 61) (l 62) (L 62) (EACUTE 63) (OUMLAUT 63) (AGRAVE 64) (AUMLAUT 64) ($ 65) (DEADTILDE 65) (RETURN 66) (CR 66) (TAB 67) (q 68) (Q 68) (w 69) (W 69) (e 70) (E 70) (r 71) (R 71) (t 72) (T 72) (z 73) (Z 73) (u 74) (U 74) (i 75) (I 75) (o 76) (O 76) (p 77) (P 77) (EGRAVE 78) (UUMLAUT 78) (DEADUMLAUT 79) (DEADACUTE 79) (ESC 80) (|1| 81) (+ 81) (|2| 82) (%" 82) (|3| 83) (* 83) (|4| 84) (CEDILLA 84) (|5| 85) (%% 85) (|6| 86) (& 86) (|7| 87) (/ 87) (|8| 88) (%( 88) (|9| 89) (%) 89) (|0| 90) (= 90) (%' 91) (? 91) (DEADCIRCUMFLEX 92) (DEADGRAVE 92) (BACKSPACE 93) (BS BACKSPACE) (F1 94) (F2 95) (F3 96) (F4 97) (F5 98) (F6 99) (F7 100) (F8 101) (F9 102) (F10 103) (F11 104) (F12 105) (< 106) ({ 106) (> 107) (} 107) (DELETE 108) (ZERO |0|) (ONE |1|) (TWO |2|) (THREE |3|) (FOUR |4|) (FIVE |5|) (SIX |6|) (SEVEN |7|) (EIGHT |8|) (NINE |9|)) MAIKO ((AGAIN "AGAIN") (ALT "ALT") (ALTGRAPH "CMPSE") (BACKSPACE "BS") (CAPSLOCK "CTRL") (COMPOSE ("ALT" "GRPH")) (CONTROL ("CAPS" "LOCK")) (COPY "COPY") (CR "RTRN") (CUT "CUT") (DELETE "DEL") (ENTER "ENTER") (FIND "FIND") (FRONT "FRONT") (HELP "HELP") (LDIAMOND "LDMND") (OPEN "OPEN") (PASTE "PASTE") (PAUSE "PAUSE") (PROPS "PROPS") (PRTSCR "PR SC") (RDIAMOND "RDMND") (SCRLLOCK ("SCRL" "LOCK")) (STOP "STOP") (UNDO "UNDO")) (HELVETIC 6) 23130 (CLASSIC 10) NIL)) (PUTPROPS KEYBOARDCONFIGS COPYRIGHT ("Xerox Corporation" 1996 1997)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/library/KEYBOARDEDITOR b/library/KEYBOARDEDITOR new file mode 100644 index 00000000..fbd6e7d4 --- /dev/null +++ b/library/KEYBOARDEDITOR @@ -0,0 +1,438 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "25-May-95 14:32:35" {DSK}medley2.0>library>KEYBOARDEDITOR.;4 51139 changes to%: (FNS EDITKEYBOARD VKBD.EDIT.CREATE-DISPLAY) previous date%: "25-May-95 11:35:16" {DSK}medley2.0>library>KEYBOARDEDITOR.;2) (* ; " Copyright (c) 1985, 1987, 1990, 1995 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT KEYBOARDEDITORCOMS) (RPAQQ KEYBOARDEDITORCOMS ((FILES VIRTUALKEYBOARDS) (COMS (* ;; "Editor for Configurations -- the description of the physical key layout, which keys are assignable, etc.") (FNS EDITCONFIGURATION VKBD.CONF.CHANGE-KEY-VALUE VKBD.CONF.DISPLAY-FIELD-VALUE VKBD.CONF.DISPLAY-INFO-KEYBOARD VKBD.CONF.DISPLAY-KEY-INFO VKBD.CONF.EDIT-DEFAULT-ASSIGNMENTS VKBD.CONF.ICONFN VKBD.CONF.PARSE-CONFIGURATION) (BITMAPS VKBD.CONF.ICON)) (* ;; "EEditor for keyboard layouts per se:") (FNS EDITKEYBOARD VKBD.EDIT.ADD-SUBITEM-TO-BACKGROUND-MENU VKBD.EDIT.CREATE-COMMAND-MENU VKBD.EDIT.CREATE-NON-CHAR-ASSIGMENTS-MENU VKBD.EDIT-KEYBOARD-COMMAND VKBD.EDIT.ASSIGN-CHARACTER VKBD.EDIT.ASSIGN-NON-CHARACTER VKBD.EDIT.CREATE-CHARACTER-SETS-MENU VKBD.EDIT.CREATE-CHARACTERS-MENU VKBD.EDIT.CREATE-DISPLAY VKBD.EDIT.DEFINE-COMMAND VKBD.EDIT.DO-MENU-COMMAND VKBD.EDIT.ICONFN VKBD.EDIT.INVERT-IF-LOCKED VKBD.EDIT.KEYBOARD-REPAINTFN VKBD.EDIT.LARGE-WINDOW-REPAINTFN VKBD.EDIT.MAKE-CURRENT-KEY VKBD.EDIT.QUIT-COMMAND VKBD.EDIT.STOP-COMMAND VKBD.EDIT.SWITCH-CHAR-SET-COMMAND VKBD.EDIT.SWITCH-CHARACTER-SET VKBD.EDIT.ROTATED-NUMBER) (INITVARS (VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS T) (VKBD.EDIT.MAX-NUMBER-OF-CASHED-MENUS 15) (VKBD.EDITOR-WINDOW-HEIGHT 450) (VKBD.EDITOR-WINDOW-WIDTH 512) (VKBD.EDIT.DISPLAY-CHAR-SETS-NAMES T)) (VARS VKBD.EDIT.BACKGROUND-MENU-SUBITEMS (VKBD.EDIT.CASH-MENUES NIL) VKBD.EDIT.CHAR-SET-NAMES VKBD.EDIT.MENU-ITEMS VKBD.EDIT.NON-CHAR-ASSIGNMENTS) (BITMAPS VKBD.EDIT.ICON VKBD.EDIT.MASK) (GLOBALVARS VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS VKBD.EDIT.BACKGROUND-MENU-SUBITEMS VKBD.EDIT.MAX-NUMBER-OF-CASHED-MENUS VKBD.EDITOR-WINDOW-HEIGHT VKBD.EDITOR-WINDOW-WIDTH VKBD.EDIT.DISPLAY-CHAR-SETS-NAMES VKBD.EDIT.CASH-MENUES VKBD.EDIT.CHAR-SET-NAMES VKBD.EDIT.MENU-ITEMS VKBD.EDIT.NON-CHAR-ASSIGNMENTS VKBD.CONF.ICON VKBD.EDIT.ICON VKBD.EDIT.MASK) (P (VKBD.EDIT.ADD-SUBITEM-TO-BACKGROUND-MENU (LIST "Edit" '(ADD.PROCESS '( VKBD.EDIT-KEYBOARD-COMMAND T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will use the default keyboard as the initial keyboard" VKBD.EDIT.BACKGROUND-MENU-SUBITEMS) "Keyboard")))) (FILESLOAD VIRTUALKEYBOARDS) (* ;; "Editor for Configurations -- the description of the physical key layout, which keys are assignable, etc." ) (DEFINEQ (EDITCONFIGURATION + [LAMBDA (CONFIGNAME) (* ; "Edited 30-Jun-87 10:03 by jds") + + (* ;; + "Edit a keyboard configuration, given the config's name or a handle on the config somehow.") + + (VKBD.CONF.DISPLAY-INFO-KEYBOARD CONFIGNAME]) (VKBD.CONF.CHANGE-KEY-VALUE + [LAMBDA (ITEM MENU MOUSEKEY) (* sm "14-Aug-85 18:05") + (PROG (MAINW CONF WINDOW PROMPTW KEY) + (SETQ WINDOW (WFROMMENU MENU)) + [SETQ PROMPTW (CAR (WINDOWPROP WINDOW 'PROMPTWINDOW] + (SETQ MAINW (MAINWINDOW WINDOW T)) + (SETQ CONF (VKBD.GET-CONFIGURATION MAINW)) + (SETQ KEY (WINDOWPROP MAINW 'VKBD.CONF.CURRENT-KEY)) + (SELECTQ (CADR ITEM) + (KEYID (PROG (NEW) + (SETQ NEW (CAR (TTYINEDIT (LIST KEY) + PROMPTW NIL "Enter new ID :"))) + (DSUBST NEW KEY CONF) + (WINDOWPROP MAINW 'VKBD.CONF.CURRENT-KEY NEW) + (SETQ KEY NEW))) + (REGIONS (PROG (CURRENT-REGIONS NEW-REGIONS) + (SETQ CURRENT-REGIONS (FASSOC KEY (fetch (KEYBOARDCONFIGURATION + KEYREGIONS) of CONF))) + (SETQ NEW-REGIONS (CAR (TTYINEDIT (LIST (CDR CURRENT-REGIONS)) + PROMPTW NIL "Enter new region(s) :"))) + (RPLACD CURRENT-REGIONS NEW-REGIONS))) + (DEFAULT (PROG (CURRENT-DEFAULT ASSIGNMENTS NEW) + (SETQ ASSIGNMENTS (fetch (KEYBOARDCONFIGURATION DEFAULTASSIGNMENT) + of CONF)) + (SETQ CURRENT-DEFAULT (FASSOC KEY ASSIGNMENTS)) + (SETQ ASSIGNMENTS (REMOVE CURRENT-DEFAULT ASSIGNMENTS)) + (SETQ NEW (CAR (TTYINEDIT (LIST (CDR CURRENT-DEFAULT)) + PROMPTW NIL "Enter new default(s):"))) + (replace (KEYBOARDCONFIGURATION DEFAULTASSIGNMENT) of CONF + with (CONS (CONS KEY NEW) + ASSIGNMENTS)) + (WINDOWPROP MAINW 'VKBD.KEYBOARD (VKBD.CREATE-DEFAULT-KEYBOARD CONF)))) + (NAMES (PROG (CURRENT NEW MAPPING) + (SETQ CURRENT (VKBD.KEY-ID-TO-KEY-NAMES KEY CONF)) + (SETQ MAPPING (fetch (KEYBOARDCONFIGURATION KEYNAMESMAPPING) of CONF)) + (for N in CURRENT do (SETQ MAPPING (REMOVE (LIST N KEY) + MAPPING))) + (SETQ NEW (CAR (TTYINEDIT (LIST CURRENT) + PROMPTW NIL "Enter new NAME(s) :"))) + (for N in (MKLIST NEW) do (pushnew MAPPING (LIST N KEY))) + (replace (KEYBOARDCONFIGURATION KEYNAMESMAPPING) of CONF with MAPPING))) + (LABEL (PROG (OLD-LABEL LABELS NEW) + (SETQ LABELS (fetch (KEYBOARDCONFIGURATION KEYLABELS) of CONF)) + (SETQ OLD-LABEL (FASSOC KEY LABELS)) + (if OLD-LABEL + then (SETQ LABELS (REMOVE OLD-LABEL LABELS)) + (SETQ OLD-LABEL (CADR OLD-LABEL))) + (SETQ NEW (CAR (TTYINEDIT (LIST OLD-LABEL) + PROMPTW NIL "Enter new LABEL :"))) + (replace (KEYBOARDCONFIGURATION KEYLABELS) of CONF + with (if NEW + then (CONS (LIST KEY NEW) + LABELS) + else LABELS)))) + (ASSIGNABLE [PROG (ASS-KEYS) + (SETQ ASS-KEYS (fetch (KEYBOARDCONFIGURATION ASSIGNABLEKEYS) + of CONF)) + (if (FMEMB KEY ASS-KEYS) + then (DREMOVE KEY ASS-KEYS) + else (replace (KEYBOARDCONFIGURATION ASSIGNABLEKEYS) of CONF + with (CONS KEY ASS-KEYS]) + (PROGN (PROMPTPRINT "ILLEGAL FIELD VALUE IN ") + (RETURN NIL))) + (CLEARW PROMPTW) + (VKBD.CONF.DISPLAY-FIELD-VALUE KEY (CADR ITEM) + CONF WINDOW MENU]) (VKBD.CONF.DISPLAY-FIELD-VALUE + [LAMBDA (KEY FIELD CONF WINDOW MENU) (* ; "Edited 11-Jun-90 16:40 by mitani") + (PROG (X Y) + [for ITEM in (fetch ITEMS of MENU) when (EQ (CADR ITEM) + FIELD) + do (SETQ Y (fetch (REGION BOTTOM) of (MENUITEMREGION ITEM MENU] + (SETQ X (IPLUS (fetch MENUREGIONLEFT of MENU) + (fetch IMAGEWIDTH of MENU) + 5)) + (DSPFILL (CREATEREGION X Y (IDIFFERENCE (fetch (REGION WIDTH) + of (WINDOWPROP WINDOW 'REGION)) + Y) + (fetch ITEMHEIGHT of MENU)) + (DSPTEXTURE NIL WINDOW) + 'REPLACE WINDOW) + (MOVETO X Y WINDOW) + (PRIN1 (SELECTQ FIELD + (KEYID KEY) + (REGIONS (VKBD.GET-KEY-REGIONS KEY CONF)) + (DEFAULT (CDR (VKBD.FETCH-KEY-ASSIGNMENT KEY (MAINWINDOW WINDOW)))) + (NAMES (VKBD.KEY-ID-TO-KEY-NAMES KEY CONF)) + (LABEL (CADR (FASSOC KEY (fetch (KEYBOARDCONFIGURATION KEYLABELS) + of CONF)))) + (ASSIGNABLE (if (FMEMB KEY (fetch (KEYBOARDCONFIGURATION ASSIGNABLEKEYS) + of CONF)) + then T + else NIL)) + (PROMPTPRINT "ILLEGAL FIELD VALUE FOR DISPLAY CONFIGURATION FIELD VALUE!")) + WINDOW]) (VKBD.CONF.DISPLAY-INFO-KEYBOARD [LAMBDA (CONFIGURATION) (* ; "Edited 25-May-95 11:34 by rmk:") (PROG (WINDOW ATT-WINDOW MENU VALIDATED-CONFIG) (COND ((NOT (SETQ VALIDATED-CONFIG (VKBD.GET-CONFIGURATION CONFIGURATION))) (* ;; "Make sure the configuration name is legit.") (ERROR CONFIGURATION "is not the name of a known keyboard configuration."))) (SETQ WINDOW (VKBD.CREATE-KEYBOARD-DISPLAY (VKBD.CREATE-DEFAULT-KEYBOARD VALIDATED-CONFIG) NIL 'VKBD.CONF.DISPLAY-KEY-INFO NIL T)) (SETQ MENU (create MENU ITEMS _ '(("Key ID" KEYID) ("Key regions" REGIONS) ("Default assignment" DEFAULT) ("Key names" NAMES) ("Key Label" LABEL) ("Assignable? " ASSIGNABLE)) MENUBORDERSIZE _ 0 MENUOUTLINESIZE _ 0 MENUFONT _ BOLDFONT WHENSELECTEDFN _ 'VKBD.CONF.CHANGE-KEY-VALUE)) (SETQ ATT-WINDOW (CREATEW (CREATEREGION 0 0 (fetch (REGION WIDTH) of (WINDOWPROP WINDOW 'REGION)) (IPLUS 10 (fetch IMAGEHEIGHT of MENU))) NIL NIL T)) (ATTACHWINDOW ATT-WINDOW WINDOW 'TOP 'JUSTIFY) (OPENW ATT-WINDOW) (ADDMENU MENU ATT-WINDOW (create POSITION XCOORD _ 0 YCOORD _ 0)) (GETPROMPTWINDOW ATT-WINDOW 2 BOLDFONT) (WINDOWPROP WINDOW 'ICONFN 'VKBD.CONF.ICONFN]) (VKBD.CONF.DISPLAY-KEY-INFO + [LAMBDA (KEY WINDOW MOUSEKEY) (* sm "14-Aug-85 15:38") + (PROG (CONFIGURATION OLD-KEY ATT-WINDOW) + (if (SETQ OLD-KEY (WINDOWPROP WINDOW 'VKBD.CONF.CURRENT-KEY)) + then (VKBD.ERASE-FRAME OLD-KEY WINDOW 2)) + (WINDOWPROP WINDOW 'VKBD.CONF.CURRENT-KEY KEY) + (VKBD.FRAME-KEY KEY WINDOW BLACKSHADE 2) + (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION WINDOW)) + (SETQ ATT-WINDOW (CAR (ATTACHEDWINDOWS WINDOW))) + (for F in '(KEYID REGIONS DEFAULT NAMES LABEL ASSIGNABLE) + do (VKBD.CONF.DISPLAY-FIELD-VALUE KEY F CONFIGURATION ATT-WINDOW + (CAR (WINDOWPROP ATT-WINDOW 'MENU]) (VKBD.CONF.EDIT-DEFAULT-ASSIGNMENTS + [LAMBDA (CONFIGURATION) (* sm "15-Aug-85 10:25") + (PROG (DUMMY-CONFIGURATION DUMMY-KEYBOARD) + (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION CONFIGURATION)) + (SETQ DUMMY-CONFIGURATION (COPY CONFIGURATION)) + (replace (KEYBOARDCONFIGURATION ASSIGNABLEKEYS) of DUMMY-CONFIGURATION + with (fetch (KEYBOARDCONFIGURATION KEYSIDLIST) of DUMMY-CONFIGURATION)) + (replace (KEYBOARDCONFIGURATION KEYLABELS) of DUMMY-CONFIGURATION with NIL) + (SETQ DUMMY-KEYBOARD (create VIRTUALKEYBOARD + KEYBOARDNAME _ "DEFAULT ASIGNMENTS" + KEYASSIGNMENTS _ (fetch (KEYBOARDCONFIGURATION + DEFAULTASSIGNMENT) of + CONFIGURATION + ) + KEYBOARDCONFIGURATION _ DUMMY-CONFIGURATION)) + (EDITKEYBOARD DUMMY-KEYBOARD) + (replace (KEYBOARDCONFIGURATION DEFAULTASSIGNMENT) of CONFIGURATION + with (fetch (VIRTUALKEYBOARD KEYASSIGNMENTS) of DUMMY-KEYBOARD]) (VKBD.CONF.ICONFN + [LAMBDA (WINDOW ICON) (* sm "15-Aug-85 11:02") + [COND + ((NULL ICON) + (SETQ ICON (TITLEDICONW (create TITLEDICON + ICON _ VKBD.CONF.ICON + MASK _ VKBD.EDIT.MASK + TITLEREG _ (CREATEREGION 5 15 80 75)) + (CONCAT "EDIT CONFIGURATION: " (fetch (KEYBOARDCONFIGURATION + CONFIGURATIONNAME) + of (VKBD.GET-CONFIGURATION WINDOW))) + (FONTCREATE 'GACHA 8] + ICON]) (VKBD.CONF.PARSE-CONFIGURATION + [LAMBDA (CONFIGURATION) (* sm " 5-Aug-85 17:05") + (PROG (ERROR-FLAG REGS IDS) + (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION CONFIGURATION)) + (if (NULL CONFIGURATION) + then (PRINTOUT T T CONFIGURATION " NOT A CONFIGURATION. ") + (RETURN NIL)) + (SETQ IDS (fetch (KEYBOARDCONFIGURATION KEYSIDLIST) of CONFIGURATION)) + (SETQ REGS (fetch (KEYBOARDCONFIGURATION KEYREGIONS) of CONFIGURATION)) + (if (NULL IDS) + then (PRINTOUT T T "Null Id list. ") + (RETURN NIL)) + (if (LESSP (LENGTH REGS) + (LENGTH IDS)) + then (PRINTOUT T T "KEYS WITHOUT REGIONS : ") + (for K in IDS when (NOT (FASSOC K REGS)) do (PRINTOUT T " " K)) + (SETQ ERROR-FLAG T)) + (for R in REGS do (for R1 in (CDR R) when (NOT (REGIONP R1)) + DO (SETQ ERROR-FLAG T) + (PRINTOUT T T "KEY : " (CAR R) + " -- " R1 " NOT A REGION"))) + (for KEY in (fetch (KEYBOARDCONFIGURATION ASSIGNABLEKEYS) of CONFIGURATION) + when (NOT (FMEMB KEY IDS)) do (SETQ ERROR-FLAG T) + (PRINTOUT T T "KEY :" KEY + " IS IN THE ASSIGNABLE KEYS BUT NOT IN KEY IDS")) + (for ASS in (fetch (KEYBOARDCONFIGURATION DEFAULTASSIGNMENT) of CONFIGURATION) + when (NOT (FMEMB (CAR ASS) + IDS)) do (SETQ ERROR-FLAG T) + (PRINTOUT T T "KEY : " (CAR ASS) + " HAS ASSIGNMENT BUT IS NOT IN ID LIST")) + (for ID in IDS when (NOT (FASSOC ID (fetch (KEYBOARDCONFIGURATION DEFAULTASSIGNMENT) + of CONFIGURATION))) + do (SETQ ERROR-FLAG T) + (PRINTOUT T T "KEY :" ID " DOES NOT HAVE ASSIGNMENT.")) + (RETURN (NOT ERROR-FLAG]) ) (RPAQQ VKBD.CONF.ICON #*(93 93)OOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHNGOOOOOOOOOOOOOOOOOOOOCHNGOOOOOOOOOOOOOOOOOOOOCHNGOOOOOOOOOOOOOOOOOOOOCHNG@HECI@HDCI@HDNALHD@GCHNG@HECI@HDCI@HDNALHD@GCHNG@HECO@HDCM@OONALHDNGCHNG@HDCO@HDCM@OONAOHGOOCHNGOOOOOOOOOOOOOOOOOOOOCHNG@BA@NDBAALDNA@IOBGOOCHNGGBA@NDBAALDNA@HGBG@GCHNGGCOOOLBAOOONAOOOOOFGCHNG@COOOLBAOOONAOOOOO@GCHNGOOOOOOOOOOOOOOOOOOHGCHNG@CHDCI@ILBCHHNBALHIGCHNG@CHDCI@ILBCHHNBALHIGCHNGOOHDCOOOLBCHINBALHIGCHNGOOHDCOOOLBGHINBALHHGCHNGOOOOOOOOOOOOOOOOOOOOCHNG@@@HDGA@HDGAALDCM@@GCHNG@@@HDGA@HDGAALDCI@@GCHNG@@@HDGA@HDGAALDCI@@GCHNG@@@HDGA@HDGAALDCI@@GCHNGOOOOOOOOOOOOOOOOOOOOCHNGOOOOOOOOOOOOOOOOOOOOCHNGOOOOOOOOOOOOOOOOOOOOCHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOH ) (* ;; "EEditor for keyboard layouts per se:") (DEFINEQ (EDITKEYBOARD [LAMBDA (KEYBOARD SOURCE-KEYBOARD CONFIGURATION-NAME) (* ; "Edited 25-May-95 14:22 by rmk:") (* sm " 1-Aug-85 17:55") (PROG (VKBD.EDIT-WINDOW CURRENT-EVENT KEYBOARD-TO-EDIT COMPLETE-KEYBOARD) (COND ((NULL KEYBOARD) (RETURN NIL))) (IF (LITATOM KEYBOARD) THEN (SETQ KEYBOARD-TO-EDIT (FINDVIRTUALKEYBOARD KEYBOARD CONFIGURATION-NAME)) (IF (NULL KEYBOARD-TO-EDIT) THEN [IF (AND (NULL SOURCE-KEYBOARD) CONFIGURATION-NAME) THEN (SETQ KEYBOARD-TO-EDIT (VKBD.CREATE-DEFAULT-KEYBOARD CONFIGURATION-NAME)) ELSE [SETQ KEYBOARD-TO-EDIT (COPY (IF (AND SOURCE-KEYBOARD (ATOM SOURCE-KEYBOARD )) THEN (FASSOC SOURCE-KEYBOARD VKBD.KNOWN-KEYBOARDS] (IF (NULL KEYBOARD-TO-EDIT) THEN (SETQ KEYBOARD-TO-EDIT (COPY (FASSOC 'DEFAULT VKBD.KNOWN-KEYBOARDS] (REPLACE KEYBOARDNAME OF KEYBOARD-TO-EDIT WITH KEYBOARD)) ELSE (SETQ KEYBOARD-TO-EDIT KEYBOARD)) (SETQ VKBD.EDIT-WINDOW (VKBD.EDIT.CREATE-DISPLAY KEYBOARD-TO-EDIT)) (WINDOWPROP VKBD.EDIT-WINDOW 'VKBD.KEYBOARD (COPY KEYBOARD-TO-EDIT)) (WINDOWPROP VKBD.EDIT-WINDOW 'VKBD.ORIGINAL-KEYBOARD KEYBOARD-TO-EDIT) (WINDOWPROP VKBD.EDIT-WINDOW 'VKBD.EDITOR-RETURN-EVENT (SETQ CURRENT-EVENT (CREATE.EVENT "VKBD.EDIT"))) (AWAIT.EVENT CURRENT-EVENT) (CLOSEW VKBD.EDIT-WINDOW) (RETURN (WINDOWPROP VKBD.EDIT-WINDOW 'VKBD.KEYBOARD]) (VKBD.EDIT.ADD-SUBITEM-TO-BACKGROUND-MENU + [LAMBDA (SUBITEM MAINITEMLABEL) (* sm "15-Aug-85 14:14") + (PROG (MAINITEM OLD) + (SETQ MAINITEM (SASSOC MAINITEMLABEL BackgroundMenuCommands)) + [COND + (MAINITEM (COND + [(AND (CDDDR MAINITEM) + (EQ (CAR (CADDDR MAINITEM)) + 'SUBITEMS)) + (COND + ((SETQ OLD (SASSOC (CAR SUBITEM) + (CADDDR MAINITEM))) + (RPLACD OLD (CDR SUBITEM))) + (T (NCONC1 (CADDDR MAINITEM) + SUBITEM] + (T (RPLACD (CDDR MAINITEM) + (LIST (LIST 'SUBITEMS SUBITEM] + (SETQ BackgroundMenu NIL]) (VKBD.EDIT.CREATE-COMMAND-MENU + [LAMBDA NIL (* sm " 1-Aug-85 17:22") + (create MENU + ITEMS _ VKBD.EDIT.MENU-ITEMS + MENUFONT _ (FONTCREATE 'HELVETICA 12 'BOLD) + CENTERFLG _ T + MENUROWS _ 1 + WHENSELECTEDFN _ 'VKBD.EDIT.DO-MENU-COMMAND]) (VKBD.EDIT.CREATE-NON-CHAR-ASSIGMENTS-MENU + [LAMBDA NIL (* sm "13-Aug-85 11:09") + (create MENU + ITEMS _ VKBD.EDIT.NON-CHAR-ASSIGNMENTS + MENUFONT _ (FONTCREATE 'GACHA 8) + MENUROWS _ (ADD1 (IQUOTIENT (SUB1 (LENGTH VKBD.EDIT.NON-CHAR-ASSIGNMENTS)) + 4)) + CENTERFLG _ T + WHENSELECTEDFN _ 'VKBD.EDIT.ASSIGN-CHARACTER]) (VKBD.EDIT-KEYBOARD-COMMAND + [LAMBDA (NEW-KEYBOARD? ASK-FOR-INITIAL?) (* sm "14-Aug-85 15:11") + (PROG (NEW-NAME KEYBOARD INITIAL-KEYBOARD) + (if (NOT NEW-KEYBOARD?) + then (SETQ KEYBOARD (VKBD.POP-UP-KEYBOARDS-MENU + "Select the keyboard that you want to edit")) + (if KEYBOARD + then (if (EQ KEYBOARD 'DEFAULT) + then (PROMPTPRINT "Can not edit the default keyboard.") + else (EDITKEYBOARD KEYBOARD))) + else [SETQ NEW-NAME (MKATOM (PROMPTFORWORD "Enter name for new keyboard :" NIL NIL + PROMPTWINDOW NIL 'TTY] + (if NEW-NAME + then (if ASK-FOR-INITIAL? + then (SETQ INITIAL-KEYBOARD (VKBD.POP-UP-KEYBOARDS-MENU + "Select the keyboard to be used as initial keyboard for the editing" + )) + (if INITIAL-KEYBOARD + then (EDITKEYBOARD NEW-NAME INITIAL-KEYBOARD)) + else (EDITKEYBOARD NEW-NAME 'DEFAULT]) (VKBD.EDIT.ASSIGN-CHARACTER + [LAMBDA (ITEM MENU MOUSE-KEY) (* sm "15-Aug-85 10:02") + (PROG (WINDOW KEY SHIFTED CURRENT-KEY-INFO KEY-ASSIGNMENT KEYBOARD) + (SETQ WINDOW (MAINWINDOW (WFROMMENU MENU) + T)) + (SETQ KEYBOARD (WINDOWPROP WINDOW 'VKBD.KEYBOARD)) + (SETQ CURRENT-KEY-INFO (WINDOWPROP WINDOW 'VKBD.CURRENT-KEY)) + (if CURRENT-KEY-INFO + then (SETQ KEY (CAR CURRENT-KEY-INFO)) + (SETQ SHIFTED (CADR CURRENT-KEY-INFO)) + (SETQ KEY-ASSIGNMENT (VKBD.FETCH-KEY-ASSIGNMENT KEY WINDOW)) + [if (AND VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS (MEMBER ITEM + VKBD.EDIT.NON-CHAR-ASSIGNMENTS + )) + then (VKBD.EDIT.ASSIGN-NON-CHARACTER KEY-ASSIGNMENT ITEM) + else (if (NULL KEY-ASSIGNMENT) + then (replace (VIRTUALKEYBOARD KEYASSIGNMENTS) of KEYBOARD + with (CONS (LIST KEY (LIST (CADR ITEM) + (CADR ITEM) + 'NOLOCKSHIFT)) + (fetch (VIRTUALKEYBOARD KEYASSIGNMENTS) of KEYBOARD) + )) + else (RPLACD (CDR KEY-ASSIGNMENT) + NIL) + (if (OR (NULL (CDR KEY-ASSIGNMENT)) + (ATOM (CADR KEY-ASSIGNMENT))) + then [RPLACD KEY-ASSIGNMENT (LIST (LIST (CADR ITEM) + (CADR ITEM) + 'NOLOCKSHIFT] + else (if SHIFTED + then (RPLACA (CDADR KEY-ASSIGNMENT) + (CADR ITEM)) + else (RPLACA (CADR KEY-ASSIGNMENT) + (CADR ITEM] + (VKBD.DISPLAY-KEY KEY WINDOW) + else (FLASHWINDOW PROMPTWINDOW) + (PRINTOUT PROMPTWINDOW T + "There is no current selected key. Character was not assigned."]) (VKBD.EDIT.ASSIGN-NON-CHARACTER + [LAMBDA (KEY-ASSIGNMENT NEW-ASSIGNMENT) (* sm "13-Aug-85 10:16") + (RPLACD KEY-ASSIGNMENT (SELECTQ NEW-ASSIGNMENT + (SHIFT '(1SHIFTDOWN . 1SHIFTUP)) + (CTRL '(CTRLDOWN . CTRLUP)) + (META '(METADOWN . METAUP)) + (LOCK '(LOCKDOWN . LOCKUP)) + (LOCKDOWN '(LOCKDOWN)) + (LOCKUP '(LOCKUP)) + (EVENT '(EVENT . EVENT)) + NIL]) (VKBD.EDIT.CREATE-CHARACTER-SETS-MENU + [LAMBDA NIL (* sm "15-Aug-85 12:13") + (if VKBD.EDIT.DISPLAY-CHAR-SETS-NAMES + then [create MENU + ITEMS _ VKBD.EDIT.CHAR-SET-NAMES + MENUFONT _ BIGFONT + ITEMWIDTH _ (ITIMES 29 16) + ITEMHEIGHT _ (ADD1 (IQUOTIENT (ITIMES 25 16) + (LENGTH VKBD.EDIT.CHAR-SET-NAMES] + else (create MENU + ITEMS _ (for I from 1 to 256 bind ROTATED-I + collect (PROGN (SETQ ROTATED-I (SUB1 (VKBD.EDIT.ROTATED-NUMBER I 16 16)) + ) + (LIST (OCTALSTRING ROTATED-I) + ROTATED-I))) + MENUCOLUMNS _ 16 + CENTERFLG _ T + ITEMHEIGHT _ 25 + ITEMWIDTH _ 29]) (VKBD.EDIT.CREATE-CHARACTERS-MENU + [LAMBDA (CHAR-SET-NUMBER FONT) (* sm "15-Aug-85 12:15") + (PROG (EXISTING-MENU-INFO NEW-MENU) + [SETQ EXISTING-MENU-INFO (for CHARSET-FONT-MENU in VKBD.EDIT.CASH-MENUES + thereis (AND (EQP (CAR CHARSET-FONT-MENU) + CHAR-SET-NUMBER) + (EQ (CADR CHARSET-FONT-MENU) + FONT] + (if EXISTING-MENU-INFO + then (RETURN (CADDR EXISTING-MENU-INFO))) + (PRINTOUT PROMPTWINDOW T "Wait. Bitmaps for character set " (OCTALSTRING CHAR-SET-NUMBER) + " are being retrieved. ") + (SETQ NEW-MENU (create MENU + ITEMS _ (for I from 0 to 255 bind CODE bind ROTATED-I + collect (PROGN (SETQ ROTATED-I (SUB1 ( + VKBD.EDIT.ROTATED-NUMBER + (ADD1 I) + 16 16))) + (LIST (GETCHARBITMAP (SETQ CODE + (VKBD.PARSE-CHAR-CODE + (LIST + CHAR-SET-NUMBER + ROTATED-I))) + FONT) + CODE))) + MENUCOLUMNS _ 16 + CENTERFLG _ T + ITEMHEIGHT _ 25 + ITEMWIDTH _ 29 + WHENSELECTEDFN _ 'VKBD.EDIT.ASSIGN-CHARACTER)) + (PROMPTPRINT "... Done. ") + (push VKBD.EDIT.CASH-MENUES (LIST CHAR-SET-NUMBER FONT NEW-MENU)) + (if (GREATERP (LENGTH VKBD.EDIT.CASH-MENUES) + VKBD.EDIT.MAX-NUMBER-OF-CASHED-MENUS) + then (RPLACD (LAST VKBD.EDIT.CASH-MENUES) + NIL)) + (RETURN NEW-MENU]) (VKBD.EDIT.CREATE-DISPLAY [LAMBDA (KEYBOARD) (* ; "Edited 25-May-95 14:07 by rmk:") (* sm "13-Aug-85 12:37") (PROG (WINDOW LARGE-WINDOW BM WPOS REGION-WIDTH REGION-HEIGHT NON-CHAR-WINDOW COMMAND-MENU NON-CHAR-MENU) (SETQ BM (VKBD.CREATE-KEYBOARD-BITMAP (fetch (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) of KEYBOARD))) (if VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS then (SETQ NON-CHAR-MENU (VKBD.EDIT.CREATE-NON-CHAR-ASSIGMENTS-MENU))) (SETQ COMMAND-MENU (VKBD.EDIT.CREATE-COMMAND-MENU)) [SETQ REGION-WIDTH (MAX VKBD.EDITOR-WINDOW-WIDTH (IPLUS 8 (BITMAPWIDTH BM] (SETQ REGION-HEIGHT (MIN SCREENHEIGHT (IPLUS (fetch IMAGEHEIGHT of COMMAND-MENU) (if VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS then (fetch IMAGEHEIGHT of NON-CHAR-MENU) else 0) (BITMAPHEIGHT BM) VKBD.EDITOR-WINDOW-HEIGHT 20))) (SETQ WPOS (GETBOXPOSITION REGION-WIDTH REGION-HEIGHT NIL NIL NIL "Specify region for Keyboard Editor window")) (SETQ WINDOW (VKBD.CREATE-KEYBOARD-DISPLAY KEYBOARD WPOS 'VKBD.EDIT.MAKE-CURRENT-KEY BM T)) (WINDOWPROP WINDOW 'REPAINTFN 'VKBD.EDIT.KEYBOARD-REPAINTFN) (WINDOWPROP WINDOW 'ICONFN 'VKBD.EDIT.ICONFN) (SETQ LARGE-WINDOW (CREATEW (CREATEREGION 0 0 VKBD.EDITOR-WINDOW-WIDTH VKBD.EDITOR-WINDOW-HEIGHT) (CONCAT "Edit of Keyboard : " (fetch (VIRTUALKEYBOARD KEYBOARDNAME) of KEYBOARD) " for " (fetch (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) of KEYBOARD)) NIL T)) (WINDOWPROP LARGE-WINDOW 'CLOSEFN 'VKBD.EDIT.STOP-COMMAND) (ATTACHWINDOW LARGE-WINDOW WINDOW 'TOP 'CENTER) (if VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS then (ATTACHMENU NON-CHAR-MENU LARGE-WINDOW 'TOP 'JUSTIFY)) (OPENW LARGE-WINDOW) (WINDOWPROP LARGE-WINDOW 'RESHAPEFN 'DON'T) (ATTACHMENU COMMAND-MENU LARGE-WINDOW 'TOP 'JUSTIFY) (WINDOWPROP WINDOW 'VKBD.CHAR-SET-MENU (VKBD.EDIT.CREATE-CHARACTER-SETS-MENU)) (VKBD.EDIT.LARGE-WINDOW-REPAINTFN LARGE-WINDOW) (VKBD.EDIT.SWITCH-CHARACTER-SET 0 LARGE-WINDOW) (WINDOWADDPROP LARGE-WINDOW 'REPAINTFN 'VKBD.EDIT.LARGE-WINDOW-REPAINTFN) (RETURN WINDOW]) (VKBD.EDIT.DEFINE-COMMAND + [LAMBDA (WINDOW) (* sm " 5-Aug-85 09:26") + (DEFINEKEYBOARD (WINDOWPROP WINDOW 'VKBD.KEYBOARD)) + (PRINTOUT PROMPTWINDOW "Keyboard " (fetch (VIRTUALKEYBOARD KEYBOARDNAME) + of (WINDOWPROP WINDOW 'VKBD.KEYBOARD)) + " was added to the set of known keyboards."]) (VKBD.EDIT.DO-MENU-COMMAND + [LAMBDA (ITEM MENU KEY) (* sm " 1-Aug-85 17:34") + (APPLY* (CADR ITEM) + (MAINWINDOW (WFROMMENU MENU) + T]) (VKBD.EDIT.ICONFN + [LAMBDA (WINDOW ICON) (* sm "15-Aug-85 11:10") + [COND + ((NULL ICON) + (SETQ ICON (TITLEDICONW (create TITLEDICON + ICON _ VKBD.EDIT.ICON + MASK _ VKBD.EDIT.MASK + TITLEREG _ (CREATEREGION 5 25 80 65)) + [CONCAT "EDIT KEYBOARD: " (fetch (VIRTUALKEYBOARD KEYBOARDNAME) + of (WINDOWPROP WINDOW 'VKBD.KEYBOARD] + (FONTCREATE 'GACHA 8] + ICON]) (VKBD.EDIT.INVERT-IF-LOCKED + [LAMBDA (KEY WINDOW) (* sm "13-Aug-85 10:01") + (PROG (KEY-ASSIGNMENT) + (SETQ KEY-ASSIGNMENT (VKBD.FETCH-KEY-ASSIGNMENT KEY WINDOW)) + (if (AND (VKBD.CHAR-ASSIGNMENTP KEY-ASSIGNMENT) + (EQ (VKBD.LOCK/NOLOCK KEY-ASSIGNMENT) + 'LOCKSHIFT)) + then (VKBD.INVERT-LOCK-KEYS WINDOW]) (VKBD.EDIT.KEYBOARD-REPAINTFN + [LAMBDA (W) (* sm " 5-Aug-85 16:12") + (PROG (CURRENT-KEY) + (VKBD.KEYBOARD-WINDOW-REPAINTFN W) + (if (SETQ CURRENT-KEY (WINDOWPROP W 'VKBD.CURRENT-KEY)) + then (VKBD.FRAME-KEY (CAR CURRENT-KEY) + W BLACKSHADE 2) + (if (CADR CURRENT-KEY) + then (VKBD.INVERT-SHIFT-KEYS W)) + (VKBD.EDIT.INVERT-IF-LOCKED (CAR CURRENT-KEY) + W]) (VKBD.EDIT.LARGE-WINDOW-REPAINTFN + [LAMBDA (W) (* sm "13-Aug-85 12:43") + (for I from 0 to 20 as Y from 390 by -25 do (MOVETO 10 Y W) + (PRIN1 (OCTALSTRING I) + W)) + (for I from 0 by 16 to 255 as X from 40 by 29 do (MOVETO X 420 W) + (PRIN1 (OCTALSTRING I) + W]) (VKBD.EDIT.MAKE-CURRENT-KEY + [LAMBDA (KEY WINDOW MOUSEKEY) (* sm " 7-Aug-85 17:51") + (PROG (CURRENT-KEY SHIFTED CURRENT-KEY-ASSIGNMENT CURRENT-KEY-INFO LOCKED) + (SETQ SHIFTED (WINDOWPROP WINDOW 'VKBD.SHIFT-DOWN)) + (SETQ CURRENT-KEY-INFO (WINDOWPROP WINDOW 'VKBD.CURRENT-KEY)) + (if (VKBD.LOCK-KEYP KEY WINDOW) + then (if (CADR CURRENT-KEY-INFO) + then (SETQ CURRENT-KEY-ASSIGNMENT (VKBD.FETCH-KEY-ASSIGNMENT (CAR + CURRENT-KEY-INFO + ) + WINDOW)) + (SETQ LOCKED (EQ (VKBD.LOCK/NOLOCK CURRENT-KEY-ASSIGNMENT) + 'LOCKSHIFT)) + (RPLACA (CDDADR CURRENT-KEY-ASSIGNMENT) + (if LOCKED + then 'NOLOCKSHIFT + else 'LOCKSHIFT)) + (VKBD.INVERT-LOCK-KEYS WINDOW)) + elseif (VKBD.ASSIGNABLE-KEYP KEY WINDOW) + then (if CURRENT-KEY-INFO + then (VKBD.ERASE-FRAME (CAR CURRENT-KEY-INFO) + WINDOW 2) + (if (CADR CURRENT-KEY-INFO) + then (VKBD.INVERT-SHIFT-KEYS WINDOW) + (VKBD.EDIT.INVERT-IF-LOCKED (CAR CURRENT-KEY-INFO) + WINDOW))) + (VKBD.FRAME-KEY KEY WINDOW BLACKSHADE 2) + (if SHIFTED + then (VKBD.INVERT-SHIFT-KEYS WINDOW) + (VKBD.EDIT.INVERT-IF-LOCKED KEY WINDOW)) + (WINDOWPROP WINDOW 'VKBD.CURRENT-KEY (LIST KEY SHIFTED]) (VKBD.EDIT.QUIT-COMMAND + [LAMBDA (WINDOW) (* sm " 2-Aug-85 15:12") + [REPLACE KEYASSIGNMENTS OF (WINDOWPROP WINDOW 'VKBD.ORIGINAL-KEYBOARD) + WITH (FETCH KEYASSIGNMENTS OF (WINDOWPROP WINDOW 'VKBD.KEYBOARD] + (NOTIFY.EVENT (WINDOWPROP WINDOW 'VKBD.EDITOR-RETURN-EVENT]) (VKBD.EDIT.STOP-COMMAND + [LAMBDA (WINDOW) (* sm " 2-Aug-85 13:04") + (NOTIFY.EVENT (WINDOWPROP (MAINWINDOW WINDOW T) + 'VKBD.EDITOR-RETURN-EVENT]) (VKBD.EDIT.SWITCH-CHAR-SET-COMMAND + [LAMBDA (MAIN-WINDOW) (* sm " 5-Aug-85 09:28") + (PROG (LARGE-WINDOW NEW-NUMBER) + (SETQ LARGE-WINDOW (CAR (ATTACHEDWINDOWS MAIN-WINDOW))) + [SETQ NEW-NUMBER (MENU (WINDOWPROP MAIN-WINDOW 'VKBD.CHAR-SET-MENU) + (create POSITION + XCOORD _ [IPLUS 34 (fetch (REGION LEFT) + of (WINDOWPROP LARGE-WINDOW + 'REGION] + YCOORD _ (IPLUS 9 (fetch (REGION BOTTOM) + of (WINDOWPROP LARGE-WINDOW 'REGION] + (if NEW-NUMBER + then (VKBD.EDIT.SWITCH-CHARACTER-SET NEW-NUMBER LARGE-WINDOW]) (VKBD.EDIT.SWITCH-CHARACTER-SET + [LAMBDA (SET-NUMBER WINDOW) (* sm " 6-Aug-85 14:08") + (PROG (MENU OLDCURSOR FONT) + (if (WINDOWPROP WINDOW 'MENU) + then (DELETEMENU (CAR (WINDOWPROP WINDOW 'MENU)) + NIL WINDOW)) + (WINDOWPROP WINDOW 'TITLE (CONCAT "Character set " (OCTALSTRING SET-NUMBER))) + [SETQ FONT (FONTCREATE (fetch (KEYBOARDCONFIGURATION KEYBOARDDISPLAYFONT) + of (VKBD.GET-CONFIGURATION (MAINWINDOW WINDOW] + (ADDMENU (VKBD.EDIT.CREATE-CHARACTERS-MENU SET-NUMBER FONT) + WINDOW + (create POSITION + XCOORD _ 30 + YCOORD _ 5]) (VKBD.EDIT.ROTATED-NUMBER + [LAMBDA (NUM ROW-NUM COL-NUM) (* edited%: " 3-Jun-85 12:47") + (IPLUS (ITIMES (IMOD (SUB1 NUM) + COL-NUM) + ROW-NUM) + (ADD1 (IQUOTIENT (SUB1 NUM) + COL-NUM]) ) (RPAQ? VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS T) (RPAQ? VKBD.EDIT.MAX-NUMBER-OF-CASHED-MENUS 15) (RPAQ? VKBD.EDITOR-WINDOW-HEIGHT 450) (RPAQ? VKBD.EDITOR-WINDOW-WIDTH 512) (RPAQ? VKBD.EDIT.DISPLAY-CHAR-SETS-NAMES T) (RPAQQ VKBD.EDIT.BACKGROUND-MENU-SUBITEMS (SUBITEMS ("New Keyboard, default initial" '(ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will use the default keyboard as the initial keyboard" ) ("New keyboard, other initial" '(ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND T T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will pop up a menu of the current known keyboards. The selected one will be used as the initial keyboard" ) ("Existing keyboard" '(ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND)) "Will let you select a keyboard from list of the known keyboards, and will calls the keyboard editor on the selected keyboard." ))) (RPAQQ VKBD.EDIT.CASH-MENUES NIL) (RPAQQ VKBD.EDIT.CHAR-SET-NAMES (("ASCII/ISO/CCITT Roman Alphabet and Punctuation" 0) ("JIS Symbols 1 - Punctuation and Symbols not in Char set 0" 33) ("JIS Symbols 2 - Punctuation and Symbols not in Char set 0" 34) ("Extended Latin" 35) ("JIS Hiragana" 36) ("JIS Katakana" 37) ("Greek" 38) ("Cyrillic" 39) ("Symbols 3 - Miscellaneous Japanese Symbols" 116) ("General and Technical Symbols 2" 238) ("General and Technical Symbols 1" 239) ("Ligatures, Graphical Entities, and Field Format Symbols" 240) ("Accented Characters" 241))) (RPAQQ VKBD.EDIT.MENU-ITEMS (("CharSet" VKBD.EDIT.SWITCH-CHAR-SET-COMMAND "Pops up a menu of all possible character set number. Selecting one will switch the displayed character set." ) ("Stop" VKBD.EDIT.STOP-COMMAND "Exit from the keyboard editor. Returns the new keyboard, but does not modify the original one." ) ("Quit" VKBD.EDIT.QUIT-COMMAND "Exit from the keyboard editor. Modifies the roriginal keyboard and returns it ." ) ("Define" VKBD.EDIT.DEFINE-COMMAND "Adds the edited keyboard in its current state to the set of known keyboards." ))) (RPAQQ VKBD.EDIT.NON-CHAR-ASSIGNMENTS (SHIFT CTRL META LOCK LOCKDOWN LOCKUP EVENT)) (RPAQQ VKBD.EDIT.ICON #*(93 93)OOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@F@@@@@@@@@@@@@@@@@@CHN@@A@@@@@@@@@@@@@@@@@@CHN@@F@@@@@@@@@@@@@@@@@@CHN@@@@@@@@AOOOOOOOO@@@@CHN@@@@@@@@A@@@@@@@A@@@@CHN@@B@@@@@A@@@@@@@A@@@@CHN@@BAOOOOOOOON@@@A@@@@CHN@@BA@@@@A@@@B@@OOO@@@CHN@@BA@@@@A@@@B@@HAA@@@CHN@@OI@@@@GL@@OHALAA@@@CHN@@GA@@@@CH@@G@ALAA@@@CHN@@BA@@@@A@@@B@@HAA@@@CHNGOOOOOOOOOOOOOOOOOOOOCHNGOOOOOOOOOOOOOOOOOOOOCHNG@HEBA@HDBA@HDBAAHD@GCHNG@HEBA@HDBA@HDBAAHD@GCHNG@HEBA@HDBA@HDBAAHDNGCHNG@HDBA@HDBA@HDBAAHD@GCHNGOOOOOOOOOOOOOOOOOOOOCHNG@BA@HDBA@HDBA@HEBA@GCHNGGBA@HDBA@HDBA@HEBA@GCHNGGBA@HDBA@HDBA@HDBAFGCHNG@BA@HDBA@HDBA@HDBA@GCHNGOOOOOOOOOOOOOOOOOOHGCHNG@AHDBA@HDBA@HDBA@HIGCHNG@AHDBA@HDBA@HDBA@HIGCHNG@AHDBA@HDBA@HDBA@HIGCHNG@AHDBA@HDBA@HDBA@HHGCHNGOOOOOOOOOOOOOOOOOOOOCHNG@@@HDBA@HDBA@HDBA@@GCHNG@@@HDBA@HDBA@HDBA@@GCHNG@@@HDBA@HDBA@HDBA@@GCHNG@@@HDBA@HDBA@HDBA@@GCHNGOOOOOOOOOOOOOOOOOOOOCHNGOOOOOOOOOOOOOOOOOOOOCHNGOOOOOOOOOOOOOOOOOOOOCHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHN@@@@@@@@@@@@@@@@@@@@@CHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOH ) (RPAQQ VKBD.EDIT.MASK #*(93 93)OOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOH ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS VKBD.EDIT.ALLOW-NON-CHAR-ASSIGNMENTS VKBD.EDIT.BACKGROUND-MENU-SUBITEMS VKBD.EDIT.MAX-NUMBER-OF-CASHED-MENUS VKBD.EDITOR-WINDOW-HEIGHT VKBD.EDITOR-WINDOW-WIDTH VKBD.EDIT.DISPLAY-CHAR-SETS-NAMES VKBD.EDIT.CASH-MENUES VKBD.EDIT.CHAR-SET-NAMES VKBD.EDIT.MENU-ITEMS VKBD.EDIT.NON-CHAR-ASSIGNMENTS VKBD.CONF.ICON VKBD.EDIT.ICON VKBD.EDIT.MASK) ) (VKBD.EDIT.ADD-SUBITEM-TO-BACKGROUND-MENU (LIST "Edit" '(ADD.PROCESS '(  VKBD.EDIT-KEYBOARD-COMMAND T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will use the default keyboard as the initial keyboard" VKBD.EDIT.BACKGROUND-MENU-SUBITEMS) "Keyboard") (PUTPROPS KEYBOARDEDITOR COPYRIGHT ("Venue & Xerox Corporation" 1985 1987 1990 1995)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3451 17311 (EDITCONFIGURATION 3461 . 3784) (VKBD.CONF.CHANGE-KEY-VALUE 3786 . 8411) ( VKBD.CONF.DISPLAY-FIELD-VALUE 8413 . 10186) (VKBD.CONF.DISPLAY-INFO-KEYBOARD 10188 . 12135) ( VKBD.CONF.DISPLAY-KEY-INFO 12137 . 12894) (VKBD.CONF.EDIT-DEFAULT-ASSIGNMENTS 12896 . 14277) ( VKBD.CONF.ICONFN 14279 . 15020) (VKBD.CONF.PARSE-CONFIGURATION 15022 . 17309)) (19637 42746 ( EDITKEYBOARD 19647 . 21947) (VKBD.EDIT.ADD-SUBITEM-TO-BACKGROUND-MENU 21949 . 22875) ( VKBD.EDIT.CREATE-COMMAND-MENU 22877 . 23227) (VKBD.EDIT.CREATE-NON-CHAR-ASSIGMENTS-MENU 23229 . 23692) (VKBD.EDIT-KEYBOARD-COMMAND 23694 . 25067) (VKBD.EDIT.ASSIGN-CHARACTER 25069 . 27743) ( VKBD.EDIT.ASSIGN-NON-CHARACTER 27745 . 28363) (VKBD.EDIT.CREATE-CHARACTER-SETS-MENU 28365 . 29404) ( VKBD.EDIT.CREATE-CHARACTERS-MENU 29406 . 31987) (VKBD.EDIT.CREATE-DISPLAY 31989 . 35222) ( VKBD.EDIT.DEFINE-COMMAND 35224 . 35626) (VKBD.EDIT.DO-MENU-COMMAND 35628 . 35838) (VKBD.EDIT.ICONFN 35840 . 36489) (VKBD.EDIT.INVERT-IF-LOCKED 36491 . 36924) (VKBD.EDIT.KEYBOARD-REPAINTFN 36926 . 37496) (VKBD.EDIT.LARGE-WINDOW-REPAINTFN 37498 . 38093) (VKBD.EDIT.MAKE-CURRENT-KEY 38095 . 40147) ( VKBD.EDIT.QUIT-COMMAND 40149 . 40502) (VKBD.EDIT.STOP-COMMAND 40504 . 40730) ( VKBD.EDIT.SWITCH-CHAR-SET-COMMAND 40732 . 41658) (VKBD.EDIT.SWITCH-CHARACTER-SET 41660 . 42443) ( VKBD.EDIT.ROTATED-NUMBER 42445 . 42744))))) STOP \ No newline at end of file diff --git a/library/LLCOLOR b/library/LLCOLOR new file mode 100644 index 00000000..d343a4f7 --- /dev/null +++ b/library/LLCOLOR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "10-Jul-92 14:57:14" |{PELE:MV:ENVOS}LIBRARY>LLCOLOR.;6| 137483 changes to%: (VARS LLCOLORCOMS) (MACROS .DRAW4BPPLINEX. .DRAW8BPPLINEX .DRAW24BPPLINEX .DRAW4BPPLINEY. .DRAW8BPPLINEY .DRAW24BPPLINEY) previous date%: "21-Aug-91 12:27:17" |{PELE:MV:ENVOS}LIBRARY>LLCOLOR.;5|) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLCOLORCOMS) (RPAQQ LLCOLORCOMS [(FNS COLORDISPLAY COLORMAPBITS \CreateColorScreenBitMap \CREATECOLORDISPLAYFDEV COLORMAP COLORMAPCOPY SCREENCOLORMAP SCREENCOLORMAPENTRY ROTATECOLORMAP RGBCOLORMAP CMYCOLORMAP GRAYCOLORMAP COLORSCREENBITMAP \COLORDISPLAYBITS COLORSCREEN SHOWCOLORTESTPATTERN) (INITVARS (COLORMONITORTYPE 'CONRAC)) (FNS \STARTCOLOR \STOPCOLOR \SENDCOLORMAPENTRY) (FNS COLORMAPCREATE COLORLEVEL COLORNUMBERP COLORFROMRGB INTENSITIESFROMCOLORMAP SETCOLORINTENSITY) (FNS \FAST8BIT \MAP4 \MAP8) (FNS \GETCOLORBRUSH) (FNS \DRAWCOLORLINE1 \DRAW4BPPCOLORLINE \DRAW8BPPCOLORLINE \DRAW24BPPCOLORLINE) (DECLARE%: DONTCOPY DOEVAL@COMPILE (MACROS .DRAW4BPPLINEX. .DRAW8BPPLINEX .DRAW24BPPLINEX .DRAW4BPPLINEY. .DRAW8BPPLINEY .DRAW24BPPLINEY) (FILES (LOADCOMP) MAIKOCOLOR)) (FNS \BWTOCOLORBLT \4BITLINEBLT \8BITLINEBLT \24BITLINEBLT \GETBASE24 \PUTBASE24 COLORTEXTUREFROMCOLOR# \BITMAPWORD) (FNS COLORIZEBITMAP UNCOLORIZEBITMAP) (INITVARS (\1COLORMENU NIL) (\4COLORMENU NIL) (\8COLORMENU NIL)) (FNS COLORMENU CURSORCOLOR) (RECORDS RGB HLS) (DECLARE%: DONTCOPY (RECORDS NIBBLES ONEOFFSETBITACCESS TWOOFFSETBITACCESS THREEOFFSETBTACCESS 2BITNIBBLES ODD2BITNIBBLES)) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) MAIKOCOLOR)) (CONSTANTS (BITSPERWORD 16)) (INITVARS (\COLORDISPLAYFDEV) (\4COLORMAP (CMYCOLORMAP 2 1 1 4)) (\8COLORMAP (CMYCOLORMAP 3 3 2 8)) (\COLORDISPLAYBITS) (ColorScreenBitMap) (\COLORSCREEN)) (FNS PSEUDOCOLOR \PSEUDOCOLOR.BITMAP \PSEUDOCOLOR.UFN) (GLOBALVARS \COLORDISPLAYFDEV \COLORDISPLAYBITS ColorScreenBitMap \4COLORMAP \8COLORMAP) (P (* ;; "NOTE: This is very bad. I shouldn't have to and don't really want to do the following, but since about March 86, someone did something really nonstandard wrt Helvetica fonts so that the in core versions are not equal to what is stored on file. The SETFONTDESCRIPTOR and friends undoes this kludge which has never been explained to LISPCORE^ by the person who brain damaged Helvetica this way. If I don't undo this kludge by someone else, then color menus come out wrong. *") (SETFONTDESCRIPTOR 'HELVETICA 10 'MRR 0 'DISPLAY NIL) (SETQ MENUFONT (FONTCREATE 'HELVETICA 10))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (DEFINEQ (COLORDISPLAY [LAMBDA (ONOFF TYPE) (* ; "Edited 28-Apr-89 21:23 by takeshi") (* Turn hardware TYPE color display  on or off. *) (PROG (OLDONOFF OLDTYPE DISPLAYSTATE DISPLAYINFO) [COND (\COLORDISPLAYFDEV (SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of \COLORDISPLAYFDEV )) (SETQ DISPLAYINFO (fetch (FDEV WINDOWDATA) of \COLORDISPLAYFDEV)) (SETQ OLDONOFF (fetch (DISPLAYSTATE ONOFF) of DISPLAYSTATE)) (SETQ OLDTYPE (fetch (DISPLAYINFO DITYPE) of DISPLAYINFO)) (COND ((NULL TYPE) (SETQ TYPE OLDTYPE] [COND ((EQ ONOFF 'ON) (COND ((EQ OLDONOFF 'ON) (* Color display already on.  *) (COLORDISPLAY 'OFF) (COLORDISPLAY 'ON TYPE)) ((OR (NULL \COLORDISPLAYFDEV) (NOT (EQ TYPE OLDTYPE))) (SETQ \COLORDISPLAYFDEV (\CREATECOLORDISPLAYFDEV TYPE)) (* Color display is off, turn it on.  *) (\STARTCOLOR \COLORDISPLAYFDEV)) (T (\STARTCOLOR \COLORDISPLAYFDEV))) (SCREENCOLORMAP (SCREENCOLORMAP)) (COND ((OR (NULL \COLORSCREEN) (NOT (EQ TYPE OLDTYPE))) (SETQ \COLORSCREEN (CREATESCREEN (COLORSCREENBITMAP))) (WINDOWWORLD 'ON \COLORSCREEN) (* Besides being a test pattern, SHOWCOLORTESTPATTERN changes a solid field of  color into a striped pattern. Some color cards have trouble holding a solid  field of color without variation steady.  *) (SHOWCOLORTESTPATTERN 10))) (SETQ BACKGROUNDCURSOREXITFN 'CURSOREXIT)) ((EQ ONOFF 'OFF) (COND ((NOT (EQ OLDONOFF 'OFF)) (* Color display is on, turn it off.  *) (SETQ BACKGROUNDCURSOREXITFN NIL) [COND ((NOT (EQ \CURSORSCREEN \MAINSCREEN)) (* Move cursor off \COLORSCREEN.  *) (CURSORSCREEN \MAINSCREEN (IQUOTIENT (fetch (SCREEN SCWIDTH) of \MAINSCREEN ) 2) (IQUOTIENT (fetch (SCREEN SCHEIGHT) of \MAINSCREEN) 2] (\STOPCOLOR \COLORDISPLAYFDEV] (RETURN OLDONOFF]) (COLORMAPBITS [LAMBDA (COLORMAP) (* kbr%: " 5-Jun-85 20:47") (INTEGERLENGTH (SUB1 (ARRAYSIZE COLORMAP]) (\CreateColorScreenBitMap [LAMBDA (FDEV) (* ; "Edited 16-Jan-87 17:17 by gbn") (* Creates color display bitmap  ColorScreenBitMap for FDEV) (DECLARE (GLOBALVARS ColorScreenBitMap)) (PROG (DISPLAYINFO WIDTH HEIGHT BITSPERPIXEL) (SETQ DISPLAYINFO (fetch (FDEV WINDOWDATA) of FDEV)) (SETQ WIDTH (fetch (DISPLAYINFO DIWIDTH) of DISPLAYINFO)) (SETQ HEIGHT (fetch (DISPLAYINFO DIHEIGHT) of DISPLAYINFO)) (SETQ BITSPERPIXEL (fetch (DISPLAYINFO DIBITSPERPIXEL) of DISPLAYINFO)) (SETQ ColorScreenBitMap (create BITMAP BITMAPBASE _ (\COLORDISPLAYBITS WIDTH HEIGHT BITSPERPIXEL) BITMAPRASTERWIDTH _ (FOLDHI (ITIMES WIDTH BITSPERPIXEL) BITSPERWORD) BITMAPWIDTH _ WIDTH BITMAPHEIGHT _ HEIGHT BITMAPBITSPERPIXEL _ BITSPERPIXEL)) (RETURN ColorScreenBitMap]) (\CREATECOLORDISPLAYFDEV [LAMBDA (TYPE) (* kbr%: "15-Feb-86 14:48") (PROG (DISPLAYINFO WSOPS) (SETQ DISPLAYINFO (ASSOC TYPE \DISPLAYINFOALIST)) (SETQ WSOPS (fetch (DISPLAYINFO DIWSOPS) of DISPLAYINFO)) (COND ((NULL DISPLAYINFO) (RETURN \COLORDISPLAYFDEV))) [COND ((NULL \COLORDISPLAYFDEV) (SETQ \COLORDISPLAYFDEV (\CREATEDISPLAY 'COLORDISPLAY] (replace (FDEV WINDOWDATA) of \COLORDISPLAYFDEV with DISPLAYINFO) (replace (FDEV EVENTFN) of \COLORDISPLAYFDEV with (fetch (WSOPS EVENTFN) of WSOPS)) (replace (FDEV WINDOWOPS) of \COLORDISPLAYFDEV with WSOPS) (\CreateColorScreenBitMap \COLORDISPLAYFDEV) (RETURN \COLORDISPLAYFDEV]) (COLORMAP [LAMBDA (BITSPERPIXEL NEWCOLORMAP) (* kbr%: "21-Aug-85 21:06") (* Change system colormap to  NEWCOLORMAP returning OLDCOLORMAP *) (PROG (OLDCOLORMAP) (SETQ OLDCOLORMAP (SELECTQ BITSPERPIXEL (4 \4COLORMAP) (8 \8COLORMAP) NIL)) [COND (NEWCOLORMAP (SELECTQ BITSPERPIXEL (4 (SETQ \4COLORMAP NEWCOLORMAP)) (8 (SETQ \8COLORMAP NEWCOLORMAP)) NIL) (COND ((AND \COLORDISPLAYFDEV (EQ (fetch (DISPLAYSTATE ONOFF) of (fetch (FDEV DEVICEINFO) of \COLORDISPLAYFDEV)) 'ON) (EQ (BITSPERPIXEL (COLORSCREENBITMAP)) BITSPERPIXEL)) (for I from 0 to (SUB1 (ARRAYSIZE NEWCOLORMAP)) do (\SENDCOLORMAPENTRY \COLORDISPLAYFDEV I (ELT NEWCOLORMAP I] (RETURN OLDCOLORMAP]) (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]) (SCREENCOLORMAP [LAMBDA (NEWCOLORMAP) (* kbr%: "21-Aug-85 21:12") (COLORMAP (BITSPERPIXEL (COLORSCREENBITMAP)) NEWCOLORMAP]) (SCREENCOLORMAPENTRY [LAMBDA (COLOR RGB) (* kbr%: " 5-Jun-86 19:40") (SETA (SCREENCOLORMAP) COLOR RGB) (\SENDCOLORMAPENTRY \COLORDISPLAYFDEV COLOR RGB]) (ROTATECOLORMAP [LAMBDA (STARTCOLOR THRUCOLOR) (* kbr%: " 5-Jun-86 23:20") (PROG (COLORMAP RGB) (SETQ COLORMAP (SCREENCOLORMAP)) (COND ((NULL STARTCOLOR) (SETQ STARTCOLOR 0))) [COND ((NULL THRUCOLOR) (SETQ THRUCOLOR (SUB1 (ARRAYSIZE COLORMAP] (SETQ RGB (ELT COLORMAP THRUCOLOR)) (for COLOR from STARTCOLOR to THRUCOLOR do (swap RGB (ELT COLORMAP COLOR)) (\SENDCOLORMAPENTRY \COLORDISPLAYFDEV COLOR (ELT COLORMAP COLOR]) (RGBCOLORMAP [LAMBDA (REDBITS GREENBITS BLUEBITS BITSPERPIXEL) (* kbr%: "13-Aug-85 16:49") (* creates a color map with the specified number of bits allocated per primary  color. Always has the RED bits on the left.) (PROG (NRED NGREEN NBLUE REDS GREENS BLUES COLORMAP) (SETQ NRED (SUB1 (EXPT 2 REDBITS))) (SETQ NGREEN (SUB1 (EXPT 2 GREENBITS))) (SETQ NBLUE (SUB1 (EXPT 2 BLUEBITS))) [SETQ REDS (for I from 0 to NRED collect (FIXR (FQUOTIENT (ITIMES 255 I) NRED] [SETQ GREENS (for I from 0 to NGREEN collect (FIXR (FQUOTIENT (ITIMES 255 I) NGREEN] [SETQ BLUES (for I from 0 to NBLUE collect (FIXR (FQUOTIENT (ITIMES 255 I) NBLUE] (SETQ COLORMAP (COLORMAPCREATE [for I from 1 to (EXPT 2 (IDIFFERENCE BITSPERPIXEL (IPLUS REDBITS GREENBITS BLUEBITS))) join (for RED in REDS join (for GREEN in GREENS join (for BLUE in BLUES collect (create RGB RED _ RED GREEN _ GREEN BLUE _ BLUE] BITSPERPIXEL)) (RETURN COLORMAP]) (CMYCOLORMAP [LAMBDA (CYANBITS MAGENTABITS YELLOWBITS BITSPERPIXEL) (* kbr%: "13-Aug-85 16:46") (PROG (COLORMAP MAXCOLOR) (SETQ COLORMAP (RGBCOLORMAP CYANBITS MAGENTABITS YELLOWBITS BITSPERPIXEL)) (SETQ MAXCOLOR (SUB1 (ARRAYSIZE COLORMAP))) [for I from 0 to (IQUOTIENT MAXCOLOR 2) do (swap (ELT COLORMAP I) (ELT COLORMAP (IDIFFERENCE MAXCOLOR I] (RETURN COLORMAP]) (GRAYCOLORMAP [LAMBDA (BITSPERPIXEL) (* kbr%: "11-Jul-85 19:20") (* creates a gray color map *) (PROG (MAXCOLOR GRAYS COLORMAP) (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) [SETQ GRAYS (for I from MAXCOLOR to 0 by -1 collect (FIXR (FQUOTIENT (ITIMES 255 I) MAXCOLOR] (SETQ COLORMAP (COLORMAPCREATE (for GRAY in GRAYS collect (create RGB RED _ GRAY GREEN _ GRAY BLUE _ GRAY)) BITSPERPIXEL)) (RETURN COLORMAP]) (COLORSCREENBITMAP [LAMBDA NIL (* rrb "22-OCT-82 14:01") (* returns the color screen bitmap) ColorScreenBitMap]) (\COLORDISPLAYBITS [LAMBDA (WIDTH HEIGHT BITSPERPIXEL) (* ; "Edited 31-Oct-89 10:25 by takeshi") (* returns a pointer to the bits  that the color board needs.) (DECLARE (GLOBALVARS \COLORDISPLAYBITS)) (COND [(AND (EQ (MACHINETYPE) 'MAIKO) (OR (\MAIKO.CGSIXP) (\MAIKO.CGTHREEP) (\MAIKO.CGFOURP))) (PROG [(DUMMY (\ALLOCPAGEBLOCK 1)) (ADDROFFSET ((OPCODES SUBRCALL 139 0] (WHILE (NEQ (LOGAND \MAIKO.COLORBUF.ALIGN (IPLUS (\LOLOC DUMMY) ADDROFFSET)) 0) DO (SETQ DUMMY (\ALLOCPAGEBLOCK 1))) (RETURN (OR (SETQ \COLORDISPLAYBITS (\ALLOCPAGEBLOCK \MAIKO.COLORPAGES)) (ERROR "No room for color screen of size" \MAIKO.COLORPAGES] (T (PROG (NPAGES) (* TBW%: If you come through this function a second time with different screen  params won't you get screwed half the time? *) [COND ((NULL \COLORDISPLAYBITS) (* 2 extra pages needed for  DORADOCOLOR microcode bug.  *) (SETQ NPAGES (IPLUS (FOLDHI (ITIMES (FOLDHI (ITIMES WIDTH BITSPERPIXEL) BITSPERWORD) HEIGHT) WORDSPERPAGE) 2)) (* \ALLOCBLOCK can't hack bitmaps of  the size of the 1132 color screen) (SETQ \COLORDISPLAYBITS (COND ((IGREATERP (UNFOLD NPAGES CELLSPERPAGE) \MaxArrayNCells) (OR (\ALLOCPAGEBLOCK NPAGES) (ERROR "No room for color screen of size" NPAGES) )) (T (\ALLOCBLOCK (UNFOLD NPAGES CELLSPERPAGE) NIL NIL CELLSPERPAGE] (RETURN \COLORDISPLAYBITS]) (COLORSCREEN [LAMBDA NIL (* kbr%: " 2-Feb-86 15:02") \COLORSCREEN]) (SHOWCOLORTESTPATTERN [LAMBDA (SIZE) (* kbr%: "15-Feb-86 15:16") (* Put a color test pattern on the color display.  SIZE is the size of the stripes that will be put up.  *) (PROG (DESTINATION WIDTH HEIGHT BITSPERPIXEL COLORS NCOLORS) (OR (NUMBERP SIZE) (SETQ SIZE 10)) (SETQ DESTINATION (COLORSCREENBITMAP)) (SETQ WIDTH (BITMAPWIDTH DESTINATION)) (SETQ HEIGHT (BITMAPHEIGHT DESTINATION)) (SETQ BITSPERPIXEL (BITSPERPIXEL DESTINATION)) (BLTSHADE MINIMUMSHADE DESTINATION) (SETQ COLORS (for BUCKET in COLORNAMES collect (CAR BUCKET))) (SETQ NCOLORS (LENGTH COLORS)) (for COLOR from 0 as LEFT from 10 by 80 to WIDTH do (BLTSHADE [CAR (NTH COLORS (ADD1 (IMOD COLOR NCOLORS] DESTINATION LEFT 410 60 60)) (for COLOR from 1 as LEFT from 10 by 80 to WIDTH do (BLTSHADE [CAR (NTH COLORS (ADD1 (IMOD COLOR NCOLORS] DESTINATION LEFT 330 60 60)) (for HORIZCOLOR from 0 as BOTTOM from 0 to 300 by SIZE do (BLTSHADE [CAR (NTH COLORS (ADD1 (IMOD HORIZCOLOR NCOLORS] DESTINATION 0 BOTTOM WIDTH SIZE 'REPLACE) finally (for VERTCOLOR from 0 as LEFT from 0 to WIDTH by (ITIMES SIZE 2) do (BLTSHADE [CAR (NTH COLORS (ADD1 (IMOD VERTCOLOR NCOLORS] DESTINATION LEFT 0 SIZE BOTTOM 'REPLACE]) ) (RPAQ? COLORMONITORTYPE 'CONRAC) (DEFINEQ (\STARTCOLOR [LAMBDA (FDEV) (* kbr%: " 1-Jul-85 13:41") (WSOP 'STARTCOLOR FDEV]) (\STOPCOLOR [LAMBDA (FDEV) (* kbr%: " 1-Jul-85 13:40") (WSOP 'STOPCOLOR FDEV]) (\SENDCOLORMAPENTRY [LAMBDA (FDEV COLOR# RGB) (* kbr%: " 1-Jul-85 19:43") (* changes the window world  background to SHADE) (WSOP 'SENDCOLORMAPENTRY FDEV COLOR# RGB]) ) (DEFINEQ (COLORMAPCREATE [LAMBDA (INTENSITIES BITSPERPIXEL) (* ; "Edited 16-Jan-87 17:36 by gbn") (PROG (COLORMAP) (SELECTQ BITSPERPIXEL (4 [COND ((NULL INTENSITIES) (SETQ COLORMAP (CMYCOLORMAP 2 1 1 BITSPERPIXEL))) (T (SETQ COLORMAP (ARRAY 16 NIL NIL 0)) (for COLOR from 0 to 15 as RGB in INTENSITIES do (SETA COLORMAP COLOR RGB]) (8 [COND ((NULL INTENSITIES) (SETQ COLORMAP (CMYCOLORMAP 3 3 2 BITSPERPIXEL))) (T (SETQ COLORMAP (ARRAY 256 NIL NIL 0)) (for COLOR from 0 to 255 as RGB in INTENSITIES do (SETA COLORMAP COLOR RGB]) (24 (SETQ COLORMAP NIL)) (\ILLEGAL.ARG BITSPERPIXEL)) (RETURN COLORMAP]) (COLORLEVEL [LAMBDA (COLOR PRIMARY NEWLEVEL) (* kbr%: " 5-Jun-86 19:58") (PROG (RGB OLDVALUE) (SETQ RGB (ELT (SCREENCOLORMAP) COLOR)) (SETQ OLDVALUE (SELECTQ PRIMARY (RED (fetch (RGB RED) of RGB)) (GREEN (fetch (RGB GREEN) of RGB)) (BLUE (fetch (RGB BLUE) of RGB)) (\ILLEGAL.ARG PRIMARY))) (COND (NEWLEVEL (SELECTQ PRIMARY (RED (replace (RGB RED) of RGB with NEWLEVEL)) (GREEN (replace (RGB GREEN) of RGB with NEWLEVEL)) (BLUE (replace (RGB BLUE) of RGB with NEWLEVEL)) (SHOULDNT)) (\SENDCOLORMAPENTRY \COLORDISPLAYFDEV COLOR RGB))) (RETURN OLDVALUE]) (COLORNUMBERP [LAMBDA (COLOR# BITSPERPIXEL NOERRFLG) (* kbr%: "21-Aug-85 21:22") (* returns the color number from a  color.) (PROG (RGB) (COND [(FIXP COLOR#) (RETURN (COND ((AND (IGEQ COLOR# 0) (ILEQ COLOR# (MAXIMUMCOLOR BITSPERPIXEL)) COLOR#)) (NOERRFLG NIL) (T (\ILLEGAL.ARG COLOR#] [(LITATOM COLOR#) (RETURN (COND ((SETQ RGB (\LOOKUPCOLORNAME COLOR#)) (* recursively look up color number) (COLORNUMBERP (CDR RGB) BITSPERPIXEL NOERRFLG)) (NOERRFLG NIL) (T (ERROR "Unknown color name" COLOR#] ((HLSP COLOR#) (* HLS form convert to RGB) (SETQ RGB (HLSTORGB COLOR#))) ((RGBP COLOR#) (* check for RGB or HLS) (SETQ RGB COLOR#)) (NOERRFLG (RETURN NIL)) (T (\ILLEGAL.ARG COLOR#))) (RETURN (COND ((COLORFROMRGB RGB BITSPERPIXEL)) (NOERRFLG NIL) (T (ERROR COLOR# "not available in color map"]) (COLORFROMRGB [LAMBDA (RGB BITSPERPIXEL) (* kbr%: "15-Feb-86 11:16") (* looks in the colormap for a color  that has RGB levels) (PROG (COLOR COLORMAP) (COND ((EQ BITSPERPIXEL 24) (* Assuming subtractive system in  which white=0. *) [SETQ COLOR (LOGOR (LLSH (IDIFFERENCE 255 (fetch (RGB RED) of RGB)) 16) (LLSH (IDIFFERENCE 255 (fetch (RGB GREEN) of RGB)) 8) (IDIFFERENCE 255 (fetch (RGB BLUE) of RGB] (RETURN COLOR))) (SETQ COLORMAP (COLORMAP BITSPERPIXEL)) (SETQ COLOR (for COLOR from 0 to (SUB1 (ARRAYSIZE COLORMAP)) thereis (EQUAL (ELT COLORMAP COLOR) RGB))) (RETURN COLOR]) (INTENSITIESFROMCOLORMAP [LAMBDA (COLORMAP) (* kbr%: "21-Aug-85 21:17") (* returns the intensity levels of the primary colors from a colormap.  This list can be passed into COLORMAPCREATE to get an equivalent colormap.) (for I from 0 to (SUB1 (ARRAYSIZE COLORMAP)) collect (ELT COLORMAP I]) (SETCOLORINTENSITY [LAMBDA (COLORMAP COLOR# INTENSITIES) (* rrb "13-DEC-82 13:15") (* sets the intensity levels of a color number in a color map.  Does not return the previous setting.) (PROG (RGB) (SETQ RGB INTENSITIES) LP (COND [(NULL RGB) (SETQ RGB '(0 0 0] ((RGBP RGB)) ((HLSP RGB) (SETQ RGB (HLSTORGB RGB))) ((SETQ RGB (CDR (\LOOKUPCOLORNAME RGB))) (GO LP)) (T (\ILLEGAL.ARG RGB))) (COLORLEVEL COLORMAP COLOR# 'RED (fetch (RGB RED) of RGB)) (COLORLEVEL COLORMAP COLOR# 'GREEN (fetch (RGB GREEN) of RGB)) (COLORLEVEL COLORMAP COLOR# 'BLUE (fetch (RGB BLUE) of RGB]) ) (DEFINEQ (\FAST8BIT [LAMBDA (A B N MAP) (* edited%: "10-SEP-82 16:14") (bind AW (I _ 0) for J from 0 do (SETQ AW (\ADDBASE A J)) (OR (IGREATERP N I) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN1) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN2) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN3) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN4) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN5) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN6) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN7) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN8) of AW))) (add I 1]) (\MAP4 [LAMBDA (|0C| |1C|) (* edited%: "10-SEP-82 15:50") (SETQ |0C| (COND (|0C| (COLORNUMBERP |0C| 4)) (T 0))) (* Mask out but 4 bits) (SETQ |1C| (COND (|1C| (COLORNUMBERP |1C| 4)) (T 15))) (PROG (MAP) (SETQ MAP (ARRAY 16 'SMALLPOSP 0 0)) [for I from 0 to 15 do (SETA MAP I (for J from 0 to 3 sum (LLSH (COND ((ZEROP (LOGAND I (LLSH 1 J))) |0C|) (T |1C|)) (ITIMES J 4] (RETURN MAP]) (\MAP8 [LAMBDA (|0C| |1C|) (* edited%: "10-SEP-82 15:50") (* returns an array of words that contain the destination bitmap should contain  if a black and white bitmap is blown up to an 8 bit per pixel bitmap.) (SETQ |0C| (COND (|0C| (COLORNUMBERP |0C| 8)) (T 0))) (* make sure color numbers are  given.) (SETQ |1C| (COND (|1C| (COLORNUMBERP |1C| 8)) (T 255))) (PROG (MAP) (SETQ MAP (ARRAY 4 'SMALLPOSP 0 0)) [for I from 0 to 3 do (SETA MAP I (LOGOR (COND ((ZEROP (LOGAND I 1)) |0C|) (T |1C|)) (LLSH (COND ((ZEROP (LOGAND I 2)) |0C|) (T |1C|)) 8] (RETURN MAP]) ) (DEFINEQ (\GETCOLORBRUSH [LAMBDA (BRUSH COLOR NBITS) (* rrb "21-DEC-82 20:46") (* produces a colorbitmap that is  1's where ever the brush bitmap  would be 1) (COND ((AND (BITMAPP BRUSH) (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BRUSH) NBITS)) BRUSH) (T (COLORIZEBITMAP [COND ((LISTP BRUSH) (\BRUSHBITMAP (fetch (BRUSH BRUSHSHAPE) of BRUSH) (fetch (BRUSH BRUSHSIZE) of BRUSH))) (T (\BRUSHBITMAP 'ROUND (OR BRUSH 1] 0 COLOR NBITS]) ) (DEFINEQ (\DRAWCOLORLINE1 [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH NBITS COLOR) (* ; "Edited 21-Aug-91 12:15 by jds") (DECLARE (LOCALVARS . T)) [COND ((EQ MODE 'ERASE) (* ;  "treat erase as AND of background") (SETQ COLOR (OPPOSITECOLOR COLOR NBITS] (COND ((EQ NBITS 4) (\DRAW4BPPCOLORLINE X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR) ) (T (\DRAW8BPPCOLORLINE X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR]) (\DRAW4BPPCOLORLINE [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR) (* ; "Edited 21-Aug-91 12:12 by jds") (DECLARE (LOCALVARS . T)) (* ;; "draws a color line starting at X0,Y0 at a slope of DX/DY until reaching either XLIMIT or YLIMIT with an initial overflow bucket size of CDL in MODE. Arranged so that the clipping routines can determine what the exact location of the end point of the clipped line is wrt line drawing coordinates eg. amount in overflow bucket. XLIMIT and YLIMIT are the number of points to be moved in that direction.") (PROG (MAPPTR MASK COLORMASK COLORMASKORG WORDOFFSET) (SETQ COLORMASKORG (LLSH COLOR 12)) (* ;; "keep word offset from bitmapbase so that the YINC can be negative or positive. Used to use \ADDBASE directly but negative case was not in micro code and ran much slower.") [SETQ WORDOFFSET (IPLUS (ITIMES Y0 RASTERWIDTH) (FOLDLO X0 (CONSTANT (LRSH BITSPERWORD 2] (SETQ MAPPTR (\ADDBASE BITMAPBASE WORDOFFSET)) (SETQ MASK (\4BITMASK X0)) (SETQ COLORMASK (LLSH COLOR (LLSH (IDIFFERENCE 3 (LOGAND X0 3)) 2))) (SETQ X0 0) (SETQ Y0 0) (COND ((IGEQ DX DY) (* ; "X is the fastest mover.") (.DRAW4BPPLINEX. MODE)) (T (* ; "Y is the fastest mover.") (.DRAW4BPPLINEY. MODE]) (\DRAW8BPPCOLORLINE [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR) (* ; "Edited 19-Mar-91 12:46 by matsuda") ((OPCODES SUBRCALL 143 12) X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR]) (\DRAW24BPPCOLORLINE [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR) (* kbr%: "15-Feb-86 23:00") (DECLARE (LOCALVARS . T)) (* draws a color line starting at X0,Y0 at a slope of DX/DY until reaching  either XLIMIT or YLIMIT with an initial overflow bucket size of CDL in MODE.  Arranged so that the clipping routines can determine what the exact location of  the end point of the clipped line is wrt line drawing coordinates eg.  amount in overflow bucket. XLIMIT and YLIMIT are the number of points to be  moved in that direction.) (PROG (MAPPTR STARTBYTE WORDOFFSET) (* keep word offset from bitmapbase so that the YINC can be negative or  positive. Used to use \ADDBASE directly but negative case was not in micro code  and ran much slower.) [SETQ WORDOFFSET (IPLUS (ITIMES Y0 RASTERWIDTH) (FOLDLO X0 (CONSTANT (LRSH BITSPERWORD 3] (SETQ MAPPTR (\ADDBASE BITMAPBASE WORDOFFSET)) (SETQ STARTBYTE (LOGAND X0 1)) (SETQ X0 0) (SETQ Y0 0) (COND ((IGEQ DX DY) (* X is the fastest mover.) (.DRAW24BPPLINEX MODE)) (T (* Y is the fastest mover.) (.DRAW24BPPLINEY MODE]) ) (DECLARE%: DONTCOPY DOEVAL@COMPILE (DECLARE%: EVAL@COMPILE (PUTPROPS .DRAW4BPPLINEX. MACRO [(MODE) (PROG (INSIDEBITS OUTSIDEBITS) (until (IGREATERP X0 XLIMIT) do (* main loop) (SETQ INSIDEBITS (LOGAND MASK (fetch (BITMAPWORD BITS) of MAPPTR))) (SETQ OUTSIDEBITS (LOGAND (LOGNOT MASK) (fetch (BITMAPWORD BITS) of MAPPTR))) [replace (BITMAPWORD BITS) of MAPPTR with (SELECTQ MODE (ERASE (LOGOR (LOGAND COLORMASK INSIDEBITS) OUTSIDEBITS)) (INVERT (LOGOR (LOGXOR COLORMASK INSIDEBITS) OUTSIDEBITS)) (PAINT (LOGOR (LOGOR COLORMASK INSIDEBITS) OUTSIDEBITS)) (PROGN (* case is REPLACE.  Legality of OPERATION has been  checked by \CLIPANDDRAWLINE1) (LOGOR COLORMASK OUTSIDEBITS] [COND ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY] (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DX)) (SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC] [COND [(ZEROP (SETQ MASK (LRSH MASK 4))) (* crossed word boundary) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET] (SETQ COLORMASK COLORMASKORG) (SETQ MASK (CONSTANT (\4BITMASK 0] (T (SETQ COLORMASK (LRSH COLORMASK 4] (SETQ X0 (ADD1 X0]) (PUTPROPS .DRAW8BPPLINEX MACRO ((MODE) (PROG NIL (COND ((EQ STARTBYTE 1) (GO 1LP))) 0LP (* main loop) (\PUTBASEBYTE MAPPTR 0 (SELECTQ MODE (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 0) )) (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 0 ))) (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 0))) (PROGN (* case is REPLACE.  Legality of OPERATION has been  checked by \CLIPANDDRAWLINE1) COLOR))) [COND ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY] (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DX)) (SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC] (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) 1LP (\PUTBASEBYTE MAPPTR 1 (SELECTQ MODE (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 1) )) (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 1 ))) (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 1))) (PROGN (* case is REPLACE.  Legality of OPERATION has been  checked by \CLIPANDDRAWLINE1) COLOR))) [COND ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY] (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DX)) (SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC] (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET] (GO 0LP)))) (PUTPROPS .DRAW24BPPLINEX MACRO ((MODE) (PROG NIL (* main loop) LP (\PUTBASE24 MAPPTR 0 (SELECTQ MODE (ERASE (LOGAND COLOR (\GETBASE24 MAPPTR 0))) (INVERT (LOGXOR COLOR (\GETBASE24 MAPPTR 0))) (PAINT (LOGOR COLOR (\GETBASE24 MAPPTR 0))) (PROGN (* case is REPLACE.  Legality of OPERATION has been  checked by \CLIPANDDRAWLINE1) COLOR))) [COND ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY] (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DX)) (SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC] (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET] (GO LP)))) (PUTPROPS .DRAW4BPPLINEY. MACRO [(MODE) (PROG (INSIDEBITS OUTSIDEBITS) (until (IGREATERP Y0 YLIMIT) do (* main loop) (SETQ INSIDEBITS (LOGAND MASK (fetch (BITMAPWORD BITS) of MAPPTR))) (SETQ OUTSIDEBITS (LOGAND (LOGNOT MASK) (fetch (BITMAPWORD BITS) of MAPPTR))) [replace (BITMAPWORD BITS) of MAPPTR with (SELECTQ MODE (ERASE (LOGOR (LOGAND COLORMASK INSIDEBITS) OUTSIDEBITS)) (INVERT (LOGOR (LOGXOR COLORMASK INSIDEBITS) OUTSIDEBITS)) (PAINT (LOGOR (LOGOR COLORMASK INSIDEBITS) OUTSIDEBITS)) (PROGN (* case is REPLACE.  Legality of OPERATION has been  checked by \CLIPANDDRAWLINE1) (LOGOR COLORMASK OUTSIDEBITS] [COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY)) (COND [(ZEROP (SETQ MASK (LRSH MASK 4))) (* crossed word boundary) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET ] (SETQ COLORMASK COLORMASKORG) (SETQ MASK (CONSTANT (\4BITMASK 0] (T (SETQ COLORMASK (LRSH COLORMASK 4] [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC] (SETQ Y0 (ADD1 Y0]) (PUTPROPS .DRAW8BPPLINEY MACRO ((MODE) (PROG NIL (COND ((EQ STARTBYTE 1) (GO 1LP))) 0LP (* main loop) (\PUTBASEBYTE MAPPTR 0 (SELECTQ MODE (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 0) )) (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 0 ))) (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 0))) (PROGN (* case is REPLACE.  Legality of OPERATION has been  checked by \CLIPANDDRAWLINE1) COLOR))) (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC] (COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (* moved enough in Y to move a point  in X) (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY)) (GO 1LP))) (GO 0LP) 1LP (\PUTBASEBYTE MAPPTR 1 (SELECTQ MODE (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 1) )) (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 1 ))) (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 1))) (PROGN (* case is REPLACE.  Legality of OPERATION has been  checked by \CLIPANDDRAWLINE1) COLOR))) (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC] (COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (* moved enough in Y to move a point  in X) (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY)) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET ] (GO 0LP))) (GO 1LP)))) (PUTPROPS .DRAW24BPPLINEY MACRO ((MODE) (PROG NIL (COND ((EQ STARTBYTE 1) (GO 1LP))) 0LP (* main loop) (\PUTBASEBYTE MAPPTR 0 (SELECTQ MODE (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 0 ))) (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 0))) (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 0) )) (PROGN (* case is REPLACE.  Legality of OPERATION has been  checked by \CLIPANDDRAWLINE1) COLOR))) (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC] (COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (* moved enough in Y to move a point  in X) (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY)) (GO 1LP))) (GO 0LP) 1LP (\PUTBASEBYTE MAPPTR 1 (SELECTQ MODE (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 1 ))) (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 1))) (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 1) )) (PROGN (* case is REPLACE.  Legality of OPERATION has been  checked by \CLIPANDDRAWLINE1) COLOR))) (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC] (COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (* moved enough in Y to move a point  in X) (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY)) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET ] (GO 0LP))) (GO 1LP)))) ) (FILESLOAD (LOADCOMP) MAIKOCOLOR) ) (DEFINEQ (\BWTOCOLORBLT [LAMBDA (SOURCEBWBM SLEFT SBOTTOM DESTCOLORBM DLEFT DBOTTOM WIDTH HEIGHT 0COLOR 1COLOR DESTNBITS) (* kbr%: "15-Feb-86 11:06") (* blits from a black and white bitmap into a color bitmap which has DESTNBITS  bits per pixel. DESTCOLORBM is a pointer to the color bitmap.) (* assumes all datatypes and bounds  have been checked) (SELECTQ DESTNBITS (4 [PROG (MAP SRCBASE SRCHEIGHT SRCRW SRCWRD SRCOFFSET DESBASE DESHEIGHT DESRW DESWRD DESOFF NBITS DESALIGNLEFT SCR) (SETQ MAP (fetch (ARRAYP BASE) of (\MAP4 0COLOR 1COLOR))) (SETQ SRCBASE (fetch (BITMAP BITMAPBASE) of SOURCEBWBM)) (SETQ SRCHEIGHT (fetch (BITMAP BITMAPHEIGHT) of SOURCEBWBM)) (SETQ SRCRW (fetch (BITMAP BITMAPRASTERWIDTH) of SOURCEBWBM)) (SETQ SRCWRD (FOLDLO SLEFT BITSPERWORD)) (SETQ SRCOFFSET (MOD SLEFT BITSPERWORD)) (SETQ DESBASE (fetch (BITMAP BITMAPBASE) of DESTCOLORBM)) (SETQ DESHEIGHT (fetch (BITMAP BITMAPHEIGHT) of DESTCOLORBM)) (SETQ DESRW (fetch (BITMAP BITMAPRASTERWIDTH) of DESTCOLORBM)) (SETQ DESWRD (FOLDLO DLEFT 4)) (SETQ DESOFF (MOD DLEFT 4)) (SETQ NBITS 4) (* DESTCOLORBM is used to allow one  bit per pixel bitblt operations on  the bitmap.) [COND ((NOT (EQ 0 DESOFF)) (* save the left bits of the  destination bitmap so it can be word  aligned.) (SETQ SCR (BITMAPCREATE 4 HEIGHT 4)) (BITBLT DESTCOLORBM (SETQ DESALIGNLEFT (LLSH DESWRD 2)) DBOTTOM SCR 0 0 DESOFF HEIGHT 'INPUT 'REPLACE] (for LINECOUNTER from 1 to HEIGHT do (* linecounter goes from 1 to height because bitmaps are stored internally with  top first so subtracting height is necessary to get offset of line and the 1  corrects for height difference.) (\4BITLINEBLT (\ADDBASE SRCBASE (IPLUS (ITIMES (IDIFFERENCE SRCHEIGHT (IPLUS LINECOUNTER SBOTTOM)) SRCRW) SRCWRD)) SRCOFFSET (\ADDBASE DESBASE (IPLUS (ITIMES (IDIFFERENCE DESHEIGHT (IPLUS LINECOUNTER DBOTTOM)) DESRW) DESWRD)) WIDTH MAP 0COLOR 1COLOR)) (COND (DESALIGNLEFT (* move the color bits to the right  and restore the saved color bits.) (BITBLT DESTCOLORBM DESALIGNLEFT DBOTTOM DESTCOLORBM (IPLUS DESALIGNLEFT DESOFF) DBOTTOM WIDTH HEIGHT 'INPUT 'REPLACE) (BITBLT SCR 0 0 DESTCOLORBM DESALIGNLEFT DBOTTOM DESOFF HEIGHT 'INPUT 'REPLACE]) (8 (PROG (MAP SRCBASE SRCHEIGHT SRCRW SRCWRD SRCOFFSET DESBASE DESHEIGHT DESRW DESWRD DESOFF) (SETQ MAP (fetch (ARRAYP BASE) of (\MAP8 0COLOR 1COLOR))) (SETQ SRCBASE (fetch (BITMAP BITMAPBASE) of SOURCEBWBM)) (SETQ SRCHEIGHT (fetch (BITMAP BITMAPHEIGHT) of SOURCEBWBM)) (SETQ SRCRW (fetch (BITMAP BITMAPRASTERWIDTH) of SOURCEBWBM)) (SETQ SRCWRD (FOLDLO SLEFT BITSPERWORD)) (SETQ SRCOFFSET (MOD SLEFT BITSPERWORD)) (SETQ DESBASE (fetch (BITMAP BITMAPBASE) of DESTCOLORBM)) (SETQ DESHEIGHT (fetch (BITMAP BITMAPHEIGHT) of DESTCOLORBM)) (SETQ DESRW (fetch (BITMAP BITMAPRASTERWIDTH) of DESTCOLORBM)) (SETQ DESWRD (FOLDLO DLEFT 2)) (SETQ DESOFF (MOD DLEFT 2)) (for LINECOUNTER from 1 to HEIGHT do (* linecounter goes from 1 to height because bitmaps are stored internally with  top first so subtracting height is necessary to get offset of line and the 1  corrects for height difference.) (\8BITLINEBLT (\ADDBASE SRCBASE (IPLUS (ITIMES (IDIFFERENCE SRCHEIGHT (IPLUS LINECOUNTER SBOTTOM)) SRCRW) SRCWRD)) SRCOFFSET (\ADDBASE DESBASE (IPLUS (ITIMES (IDIFFERENCE DESHEIGHT (IPLUS LINECOUNTER DBOTTOM)) DESRW) DESWRD)) DESOFF WIDTH MAP 0COLOR 1COLOR)))) (24 (PROG (SRCBASE SRCHEIGHT SRCRW DESBASE DESHEIGHT DESRW) (SETQ SRCBASE (fetch (BITMAP BITMAPBASE) of SOURCEBWBM)) (SETQ SRCHEIGHT (fetch (BITMAP BITMAPHEIGHT) of SOURCEBWBM)) (SETQ SRCRW (fetch (BITMAP BITMAPRASTERWIDTH) of SOURCEBWBM)) (SETQ DESBASE (fetch (BITMAP BITMAPBASE) of DESTCOLORBM)) (SETQ DESHEIGHT (fetch (BITMAP BITMAPHEIGHT) of DESTCOLORBM)) (SETQ DESRW (fetch (BITMAP BITMAPRASTERWIDTH) of DESTCOLORBM)) (for LINECOUNTER from 1 to HEIGHT do (* linecounter goes from 1 to height because bitmaps are stored internally with  top first so subtracting height is necessary to get offset of line and the 1  corrects for height difference.) (\24BITLINEBLT (\ADDBASE SRCBASE (ITIMES (IDIFFERENCE SRCHEIGHT (IPLUS LINECOUNTER SBOTTOM)) SRCRW)) SLEFT (\ADDBASE DESBASE (ITIMES (IDIFFERENCE DESHEIGHT (IPLUS LINECOUNTER DBOTTOM)) DESRW)) DLEFT WIDTH 0COLOR 1COLOR)))) (SHOULDNT]) (\4BITLINEBLT [LAMBDA (SBASE SBITOFFSET DBASE WIDTH MAPBASE 0COLOR 1COLOR) (* rrb "15-OCT-82 09:28") (* moves one line of a black and white bitmap into a color bitmap using a  mapping table. Destination bit offset is assumed to be 0 because \BWTOCOLORBLT  arranges things so that it is.) (SELECTQ (MOD SBITOFFSET 4) (0 (* case of moving even aligned bits.) [PROG NIL ONEWRDLP (* SBITOFFSET is either 0, 4, 8 or  12) (COND ((AND (EQ SBITOFFSET 0) (IGREATERP WIDTH (SUB1 BITSPERWORD))) (* go to center loop.) (GO LP)) ((IGREATERP 4 WIDTH) [PROG (SWORDCONTENTS) (SETQ SWORDCONTENTS (\GETBASE SBASE 0)) (SELECTQ WIDTH (0) (1 (PUTBASEBYTE DBASE 0 (LOGOR (LOGAND (\GETBASEBYTE DBASE 0) 15) (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4)))) (2 [PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (ADD1 SBITOFFSET] 0COLOR) (T 1COLOR]) (PROGN [\PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (ADD1 SBITOFFSET] 0COLOR) (T 1COLOR] (\PUTBASEBYTE DBASE 1 (LOGOR (LLSH (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (IPLUS SBITOFFSET 2] 0COLOR) (T 1COLOR)) 4) (LOGAND (\GETBASE DBASE 0) 15] (RETURN)) (T (* move 4 bits from source to  destination.) [\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET (0 (fetch (NIBBLES N1) of SBASE)) (4 (fetch (NIBBLES N2) of SBASE)) (8 (fetch (NIBBLES N3) of SBASE)) (fetch (NIBBLES N4) of SBASE] (SETQ DBASE (\ADDBASE DBASE 1)) (SETQ WIDTH (IDIFFERENCE WIDTH 4)) [COND ((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4)) 16) (SETQ SBITOFFSET 0) (SETQ SBASE (\ADDBASE SBASE 1] (GO ONEWRDLP))) LP (COND ((IGREATERP WIDTH (SUB1 BITSPERWORD)) (* move a source word's worth of  bits.) (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (NIBBLES N1) of SBASE))) (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (NIBBLES N2) of SBASE))) (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (NIBBLES N3) of SBASE))) (\PUTBASE DBASE 3 (\GETBASE MAPBASE (fetch (NIBBLES N4) of SBASE))) (SETQ DBASE (\ADDBASE DBASE 4)) (SETQ SBASE (\ADDBASE SBASE 1)) (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD)) (GO LP)) (T (* finish off last less than 16  bits.) (GO ONEWRDLP]) (1 (* moving bits that are aligned with 1 extra bit in the following word of the  source.) [PROG NIL ONEWRDLP (* SBITOFFSET is either 0, 4, 8 or  12) (COND ((AND (EQ SBITOFFSET 1) (IGREATERP WIDTH (SUB1 BITSPERWORD))) (* go to center loop.) (GO LP)) ((IGREATERP 4 WIDTH) [PROG (SWORDCONTENTS) (SETQ SWORDCONTENTS (\GETBASE SBASE 0)) (SELECTQ WIDTH (0) (1 (PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4) (LOGAND (\GETBASEBYTE DBASE 0) 15)))) (2 [PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (ADD1 SBITOFFSET] 0COLOR) (T 1COLOR]) (PROGN [\PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (ADD1 SBITOFFSET] 0COLOR) (T 1COLOR] (\PUTBASEBYTE DBASE 1 (LOGOR (LLSH (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (IPLUS SBITOFFSET 2] 0COLOR) (T 1COLOR)) 4) (LOGAND (\GETBASE DBASE 0) 15] (RETURN)) (T (* move 4 bits from source to  destination.) [\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET (1 (fetch (ONEOFFSETBITACCESS BITS1TO4) of SBASE)) (5 (fetch (ONEOFFSETBITACCESS BITS5TO8) of SBASE)) (9 (fetch (ONEOFFSETBITACCESS BITS9TO12) of SBASE)) (LOGOR (LLSH (fetch ( ONEOFFSETBITACCESS BITS13TO15) of SBASE) 1) (fetch (ODD2BITNIBBLES BIT0) of (SETQ SBASE (\ADDBASE SBASE 1] (SETQ DBASE (\ADDBASE DBASE 1)) (SETQ WIDTH (IDIFFERENCE WIDTH 4)) (COND ((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4)) 17) (* SBASE has already been  incremented as part of fetching the  last 4 bits.) (SETQ SBITOFFSET 1))) (GO ONEWRDLP))) LP (COND ((IGREATERP WIDTH (SUB1 BITSPERWORD)) (* move a source word's worth of  bits.) (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (ONEOFFSETBITACCESS BITS1TO4) of SBASE))) (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (ONEOFFSETBITACCESS BITS5TO8) of SBASE))) (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (ONEOFFSETBITACCESS BITS9TO12) of SBASE))) [\PUTBASE DBASE 3 (\GETBASE MAPBASE (LOGOR (LLSH (fetch (ONEOFFSETBITACCESS BITS13TO15) of SBASE) 1) (fetch (ODD2BITNIBBLES BIT0) of (SETQ SBASE (\ADDBASE SBASE 1] (SETQ DBASE (\ADDBASE DBASE 4)) (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD)) (GO LP)) (T (* finish off last less than 16  bits.) (GO ONEWRDLP]) (2 (* moving bits that are aligned with 2 extra bits in the following word of the  source.) [PROG NIL ONEWRDLP (* SBITOFFSET is either 2, 6, 10 or  14) (COND ((AND (EQ SBITOFFSET 2) (IGREATERP WIDTH (SUB1 BITSPERWORD))) (* go to center loop.) (GO LP)) ((IGREATERP 4 WIDTH) [PROG (SWORDCONTENTS) (SETQ SWORDCONTENTS (\GETBASE SBASE 0)) (SELECTQ WIDTH (0) (1 (PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4) (LOGAND (\GETBASEBYTE DBASE 0) 15)))) (2 [PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (ADD1 SBITOFFSET] 0COLOR) (T 1COLOR]) (PROGN (* first two bits are always in this  word.) [\PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET ))) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (ADD1 SBITOFFSET ] 0COLOR) (T 1COLOR] (\PUTBASEBYTE DBASE 1 (LOGOR (LLSH (COND ([ZEROP (COND ((EQ SBITOFFSET 14) (* the next one is in the next word  if the offset is 14) (fetch (TWOOFFSETBITACCESS BIT0OFNEXTWORD) of SBASE)) (T (LOGAND SWORDCONTENTS (\BITMASK (IPLUS SBITOFFSET 2] 0COLOR) (T 1COLOR)) 4) (LOGAND (\GETBASE DBASE 0) 15] (RETURN)) (T (* move 4 bits from source to  destination.) [\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET (2 (fetch (TWOOFFSETBITACCESS BITS2TO5) of SBASE)) (6 (fetch (TWOOFFSETBITACCESS BITS6TO9) of SBASE)) (10 (fetch (TWOOFFSETBITACCESS BITS10TO13) of SBASE)) (LOGOR (LLSH (fetch ( TWOOFFSETBITACCESS BITS14TO15) of SBASE) 2) (fetch (TWOOFFSETBITACCESS BITS0TO1) of (SETQ SBASE (\ADDBASE SBASE 1] (SETQ DBASE (\ADDBASE DBASE 1)) (SETQ WIDTH (IDIFFERENCE WIDTH 4)) (COND ((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4)) 18) (* SBASE has already been  incremented as part of fetching the  last 4 bits.) (SETQ SBITOFFSET 2))) (GO ONEWRDLP))) LP (COND ((IGREATERP WIDTH (SUB1 BITSPERWORD)) (* move a source word's worth of  bits.) (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (TWOOFFSETBITACCESS BITS2TO5) of SBASE))) (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (TWOOFFSETBITACCESS BITS6TO9) of SBASE))) (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (TWOOFFSETBITACCESS BITS10TO13) of SBASE))) [\PUTBASE DBASE 3 (\GETBASE MAPBASE (LOGOR (LLSH (fetch (TWOOFFSETBITACCESS BITS14TO15) of SBASE) 2) (fetch (TWOOFFSETBITACCESS BITS0TO1) of (SETQ SBASE (\ADDBASE SBASE 1] (SETQ DBASE (\ADDBASE DBASE 4)) (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD)) (GO LP)) (T (* finish off last less than 16  bits.) (GO ONEWRDLP]) (PROG NIL (* moving bits that are aligned with 3 extra bits in the following word of the  source.) ONEWRDLP (* SBITOFFSET is either 3, 7, 11 or  15) (COND ((AND (EQ SBITOFFSET 3) (IGREATERP WIDTH (SUB1 BITSPERWORD))) (* go to center loop.) (GO LP)) ((IGREATERP 4 WIDTH) [PROG (SWORDCONTENTS) (SETQ SWORDCONTENTS (\GETBASE SBASE 0)) (SELECTQ WIDTH (0) (1 (PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET) )) 0COLOR) (T 1COLOR)) 4) (LOGAND (\GETBASEBYTE DBASE 0) 15)))) (2 [PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET ))) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (COND ((EQ SBITOFFSET 15) (* the next bit is in the next word  if the offset is 15) (fetch (TWOOFFSETBITACCESS BIT0OFNEXTWORD) of SBASE)) (T (LOGAND SWORDCONTENTS (\BITMASK (IPLUS SBITOFFSET 2] 0COLOR) (T 1COLOR]) (PROGN (* first two bits are always in this  word.) [\PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET)) ) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (COND ((EQ SBITOFFSET 15) (* the next bit is in the next word  if the offset is 15) (fetch (TWOOFFSETBITACCESS BIT0OFNEXTWORD) of SBASE)) (T (LOGAND SWORDCONTENTS (\BITMASK (IPLUS SBITOFFSET 2] 0COLOR) (T 1COLOR] (\PUTBASEBYTE DBASE 1 (LOGOR (LLSH (COND ([ZEROP (COND ((EQ SBITOFFSET 15) (* the next one is in the next word  if the offset is 15) (fetch (TWOOFFSETBITACCESS BIT1OFNEXTWORD) of SBASE)) (T (LOGAND SWORDCONTENTS (\BITMASK (IPLUS SBITOFFSET 2] 0COLOR) (T 1COLOR)) 4) (LOGAND (\GETBASE DBASE 0) 15] (RETURN)) (T (* move 4 bits from source to  destination.) [\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET (3 (fetch (THREEOFFSETBTACCESS BITS3TO6) of SBASE)) (7 (fetch (THREEOFFSETBTACCESS BITS7TO10) of SBASE)) (11 (fetch (THREEOFFSETBTACCESS BITS11TO14) of SBASE)) (LOGOR (LLSH (fetch (ODD2BITNIBBLES BIT15) of SBASE) 3) (fetch (THREEOFFSETBTACCESS BITS0TO2) of (SETQ SBASE (\ADDBASE SBASE 1] (SETQ DBASE (\ADDBASE DBASE 1)) (SETQ WIDTH (IDIFFERENCE WIDTH 4)) (COND ((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4)) 19) (* SBASE has already been  incremented as part of fetching the  last 4 bits.) (SETQ SBITOFFSET 3))) (GO ONEWRDLP))) LP (COND ((IGREATERP WIDTH (SUB1 BITSPERWORD)) (* move a source word's worth of  bits.) (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (THREEOFFSETBTACCESS BITS3TO6) of SBASE))) (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (THREEOFFSETBTACCESS BITS7TO10) of SBASE))) (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (THREEOFFSETBTACCESS BITS11TO14) of SBASE))) [\PUTBASE DBASE 3 (\GETBASE MAPBASE (LOGOR (LLSH (fetch (ODD2BITNIBBLES BIT15) of SBASE) 3) (fetch (THREEOFFSETBTACCESS BITS0TO2 ) of (SETQ SBASE (\ADDBASE SBASE 1] (SETQ DBASE (\ADDBASE DBASE 4)) (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD)) (GO LP)) (T (* finish off last less than 16  bits.) (GO ONEWRDLP]) (\8BITLINEBLT [LAMBDA (SBASE SBITOFFSET DBASE DBITOFFSET WIDTH MAPBASE 0COLOR 1COLOR) (* edited%: "16-SEP-82 19:36") (* moves one line of a black and white bitmap into a color bitmap using a  mapping table.) [COND ((EQ 1 DBITOFFSET) (* move the first bit specially to  get to word boundary in destination.) (\PUTBASEBYTE DBASE 1 (COND ((ZEROP (LOGAND (\GETBASE SBASE 0) (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR))) [COND ((EQ (SETQ SBITOFFSET (ADD1 SBITOFFSET)) BITSPERWORD) (* SBITOFFSET flowed onto next word.) (SETQ SBITOFFSET 0) (SETQ SBASE (\ADDBASE SBASE 1] (SETQ DBITOFFSET 0) (SETQ DBASE (\ADDBASE DBASE 1)) (SETQ WIDTH (SUB1 WIDTH] (COND ((ZEROP (MOD SBITOFFSET 2)) (* case of moving even aligned bits.) (PROG NIL LP [COND ((AND (IGREATERP WIDTH (SUB1 BITSPERWORD)) (EQ SBITOFFSET 0)) (* move a source word's worth of  bits.) (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN1) of SBASE))) (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN2) of SBASE))) (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN3) of SBASE))) (\PUTBASE DBASE 3 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN4) of SBASE))) (\PUTBASE DBASE 4 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN5) of SBASE))) (\PUTBASE DBASE 5 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN6) of SBASE))) (\PUTBASE DBASE 6 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN7) of SBASE))) (\PUTBASE DBASE 7 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN8) of SBASE))) (SETQ DBASE (\ADDBASE DBASE 8)) (SETQ SBASE (\ADDBASE SBASE 1)) (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD))) ((EQ WIDTH 0) (RETURN)) ((EQ WIDTH 1) (* move last bit specially) (\PUTBASEBYTE DBASE 0 (COND ((ZEROP (LOGAND (\GETBASE SBASE 0) (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR))) (RETURN)) (T (* move the rest of the first word  or last word two at a time.) (\PUTBASEBYTE DBASE 0 (COND ((ZEROP (LOGAND (\GETBASE SBASE 0) (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR))) (\PUTBASEBYTE DBASE 1 (COND ([ZEROP (LOGAND (\GETBASE SBASE 0) (\BITMASK (ADD1 SBITOFFSET] 0COLOR) (T 1COLOR))) (SETQ DBASE (\ADDBASE DBASE 1)) (SETQ WIDTH (IDIFFERENCE WIDTH 2)) (COND ((EQ SBITOFFSET 14) (SETQ SBASE (\ADDBASE SBASE 1)) (SETQ SBITOFFSET 0)) (T (SETQ SBITOFFSET (IPLUS SBITOFFSET 2] (GO LP))) (T (* moving odd aligned bits.) (PROG NIL LP [COND ((AND (IGREATERP WIDTH (SUB1 BITSPERWORD)) (EQ SBITOFFSET 1)) (* move a source word's worth of bits. move the 1th thru 15th bits in the first  word plus the 0th bit in the next word.) (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT1) of SBASE))) (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT2) of SBASE))) (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT3) of SBASE))) (\PUTBASE DBASE 3 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT4) of SBASE))) (\PUTBASE DBASE 4 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT5) of SBASE))) (\PUTBASE DBASE 5 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT6) of SBASE))) (\PUTBASE DBASE 6 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT7) of SBASE))) (\PUTBASEBYTE DBASE 14 (COND ((ZEROP (fetch (ODD2BITNIBBLES BIT15) of SBASE) ) 0COLOR) (T 1COLOR))) (\PUTBASEBYTE DBASE 15 (COND ([ZEROP (fetch (ODD2BITNIBBLES BIT0) of (SETQ SBASE (\ADDBASE SBASE 1] 0COLOR) (T 1COLOR))) (SETQ DBASE (\ADDBASE DBASE 8)) (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD))) ((EQ WIDTH 0) (RETURN)) ((EQ WIDTH 1) (* move last bit specially) (\PUTBASEBYTE DBASE 0 (COND ((ZEROP (LOGAND (\GETBASE SBASE 0) (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR))) (RETURN)) ((EQ SBITOFFSET 15) (* case of moving one bit from each  of two words in the slow case.) (\PUTBASEBYTE DBASE 0 (COND ((ZEROP (fetch (ODD2BITNIBBLES BIT15) of SBASE)) 0COLOR) (T 1COLOR))) (\PUTBASEBYTE DBASE (SETQ SBITOFFSET 1) (COND ([ZEROP (fetch (ODD2BITNIBBLES BIT0) of (SETQ SBASE (\ADDBASE SBASE 1] 0COLOR) (T 1COLOR))) (SETQ WIDTH (IDIFFERENCE WIDTH 2)) (SETQ DBASE (\ADDBASE DBASE 1))) (T (* move the rest of the first word or the rest of last word two at a time.) (\PUTBASEBYTE DBASE 0 (COND ((ZEROP (LOGAND (\GETBASE SBASE 0) (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR))) (\PUTBASEBYTE DBASE 1 (COND ([ZEROP (LOGAND (\GETBASE SBASE 0) (\BITMASK (ADD1 SBITOFFSET] 0COLOR) (T 1COLOR))) (SETQ SBITOFFSET (IPLUS SBITOFFSET 2)) (SETQ WIDTH (IDIFFERENCE WIDTH 2)) (SETQ DBASE (\ADDBASE DBASE 1] (GO LP]) (\24BITLINEBLT [LAMBDA (SBASE SLEFT DBASE DLEFT WIDTH 0COLOR 1COLOR) (* kbr%: "15-Feb-86 10:56") (* moves one line of a black and white bitmap into a color bitmap using a  mapping table.) (PROG NIL (for SX from SLEFT to (IPLUS SLEFT WIDTH -1) as DX from DLEFT do (\PUTBASE24 DBASE DX (COND ([ZEROP (LOGAND (\GETBASE SBASE (FOLDLO SX BITSPERWORD)) (\BITMASK (LOGAND SX 15] 0COLOR) (T 1COLOR]) (\GETBASE24 [LAMBDA (X D) (* kbr%: "13-Feb-86 21:07") (* Get Dth 24bit pixel from packed  X. *) (PROG (DWORD ANSWER) (SETQ DWORD (FOLDLO (ITIMES 24 D) BITSPERWORD)) [SETQ ANSWER (SELECTQ (LOGAND D 1) (0 (* Get nibbles 1 0 of DWORD and  nibble 1 of following word.  *) (LOGOR (LLSH (\GETBASE X DWORD) 8) (LRSH (\GETBASE X (ADD1 DWORD)) 8))) (PROGN (* Get nibble 0 of DWORD and nibbles  1 0 of following word.  *) (LOGOR (LLSH (LOGAND (\GETBASE X DWORD) (MASK.1'S 0 8)) 16) (\GETBASE X (ADD1 DWORD] (RETURN ANSWER]) (\PUTBASE24 [LAMBDA (X D V) (* kbr%: "13-Feb-86 21:19") (* Set Dth 24bit pixel from packed  X. *) (PROG (DWORD) (SETQ DWORD (FOLDLO (ITIMES 24 D) BITSPERWORD)) (SELECTQ (LOGAND D 1) (0 (* Replace nibbles 1 0 of DWORD and  nibble 1 of following word.  *) (\PUTBASE X DWORD (LRSH V 8)) [\PUTBASE X (ADD1 DWORD) (LOGOR (LLSH (LOGAND V (MASK.1'S 0 8)) 8) (LOGAND (\GETBASE X DWORD) (MASK.1'S 0 8]) (PROGN (* Replace nibble 0 of DWORD and  nibbles 1 0 of following word.  *) (\PUTBASE X DWORD (LOGOR (LOGAND (\GETBASE X DWORD) (LLSH (MASK.1'S 0 8) 8)) (LRSH V 16))) (\PUTBASE X (ADD1 DWORD) (LOGAND V (MASK.1'S 0 16]) (COLORTEXTUREFROMCOLOR# [LAMBDA (COLOR# BITSPERPIXEL) (* kbr%: "27-Feb-86 16:48") (* returns a TEXTURE that is COLOR# tessellated in a pattern to put down  BITSPERPIXEL per pixel color) (PROG (TEXTURE) (COND ((type? BITMAP COLOR#) (* already is a texture.) (RETURN COLOR#))) (SETQ COLOR# (COLORNUMBERP COLOR# BITSPERPIXEL)) (SETQ TEXTURE (SELECTQ BITSPERPIXEL (4 (PROG (TEXTUREBITMAP BITPATTERN) (SETQ TEXTUREBITMAP (BITMAPCREATE 4 4 4)) (SETQ BITPATTERN (LOGOR (LLSH COLOR# 12) (LLSH COLOR# 8) (LLSH COLOR# 4) COLOR#)) (for I from 0 to 3 do (\BITMAPWORD TEXTUREBITMAP I BITPATTERN)) (RETURN TEXTUREBITMAP))) (8 (PROG (TEXTUREBITMAP BITPATTERN) (SETQ TEXTUREBITMAP (BITMAPCREATE 2 4 8)) (SETQ BITPATTERN (LOGOR (LLSH COLOR# 8) COLOR#)) (for I from 0 to 3 do (\BITMAPWORD TEXTUREBITMAP I BITPATTERN)) (RETURN TEXTUREBITMAP))) (24 (* This isn't right, but at least it  won't break you. *) (PROG (TEXTUREBITMAP BITMAPBASE) (SETQ TEXTUREBITMAP (BITMAPCREATE 2 4 24)) (SETQ BITMAPBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBITMAP )) (for I from 0 to 7 do (\PUTBASE24 BITMAPBASE I COLOR#)) (RETURN TEXTUREBITMAP))) (ERROR "Only 4, 8 and 24 bits per pixel implemented."))) (RETURN TEXTURE]) (\BITMAPWORD [LAMBDA (BM WORDN NEWBITS) (* edited%: " 8-SEP-82 10:54") (* puts a words worth of bits into  the WORDNth word of a bitmap.) (\PUTBASE (\ADDBASE (fetch (BITMAP BITMAPBASE) of BM) WORDN) 0 (LOGAND NEWBITS WORDMASK]) ) (DEFINEQ (COLORIZEBITMAP [LAMBDA (BITMAP 0COLOR 1COLOR BITSPERPIXEL) (* kbr%: "15-Feb-86 10:13") (* creates a copy of BITMAP that is in color form allowing BITSPERPIXEL per  pixel. 0COLOR and 1COLOR are the color numbers that get translated from 0 and 1  respectively.) (PROG (COLORBITMAP) (SETQ COLORBITMAP (BITMAPCREATE (fetch (BITMAP BITMAPWIDTH) of BITMAP) (fetch (BITMAP BITMAPHEIGHT) of BITMAP) BITSPERPIXEL)) (\BWTOCOLORBLT BITMAP 0 0 COLORBITMAP 0 0 (fetch (BITMAP BITMAPWIDTH) of BITMAP ) (fetch (BITMAP BITMAPHEIGHT) of BITMAP) (COLORNUMBERP 0COLOR BITSPERPIXEL) (COLORNUMBERP 1COLOR BITSPERPIXEL) BITSPERPIXEL) (RETURN COLORBITMAP]) (UNCOLORIZEBITMAP [LAMBDA (BITMAP COLORMAP) (* kbr%: " 2-Sep-85 19:21") (PROG (BITSPERPIXEL MAXCOLOR MAXX MAXY BWBITMAP TABLE RGB R G B BIT BASE BWBASE RASTERWIDTH BWRASTERWIDTH WORD) (SETQ MAXX (SUB1 (fetch (BITMAP BITMAPWIDTH) of BITMAP))) (SETQ MAXY (SUB1 (fetch (BITMAP BITMAPHEIGHT) of BITMAP))) (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)) (SETQ COLORMAP (OR COLORMAP (COLORMAP BITSPERPIXEL))) (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) (SETQ BWBITMAP (BITMAPCREATE (ADD1 MAXX) (ADD1 MAXY) 1)) (SETQ TABLE (\ALLOCBLOCK (FOLDHI (ADD1 MAXCOLOR) 2))) (for I from 0 to MAXCOLOR do (SETQ RGB (ELT COLORMAP I)) (SETQ R (fetch (RGB RED) of RGB)) (SETQ G (fetch (RGB GREEN) of RGB)) (SETQ B (fetch (RGB BLUE) of RGB)) (SETQ BIT (IDIFFERENCE 1 (IQUOTIENT (IPLUS R G B) 384))) (\PUTBASE TABLE I BIT)) (SETQ BASE (fetch (BITMAP BITMAPBASE) of BITMAP)) (SETQ BWBASE (fetch (BITMAP BITMAPBASE) of BWBITMAP)) (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP)) (SETQ BWRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BWBITMAP)) (SELECTQ BITSPERPIXEL (4 [for Y from 0 to MAXY do (SETQ WORD 0) [for X from 0 to MAXX do [SETQ WORD (LOGOR (LLSH WORD 1) (\GETBASE TABLE (\GETBASENYBBLE BASE X] (COND ((EQ (LOGAND X 15) 15) (\PUTBASE BWBASE (FOLDLO X 16) WORD) (SETQ WORD 0] (COND ((NOT (EQ (LOGAND MAXX 15) 15)) [SETQ WORD (LLSH WORD (IDIFFERENCE 15 (LOGAND MAXX 15] (\PUTBASE BWBASE (FOLDLO MAXX 16) WORD))) (COND ((NOT (EQ Y MAXY)) (SETQ BASE (\ADDBASE BASE RASTERWIDTH)) (SETQ BWBASE (\ADDBASE BWBASE BWRASTERWIDTH]) (8 [for Y from 0 to MAXY do (SETQ WORD 0) [for X from 0 to MAXX do [SETQ WORD (LOGOR (LLSH WORD 1) (\GETBASE TABLE (\GETBASEBYTE BASE X] (COND ((EQ (LOGAND X 15) 15) (\PUTBASE BWBASE (FOLDLO X 16) WORD) (SETQ WORD 0] (COND ((NOT (EQ (LOGAND MAXX 15) 15)) [SETQ WORD (LLSH WORD (IDIFFERENCE 15 (LOGAND MAXX 15] (\PUTBASE BWBASE (FOLDLO MAXX 16) WORD))) (COND ((NOT (EQ Y MAXY)) (SETQ BASE (\ADDBASE BASE RASTERWIDTH)) (SETQ BWBASE (\ADDBASE BWBASE BWRASTERWIDTH]) NIL) (RETURN BWBITMAP]) ) (RPAQ? \1COLORMENU NIL) (RPAQ? \4COLORMENU NIL) (RPAQ? \8COLORMENU NIL) (DEFINEQ (COLORMENU [LAMBDA (BITSPERPIXEL) (* kbr%: " 5-Jun-85 18:24") (* Make a BITSPERPIXEL color menu.  *) (PROG (MENU ITEMS MENUCOLUMNS MENUROWS BITMAP) (* Try to find old menu.  *) (SETQ MENU (SELECTQ BITSPERPIXEL (1 \1COLORMENU) (4 \4COLORMENU) (8 \8COLORMENU) (\ILLEGAL.ARG BITSPERPIXEL))) (COND (MENU (RETURN MENU))) (* Calculate menu items.  *) (SETQ ITEMS (SELECTQ BITSPERPIXEL (1 (for COLOR from 0 to 1 as SHADE in (LIST WHITESHADE BLACKSHADE) collect (LIST (PROGN (SETQ BITMAP (BITMAPCREATE 32 32)) (BLTSHADE SHADE BITMAP) BITMAP) COLOR))) (4 (for COLOR from 0 to 15 collect (LIST (PROGN (SETQ BITMAP (BITMAPCREATE 16 16 4)) (BLTSHADE COLOR BITMAP) BITMAP) COLOR))) (8 (for COLOR from 0 to 255 collect (LIST (PROGN (SETQ BITMAP (BITMAPCREATE 8 8 8)) (BLTSHADE COLOR BITMAP) BITMAP) COLOR))) (SHOULDNT))) (SETQ MENUROWS (SELECTQ BITSPERPIXEL (1 1) (4 4) (8 16) (SHOULDNT))) (SETQ MENUCOLUMNS (SELECTQ BITSPERPIXEL (1 2) (4 4) (8 16) (SHOULDNT))) (SETQ MENU (create MENU ITEMS _ ITEMS MENUROWS _ MENUROWS MENUCOLUMNS _ MENUCOLUMNS MENUBORDERSIZE _ 1)) (SELECTQ BITSPERPIXEL (1 (SETQ \1COLORMENU MENU)) (4 (SETQ \4COLORMENU MENU)) (8 (SETQ \8COLORMENU MENU)) (SHOULDNT)) (RETURN MENU]) (CURSORCOLOR [LAMBDA (COLOR) (* edited%: " 4-Jun-85 15:56") (PROG (IMAGE MASK) (SETQ IMAGE (fetch (CURSOR CUIMAGE) of \CURRENTCURSOR)) (SETQ MASK (fetch (CURSOR CUMASK) of \CURRENTCURSOR)) (BLTSHADE COLOR IMAGE) (BITBLT MASK NIL NIL IMAGE NIL NIL NIL NIL 'INVERT 'ERASE]) ) (DECLARE%: EVAL@COMPILE (RECORD RGB (RED GREEN BLUE)) (RECORD HLS (HUE LIGHTNESS SATURATION)) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (BLOCKRECORD NIBBLES ((N1 BITS 4) (N2 BITS 4) (N3 BITS 4) (N4 BITS 4))) (BLOCKRECORD ONEOFFSETBITACCESS ((BIT0 BITS 1) (BITS1TO4 BITS 4) (BITS5TO8 BITS 4) (BITS9TO12 BITS 4) (BITS13TO15 BITS 3))) (BLOCKRECORD TWOOFFSETBITACCESS ((BITS0TO1 BITS 2) (BITS2TO5 BITS 4) (BITS6TO9 BITS 4) (BITS10TO13 BITS 4) (BITS14TO15 BITS 2) (BIT0OFNEXTWORD BITS 1) (BIT1OFNEXTWORD BITS 1) (BITS2TO15OFNEXTWORD BITS 14))) (BLOCKRECORD THREEOFFSETBTACCESS ((BITS0TO2 BITS 3) (BITS3TO6 BITS 4) (BITS7TO10 BITS 4) (BITS11TO14 BITS 4) (BIT15 BITS 1))) (BLOCKRECORD 2BITNIBBLES ((EN1 BITS 2) (EN2 BITS 2) (EN3 BITS 2) (EN4 BITS 2) (EN5 BITS 2) (EN6 BITS 2) (EN7 BITS 2) (EN8 BITS 2))) (BLOCKRECORD ODD2BITNIBBLES ((BIT0 BITS 1) (ODD2BIT1 BITS 2) (ODD2BIT2 BITS 2) (ODD2BIT3 BITS 2) (ODD2BIT4 BITS 2) (ODD2BIT5 BITS 2) (ODD2BIT6 BITS 2) (ODD2BIT7 BITS 2) (BIT15 BITS 1))) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) MAIKOCOLOR) ) (DECLARE%: EVAL@COMPILE (RPAQQ BITSPERWORD 16) (CONSTANTS (BITSPERWORD 16)) ) (RPAQ? \COLORDISPLAYFDEV ) (RPAQ? \4COLORMAP (CMYCOLORMAP 2 1 1 4)) (RPAQ? \8COLORMAP (CMYCOLORMAP 3 3 2 8)) (RPAQ? \COLORDISPLAYBITS ) (RPAQ? ColorScreenBitMap ) (RPAQ? \COLORSCREEN ) (DEFINEQ (PSEUDOCOLOR [LAMBDA (TABLE DESTINATION LEFT BOTTOM WIDTH HEIGHT) (* kbr%: " 2-Sep-85 19:08") (DECLARE (LOCALVARS . T)) (PROG (left top bottom right width height DESTDD DESTSTRM) (COND ((NULL LEFT) (SETQ LEFT 0))) (COND ((NULL BOTTOM) (SETQ BOTTOM 0))) (* left, right top and bottom are the limits in destination taking into account  Clipping Regions. Clip to region in the arguments of this call.) [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] ((SETQ DESTDD (\GETDISPLAYDATA DESTINATION)) (SETQ DESTSTRM DESTINATION) (SETQ DESTINATION (fetch (\DISPLAYDATA DDDestination) of DESTDD)) (SETQ LEFT (\DSPTRANSFORMX LEFT DESTDD)) (SETQ BOTTOM (\DSPTRANSFORMY BOTTOM DESTDD)) (PROGN (* compute limits based on clipping  regions.) (SETQ left (fetch (\DISPLAYDATA DDClippingLeft) of DESTDD)) (SETQ bottom (fetch (\DISPLAYDATA DDClippingBottom) of DESTDD)) (SETQ right (fetch (\DISPLAYDATA DDClippingRight) of DESTDD)) (SETQ top (fetch (\DISPLAYDATA DDClippingTop) of DESTDD] (COND ((NOT (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATION) 8)) (ERROR "Pseudocolor only implemented for 8 bitsperpixel bitmaps" DESTINATION))) [PROGN (SETQ left (IMAX LEFT left)) (SETQ bottom (IMAX BOTTOM bottom)) [COND (WIDTH (* WIDTH is optional) (SETQ right (IMIN (IPLUS LEFT WIDTH) right] (COND (HEIGHT (* HEIGHT is optional) (SETQ top (IMIN (IPLUS BOTTOM HEIGHT) top] (* Clip and translate coordinates.) (SETQ width (IPLUS right (IMINUS left) 1)) (SETQ height (IPLUS top (IMINUS bottom) 1)) (COND (DESTSTRM (.WHILE.TOP.DS. DESTSTRM (\PSEUDOCOLOR.BITMAP TABLE DESTINATION left bottom width height))) (T (\PSEUDOCOLOR.BITMAP TABLE DESTINATION left bottom width height]) (\PSEUDOCOLOR.BITMAP [LAMBDA (TABLE BITMAP LEFT BOTTOM WIDTH HEIGHT) (* kbr%: "10-Jul-85 22:33") (\PSEUDOCOLOR.UFN (fetch (ARRAYP BASE) of TABLE) BITMAP LEFT BOTTOM WIDTH 0 HEIGHT]) (\PSEUDOCOLOR.UFN [LAMBDA (TABLEBASE BITMAP LEFT BOTTOM WIDTH ZERO HEIGHT) (* kbr%: "10-Jul-85 22:37") (* * Substitutes colors according to TABLEBASE within region of 8 bitsperpixel  BITMAP. *) (PROG (BASE RASTERWIDTH BMHEIGHT TOP RIGHT ROWBASE) (SETQ BASE (fetch (BITMAP BITMAPBASE) of BITMAP)) (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP)) (SETQ BMHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) (SETQ RIGHT (IPLUS LEFT WIDTH -1)) (SETQ BOTTOM (ITIMES RASTERWIDTH (IDIFFERENCE (SUB1 BMHEIGHT) BOTTOM))) [SETQ TOP (IDIFFERENCE BOTTOM (ITIMES RASTERWIDTH (SUB1 HEIGHT] (for Y from TOP to BOTTOM by RASTERWIDTH do (SETQ ROWBASE (\ADDBASE BASE Y)) (for X from LEFT to RIGHT do (\PUTBASEBYTE ROWBASE X (\GETBASE TABLEBASE (\GETBASEBYTE ROWBASE X ]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \COLORDISPLAYFDEV \COLORDISPLAYBITS ColorScreenBitMap \4COLORMAP \8COLORMAP) ) (* ;; "NOTE: This is very bad. I shouldn't have to and don't really want to do the following, but since about March 86, someone did something really nonstandard wrt Helvetica fonts so that the in core versions are not equal to what is stored on file. The SETFONTDESCRIPTOR and friends undoes this kludge which has never been explained to LISPCORE^ by the person who brain damaged Helvetica this way. If I don't undo this kludge by someone else, then color menus come out wrong. *") (SETFONTDESCRIPTOR 'HELVETICA 10 'MRR 0 'DISPLAY NIL) (SETQ MENUFONT (FONTCREATE 'HELVETICA 10)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS LLCOLOR COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3539 21062 (COLORDISPLAY 3549 . 6952) (COLORMAPBITS 6954 . 7111) ( \CreateColorScreenBitMap 7113 . 8484) (\CREATECOLORDISPLAYFDEV 8486 . 9444) (COLORMAP 9446 . 10860) ( COLORMAPCOPY 10862 . 11382) (SCREENCOLORMAP 11384 . 11578) (SCREENCOLORMAPENTRY 11580 . 11807) ( ROTATECOLORMAP 11809 . 12701) (RGBCOLORMAP 12703 . 14841) (CMYCOLORMAP 14843 . 15333) (GRAYCOLORMAP 15335 . 16293) (COLORSCREENBITMAP 16295 . 16533) (\COLORDISPLAYBITS 16535 . 19180) (COLORSCREEN 19182 . 19310) (SHOWCOLORTESTPATTERN 19312 . 21060)) (21101 21732 (\STARTCOLOR 21111 . 21249) (\STOPCOLOR 21251 . 21387) (\SENDCOLORMAPENTRY 21389 . 21730)) (21733 27692 (COLORMAPCREATE 21743 . 22729) ( COLORLEVEL 22731 . 23712) (COLORNUMBERP 23714 . 25298) (COLORFROMRGB 25300 . 26482) ( INTENSITIESFROMCOLORMAP 26484 . 26869) (SETCOLORINTENSITY 26871 . 27690)) (27693 33530 (\FAST8BIT 27703 . 31402) (\MAP4 31404 . 32283) (\MAP8 32285 . 33528)) (33531 34438 (\GETCOLORBRUSH 33541 . 34436 )) (34439 38686 (\DRAWCOLORLINE1 34449 . 35191) (\DRAW4BPPCOLORLINE 35193 . 36838) (\DRAW8BPPCOLORLINE 36840 . 37160) (\DRAW24BPPCOLORLINE 37162 . 38684)) (62183 120797 (\BWTOCOLORBLT 62193 . 70344) ( \4BITLINEBLT 70346 . 104918) (\8BITLINEBLT 104920 . 113861) (\24BITLINEBLT 113863 . 114646) ( \GETBASE24 114648 . 116106) (\PUTBASE24 116108 . 117716) (COLORTEXTUREFROMCOLOR# 117718 . 120341) ( \BITMAPWORD 120343 . 120795)) (120798 126101 (COLORIZEBITMAP 120808 . 121783) (UNCOLORIZEBITMAP 121785 . 126099)) (126189 129506 (COLORMENU 126199 . 129118) (CURSORCOLOR 129120 . 129504)) (132029 136501 ( PSEUDOCOLOR 132039 . 134952) (\PSEUDOCOLOR.BITMAP 134954 . 135183) (\PSEUDOCOLOR.UFN 135185 . 136499)) ))) STOP \ No newline at end of file diff --git a/library/MAIKOCOLOR b/library/MAIKOCOLOR new file mode 100644 index 00000000..7f81c6c6 --- /dev/null +++ b/library/MAIKOCOLOR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "23-Oct-91 14:43:35" |{PELE:MV:ENVOS}LIBRARY>MAIKOCOLOR.;6| 57582 changes to%: (VARS MAIKOCOLORCOMS) (FNS \MAIKOCOLOR.EVENTFN) previous date%: "22-Aug-91 17:11:25" |{PELE:MV:ENVOS}LIBRARY>MAIKOCOLOR.;3|) (* ; " Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserved. ") (PRETTYCOMPRINT MAIKOCOLORCOMS) (RPAQQ MAIKOCOLORCOMS [(P (MOVD? 'BITBLT 'ORG.BITBLT) (MOVD? 'BLTSHADE 'ORG.BLTSHADE) (MOVD? '\SLOWBLTCHAR '\OLD.SLOWBLTCHAR) (MOVD? 'CURSOREXIT 'OLD.CURSOREXIT) (MOVD? '\SOFTCURSORUP '\OLD.SOFTCURSORUP)) (FNS \MAIKO.COLORINIT \MAIKO.STARTCOLOR \MAIKO.STOPCOLOR \MAIKOCOLOR.EVENTFN \MAIKO.SENDCOLORMAPENTRY \MAIKO.CHANGESCREEN) (FNS CURSOREXIT CURSORSCREEN WARPCURSOR \SLOWBLTCHAR \SOFTCURSORUP \BITBLT.DISPLAY) (* ;  "these FNS defs. will be moved to original files,later") (FNS \PUNT.SLOWBLTCHAR \MAIKO.PUNTBLTCHAR \MAIKO.BLTCHAR) (FNS \PUNT.BLTSHADE.BITMAP \PUNT.BITBLT.BITMAP) (FNS BITMAPOBJ.SNAPW) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \MAIKO.CGTHREEP \MAIKO.CGFOURP \MAIKO.CGSIXP \MAIKO.CGTWOP) (CONSTANTS (\TO.MAIKO.MONOSCREEN 0) (\TO.MAIKO.COLORSCREEN 1) (\MAIKO.COLORSCREENWIDTH 1152) (\MAIKO.COLORSCREENHEIGHT 900) (\MAIKO.COLORPAGES 2048) (\MAIKO.COLORBUF.ALIGN 4095)) (FILES (LOADCOMP) LLDISPLAY BIGBITMAPS)) (INITVARS \MONO.PROMPTWINDOW \COLOR.PROMPTWINDOW) (GLOBALVARS MAIKOCOLOR.BITSPERPIXEL) (FILES COLOR BIGBITMAPS) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD 'CURSOREXIT 'SAVE.CURSOREXIT) (MOVD '\MAIKO.BLTCHAR '\BILTCHAR) (\MAIKO.COLORINIT) (COLORDISPLAY 'ON 'MAIKOCOLOR) (CURSORSCREEN (COLORSCREEN) 100 100) (CHANGEBACKGROUND 36) (ADD-EXEC :TTY T :REGION '(0 650 370 150)) (LOGOW]) (MOVD? 'BITBLT 'ORG.BITBLT) (MOVD? 'BLTSHADE 'ORG.BLTSHADE) (MOVD? '\SLOWBLTCHAR '\OLD.SLOWBLTCHAR) (MOVD? 'CURSOREXIT 'OLD.CURSOREXIT) (MOVD? '\SOFTCURSORUP '\OLD.SOFTCURSORUP) (DEFINEQ (\MAIKO.COLORINIT [LAMBDA NIL (DECLARE (GLOBALVARS \MAIKOCOLORWSOPS \MAIKOCOLORINFO)) (* ; "Edited 28-Apr-89 16:51 by tshimizu.fx") (SETQ \MAIKOCOLORWSOPS (create WSOPS STARTBOARD _ (FUNCTION NILL) STARTCOLOR _ (FUNCTION \MAIKO.STARTCOLOR) STOPCOLOR _ (FUNCTION \MAIKO.STOPCOLOR) EVENTFN _ (FUNCTION \MAIKOCOLOR.EVENTFN) SENDCOLORMAPENTRY _ (FUNCTION \MAIKO.SENDCOLORMAPENTRY) SENDPAGE _ (FUNCTION NILL) PILOTBITBLT _ (FUNCTION \DISPLAY.PILOTBITBLT))) (SETQ \MAIKOCOLORINFO (create DISPLAYINFO DITYPE _ 'MAIKOCOLOR DIWIDTH _ \MAIKO.COLORSCREENWIDTH DIHEIGHT _ \MAIKO.COLORSCREENHEIGHT DIBITSPERPIXEL _ 8 DIWSOPS _ \MAIKOCOLORWSOPS)) (\DEFINEDISPLAYINFO \MAIKOCOLORINFO]) (\MAIKO.STARTCOLOR [LAMBDA (FDEV) (* ; "Edited 2-Nov-88 11:13 by shimizu") (PROG (DISPLAYSTATE) (SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV)) (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'STARTCOLOR) (MOVD '\DISPLAY.PILOTBITBLT '\SOFTCURSORPILOTBITBLT) (* ;; " MMAP colorbuffer") ((OPCODES SUBRCALL 136 1) (FETCH (BITMAP BITMAPBASE) OF ColorScreenBitMap)) (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'ON]) (\MAIKO.STOPCOLOR [LAMBDA (FDEV) (* ; "Edited 28-Apr-89 16:51 by tshimizu.fx") (* ; "By Take") (PROG (DISPLAYSTATE) (SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV)) (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'OFF]) (\MAIKOCOLOR.EVENTFN [LAMBDA (FDEV EVENT) (* ; "Edited 23-Oct-91 14:18 by jds") (COND ((EQ (fetch (DISPLAYSTATE ONOFF) of (fetch (FDEV DEVICEINFO) of FDEV)) 'ON) (SELECTQ EVENT ((AFTERSAVEVM AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS) (\MAIKO.STARTCOLOR \COLORDISPLAYFDEV) (SCREENCOLORMAP (SCREENCOLORMAP)) (COND ((EQ LASTSCREEN (COLORSCREEN)) (CURSORSCREEN (COLORSCREEN) 200 200)))) NIL]) (\MAIKO.SENDCOLORMAPENTRY [LAMBDA (FDEV COLOR# RGB) (* ; "Edited 1-Dec-88 18:16 by shimizu") ((OPCODES SUBRCALL 138 4) COLOR# (CAR RGB) (CADR RGB) (CADDR RGB]) (\MAIKO.CHANGESCREEN [LAMBDA (TOSCREEN) (* ; "Edited 1-Dec-88 18:32 by shimizu") ((OPCODES SUBRCALL 137 1) TOSCREEN]) ) (DEFINEQ (CURSOREXIT [LAMBDA NIL (* ; "Edited 11-Aug-89 13:16 by takeshi") (* * called when cursor moves off the screen edge) (DECLARE (GLOBALVARS LASTSCREEN LASTMOUSEX LASTMOUSEY \MAIKO.CURRENT.SCREEN.MODE)) (PROG (SCREEN XCOORD YCOORD SCREEN2 XCOORD2 YCOORD2) (SETQ SCREEN LASTSCREEN) (SETQ XCOORD LASTMOUSEX) (SETQ YCOORD LASTMOUSEY) [SETQ SCREEN2 (COND ((EQ SCREEN \MAINSCREEN) (PROGN \COLORSCREEN)) (T (PROGN \MAINSCREEN] (* generalize for more than two  screens (or alternate physical  arrangement of screens.)) (COND ((EQ XCOORD 0) (SETQ XCOORD2 (IDIFFERENCE (fetch (SCREEN SCWIDTH) of SCREEN2) 2))) ((EQ XCOORD (SUB1 (fetch (SCREEN SCWIDTH) of SCREEN))) (SETQ XCOORD2 1)) (T (RETURN))) [SETQ YCOORD2 (IQUOTIENT (ITIMES YCOORD (SUB1 (fetch (SCREEN SCHEIGHT) of SCREEN2)) ) (SUB1 (fetch (SCREEN SCHEIGHT) of SCREEN] (CURSORSCREEN SCREEN2 XCOORD2 YCOORD2]) (CURSORSCREEN [LAMBDA (SCREEN XCOORD YCOORD) (* ; "Edited 19-Jun-90 16:33 by matsuda") (* * sets up SCREEN to be the current screen, XCOORD %, YCOORD is initial pos  of cursor on SCREEN) (COND ((NULL XCOORD) (SETQ XCOORD 0))) (COND ((NULL YCOORD) (SETQ YCOORD 0))) (PROG (DESTINATION) (SETQ DESTINATION (fetch (SCREEN SCDESTINATION) of SCREEN)) (\CURSORDOWN) (SETQ \CURSORSCREEN SCREEN) (\CURSORDESTINATION DESTINATION) (\CURSORUP \CURRENTCURSOR) (\CURSORPOSITION XCOORD YCOORD) (AND (EQUAL (MACHINETYPE) 'MAIKO) (COND ((EQ (fetch (SCREEN SCBITSPERPIXEL) of SCREEN) 1) (SETQ \COLOR.PROMPTWINDOW PROMPTWINDOW) (\MAIKO.CHANGESCREEN \TO.MAIKO.MONOSCREEN) (SETQ PROMPTWINDOW \MONO.PROMPTWINDOW)) (T (SETQ \MONO.PROMPTWINDOW PROMPTWINDOW) (\MAIKO.CHANGESCREEN \TO.MAIKO.COLORSCREEN) (SETQ PROMPTWINDOW (OR \COLOR.PROMPTWINDOW (PROG1 (SETQ W (CREATEW '(0 800 370 80) "Prompt Window" 2)) (SETQ DISPLAYDATA (FETCH IMAGEDATA OF (FETCH (WINDOW DSP) OF W))) (REPLACE DDOPERATION OF DISPLAYDATA WITH 'ERASE) (REPLACE DDTexture OF DISPLAYDATA WITH 65535) (CLEARW W))]) (WARPCURSOR [LAMBDA (ENABLE) (* ; "Edited 20-Jul-90 19:02 by matsuda") (COND (ENABLE (MOVD 'SAVE.CURSOREXIT 'CURSOREXIT) T) (T (MOVD 'NILL 'CURSOREXIT) NIL]) (\SLOWBLTCHAR [LAMBDA (CHARCODE DISPLAYSTREAM) (* ; "Edited 7-Jun-90 14:06 by matsuda") ((OPCODES SUBRCALL 140 2) CHARCODE DISPLAYSTREAM]) (\SOFTCURSORUP [LAMBDA (NEWCURSOR) (* ; "Edited 16-Jan-89 15:44 by shimizu") (* Put soft NEWCURSOR up, assuming  soft cursor is down.  *) (COND ((EQ \MACHINETYPE \MAIKO) (SETQ \CURRENTCURSOR NEWCURSOR)) (T (PROG (IMAGE MASK WIDTH BWIDTH HEIGHT CURSORBITSPERPIXEL CURSORBPL UPBMBASE DOWNBMBASE) (* Get cursor IMAGE & MASK.  *) (SETQ IMAGE (fetch (CURSOR CUIMAGE) of NEWCURSOR)) (SETQ MASK (fetch (CURSOR CUMASK) of NEWCURSOR)) (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of IMAGE)) (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of IMAGE)) (SETQ CURSORBITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE)) (* Create new UPBM & DOWNBM caches  if necessary. *) (COND ((NOT (AND (type? BITMAP \SOFTCURSORUPBM) (EQ (fetch (BITMAP BITMAPWIDTH) of \SOFTCURSORUPBM) WIDTH) (EQ (fetch (BITMAP BITMAPHEIGHT) of \SOFTCURSORUPBM) HEIGHT) (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of \SOFTCURSORUPBM) CURSORBITSPERPIXEL))) (SETQ \SOFTCURSORWIDTH WIDTH) (SETQ \SOFTCURSORHEIGHT HEIGHT) (SETQ \SOFTCURSORUPBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL)) (SETQ \SOFTCURSORDOWNBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL)) (SETQ UPBMBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORUPBM)) (\TEMPLOCKPAGES UPBMBASE 1) (SETQ DOWNBMBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORDOWNBM)) (\TEMPLOCKPAGES DOWNBMBASE 1) (SETQ CURSORBPL (UNFOLD (fetch (BITMAP BITMAPRASTERWIDTH) of IMAGE) BITSPERWORD)) (SETQ BWIDTH (ITIMES (fetch (BITMAP BITMAPWIDTH) of IMAGE) (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE))) (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT1 with CURSORBPL) (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT2 with UPBMBASE) (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT2 with CURSORBPL) (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT2 with DOWNBMBASE) (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT2 with CURSORBPL) (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT2 with BWIDTH) (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT2 with HEIGHT) (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT3 with UPBMBASE) (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT3 with CURSORBPL) (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT3 with CURSORBPL) (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT3 with BWIDTH) (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT3 with HEIGHT) (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT4 with UPBMBASE) (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT4 with CURSORBPL) (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT4 with CURSORBPL) (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT4 with BWIDTH) (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT4 with HEIGHT) (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT5 with CURSORBPL) (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT6 with CURSORBPL))) (* Change PILOTBBTs.  *) (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT3 with (fetch (BITMAP BITMAPBASE ) of MASK)) (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT4 with (fetch (BITMAP BITMAPBASE ) of IMAGE)) (* Put up new \CURRENTCURSOR.  *) (SETQ \CURRENTCURSOR NEWCURSOR) (\TEMPLOCKPAGES \CURRENTCURSOR 1) (SETQ \SOFTCURSORP T) (\SOFTCURSORUPCURRENT]) (\BITBLT.DISPLAY [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTSTRM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (* ; "Edited 24-Jan-91 11:57 by matsuda") (DECLARE (LOCALVARS . T)) (DECLARE (GLOBALVARS \SYSPILOTBBT \SCREENBITMAPS \BBSCRATCHTEXTURE \SOFTCURSORP \SOFTCURSORUPP \CURSORDESTINATION)) (PROG (stodx stody left top bottom right DESTDD DESTBITMAP DESTINATIONNBITS SOURCENBITS MAXSHADE) (SETQ DESTDD (fetch (STREAM IMAGEDATA) of DESTSTRM)) (SETQ DESTBITMAP (fetch (\DISPLAYDATA DDDestination) of DESTDD)) (* ;; "bring it to top so that its TOTOPFNs will get called before the destination information is cached in case one of them moves, reshapes, etc. the window") (* ;; "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.") (\INSURETOPWDS DESTSTRM) (SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD)) (SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD)) [PROGN (* ;  "compute limits based on clipping regions.") (SETQ left (fetch (\DISPLAYDATA DDClippingLeft) of DESTDD)) (SETQ bottom (ffetch (\DISPLAYDATA DDClippingBottom) of DESTDD)) (SETQ right (ffetch (\DISPLAYDATA DDClippingRight) of DESTDD)) (SETQ top (ffetch (\DISPLAYDATA 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 (\DSPTRANSFORMX (fetch (REGION LEFT) of CLIPPINGREGION) DESTDD] [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (\DSPTRANSFORMY (ffetch (REGION BOTTOM ) of CLIPPINGREGION) DESTDD] [SETQ right (IMIN right (IPLUS CRLEFT (ffetch (REGION WIDTH) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch (REGION HEIGHT) of CLIPPINGREGION] (SETQ DESTINATIONNBITS (BITSPERPIXEL DESTBITMAP)) (SETQ SOURCENBITS (BITSPERPIXEL SOURCEBITMAP)) [COND ((NOT (EQ SOURCENBITS DESTINATIONNBITS)) (COND ((EQ SOURCENBITS 1) (SETQ SOURCEBITMAP (COLORIZEBITMAP SOURCEBITMAP (ffetch DDBACKGROUNDCOLOR of DESTDD) (ffetch DDFOREGROUNDCOLOR of DESTDD) DESTINATIONNBITS))) [(EQ DESTINATIONNBITS 1) (SETQ SOURCEBITMAP (UNCOLORIZEBITMAP SOURCEBITMAP (COLORMAP DESTINATIONNBITS] (T (* ;; "Between two color bitmaps with different bpp. It seems that NOP is better than breaking. Eventually do some kind of output here, but don't error now. ") (RETURN] (* ;; "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 (BITMAPWIDTH SOURCEBITMAP) (IDIFFERENCE right stodx) (IPLUS CLIPPEDSOURCELEFT WIDTH))) (* ; "compute top margin") (SETQ top (IMIN (BITMAPHEIGHT SOURCEBITMAP) (IDIFFERENCE top stody) (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (OR OPERATION (SETQ OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD))) (SETQ MAXSHADE (MAXIMUMSHADE DESTINATIONNBITS)) (SELECTQ SOURCETYPE (MERGE (* ;  "Need to use complement of TEXTURE") [COND ((AND (LISTP TEXTURE) (EQ DESTINATIONNBITS 1)) (* ;  "either a color or a (texture color) filling.") (SETQ TEXTURE (INSURE.B&W.TEXTURE TEXTURE] [SETQ TEXTURE (COND ((NULL TEXTURE) MAXSHADE) ((FIXP TEXTURE) (LOGXOR (LOGAND TEXTURE MAXSHADE) MAXSHADE)) [(type? BITMAP TEXTURE) (INVERT.TEXTURE.BITMAP TEXTURE (OR \BBSCRATCHTEXTURE (SETQ \BBSCRATCHTEXTURE (BITMAPCREATE 16 16] ((NOT (EQ DESTINATIONNBITS 1)) (COLORNUMBERP TEXTURE DESTINATIONNBITS)) (T (\ILLEGAL.ARG TEXTURE] [COND ((NOT (EQ DESTINATIONNBITS 1)) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS]) (TEXTURE [COND ((EQ DESTINATIONNBITS 1) (* ;  "either a color or a (texture color) filling.") (SETQ TEXTURE (INSURE.B&W.TEXTURE TEXTURE]) NIL) [COND ((AND (NOT (EQ DESTINATIONNBITS 1)) (NOT (type? BIGBM SOURCEBITMAP)) (NOT (type? BIGBM DESTBITMAP))) (SETQ left (ITIMES DESTINATIONNBITS left)) (SETQ right (ITIMES DESTINATIONNBITS right)) (SETQ stodx (ITIMES DESTINATIONNBITS stodx] [.WHILE.TOP.DS. DESTSTRM (COND [(AND (NOT (type? BIGBM SOURCEBITMAP)) (NOT (type? BIGBM DESTBITMAP))) (PROG (HEIGHT WIDTH DTY DLX STY SLX) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ DTY (\SFInvert DESTBITMAP (IPLUS top stody))) (SETQ DLX (IPLUS left stodx)) (SETQ STY (\SFInvert SOURCEBITMAP top)) (SETQ SLX left) (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT with WIDTH) (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT with HEIGHT) (COND ((EQ SOURCETYPE 'MERGE) (\BITBLT.MERGE \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT OPERATION TEXTURE)) (T (\BITBLTSUB \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY HEIGHT SOURCETYPE OPERATION TEXTURE] (T (PROG (HEIGHT WIDTH DBY DLX SBY SLX) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ DBY (IPLUS bottom stody)) (SETQ DLX (IPLUS left stodx)) (SETQ SBY bottom) (SETQ SLX left) (BITBLT.BIGBM SOURCEBITMAP SLX SBY DESTBITMAP DLX DBY WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE] (RETURN T]) ) (* ; "these FNS defs. will be moved to original files,later") (DEFINEQ (\PUNT.SLOWBLTCHAR [LAMBDA (CHARCODE DISPLAYSTREAM) (* ; "Edited 2-Jul-90 14:23 by matsuda") (* ;; "case of BLTCHAR where either font is rotated or destination is a color bitmap. DISPLAYSTREAM is known to be a display stream, and its cache fields have been updated for CHARCODE's charset") (PROG (ROTATION CHAR8CODE DD FONTDESC) (SETQ CHAR8CODE (\CHAR8CODE CHARCODE)) (SETQ DD (ffetch (STREAM IMAGEDATA) of DISPLAYSTREAM)) (SETQ FONTDESC (ffetch (\DISPLAYDATA DDFONT) of DD)) (SETQ ROTATION (ffetch (FONTDESCRIPTOR ROTATION) of FONTDESC)) (COND ((EQ 0 ROTATION) (PROG (NEWX LEFT RIGHT CURX PILOTBBT DESTBIT WIDTH SOURCEBIT CSINFO) (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) (ffetch (\DISPLAYDATA DDFONT) of DD))) (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DD)) (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DD))) [COND ((IGREATERP NEWX (ffetch (\DISPLAYDATA DDRightMargin) of DD)) (* ; "past RIGHT margin, force eol") (\DSPPRINTCR/LF (CHARCODE EOL) DISPLAYSTREAM) (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DD)) (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DD] (* ; "update the x position.") (freplace (\DISPLAYDATA DDXPOSITION) of DD with NEWX) (* SETQ CURX (\DSPTRANSFORMX CURX DD)) (SETQ LEFT (IMAX (ffetch (\DISPLAYDATA DDClippingLeft) of DD) CURX)) (SETQ RIGHT (IMIN (ffetch (\DISPLAYDATA DDClippingRight) of DD) (\DSPTRANSFORMX NEWX DD))) (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) (\DSPGETCHAROFFSET CHAR8CODE DD) 0 DISPLAYSTREAM CURX (IDIFFERENCE (ffetch (\DISPLAYDATA DDYPOSITION) of DD) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) (\DSPGETCHARWIDTH CHAR8CODE DD) (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO))) (* ; "(SETQ PILOTBBT (|ffetch| (\\DISPLAYDATA DDPILOTBBT) |of| DD)) (COND ((AND (ILESSP LEFT RIGHT) (NOT (EQ (|ffetch| (PILOTBBT PBTHEIGHT) |of| PILOTBBT) 0))) (SETQ DESTBIT LEFT) (SETQ WIDTH (IDIFFERENCE RIGHT LEFT)) (SETQ SOURCEBIT (IDIFFERENCE (IPLUS (\\DSPGETCHAROFFSET CHAR8CODE DD) LEFT) CURX)) (SELECTQ (|ffetch| (BITMAP BITMAPBITSPERPIXEL) |of| (|ffetch| (\\DISPLAYDATA |DDDestination|) |of| DD)) (1) (4 (SETQ DESTBIT (LLSH DESTBIT 2)) (SETQ WIDTH (LLSH WIDTH 2)) (SETQ SOURCEBIT (LLSH SOURCEBIT 2))) (8 (SETQ DESTBIT (LLSH DESTBIT 3)) (SETQ WIDTH (LLSH WIDTH 3)) (SETQ SOURCEBIT (LLSH SOURCEBIT 3))) (24 (SETQ DESTBIT (ITIMES 24 DESTBIT)) (SETQ WIDTH (ITIMES 24 WIDTH)) (SETQ SOURCEBIT (ITIMES 24 SOURCEBIT))) (SHOULDNT)) (.WHILE.TOP.DS. DISPLAYSTREAM (|freplace| (PILOTBBT PBTDESTBIT) |of| PILOTBBT |with| DESTBIT) (|freplace| (PILOTBBT PBTWIDTH) |of| PILOTBBT |with| WIDTH) (|freplace| (PILOTBBT PBTSOURCEBIT) |of| PILOTBBT |with| SOURCEBIT) (\\PILOTBITBLT PILOTBBT 0)) T))") )) (T (* ; "handle rotated fonts") (PROG (YPOS HEIGHTMOVED CSINFO) (SETQ YPOS (ffetch (\DISPLAYDATA DDYPOSITION) of DD)) (SETQ HEIGHTMOVED (\DSPGETCHARWIDTH CHAR8CODE DD)) (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) (ffetch (\DISPLAYDATA DDFONT) of DD))) (COND ((EQ ROTATION 90) (* ;  "don't force CR for rotated fonts.") (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IPLUS YPOS HEIGHTMOVED)) (* ;  "update the display stream x position.") (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) 0 (\DSPGETCHAROFFSET CHAR8CODE DD) DISPLAYSTREAM (ADD1 (IDIFFERENCE (ffetch (\DISPLAYDATA DDXPOSITION) of DD) (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO)) ) YPOS (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) HEIGHTMOVED)) ((EQ ROTATION 270) (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IDIFFERENCE YPOS HEIGHTMOVED)) (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) 0 (\GETBASE (ffetch (\DISPLAYDATA DDOFFSETSCACHE) of DD) CHAR8CODE) DISPLAYSTREAM (IDIFFERENCE (ffetch (\DISPLAYDATA DDXPOSITION) of DD) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) (ffetch (\DISPLAYDATA DDYPOSITION) of DISPLAYSTREAM) (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"]) (\MAIKO.PUNTBLTCHAR [LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* ; "Edited 1-Nov-89 15:26 by takeshi") (* ;; "puts a character on a display stream. This function will be called when \maiko.bltchar failed. Punt from subr call") (DECLARE (LOCALVARS . T)) (PROG (LOCAL1 RIGHT LEFT CURX CHAR8CODE) (SETQ CHAR8CODE (\CHAR8CODE CHARCODE)) CRLP [COND ((NOT (EQ (ffetch (\DISPLAYDATA DDCHARSET) of DISPLAYDATA) (\CHARSET CHARCODE))) (\CHANGECHARSET.DISPLAY DISPLAYDATA (\CHARSET CHARCODE] [COND ((ffetch (\DISPLAYDATA DDSlowPrintingCase) of DISPLAYDATA) (RETURN (COND ((type? STREAM DISPLAYSTREAM) (\SLOWBLTCHAR CHARCODE DISPLAYSTREAM)) ((type? WINDOW DISPLAYSTREAM) (\SLOWBLTCHAR CHARCODE (FETCH DSP OF DISPLAYSTREAM))) (T (ERROR "Not Stream or Window" DISPLAYSTREAM] (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA)) (SETQ RIGHT (IPLUS CURX (\DSPGETCHARIMAGEWIDTH CHAR8CODE DISPLAYDATA))) [COND ((IGREATERP RIGHT (ffetch (\DISPLAYDATA DDRightMargin) of DISPLAYDATA)) (* ;  "would go past right margin, force a cr") (COND ((IGREATERP CURX (ffetch (\DISPLAYDATA DDLeftMargin) of DISPLAYDATA)) (* ;  "don't bother CR if position is at left margin anyway. This also serves to break the loop.") (\DSPPRINTCR/LF (CHARCODE EOL) DISPLAYSTREAM) (* ;  "reuse the code in the test of this conditional rather than repeat it here.") (GO CRLP] (* ;  "update the display stream x position.") (freplace (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA with (IPLUS CURX ( \DSPGETCHARWIDTH CHAR8CODE DISPLAYDATA))) (* ;  "transforms an x coordinate into the destination coordinate.") (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDXOFFSET) of DISPLAYDATA)) (SETQ CURX (IPLUS CURX LOCAL1)) (SETQ RIGHT (IPLUS RIGHT LOCAL1)) (COND ((IGREATERP RIGHT (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDClippingRight) of DISPLAYDATA ))) (* ;  "character overlaps right edge of clipping region.") (SETQ RIGHT LOCAL1))) (SETQ LEFT (COND ((IGREATERP CURX (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDClippingLeft) of DISPLAYDATA))) CURX) (T LOCAL1))) (RETURN (COND ((AND (ILESSP LEFT RIGHT) (NOT (EQ (fetch (PILOTBBT PBTHEIGHT) of (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDPILOTBBT) of DISPLAYDATA))) 0))) (.WHILE.TOP.DS. DISPLAYSTREAM ((OPCODES SUBRCALL 70 6) LOCAL1 DISPLAYDATA CHAR8CODE CURX LEFT RIGHT)) T]) (\MAIKO.BLTCHAR [LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* ; "Edited 6-Jul-90 10:14 by matsuda") ((OPCODES SUBRCALL 135 3) CHARCODE DISPLAYSTREAM DISPLAYDATA]) ) (DEFINEQ (\PUNT.BLTSHADE.BITMAP [LAMBDA (TEXTURE DESTINATIONBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* ; "Edited 5-Jun-90 12:12 by Takeshi") (* ;; "This FNS is for a punt case of \BLTSHADE.BITMAP which is implemeted in C ") (* ;  " Stolen from old definition of \BLTSHADE.BITMAP") (DECLARE (LOCALVARS . T)) (PROG (left bottom top right DESTINATIONNBITS) (SETQ left 0) (SETQ bottom 0) (SETQ top (fetch (BITMAP BITMAPHEIGHT) of DESTINATIONBITMAP)) (SETQ right (fetch (BITMAP BITMAPWIDTH) of DESTINATIONBITMAP)) (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATIONBITMAP)) (COND ((EQ DESTINATIONNBITS 1) (* ;  "DESTINATIONNBITS is NIL for the case of 1 bit per pixel.") (SETQ DESTINATIONNBITS NIL))) [COND (CLIPPINGREGION (* ; "adjust limits") (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION))) (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION))) [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION) (fetch (REGION LEFT) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION) (fetch (REGION HEIGHT) of CLIPPINGREGION] (OR DESTINATIONLEFT (SETQ DESTINATIONLEFT 0)) (OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM 0)) (* ;; "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 (SELECTQ (TYPENAME TEXTURE) (LITATOM (* ; "includes NIL case") (COND [DESTINATIONNBITS (COND (TEXTURE (* ; "should be a color name") (OR (COLORNUMBERP TEXTURE DESTINATIONNBITS T) (\ILLEGAL.ARG TEXTURE))) (T (MAXIMUMCOLOR DESTINATIONNBITS] (TEXTURE (\ILLEGAL.ARG TEXTURE)) (T WHITESHADE))) ((SMALLP FIXP) (COND [DESTINATIONNBITS (* ;; "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 (MAXIMUMCOLOR DESTINATIONNBITS] (T (LOGAND TEXTURE BLACKSHADE)))) (BITMAP TEXTURE) (LISTP (* ;  "can be a list of (TEXTURE COLOR) or a list of levels rgb or hls.") (COND [DESTINATIONNBITS (* ;; "color case: If it is a color, use it; if it is a list that contains a color, use that; otherwise, use the texture") (COND ((COLORNUMBERP TEXTURE)) [(COLORNUMBERP (CAR (LISTP (CDR TEXTURE] ((FIXP (CAR TEXTURE)) (LOGAND (CAR TEXTURE) (MAXIMUMCOLOR DESTINATIONNBITS))) ((TEXTUREP (CAR TEXTURE))) (T (\ILLEGAL.ARG TEXTURE] ((TEXTUREP (CAR TEXTURE))) ((COLORNUMBERP TEXTURE) (TEXTUREOFCOLOR TEXTURE)) (T (\ILLEGAL.ARG TEXTURE)))) (\ILLEGAL.ARG TEXTURE))) (* ; "filling an area with a texture.") [COND (DESTINATIONNBITS (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.") (UNINTERRUPTABLY (PROG (HEIGHT) (SETQ HEIGHT (IDIFFERENCE top bottom)) (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT with (IDIFFERENCE right left)) (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT with HEIGHT) (\BITBLTSUB \SYSPILOTBBT NIL left NIL DESTINATIONBITMAP left (\SFInvert DESTINATIONBITMAP top) HEIGHT 'TEXTURE OPERATION TEXTURE))) (RETURN T]) (\PUNT.BITBLT.BITMAP [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (* ; "Edited 5-Jun-90 11:59 by Takeshi") (* ;; " This FNS is for a punt case of \BITBLT.BITMAP which is implemeted in C") (* ;; " Stolen from old definition of \BITBLT.BITMAP") (DECLARE (LOCALVARS . T)) (PROG (stodx stody right top DESTINATIONNBITS left bottom SOURCENBITS) (SETQ top (fetch (BITMAP BITMAPHEIGHT) of DESTBITMAP)) (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTBITMAP)) (SETQ left 0) (SETQ bottom 0) (SETQ SOURCENBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of SOURCEBITMAP)) (SETQ right (fetch (BITMAP BITMAPWIDTH) of DESTBITMAP)) [COND (CLIPPINGREGION (* ; "adjust limits") (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION))) (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION))) [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION) (fetch (REGION LEFT) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION) (fetch (REGION HEIGHT) of CLIPPINGREGION] (* ;; "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 0 (IDIFFERENCE left stodx))) (* ; "compute bottom margin") (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM 0 (IDIFFERENCE bottom stody))) (* ; "compute right margin") (SETQ right (IMIN (ffetch (BITMAP BITMAPWIDTH) of SOURCEBITMAP) (IDIFFERENCE right stodx) (IPLUS CLIPPEDSOURCELEFT WIDTH))) (* ; "compute top margin") (SETQ top (IMIN (ffetch (BITMAP BITMAPHEIGHT) of SOURCEBITMAP) (IDIFFERENCE top stody) (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (SELECTQ SOURCETYPE (MERGE (* ;  "Need to use complement of TEXTURE") (* ; "MAY NOT WORK FOR COLOR CASE.") [SETQ TEXTURE (COND ((NULL TEXTURE) BLACKSHADE) ((FIXP TEXTURE) (LOGXOR (LOGAND TEXTURE BLACKSHADE) BLACKSHADE)) ((AND (NOT (EQ DESTINATIONNBITS 1)) (COLORNUMBERP TEXTURE DESTINATIONNBITS))) [(type? BITMAP TEXTURE) (INVERT.TEXTURE.BITMAP TEXTURE (OR \BBSCRATCHTEXTURE (SETQ \BBSCRATCHTEXTURE (BITMAPCREATE 16 16] (T (\ILLEGAL.ARG TEXTURE]) NIL) (COND [(EQ SOURCENBITS DESTINATIONNBITS) (* ;  "going from one to another of the same size.") (SELECTQ DESTINATIONNBITS (4 (* ;  "use UNFOLD with constant value rather than multiple because it compiles into opcodes.") (SETQ left (UNFOLD left 4)) (SETQ right (UNFOLD right 4)) (SETQ stodx (UNFOLD stodx 4)) (* ;  "set texture if it will ever get looked at.") (AND (EQ SOURCETYPE 'MERGE) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) (8 (SETQ left (UNFOLD left 8)) (SETQ right (UNFOLD right 8)) (SETQ stodx (UNFOLD stodx 8)) (AND (EQ SOURCETYPE 'MERGE) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) (24 (SETQ left (ITIMES left 24)) (SETQ right (ITIMES right 24)) (SETQ stodx (ITIMES stodx 24)) (AND (EQ SOURCETYPE 'MERGE) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) NIL) (* ;  "easy case of black and white bitmap into black and white or color to color or texture filling.") (UNINTERRUPTABLY [PROG (HEIGHT WIDTH DTY DLX STY SLX) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ DTY (\SFInvert DESTBITMAP (IPLUS top stody))) (SETQ DLX (IPLUS left stodx)) (SETQ STY (\SFInvert SOURCEBITMAP top)) (SETQ SLX left) (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT with WIDTH) (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT with HEIGHT) (COND ((EQ SOURCETYPE 'MERGE) (\BITBLT.MERGE \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT OPERATION TEXTURE)) (T (\BITBLTSUB \SYSPILOTBBT 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 (NOT (EQ SOURCETYPE 'INPUT)) (ERROR "SourceType not implemented from B&W to color bitmaps." SOURCETYPE)) (PROG (HEIGHT WIDTH DBOT DLFT) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ DBOT (IPLUS bottom stody)) (SETQ DLFT (IPLUS left stodx)) (SELECTQ OPERATION ((NIL REPLACE) (\BWTOCOLORBLT SOURCEBITMAP left bottom DESTBITMAP DLFT DBOT WIDTH HEIGHT 0 (MAXIMUMCOLOR DESTINATIONNBITS) 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]) ) (DEFINEQ (BITMAPOBJ.SNAPW [LAMBDA NIL (* ; "Edited 12-Apr-90 09:09 by matsuda") (* * makes an image object of a prompted for region of the screen.) (PROG ((REG (GETREGION)) BM) [SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG) (BITSPERPIXEL (SCREENBITMAP \CURSORSCREEN] (BITBLT (SCREENBITMAP \CURSORSCREEN) (fetch (REGION LEFT) of REG) (fetch (REGION BOTTOM) of REG) BM 0 0 NIL NIL 'INPUT 'REPLACE) (COPYINSERT (BITMAPTEDITOBJ BM 1 0)) (RETURN]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE [PROGN (DEFMACRO \MAIKO.CGTHREEP () (EQ (LOGAND 120 (fetch DEVCONFIG of \InterfacePage)) 48)) (PUTPROPS \MAIKO.CGTHREEP MACRO (NIL (EQ (LOGAND 120 (fetch DEVCONFIG of \InterfacePage )) 48)))] (PUTPROPS \MAIKO.CGFOURP MACRO (NIL (EQ (LOGAND 120 (fetch DEVCONFIG of \InterfacePage )) 64))) [PROGN (DEFMACRO \MAIKO.CGSIXP () (EQ (LOGAND 120 (fetch DEVCONFIG of \InterfacePage)) 96)) (PUTPROPS \MAIKO.CGSIXP MACRO (NIL (EQ (LOGAND 120 (fetch DEVCONFIG of \InterfacePage )) 96)))] (PUTPROPS \MAIKO.CGTWOP MACRO (NIL (EQ (LOGAND 120 (fetch DEVCONFIG of \InterfacePage )) 24))) ) (DECLARE%: EVAL@COMPILE (RPAQQ \TO.MAIKO.MONOSCREEN 0) (RPAQQ \TO.MAIKO.COLORSCREEN 1) (RPAQQ \MAIKO.COLORSCREENWIDTH 1152) (RPAQQ \MAIKO.COLORSCREENHEIGHT 900) (RPAQQ \MAIKO.COLORPAGES 2048) (RPAQQ \MAIKO.COLORBUF.ALIGN 4095) (CONSTANTS (\TO.MAIKO.MONOSCREEN 0) (\TO.MAIKO.COLORSCREEN 1) (\MAIKO.COLORSCREENWIDTH 1152) (\MAIKO.COLORSCREENHEIGHT 900) (\MAIKO.COLORPAGES 2048) (\MAIKO.COLORBUF.ALIGN 4095)) ) (FILESLOAD (LOADCOMP) LLDISPLAY BIGBITMAPS) ) (RPAQ? \MONO.PROMPTWINDOW NIL) (RPAQ? \COLOR.PROMPTWINDOW NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MAIKOCOLOR.BITSPERPIXEL) ) (FILESLOAD COLOR BIGBITMAPS) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD 'CURSOREXIT 'SAVE.CURSOREXIT) (MOVD '\MAIKO.BLTCHAR '\BILTCHAR) (\MAIKO.COLORINIT) (COLORDISPLAY 'ON 'MAIKOCOLOR) (CURSORSCREEN (COLORSCREEN) 100 100) (CHANGEBACKGROUND 36) (ADD-EXEC :TTY T :REGION '(0 650 370 150)) (LOGOW) ) (PUTPROPS MAIKOCOLOR COPYRIGHT ("Fuji Xerox Co., Ltd." 1988 1989 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2782 5984 (\MAIKO.COLORINIT 2792 . 3962) (\MAIKO.STARTCOLOR 3964 . 4559) ( \MAIKO.STOPCOLOR 4561 . 4945) (\MAIKOCOLOR.EVENTFN 4947 . 5578) (\MAIKO.SENDCOLORMAPENTRY 5580 . 5805) (\MAIKO.CHANGESCREEN 5807 . 5982)) (5985 26414 (CURSOREXIT 5995 . 7433) (CURSORSCREEN 7435 . 9475) ( WARPCURSOR 9477 . 9726) (\SLOWBLTCHAR 9728 . 9910) (\SOFTCURSORUP 9912 . 15707) (\BITBLT.DISPLAY 15709 . 26412)) (26485 37922 (\PUNT.SLOWBLTCHAR 26495 . 33267) (\MAIKO.PUNTBLTCHAR 33269 . 37722) ( \MAIKO.BLTCHAR 37724 . 37920)) (37923 54124 (\PUNT.BLTSHADE.BITMAP 37933 . 44959) (\PUNT.BITBLT.BITMAP 44961 . 54122)) (54125 54867 (BITMAPOBJ.SNAPW 54135 . 54865))))) STOP \ No newline at end of file diff --git a/library/MAIKOKEYBOARDS b/library/MAIKOKEYBOARDS new file mode 100644 index 00000000..fbd19807 --- /dev/null +++ b/library/MAIKOKEYBOARDS @@ -0,0 +1 @@ +((EUROPEAN ((100 (53 197 NOLOCKSHIFT)) (101 (52 196 NOLOCKSHIFT)) (102 (54 198 NOLOCKSHIFT)) (103 ( 61887 61759 LOCKSHIFT)) (104 (55 199 NOLOCKSHIFT)) (105 (61888 61760 LOCKSHIFT)) (106 (61872 61744 LOCKSHIFT)) (107 (61860 61732 LOCKSHIFT)) (108 (48 126 NOLOCKSHIFT)) (109 (61892 61764 LOCKSHIFT)) ( 110 (203 207 NOLOCKSHIFT)) (111 (61919 61791 LOCKSHIFT)) (112 (47 191 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 195 NOLOCKSHIFT)) (117 (50 194 NOLOCKSHIFT)) (118 (61873 61745 LOCKSHIFT)) (119 (61858 61730 LOCKSHIFT)) (120 (61874 61746 LOCKSHIFT)) (121 (61859 61731 LOCKSHIFT)) (122 (57 202 NOLOCKSHIFT)) (123 (61886 61758 LOCKSHIFT)) (124 (61864 61736 LOCKSHIFT)) (125 (61903 61775 LOCKSHIFT)) (126 (61908 61780 LOCKSHIFT)) (127 (241 225 LOCKSHIFT)) (128 (187 170 LOCKSHIFT)) ( 129 (249 233 LOCKSHIFT)) (132 (49 193 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61905 61777 LOCKSHIFT)) (137 (61869 61741 LOCKSHIFT)) (138 (61877 61749 LOCKSHIFT)) (139 (61906 61778 LOCKSHIFT)) (140 (251 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 ( 250 234 LOCKSHIFT)) (143 (59 58 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (171 186 LOCKSHIFT )) (148 (61904 61776 LOCKSHIFT)) (149 (61920 61792 LOCKSHIFT)) (150 (61921 61793 LOCKSHIFT)) (151 ( 61857 61729 LOCKSHIFT)) (152 (61863 61735 LOCKSHIFT)) (153 (56 200 NOLOCKSHIFT)) (154 (61900 61772 LOCKSHIFT)) (155 (239 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( 246 230 LOCKSHIFT)) (159 (207 176 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (logic ((100 ( 53 37 NOLOCKSHIFT)) (101 (52 164 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61258 61260 NOLOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (61292 61293 NOLOCKSHIFT)) (106 (61271 61270 NOLOCKSHIFT) ) (107 (61284 61285 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61307 61306 NOLOCKSHIFT)) (110 (45 177 NOLOCKSHIFT)) (111 (61269 61268 LOCKSHIFT)) (112 (172 174 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61240 61241 NOLOCKSHIFT)) (119 ( 61234 61235 NOLOCKSHIFT)) (120 (61266 61262 NOLOCKSHIFT)) (121 (61365 61365 NOLOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (61275 61274 NOLOCKSHIFT)) (124 (61300 61299 NOLOCKSHIFT)) (125 (61273 61272 NOLOCKSHIFT)) (126 (61282 61283 NOLOCKSHIFT)) (127 (61256 61257 NOLOCKSHIFT)) (128 (61356 61356 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61250 61251 NOLOCKSHIFT)) (137 (61298 61297 NOLOCKSHIFT)) (138 (61305 61303 NOLOCKSHIFT)) (139 (61265 61264 NOLOCKSHIFT)) (140 (61364 61364 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (61281 233 NOLOCKSHIFT)) (143 (61351 61351 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (61357 61357 NOLOCKSHIFT)) (148 (61279 61278 NOLOCKSHIFT)) (149 (61239 61238 NOLOCKSHIFT)) (150 (61290 61290 NOLOCKSHIFT)) (151 (61263 61261 NOLOCKSHIFT)) (152 (61295 61295 NOLOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61252 61253 NOLOCKSHIFT)) (155 (61254 61255 NOLOCKSHIFT) ) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (MATH ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (61284 61285 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (174 61245 NOLOCKSHIFT)) (107 (61369 61363 NOLOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (61254 61255 NOLOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (173 61246 LOCKSHIFT)) ( 112 (47 61300 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (61282 61283 LOCKSHIFT)) (119 (61287 61286 NOLOCKSHIFT)) (120 (61301 61302 NOLOCKSHIFT)) (121 (61351 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (175 61247 LOCKSHIFT)) (124 ( 180 184 LOCKSHIFT)) (125 (172 61244 LOCKSHIFT)) (126 (61256 61257 LOCKSHIFT)) (127 (44 61250 NOLOCKSHIFT)) (128 (61298 61253 NOLOCKSHIFT)) (129 (93 61265 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) ( 133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 ( 61356 61362 LOCKSHIFT)) (138 (61254 61291 NOLOCKSHIFT)) (139 (98 61360 NOLOCKSHIFT)) (140 (61309 177 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 61251 NOLOCKSHIFT)) (143 (61299 61252 NOLOCKSHIFT)) ( 144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (61358 82 LOCKSHIFT)) (149 (61296 61266 NOLOCKSHIFT)) (150 (61305 61303 NOLOCKSHIFT)) (151 (61308 61267 LOCKSHIFT)) (152 (61288 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (61357 61361 NOLOCKSHIFT)) (155 (61292 61293 LOCKSHIFT)) ( 156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 61264 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (OFFICE ((100 (61397 61381 NOLOCKSHIFT)) (101 ( 61396 61380 NOLOCKSHIFT)) (102 (61398 61382 NOLOCKSHIFT)) (103 (8557 8554 NOLOCKSHIFT)) (104 (61399 61383 NOLOCKSHIFT)) (105 (61232 8743 NOLOCKSHIFT)) (106 (61346 8571 NOLOCKSHIFT)) (107 (188 86 NOLOCKSHIFT)) (108 (61402 61386 NOLOCKSHIFT)) (109 (210 8738 NOLOCKSHIFT)) (110 (61437 61438 NOLOCKSHIFT)) (111 (163 8558 NOLOCKSHIFT)) (112 (61248 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (61395 61379 NOLOCKSHIFT)) (117 (61394 61378 NOLOCKSHIFT)) (118 (185 8553 NOLOCKSHIFT)) ( 119 (176 8546 NOLOCKSHIFT)) (120 (167 8744 NOLOCKSHIFT)) (121 (97 8745 NOLOCKSHIFT)) (122 (61401 61385 NOLOCKSHIFT)) (123 (162 8570 NOLOCKSHIFT)) (124 (61437 88 NOLOCKSHIFT)) (125 (111 8569 NOLOCKSHIFT)) (126 (61289 8737 NOLOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (61393 61377 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (61233 8742 NOLOCKSHIFT)) (137 (61438 67 NOLOCKSHIFT)) (138 (8739 74 NOLOCKSHIFT)) (139 (190 61436 NOLOCKSHIFT)) (140 (189 90 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( 142 (61249 62 NOLOCKSHIFT)) (143 (61352 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 61280 NOLOCKSHIFT)) (148 (212 8574 NOLOCKSHIFT)) (149 (61354 8573 NOLOCKSHIFT)) (150 (61286 8741 NOLOCKSHIFT)) (151 (165 8572 NOLOCKSHIFT)) (152 (61368 8740 NOLOCKSHIFT)) (153 (61400 61384 NOLOCKSHIFT)) (154 (173 175 NOLOCKSHIFT)) (155 (172 174 NOLOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61406 61368 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (DVORAK ((100 (49 42 NOLOCKSHIFT)) (101 (51 41 NOLOCKSHIFT)) (102 (57 37 NOLOCKSHIFT)) (103 (46 62 NOLOCKSHIFT)) (104 (48 38 NOLOCKSHIFT)) (105 (101 69 LOCKSHIFT)) (106 (103 71 LOCKSHIFT)) (107 (107 75 LOCKSHIFT)) (108 (54 45 NOLOCKSHIFT)) (109 (116 84 LOCKSHIFT)) (110 (56 95 NOLOCKSHIFT)) (111 (108 76 LOCKSHIFT)) (112 (122 90 LOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (53 40 NOLOCKSHIFT)) (117 (55 35 NOLOCKSHIFT)) (118 (44 60 NOLOCKSHIFT)) (119 (63 47 NOLOCKSHIFT)) ( 120 (111 79 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (52 164 NOLOCKSHIFT)) (123 (99 67 LOCKSHIFT)) ( 124 (113 81 LOCKSHIFT)) (125 (114 82 LOCKSHIFT)) (126 (110 78 LOCKSHIFT)) (127 (119 87 LOCKSHIFT)) ( 128 (44 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (33 64 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (117 85 LOCKSHIFT)) (137 (106 74 LOCKSHIFT)) (138 (104 72 LOCKSHIFT)) (139 (120 88 LOCKSHIFT)) (140 (59 58 NOLOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (118 86 LOCKSHIFT)) (143 (115 83 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (169 170 NOLOCKSHIFT)) (148 (112 80 LOCKSHIFT)) (149 (121 89 LOCKSHIFT)) (150 (105 73 LOCKSHIFT)) (151 (102 70 LOCKSHIFT)) (152 (100 68 LOCKSHIFT)) (153 (50 162 NOLOCKSHIFT)) (154 (98 66 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 ( 91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (GREEK ((100 ( 53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (9830 69 LOCKSHIFT)) ( 104 (55 38 NOLOCKSHIFT)) (105 (9829 9797 LOCKSHIFT)) (106 (9849 9817 LOCKSHIFT)) (107 (115 9814 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (9837 9805 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (9843 9811 LOCKSHIFT)) (112 (47 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (9853 9821 LOCKSHIFT)) (119 (9835 9803 LOCKSHIFT)) (120 (9846 9814 LOCKSHIFT)) (121 (9825 9793 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (9836 9804 LOCKSHIFT)) (124 ( 9851 9819 LOCKSHIFT)) (125 (9842 9810 LOCKSHIFT)) (126 (9838 9806 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT) ) (128 (39 34 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (9850 9818 LOCKSHIFT)) (137 (9841 9809 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (9826 66 LOCKSHIFT)) (140 (9833 9801 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (9845 9813 LOCKSHIFT)) (149 (9848 9816 LOCKSHIFT)) (150 (9828 9796 LOCKSHIFT)) (151 (9852 9820 LOCKSHIFT)) (152 (9834 9802 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) ( 154 (9840 9808 LOCKSHIFT)) (155 (9839 9807 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT ) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (ITALIAN ((100 (53 61903 NOLOCKSHIFT)) (101 (52 61886 NOLOCKSHIFT)) (102 (54 61919 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) ( 116 (51 61872 NOLOCKSHIFT)) (117 (50 61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (39 186 NOLOCKSHIFT)) (129 (93 125 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) ( 145 (95 170 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) ( 151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) ( 155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (91 123 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (SPANISH ((100 (53 61904 NOLOCKSHIFT)) (101 (52 61887 NOLOCKSHIFT)) (102 (54 61920 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 61873 NOLOCKSHIFT)) (117 (50 61858 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 ( 97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 ( 111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (59 58 NOLOCKSHIFT)) (129 (203 187 NOLOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) ( 143 (61900 61772 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (161 191 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61925 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (44 171 NOLOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (FRENCH ((100 (53 61905 NOLOCKSHIFT)) (101 (52 61888 NOLOCKSHIFT)) (102 (54 61921 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) ( 105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) ( 109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (204 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (51 61874 NOLOCKSHIFT)) (117 (50 61859 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) (120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) (124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 171 NOLOCKSHIFT)) (128 (39 61857 NOLOCKSHIFT)) (129 (61872 61892 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT)) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 187 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (61869 61741 LOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 (121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 61919 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 (109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61873 61877 LOCKSHIFT)) (159 (61 43 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (GERMAN ((100 (53 37 NOLOCKSHIFT)) (101 (52 36 NOLOCKSHIFT)) (102 (54 126 NOLOCKSHIFT)) (103 (101 69 LOCKSHIFT)) (104 (55 38 NOLOCKSHIFT)) (105 (100 68 LOCKSHIFT)) (106 (117 85 LOCKSHIFT)) (107 (118 86 LOCKSHIFT)) (108 (48 41 NOLOCKSHIFT)) (109 (107 75 LOCKSHIFT)) (110 (45 45 NOLOCKSHIFT)) (111 (112 80 LOCKSHIFT)) (112 (251 63 NOLOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) ( 116 (51 35 NOLOCKSHIFT)) (117 (50 64 NOLOCKSHIFT)) (118 (119 87 LOCKSHIFT)) (119 (113 81 LOCKSHIFT)) ( 120 (115 83 LOCKSHIFT)) (121 (97 65 LOCKSHIFT)) (122 (57 40 NOLOCKSHIFT)) (123 (105 73 LOCKSHIFT)) ( 124 (120 88 LOCKSHIFT)) (125 (111 79 LOCKSHIFT)) (126 (108 76 LOCKSHIFT)) (127 (44 60 NOLOCKSHIFT)) ( 128 (39 34 NOLOCKSHIFT)) (129 (61863 61735 LOCKSHIFT)) (132 (49 33 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (102 70 LOCKSHIFT)) (137 (99 67 LOCKSHIFT )) (138 (106 74 LOCKSHIFT)) (139 (98 66 LOCKSHIFT)) (140 (122 90 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) (142 (46 62 NOLOCKSHIFT)) (143 (59 58 NOLOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (95 94 NOLOCKSHIFT)) (148 (114 82 LOCKSHIFT)) (149 (116 84 LOCKSHIFT)) (150 (103 71 LOCKSHIFT)) (151 ( 121 89 LOCKSHIFT)) (152 (104 72 LOCKSHIFT)) (153 (56 42 NOLOCKSHIFT)) (154 (110 78 LOCKSHIFT)) (155 ( 109 77 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (61908 61780 LOCKSHIFT)) (159 (61925 61797 LOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO) (STANDARD-RUSSIAN (( 100 (34 52 NOLOCKSHIFT)) (101 (47 51 NOLOCKSHIFT)) (102 (58 53 NOLOCKSHIFT)) (103 (10085 10037 LOCKSHIFT)) (104 (44 54 NOLOCKSHIFT)) (105 (10067 10019 LOCKSHIFT)) (106 (10068 10020 LOCKSHIFT)) (107 (10078 10030 LOCKSHIFT)) (108 (63 57 NOLOCKSHIFT)) (109 (10077 10029 LOCKSHIFT)) (110 (37 48 NOLOCKSHIFT)) (111 (10073 10025 LOCKSHIFT)) (112 (10071 10023 LOCKSHIFT)) (115 (1 1 NOLOCKSHIFT) . IGNORE) (116 (45 50 NOLOCKSHIFT)) (117 (61352 49 NOLOCKSHIFT)) (118 (10088 10040 LOCKSHIFT)) (119 ( 10075 10027 LOCKSHIFT)) (120 (10093 10045 LOCKSHIFT)) (121 (10086 10038 LOCKSHIFT)) (122 (95 56 NOLOCKSHIFT)) (123 (10090 10042 LOCKSHIFT)) (124 (10089 10041 LOCKSHIFT)) (125 (10091 10043 LOCKSHIFT) ) (126 (10069 10021 LOCKSHIFT)) (127 (10066 10018 LOCKSHIFT)) (128 (10095 10047 LOCKSHIFT)) (129 ( 10092 10044 LOCKSHIFT)) (132 (167 43 NOLOCKSHIFT)) (133 (92 124 NOLOCKSHIFT) . IGNORE) (134 (9 9 NOLOCKSHIFT) . IGNORE) (135 (10065 10017 LOCKSHIFT)) (137 (10083 10035 LOCKSHIFT)) (138 (10080 10032 LOCKSHIFT)) (139 (10074 10026 LOCKSHIFT)) (140 (10097 10049 LOCKSHIFT)) (141 1SHIFTDOWN . 1SHIFTUP) ( 142 (10096 10048 LOCKSHIFT)) (143 (10072 10024 LOCKSHIFT)) (144 (13 13 NOLOCKSHIFT) . IGNORE) (145 (41 40 NOLOCKSHIFT)) (148 (10076 10028 LOCKSHIFT)) (149 (10070 10022 LOCKSHIFT)) (150 (10081 10033 LOCKSHIFT)) (151 (10079 10031 LOCKSHIFT)) (152 (10082 10034 LOCKSHIFT)) (153 (46 55 NOLOCKSHIFT)) (154 (10084 10036 LOCKSHIFT)) (155 (10094 10046 LOCKSHIFT)) (156 LOCKDOWN . LOCKUP) (157 (32 32 NOLOCKSHIFT) . IGNORE) (158 (10087 10039 LOCKSHIFT)) (159 (33 61 NOLOCKSHIFT)) (160 2SHIFTDOWN . 2SHIFTUP)) MAIKO)) \ No newline at end of file diff --git a/library/MASTERSCOPE b/library/MASTERSCOPE new file mode 100644 index 00000000..23c96585 --- /dev/null +++ b/library/MASTERSCOPE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "24-Oct-2018 16:25:58"  {DSK}kaplan>Local>medley3.5>lispcore>library>MASTERSCOPE.;2 194331 changes to%: (FNS MSEDITE) previous date%: " 8-Sep-94 17:08:28" {DSK}kaplan>Local>medley3.5>lispcore>library>MASTERSCOPE.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1994, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MASTERSCOPECOMS) (RPAQQ MASTERSCOPECOMS [ (* ;; "Main file for MASTERSCOPE.") (FILES MSPARSE MSANALYZE) (PROP FILETYPE MASTERSCOPE) (COMS * MSDATABASECOMS) (COMS * MSAUXCOMS) (COMS * MSDBCOMS) (COMS * MSCHECKBLOCKSCOMS) (COMS * MSPATHSCOMS) [COMS (FNS MSFIND MSEDITF MSEDITE EDITGETDEF) (VARS MSBLIP) (* ;; "List of (FILEPKGTYPE FILEPKGTYPE GETDEF-fn MARKASCHANGED-fn) for types that Masterscope knows how to analyze. LOOPSMS, for example, adds LOOPS constructs to this lists using MSADDANALYZE.") [INITVARS (MSFNTYPES '((FNS FNS GETDEF] (COMS (* ; "SCRATCHASH") (INITVARS (MSCRATCHASH)) (DECLARE%: DONTCOPY (MACROS SCRATCHASH] (COMS (* ; "marking changed") (FNS MSMARKCHANGED CHANGEMACRO CHANGEVAR CHANGEI.S. CHANGERECORD MSNEEDUNSAVE UNSAVEFNS ) (ADDVARS (COMPILE.TIME.CONSTANTS)) (VARS (RECORDCHANGEFN 'CHANGERECORD)) (INITVARS (CHECKUNSAVEFLG T) (MSNEEDUNSAVE))) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS GETWORDTYPE)) (COMS (* ; "interactive routines") [VARS * (LIST (LIST 'MASTERSCOPEDATE (SUBSTRING (DATE) 1 9] (ADDVARS (HISTORYCOMS %.)) (FNS %. MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC) (* ; "Interpreting commands") (FNS MSINTERPRETSET MSINTERPA MSGETBLOCKDEC LISTHARD MSMEMBSET MSLISTSET MSHASHLIST MSHASHLIST1 CHECKPATHS ONFILE) (FNS MSINTERPRET VERBNOTICELIST MSOUTPUT MSCHECKEMPTY CHECKFORCHANGED MSSOLVE) (DECLARE%: DONTCOPY (RECORDS GETHASH INRELATION PATHOPTIONS MSANALYZABLE))) (FILES MSCOMMON) (DECLARE%: DONTCOPY (COMS * MSCOMPILETIME)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA %.) (NLAML) (LAMA MSEDITE MSEDITF MSEDITF]) (* ;; "Main file for MASTERSCOPE.") (FILESLOAD MSPARSE MSANALYZE) (PUTPROPS MASTERSCOPE FILETYPE :COMPILE-FILE) (RPAQQ MSDATABASECOMS ((FNS UPDATEFN MSEDITF MSGETDEF MSNOTICEFILE MSSHOWUSE MSUPDATEFN1 MSUPDATE MSNLAMBDACHECK MSCOLLECTDATA) (FNS UPDATECHANGED UPDATECHANGED1) (VARS TABLE.TO.NOTICED) (FNS MSCLOSEFILES) (VARS (MSFILELST) (MSOPENFILES)) (VARS (MSPRINTFLG '%.) (MSPRINTCNT 0)) (ADDVARS (MSHASHFILE) (ANALYZEUSERFNS)))) (DEFINEQ (UPDATEFN [LAMBDA (FN EVENIFVALID IFCANT TYPE) (* ; "Edited 27-Jan-88 16:49 by jrb:") (* Update the analysis of a particular function -  this is a "user" entry) (PROG NIL (OR (AND FN (LITATOM FN)) (RETURN)) (MSINIT) (COND ((AND (NOT EVENIFVALID) (NOT (GETHASH FN MSCHANGEDARRAY)) (TESTRELQ KNOWN FN)) (* Previous valid analysis --  return) (RETURN))) [SETQ DEF (MSGETDEF FN TYPE (SELECTQ IFCANT (0 'CURRENT) '?) '(NOERROR NOCOPY MASTERSCOPE] (COND ((NULL DEF) (* No definition can be found --  look at IFCANT) (SELECTQ IFCANT (ERROR (ERROR FN "can't be analyzed " T)) ((NIL PRINT) (printout T "Sorry, the function " |.P2| FN " can't be analyzed!" T)) NIL) (COND ((TESTRELQ KNOWN FN) (MSERASE (LIST FN))) (T (PUTHASH FN NIL MSCHANGEDARRAY))) (RETURN))) (MSUPDATEFN1 FN DEF]) (MSEDITF [LAMBDA ARGCOUNT (* ; "Edited 31-May-88 17:58 by jrb:") (LET [(FNAME (ARG ARGCOUNT 1)) (FEDITCOMS (for X from 2 to ARGCOUNT collect (ARG ARGCOUNT X] (for FPTYPE in MSFNTYPES bind FPNAME when (HASDEF FNAME (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE))) do (if (EQ FPTYPE 'FNS) then (APPLY 'EDITF (CONS FNAME FEDITCOMS)) else (EDITE (GETDEF FNAME FPNAME NIL '(NOERROR NOCOPY EDIT)) FEDITCOMS FNAME FPNAME)) (RETURN FNAME]) (MSGETDEF [LAMBDA (NAME TYPE SOURCE OPTIONS) (* ;  "Edited 23-Jun-93 10:21 by sybalsky:mv:envos") (* ;;; "Take a whack at getting the definition of NAME. Masterscope assumes a bijection between names and analyzable things; it caches that relationship in the FPTYPE table") (LET (TABLEFPTYPE REALDEF) (COND ([SETQ TABLEFPTYPE (CAR (GETRELATION NAME (PARSERELATION 'FPTYPE] (APPLY* (ffetch (MSANALYZABLE GETDEF-FN) of (ASSOC TABLEFPTYPE MSFNTYPES)) NAME TABLEFPTYPE SOURCE OPTIONS)) (T (for FPTYPE in MSFNTYPES bind RESULT when (CL:MULTIPLE-VALUE-SETQ (RESULT REALDEF) (APPLY* (ffetch (MSANALYZABLE GETDEF-FN) of FPTYPE) NAME TYPE SOURCE OPTIONS)) do (PUTTABLE NAME (LIST (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE)) (CADR (FASSOC 'FPTYPE MSDATABASELST))) (* ;; "Look up active editors, and use the edited defn, if there is one:") (SETQ REALDEF (OR (EDITGETDEF NAME TYPE) REALDEF)) (RETURN (CL:VALUES RESULT REALDEF)) finally NIL]) (MSNOTICEFILE [LAMBDA (FILE) (* ; "Edited 8-Apr-88 12:00 by jrb:") (DECLARE (GLOBALVARS MSHASHFILE LOADDBFLG)) (PROG (FULL COMS TEM) LP (COND ((SETQ TEM (FASSOC FILE MSFILELST)) (* already noticed) (RETURN TEM))) (OR COMS (SETQ COMS (FILECOMS FILE))) (SETQ FULL (FINDFILE FILE T)) [COND ((NOT (FMEMB FILE FILELST)) (* two possibilities%: either FILE is something like FOO or it has not  been loaded yet) [COND ((AND (NOT FULL) (EQ FILE (NAMEFIELD FILE T))) (COND ((LISTP (GETATOMVAL COMS)) (* dummy or new file since COMS set but not on filelst) (GO DUMMY] (* either the file has never been loaded, or an explicit was given) (OR FULL (ERROR FILE "not found")) [SETQ COMS (FILECOMS (SETQ FILE (NAMEFIELD FULL T] (OR (AND [EQ FULL (CDAR (GETPROP FILE 'FILEDATES] (LISTP (EVALV COMS))) (COND ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "should I LOADFROM" FULL))) (RESETVARS [(LOADDBFLG (COND (MSHASHFILE LOADDBFLG) (T 'NO] (* Should bring the hashfile up-to-date if we are noticing the file) (LOADFROM FULL))) (T (ERROR!] [COND ((EQ [CDAR (SETQ TEM (GETPROP FILE 'FILE] 'Compiled) (* If only the compiled version of the file has been loaded, still want to  know about GLOBALVARS or other things) (LOADVARS '((DECLARE%: -- DONTCOPY --)) (OR (AND (SETQ FULL (GETP FILE 'FILEDATES)) (INFILEP (CDAR FULL))) FILE)) (/RPLACD (CAR TEM) 'COMPILED] DUMMY (RETURN (OR (FASSOC FILE MSFILELST) (CAR (SETQ MSFILELST (CONS (CONS FILE COMS) MSFILELST]) (MSSHOWUSE [LAMBDA (SHOWFN SHOWTYPE SHOWSET SHOWEDIT IFCANT EDITCOMS) (* ;  "Edited 23-Jun-93 09:40 by sybalsky:mv:envos") (* ;; "Show/Edit where SHOWFN uses/etc. a pattern.") (PROG (DEF REALDEF ANYFOUND) (COND ([OR [CL:MULTIPLE-VALUE-SETQ (DEF REALDEF) (MSGETDEF SHOWFN (AND (fetch (MSSETPHRASE KNOWN) of SHOWSET) (fetch (MSSETPHRASE TYPE) of SHOWSET)) (COND ((EQ SHOWEDIT 'SHOW) '?) (T 'CURRENT NIL)) '(NOERROR NODWIM NOCOPY] (SETQ DEF (AND (EQ SHOWEDIT 'EDIT) (LET ((FILE (EDITLOADFNS? SHOWFN))) (COND (FILE (LOADFNS SHOWFN FILE 'PROP) (GETPROP SHOWFN 'EXPR] (* ;  "was (MSGETDEF SHOWFN IFCANT (EQ SHOWEDIT (QUOTE SHOW)))") (* ;  "The SHOW command does not need to save") (MSUPDATEFN1 SHOWFN DEF (LIST SHOWTYPE [FUNCTION (LAMBDA (ITEM SS SE PRNT INCLISP) (COND ((MSMEMBSET ITEM SS) (COND ((NOT ANYFOUND) (TAB 0 0 T) (PRIN2 SHOWFN) (PRIN1 " : "))) (SETQ ANYFOUND (CONS (CONS PRNT (AND INCLISP (NOT (MSFIND INCLISP PRNT)) INCLISP)) ANYFOUND)) (COND ([AND (EQ SE 'SHOW) (NOT (FASSOC PRNT (CDR ANYFOUND] (* ;; "The EDIT command works by collecting a list of the expressions, and then doing a (*ORF* (= . lst1) (= . lst2)) --- if within a CLISP translation (determined by the binding of the INCLISP variable) then want to point at the CLISP if the expression is not actually embedded in the expression") (SPACES 3) (LVLPRINT PRNT (OUTPUT) 2) (COND ((CDAR ANYFOUND) (* ; "This is under a clisp") (PRIN1 " {under ") (LVLPRIN2 INCLISP (OUTPUT) 2) (PRIN1 "} "] SHOWSET SHOWEDIT))) (T (printout T "Can't find a definition for " SHOWFN "!" T) (RETURN))) (COND ((NOT ANYFOUND) (RETURN)) ((EQ SHOWEDIT 'EDIT) [MAPC ANYFOUND (FUNCTION (LAMBDA (X) (FRPLNODE X '== (OR (CDR X) (CAR X] (SETQ ANYFOUND (CONS '*ANY* ANYFOUND)) (PRINT [APPLY* 'MSEDITE SHOWFN (OR REALDEF DEF) (ASSOC [CAR (GETRELATION SHOWFN (PARSERELATION 'FPTYPE] MSFNTYPES) (LIST 'BIND '(E (SETQ %#1) T) (LIST 'F ANYFOUND T) (LIST 'LPQ (LIST 'IF '(NEQ (%##) %#1) [LIST '(ORR (P) NIL) '(S %#1) (COND (EDITCOMS (CONS 'BIND EDITCOMS)) (T 'TTY%:] NIL) (LIST 'F ANYFOUND 'N] T T))) (RETURN T]) (MSUPDATEFN1 [LAMBDA (FN DEF EACHTIME DOSUBFNS) (* ; "Edited 27-Jan-88 16:49 by jrb:") (* Subfunction of UPDATEFN -- notices all of the "new" functions called by FN) (MSUPDATE FN DEF EACHTIME) (AND DOSUBFNS (for X in (GETRELQ (CALL NOTERROR) FN) when (NOT (TESTRELQ KNOWN X)) do (PROG (DEF) (AND [SETQ DEF (MSGETDEF X NIL 'CURRENT '(NOCOPY NODWIM NOERROR MASTERSCOPE] (MSUPDATEFN1 X DEF EACHTIME T]) (MSUPDATE [LAMBDA (FNNAME FNDEF EACHTIME) (* lmm "22-Jul-86 18:24") (* This is the main internal entry to the analysis routines.) (PROG (VARS ERS TEM PRFLG DATA) (* VARS is used to mark the CURRENT variables bound.  INCLISP and EACHTIME need to be bound by ADDTO which checks to see if we are  in a SHOW or EDIT) (MSNLAMBDACHECK FNNAME) [COND ((EQ (CAR FNDEF) 'CL:LAMBDA)) ([OR (EQ DWIMIFYCOMPFLG T) (EQ CLISPIFYPRETTYFLG T) (EQ (CAR (SETQ TEM (CADDR FNDEF))) 'CLISP%:) (AND (EQ (CAR TEM) COMMENTFLG) (EQ (CADR TEM) 'DECLARATIONS%:)) (NOT (FMEMB (CAR FNDEF) '(LAMBDA NLAMBDA] (* Check if the whole definition  needs to be DWIMIFIED) (LET (VARS) (DECLARE (CL:SPECIAL VARS)) (MSPRGDWIM FNDEF FNNAME FNDEF] [COND ((NOT EACHTIME) (COND ((OR (EQ MSPRINTFLG T) (AND (FIXP MSPRINTFLG) (NOT (IGREATERP (SETQ MSPRINTCNT (SUB1 MSPRINTCNT)) 0)) (SETQ MSPRINTCNT MSPRINTFLG))) (SETQ PRFLG (PRIN2 FNNAME T))) ((EQ MSPRINTFLG '%.) (PRIN1 '%. T] (SETQ DATA (ALLCALLS FNDEF 'ARG NIL FNNAME T EACHTIME)) (for F in ANALYZEUSERFNS do (SETQ DATA (APPLY* F FNNAME FNDEF DATA))) [SETQ ERS (FMEMB MSERRORFN (CDR (FASSOC 'ERRORS DATA] [SELECTQ MSPRINTFLG (NIL) (%. (AND ERS (PRIN1 '? T))) (PROGN [OR PRFLG (COND ((OR ERS (AND EACHTIME (NOT ANYFOUND))) (SETQ PRFLG (PRIN2 FNNAME T] (* always print if errors) (COND (ERS (PRIN1 " (CALLS ppe)" T))) (AND PRFLG (PRIN1 '", " T] (MSSTOREDATA FNNAME DATA]) (MSNLAMBDACHECK [LAMBDA (FN) (* lmm "22-DEC-78 13:11") (COND ((AND (NOT (TEMPLATE FN T)) [SETQ FN (COND [(NLAMBDAFNP FN) (SUBSET (GETRELQ (CALL DIRECTLY) FN T) (FUNCTION (LAMBDA (FN2) (* the set of functions which call this one, but don't call it as an nlambda) (NOT (FMEMB FN (GETRELQ (CALL NLAMBDA) FN2] (T (* someone calls it as an NLAMBDA) (GETRELQ (CALL NLAMBDA) FN T] (MSMARKCHANGE1 FN]) (MSCOLLECTDATA [LAMBDA (TNAME FLG) (* lmm "30-OCT-80 10:00") (COND ((LISTP TNAME) (SELECTQ (CAR TNAME) (- (LDIFFERENCE (MSCOLLECTDATA (CADR TNAME) T) (MSCOLLECTDATA (CADDR TNAME) T))) (+ (UNION (MSCOLLECTDATA (CADR TNAME) T) (MSCOLLECTDATA (CADDR TNAME) T))) (SHOULDNT 2))) (T (PROG NIL (RETURN (MSCOLLECTDATA (CADR (OR (AND (NULL FLG) (FASSOC TNAME TABLE.TO.NOTICED)) (RETURN (CDR (FASSOC TNAME FNDATA]) ) (DEFINEQ (UPDATECHANGED [LAMBDA NIL (* lmm "16-JUL-78 05:07") (* Update all functions marked as  changed) (MSINIT) (MAPHASH MSCHANGEDARRAY (FUNCTION UPDATECHANGED1)) NIL]) (UPDATECHANGED1 [LAMBDA (VAL KEY) (* ; "Edited 27-Jan-88 16:49 by jrb:") (COND [(OR (EQ VAL T) (TESTRELQ KNOWN KEY) (TESTRELQ (CALL NOTERROR) KEY T)) (COND ([SETQ VAL (MSGETDEF KEY NIL '? '(NOERROR NOCOPY MASTERSCOPE] (MSUPDATEFN1 KEY VAL NIL T)) (T (printout T KEY " disappeared!" T) (MSERASE (LIST KEY] (T (PUTHASH KEY NIL MSCHANGEDARRAY]) ) (RPAQQ TABLE.TO.NOTICED ((BIND (- (- (- (- (+ BIND ARG) REF) SMASH) SET) TEST)) (REFFREE (- (- (- REFFREE SETFREE) SMASHFREE) TESTFREE)) (REF (- (- (- REF SET) SMASH) TEST)) (PREDICATE (- PREDICATE CALL)) (EFFECT (- (- EFFECT CALL) PREDICATE)) (CALL (- CALL NLAMBDA)) (0 TYPE) (APPLY (+ APPLY STACK)) (ARGS ARG))) (DEFINEQ (MSCLOSEFILES [LAMBDA NIL (* lmm "24-JUN-78 17:18") (* this is RESETSAVE'd from MSGETDEF to close any files that MSGETDEF leaves  open) (for X in MSOPENFILES when (AND (NOT (CADR X)) (OPENP (CADDR X))) do (CLOSEF (CADDR X))) (SETQ MSOPENFILES]) ) (RPAQQ MSFILELST NIL) (RPAQQ MSOPENFILES NIL) (RPAQQ MSPRINTFLG %.) (RPAQQ MSPRINTCNT 0) (ADDTOVAR MSHASHFILE ) (ADDTOVAR ANALYZEUSERFNS ) (RPAQQ MSAUXCOMS ((COMS (FNS MSDESCRIBE MSDESCRIBE1 FMAPRINT) (ADDVARS (DESCRIBELST)) (GLOBALVARS DESCRIBELST)) (COMS (FNS MSPRINTHELPFILE) (VARS MSHELPFILE)) (COMS (FNS TEMPLATE GETTEMPLATE SETTEMPLATE) (FILEPKGCOMS TEMPLATES)) (COMS (FNS ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (INITVARS (MSCHECKFNS NIL)) (GLOBALVARS MSCHECKFNS MSANALYZEFNS MSUSERVBTABLES)))) (DEFINEQ (MSDESCRIBE [LAMBDA (FN SN) (* lmm "22-Jul-85 18:16") (* Prints function name, arguments,  local and free variables.  etc) (DECLARE (SPECVARS FN)) (* Make FN available to user  DESCRIBELST forms) (PROG (GLOBALS FREES ARGS LINE) [SETQ ARGS (COND ((SETQ ARGS (GETRELQ ARGS FN)) (* The args in the argtable have precedence, even if the function is  resident, cause they correspond to what was actually analyzed.) (* T is for an arglist of NIL) (AND (NEQ ARGS T) ARGS)) ((GETD FN) (SMARTARGLIST FN] (printout NIL "(" .FONT BOLDFONT |.P2| FN .FONT DEFAULTFONT) (FMAPRINT ARGS NIL " " ")") (OR (TESTRELQ KNOWN FN) (PRIN1 " (not analyzed)" T)) (COND ([AND [OR (HARRAYP SN) (HARRAYP (CAR (LISTP SN] (SMALLP (SETQ LINE (GETHASH FN SN] (TAB 45 T) (PRIN1 " {line ") (PRIN1 (ABS LINE)) (PRIN1 "}"))) (TERPRI) (MSDESCRIBE1 (GETRELQ (CALL NOTERROR) FN) '"calls: ") (MSDESCRIBE1 (GETRELQ (CALL NOTERROR) FN T) '"called by:") (MSDESCRIBE1 (for VAR in (GETRELQ BIND FN) when (NOT (EQMEMB VAR ARGS)) collect VAR) '"binds: ") [for VAR in (GETRELQ (USE FREELY) FN) do (COND ((OR (FMEMB VAR GLOBALVARS) (GETPROP VAR 'GLOBALVAR)) (SETQ GLOBALS (CONS VAR GLOBALS))) (T (SETQ FREES (CONS VAR FREES] (MSDESCRIBE1 FREES '"uses free:") (MSDESCRIBE1 GLOBALS '"globals: ") (MSDESCRIBE1 (GETRELQ (USE FIELDS) FN) '"fields: ") (for D L in DESCRIBELST when (SETQ L (EVAL (CADR D))) do (MSDESCRIBE1 L (CAR D))) (TERPRI]) (MSDESCRIBE1 [LAMBDA (LST STR) (* lmm " 9-AUG-77 04:45") (* lmm%: 15 NOV 75 2248) (COND (LST (SPACES 2) (PRIN1 STR) (SPACES 1) (PROG (LL P) (COND ((NULL LST) (GO EXIT)) ((NLISTP LST) (PRIN2 LST) (GO EXIT))) (SETQ LL (LINELENGTH)) (SETQ P (POSITION)) LP (COND ((IGREATERP (IPLUS (POSITION) 5 (NCHARS (CAR LST))) LL) (TAB P))) (PRIN2 (CAR LST)) (COND ((NULL (SETQ LST (CDR LST))) (GO EXIT))) (PRIN1 '%,) (GO LP) EXIT (TERPRI]) (FMAPRINT [LAMBDA (LST FILE LEFT RIGHT SEP) (* lmm%: 28 OCT 75 757) (PROG NIL (AND LEFT (PRIN1 LEFT FILE)) (OR SEP (SETQ SEP '% )) (COND ((NULL LST) (GO EXIT)) ((NLISTP LST) (PRIN2 LST) (GO EXIT))) LP (PRIN2 (CAR LST) FILE) (COND ((NULL (SETQ LST (CDR LST))) (GO EXIT))) (PRIN1 SEP FILE) (GO LP) EXIT (AND RIGHT (PRIN1 RIGHT FILE]) ) (ADDTOVAR DESCRIBELST ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DESCRIBELST) ) (DEFINEQ (MSPRINTHELPFILE [LAMBDA NIL (* lmm "20-JAN-79 13:48") (PROG (FL) [SETQ FL (OR (INFILEP MSHELPFILE) (RETURN (PROGN (printout T "Sorry, HELP file not available!" T) NIL] (SETQ FL (INPUT (INFILE FL))) (RESETSAVE NIL (LIST 'CLOSEF FL)) (COPYBYTES FL T 0 (GETEOFPTR FL]) ) (RPAQQ MSHELPFILE MASTERSCOPE.SYNTAX) (DEFINEQ (TEMPLATE [LAMBDA (FN TEMPLATE FLG) (* lmm "23-DEC-78 14:06") (* MSTEMPLATES is the hash table for pre-defined templates.  USERTEMPLATES contains user defined templates.  The split is so that DUMPDATABASE can dump the templates as well -  check for MSDATABASE is so CALLS doesn't need to init database) (PROG [(OLD (OR (GETHASH FN USERTEMPLATES) (GETHASH FN MSTEMPLATES] (COND ((EQ OLD T) (SETQ OLD))) (COND ((AND (NOT (EQUAL TEMPLATE OLD)) (NEQ TEMPLATE T)) [COND ((NOT FLG) [AND FILEPKGFLG (MARKASCHANGED FN 'TEMPLATES (NOT (NULL OLD] (AND MSDATABASELST (MSMARKCHANGED (GETRELATION FN '(CALL DIRECTLY) T) 'FNS] (PUTHASH FN (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE (MACRO TEMPLATE) (NIL (AND (GETHASH FN MSTEMPLATES) T)) (ERROR TEMPLATE "Invalid template"))) (T TEMPLATE)) USERTEMPLATES))) (RETURN OLD]) (GETTEMPLATE [LAMBDA (FN) (* lmm " 9-AUG-77 06:20") (SETTEMPLATE FN T]) (SETTEMPLATE [LAMBDA (FN TEMPLATE) (* lmm "16-FEB-78 14:56") (PROG ([OLD (COPY (TEMPLATE FN (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE (EVAL '(CALL |..| EVAL)) ((NIL T MACRO) TEMPLATE) (ERROR TEMPLATE "Invalid template"))) (T (SELECTQ (CAR TEMPLATE) (MACRO TEMPLATE) (! (CDR TEMPLATE)) (CONS 'CALL (AND (OR (CAR TEMPLATE) (CDR TEMPLATE)) TEMPLATE] VAL) [SETQ VAL (COND ((NLISTP OLD) OLD) (T (SELECTQ (CAR OLD) (MACRO OLD) (CALL (OR (CDR OLD) (CONS))) (CONS '! OLD] [OR (EQ TEMPLATE T) (AND LISPXHIST (UNDOSAVE (LIST 'SETTEMPLATE FN OLD] (RETURN VAL]) ) (PUTDEF (QUOTE TEMPLATES) (QUOTE FILEPKGCOMS) '((COM MACRO [X (P * (MAPCAR 'X (FUNCTION (LAMBDA (FN) (LIST 'SETTEMPLATE (KWOTE FN) (KWOTE (GETTEMPLATE FN] CONTENTS NILL) (TYPE DESCRIPTION "masterscope templates"))) (DEFINEQ (ADDTEMPLATEWORD [LAMBDA (WORD) (* smL "27-Nov-85 17:49") (* * Add a new word that can be used in TEMPLATES.  This really means add a new MasterScope table.) (MSINIT) (if (NOT (ASSOC WORD MSFNDATA)) then (PUTASSOC WORD NIL MSFNDATA)) (if (NOT (ASSOC WORD MSDATABASELST)) then (PUTASSOC WORD (CONS (MAKETABLE 2) (MAKETABLE 2)) MSDATABASELST)) (if (NOT (ASSOC WORD MSDATABASEINIT)) then (PUTASSOC WORD (CONS 2 2) MSDATABASEINIT]) (MSADDANALYZE [LAMBDA (PLURAL SINGLE FILETYPE GETDEF-FN MARKCHANGED-FN) (* ; "Edited 16-Jun-88 10:35 by jrb:") (* * Defines a new MasterScope datatype) [for word in (LIST PLURAL SINGLE) do (LET ((oldDef (GETHASH word MSWORDS))) (if oldDef then (PUTASSOC 'TYPE PLURAL oldDef) else (PUTHASH word (LIST (CONS 'TYPE PLURAL)) MSWORDS] (* ;;  "MSANALYZEFNS is bogus and is hereby removed. (PUTHASH PLURAL ANALYZEFN MSANALYZEFNS)") (* ;; "JRB - ") (if FILETYPE then (LET ((oldEntry (ASSOC FILETYPE MSFNTYPES))) (if oldEntry then (replace (MSANALYZABLE SETNAME) oldEntry PLURAL) (replace (MSANALYZABLE GETDEF-FN) oldEntry GETDEF-FN) (replace (MSANALYZABLE MARKCHANGED-FN) oldEntry MARKCHANGED-FN) else (push MSFNTYPES (create MSANALYZABLE FILEPKGNAME _ FILETYPE SETNAME _ PLURAL GETDEF-FN _ GETDEF-FN MARKCHANGED-FN _ MARKCHANGED-FN]) (MSADDMODIFIER [LAMBDA (RELATION MODIFIERS TABLES) (* smL "16-Dec-85 15:39") (* * Define a new modifier to a MasterScope relation, telling what tables  should be combined to determine the modified relation) (SETQ TABLES (MKLIST TABLES)) (SETQ MODIFIERS (MKLIST MODIFIERS)) (MSINIT) (for adverb in MODIFIERS bind oldWordDef do (SETQ oldWordDef (ASSOC 'V (GETHASH adverb MSWORDS))) (if oldWordDef then (PUTASSOC 'V [CONS adverb (CONS RELATION (MKLIST (CDDR oldWordDef] (GETHASH adverb MSWORDS)) else (PUTHASH adverb (CONS (CONS 'V (LIST adverb RELATION)) (GETHASH adverb MSWORDS)) MSWORDS))) (PUTHASH RELATION (CONS (CONS MODIFIERS TABLES) (GETHASH RELATION MSUSERVBTABLES)) MSUSERVBTABLES) (for table in TABLES do (ADDTEMPLATEWORD table]) (MSADDRELATION [LAMBDA (RELATION TABLES) (* smL "16-Dec-85 14:55") (* * Let the user define a new MasterScope relation.  -  RELATION is a list of ROOT PRESENT PARTICIPLE and PAST conjugations of the  new relation. They can then be used in MasterScope commands to specify  relations. -  TABLES is a list of new MasterScope database tables.  These tables can then be used in MasterScope templates.  TABLES defaults to the ROOT of the relation.) (LET ((ROOT (CAR RELATION))) (MSSETUP (LIST RELATION)) [MSADDMODIFIER ROOT '(NIL) (MKLIST (MKLIST (OR TABLES ROOT] ROOT]) (MSADDTYPE [LAMBDA (TYPE TABLES HOWUSED SYNONYMS) (* smL "16-Dec-85 15:35") (* * Defines the TYPE as the union of the TABLES so you can use phrases like  "USE foo AS A " or "USE THE foo") [SETQ HOWUSED (MKLIST (OR HOWUSED 'USE] (SETQ SYNONYMS (MKLIST SYNONYMS)) (SETQ TABLES (MKLIST TABLES)) (MSINIT) (for typeWord in (CONS TYPE SYNONYMS) bind oldWordDef do (SETQ oldWordDef (GETHASH typeWord MSWORDS)) (if oldWordDef then (PUTASSOC 'TYPE TYPE oldWordDef) else (SETQ oldWordDef (LIST (CONS 'TYPE TYPE))) (PUTHASH typeWord oldWordDef MSWORDS)) (PUTASSOC 'AS [CONS TYPE (APPEND HOWUSED (CDDR (ASSOC 'AS oldWordDef] oldWordDef)) (MSADDMODIFIER 'USE TYPE TABLES]) ) (RPAQ? MSCHECKFNS NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MSCHECKFNS MSANALYZEFNS MSUSERVBTABLES) ) (RPAQQ MSDBCOMS [(FNS MSMARKCHANGE1 MSINIT GETVERBTABLES MSSTOREDATA STORETABLE) (ADDVARS (MSCHANGEDARRAY) (MSDATABASELST)) (INITVARS (MSDBEMPTY T)) (VARS MSDATABASEINIT NODUMPRELATIONS) (FNS PARSERELATION PARSERELATION1 GETRELATION MAPRELATION TESTRELATION) (COMS (FNS ADDHASH SUBHASH MAKEHASH MSREHASH EQMEMBHASH) [P (MAPC '((GETHASH GETTABLE) (GETHASH TESTTABLE) (PUTHASH PUTTABLE) (ADDHASH ADDTABLE) (SUBHASH SUBTABLE) (MAPHASH MAPTABLE) (MAKEHASH MAKETABLE) (EQMEMBHASH EQMEMBTABLE)) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X] (FNS MSVBTABLES MSUSERVBTABLES) (INITVARS (MSUSERVBTABLES (MAKETABLE 2)) (MSANALYZEFNS (MAKETABLE 2))) (FNS BUILDGETRELQ BUILDTESTRELQ) (DECLARE%: DONTCOPY (MACROS GETRELQ TESTRELQ))) (COMS (FNS MSERASE)) (COMS (FNS DUMPDATABASE DUMPDATABASE1 READATABASE) (VARS DATABASECOMS)) (ADDVARS (GAINSPACEFORMS (MSDATABASELST "erase current Masterscope database" (%. ERASE]) (DEFINEQ (MSMARKCHANGE1 [LAMBDA (FNS FLG) (* rmk%: "19-FEB-81 14:53") (* mark the selected functions as "changed" -  FLG=T in MSCHANGEDARRAY means to complain if the definition can't be found, 0  means give up quietly.) (OR FLG (SETQ FLG T)) (for FN inside FNS do (PUTHASH FN FLG MSCHANGEDARRAY)) (* This isn't undone by simply restoring the pevious entry in the hash array  because the user might have asked a question that caused the functions to be  reanalyzed. Against this possibility, we "undo" by re-marking the functions  for reanalysis.) (UNDOSAVE (LIST (FUNCTION MSMARKCHANGE1) FNS FLG]) (MSINIT (LAMBDA (DATABASE) (* ; "Edited 12-Jun-90 20:45 by teruuchi") (* ;; "lmm %"29-Jul-85 21:06%"") (* ;; "This function should be called at the beginning of any function which accesses the data base") (COND ((OR (NULL MSDATABASELST) (LISTP DATABASE)) (SETQ MSDATABASELST) (pushnew MARKASCHANGEDFNS (QUOTE MSMARKCHANGED)) (SETQ MSCHANGEDARRAY (HASHARRAY 128)) (* ;; "MSDATABASEINIT is a pattern for how the data base list should look. The data base is stored in multiple hash tables. These hash tables are pointed to both by a list, MSDATABASELST which is an a-list of (TableName ForwardTable . BackTable) while the array, MSDATABASE, is an array of the same length as the list, with ELT's the forward htables, and ELTD's the back tables.") (OR DATABASE (SETQ MSDBEMPTY)) (SETQ MSDATABASELST (for X in MSDATABASEINIT collect (CONS (CAR X) (CONS (OR (CADR (ASSOC (CAR X) DATABASE)) (SELECTQ (CAR X) (USERTEMPLATES USERTEMPLATES) (MAKETABLE (CADR X) (CAR X)))) (COND ((FIXP (CDDR X)) (OR (CDDR (ASSOC (CAR X) DATABASE)) (MAKETABLE (CDDR X) (CAR X) T))) (T (CDDR X))))) finally (SETQ MSFILETABLE (ASSOC (QUOTE FILE) $$VAL)) (SETQ MSARGTABLE (ASSOC (QUOTE ARGS) $$VAL)))) T))) ) (GETVERBTABLES [LAMBDA (ROOT MODIFIER) (* lmm "28-FEB-79 16:08") (for Y in (OR (MSVBTABLES ROOT MODIFIER) (SHOULDNT 3)) collect (COND [(LISTP Y) (LIST (CDDR (FASSOC (CAR Y) MSDATABASELST] (T (CDR (FASSOC Y MSDATABASELST]) (MSSTOREDATA [LAMBDA (FNNAME FNDATA) (* lmm " 1-JUN-81 23:19") (PROG [NEWREL (KWN (PARSERELATION 'KNOWN] (SETQ MSDBEMPTY NIL) (* Database for FNNAME about to become inconsistant -  mark it as changed) (PUTHASH FNNAME T MSCHANGEDARRAY) (* * Now update the database) (for TAB in MSDATABASELST when (AND (NOT (FMEMB (CAR TAB) NODUMPRELATIONS)) (NEQ (CDDR TAB) T)) do (SETQ NEWREL (MSCOLLECTDATA (CAR TAB))) (STORETABLE FNNAME TAB NEWREL)) [OR (TESTRELATION FNNAME KWN) (PUTTABLE FNNAME T (CADR (FASSOC 'NOBIND MSDATABASELST] (* Table NOBIND is for those functions which don't do very much.  The idea is that the test that a function has been analyzed is whether it  binds variables are calls functions, etc.  However, for those functions which have no such entries,  (e.g. their definition is (LAMBDA NIL NIL)) need to still be able to know  that they were.) (PUTHASH FNNAME NIL MSCHANGEDARRAY]) (STORETABLE [LAMBDA (KEY TABLST VALUE) (* lmm "10-APR-81 08:46") (PROG [(OLDREL (GETTABLE KEY (CADR TABLST] (PUTTABLE KEY VALUE (CADR TABLST)) (COND ((CDDR TABLST) (for Z in VALUE do (* Used to test here (NOT (EQMEMB Z OLDREL)) but occasionally found the data  base was out of synch & A calls B but B doesn't show being called by A;  thus we always add KEY to Z's back pointers  (nothing will be done if it is already there)) (ADDTABLE Z KEY (CDDR TABLST))) (for Z in OLDREL do (* However, we must rely on the previous value to tell who values must be  DELETED from) (AND (NOT (FMEMB Z VALUE)) (SUBTABLE Z KEY (CDDR TABLST]) ) (ADDTOVAR MSCHANGEDARRAY ) (ADDTOVAR MSDATABASELST ) (RPAQ? MSDBEMPTY T) (RPAQQ MSDATABASEINIT ((CALL 25 . 50) (BIND 10 . 10) [NLAMBDA 10 . 10] (NOBIND 10) (RECORD 20 . 10) (CREATE 2 . 2) (FETCH 10 . 10) (REPLACE 10 . 10) (REFFREE 10 . 1) (REF 10 . 25) (SETFREE 1 . 1) (SET 20 . 30) (SMASHFREE 1 . 1) (SMASH 1 . 1) (PROP 1 . 1) (TEST 1 . 1) (TESTFREE 1 . 1) (PREDICATE 10 . 10) (EFFECT 10 . 10) (CLISP 10 . 10) (SPECVARS 10 . 10) (LOCALVARS 10 . 10) (APPLY 10 . 10) (ERROR 10 . 10) (LOCALFREEVARS 10 . 10) (CONTAINS 10 . 10) (FILE 10) (ARGS 10) (USERTEMPLATES NIL . T) (0 10 . 10) (FPTYPE 10 . 10) (KEYACCEPT 2 . 2) (KEYSPECIFY 2 . 2) (KEYCALL 2 . 2) (FLET 2 . 2) (LABEL 2 . 2) (MACROLET 2 . 2) (COMPILER-LET 2 . 2) (SENDNOTSELF 2 . 2) (SENDSELF 2 . 2) (IMPLEMENT 2 . 2) (GETNOTSELF 2 . 2) (GETSELF 2 . 2) (GETCVSELF 2 . 2) (GETCVNOTSELF 2 . 2) (PUTNOTSELF 2 . 2) (PUTSELF 2 . 2) (PUTCVSELF 2 . 2) (PUTCVNOTSELF 2 . 2) (OBJECT 2 . 2))) (RPAQQ NODUMPRELATIONS (CONTAINS FILE)) (DEFINEQ (PARSERELATION [LAMBDA (RELATION) (* lmm "11-Jul-86 15:50") (MSINIT) (COND ((EQ (CAR (LISTP RELATION)) 'TABLES) RELATION) (T (CONS 'TABLES (for Y in (PARSERELATION1 RELATION) collect (COND [(LISTP Y) (CDR (CDR (FASSOC (CAR Y) MSDATABASELST] (T (CDR (FASSOC Y MSDATABASELST]) (PARSERELATION1 [LAMBDA (ROOT MOD TAIL) (* lmm "30-DEC-78 17:06") (COND [TAIL (APPLY* (SELECTQ (CAR TAIL) (ANDNOT (FUNCTION LDIFFERENCE)) (AND (COND ((EQ (CADR TAIL) 'NOT) (SETQ TAIL (CDR TAIL)) (FUNCTION LDIFFERENCE)) (T (FUNCTION INTERSECTION)))) (OR (FUNCTION UNION)) (ERROR TAIL '?)) (PARSERELATION1 ROOT MOD) (PARSERELATION1 (CADR TAIL) (CDDR TAIL] ((LISTP ROOT) (PARSERELATION1 (CAR ROOT) (CDR ROOT))) [(LISTP MOD) (SELECTQ (CAR MOD) ((A AS AN FOR) (PARSERELATION1 ROOT (CDR MOD))) ((AND OR ANDNOT) (PARSERELATION1 ROOT NIL MOD)) (PARSERELATION1 ROOT (CAR MOD) (CDR MOD] (T (OR (MSVBTABLES ROOT MOD) [MSVBTABLES (GETWORDTYPE ROOT 'S) (CAR (OR (GETWORDTYPE MOD 'V) (GETWORDTYPE MOD 'AS) (GETWORDTYPE MOD 'FOR) (ERROR MOD '?] (ERROR ROOT '?]) (GETRELATION [LAMBDA (ITEM RELATION INVERTED) (* lmm "11-Jul-86 15:51") (PROG (VAL) (for TABLE in [CDR (COND ((EQ (CAR (LISTP RELATION)) 'TABLES) RELATION) (T (PARSERELATION RELATION] do (SETQ VAL (UNION [GETTABLE ITEM (COND (INVERTED (COND ((LITATOM (CDR TABLE)) (ERROR RELATION "CAN'T BE INVERTED"))) (CDR TABLE)) (T (CAR TABLE] VAL))) (RETURN VAL]) (MAPRELATION [LAMBDA (RELATION MAPFN) (* lmm "21-SEP-78 04:20") (DECLARE (SPECVARS MAPZ MAPW MAPFN2 MAPFN)) (PROG ((MAPZ (NARGS MAPFN)) (MAPW (PARSERELATION RELATION))) (MAP (CDR MAPW) (FUNCTION (LAMBDA (MAPFN2) (MAPTABLE (CAAR MAPFN2) (FUNCTION (LAMBDA (DUMMY MAPX) (OR [SOME (CDR MAPFN2) (FUNCTION (LAMBDA (HT2) (TESTTABLE MAPX (CAR HT2] (COND ((EQ MAPZ 1) (APPLY* MAPFN MAPX)) (T (MAPC (GETRELATION MAPX MAPW) (FUNCTION (LAMBDA (Z) (APPLY* MAPFN MAPX Z]) (TESTRELATION [LAMBDA (ITEM RELATION ITEM2 INVERTED) (* lmm "25-JUN-78 01:16") (AND [SOME [CDR (COND ((EQ (CAR RELATION) 'TABLES) RELATION) (T (PARSERELATION RELATION] (FUNCTION (LAMBDA (TABLE) (COND [ITEM2 (FMEMB ITEM2 (GETTABLE ITEM (COND (INVERTED (CDR TABLE)) (T (CAR TABLE] (T (TESTTABLE ITEM (COND (INVERTED (CDR TABLE)) (T (CAR TABLE] T]) ) (DEFINEQ (ADDHASH [LAMBDA (ITEM VAL ARRAY) (* lmm "10-JUL-78 03:03") (* Add VAL to the hash-key of ITEM  in ARRAY) (PROG ((OV (GETHASH ITEM ARRAY))) (COND (OV (OR (FMEMB VAL OV) (NCONC1 OV VAL))) (T (PUTHASH ITEM (LIST VAL) ARRAY]) (SUBHASH [LAMBDA (ITEM VAL ARRAY) (* lmm "10-JUL-78 03:03") (PROG ((OV (GETHASH ITEM ARRAY))) (AND OV (OR (DREMOVE VAL OV) (PUTHASH ITEM NIL ARRAY]) (MAKEHASH [LAMBDA (N) (* rmk%: " 3-Jan-84 21:31") (HASHARRAY N (FUNCTION MSREHASH]) (MSREHASH [LAMBDA (HA) (* rmk%: "30-Dec-83 11:45") (* The hash tables in the database rehash using this algorithm;  they increase size by 25% + 50 This insures that even though some tables  start out small (e.g. 1 or 2 elements) they will rehash to larger ones.) (IPLUS (IQUOTIENT (ITIMES 5 (HARRAYSIZE HA)) 4) 50]) (EQMEMBHASH [LAMBDA (X V H) (* rmk%: "10-JUN-79 21:00") (* Provided in case MSHASH is loaded  without MSSWAP) (MEMB V (GETHASH X H]) ) [MAPC '((GETHASH GETTABLE) (GETHASH TESTTABLE) (PUTHASH PUTTABLE) (ADDHASH ADDTABLE) (SUBHASH SUBTABLE) (MAPHASH MAPTABLE) (MAKEHASH MAKETABLE) (EQMEMBHASH EQMEMBTABLE)) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X] (DEFINEQ (MSVBTABLES [LAMBDA (VERB MOD) (* ; "Edited 30-Jun-87 10:32 by jrb:") (* ;; "The call to MSUSERVBTABLES checks a user hash table to allow extensions.") [COND ((LISTP VERB) (SETQ MOD (CADR VERB)) (SETQ VERB (CAR VERB] (MKLIST (OR (SELECTQ VERB (BIND (SELECTQ MOD (NIL '(BIND REF SET SMASH TEST)) (NOTUSE 'BIND) NIL)) (CALL (SELECTQ MOD (DIRECTLY '(CALL EFFECT PREDICATE NLAMBDA)) (EFFECT 'EFFECT) (INDIRECTLY 'APPLY) (NIL '(APPLY CALL EFFECT ERROR PREDICATE NLAMBDA)) (NOTERROR '(APPLY CALL EFFECT PREDICATE NLAMBDA)) (PREDICATE 'PREDICATE) (TESTING 'PREDICATE) (VALUE '(CALL NLAMBDA)) (NLAMBDA 'NLAMBDA) NIL)) (CREATE (SELECTQ MOD (NIL 'CREATE) NIL)) (DECLARE (SELECTQ MOD (CL:LOCALLY 'LOCALVARS) (LOCALVARS 'LOCALVARS) (NIL '(LOCALVARS SPECVARS)) (SPECVARS 'SPECVARS) NIL)) (FETCH (SELECTQ MOD (NIL 'FETCH) NIL)) (IS (SELECTQ MOD (FIELDS '((FETCH) (REPLACE))) (FNS '(CALL NOBIND REF (CALL) (APPLY))) (KNOWN '(CALL NOBIND REF)) (NIL '(CALL NOBIND REF (CALL) (BIND) (REFFREE) (REF) (SETFREE) (SET) (SMASHFREE) (SMASH) (RECORDS) (FETCH) (REPLACE) (PROP) (APPLY) (TEST) (TESTFREE))) (PROPS '((PROP))) (RECORDS '((RECORD) (CREATE))) (VARS '((BIND) (REFFREE) (REF) (SETFREE) (SET) (SMASHFREE) (SMASH) (TEST) (TESTFREE))) (TYPE '((0))) NIL)) (KNOWN (SELECTQ MOD (NIL '(CALL NOBIND REF)) NIL)) (PROG (SELECTQ MOD (NIL 'PROG) NIL)) (REFERENCE (SELECTQ MOD (FIELDS 'FETCH) (FREELY '(REFFREE TESTFREE SMASHFREE)) (CL:LOCALLY '(REF TEST SMASH)) (NIL '(REF REFFREE TEST TESTFREE SMASH SMASHFREE)) NIL)) (REPLACE (SELECTQ MOD (NIL 'REPLACE) NIL)) (SET (SELECTQ MOD (FIELDS 'REPLACE) (FREELY 'SETFREE) (CL:LOCALLY 'SET) (NIL '(SET SETFREE)) NIL)) (SMASH (SELECTQ MOD (FIELDS 'REPLACE) (FREELY 'SMASHFREE) (CL:LOCALLY 'SMASH) (NIL '(SMASH SMASHFREE)) NIL)) (TEST (SELECTQ MOD (FREELY 'TESTFREE) (CL:LOCALLY 'TEST) (NIL '(TEST TESTFREE)) NIL)) (USE (SELECTQ MOD (FIELDS '(FETCH REPLACE)) (FREELY '(REFFREE SETFREE SMASHFREE TESTFREE)) (I.S.OPRS 'CLISP) (INDIRECTLY 'LOCALFREEVARS) (CL:LOCALLY '(REF SET SMASH TEST)) (NIL '(REF REFFREE SET SETFREE SMASH SMASHFREE TEST TESTFREE)) (PREDICATE '(TEST TESTFREE)) (PROPNAMES 'PROP) (RECORDS '(CREATE RECORD)) (TESTING '(TEST TESTFREE)) (VALUE '(REF REFFREE SMASH SMASHFREE)) (TYPE '0) NIL)) NIL) (MSUSERVBTABLES VERB MOD]) (MSUSERVBTABLES [LAMBDA (VERB MOD) (* smL "20-Dec-85 17:03") (* * Find the relation tables for a user-defined relation) (OR [AND (BOUNDP 'MSUSERVBTABLES) (HASHARRAYP MSUSERVBTABLES) (CDR (for modifier in (GETHASH VERB MSUSERVBTABLES) thereis (EQMEMB MOD (CAR modifier] VERB]) ) (RPAQ? MSUSERVBTABLES (MAKETABLE 2)) (RPAQ? MSANALYZEFNS (MAKETABLE 2)) (DEFINEQ (BUILDGETRELQ [LAMBDA (X) (* ; "Edited 16-Jun-87 12:36 by jrb:") (PROG ([VAR (COND ((LITATOM (CADR X)) (CADR X)) (T '$$1] FORM F1) [for REL in (MSVBTABLES (CAR X)) do [SETQ F1 (LIST 'GETTABLE VAR (LIST (COND ((CADDR X) 'CDDR) (T 'CADR)) (LIST 'FASSOC (KWOTE REL) 'MSDATABASELST] (SETQ FORM (COND (FORM (LIST 'UNION F1 FORM)) (T F1] (RETURN (COND ((EQ VAR (CADR X)) FORM) (T (LIST (LIST 'LAMBDA (LIST VAR) FORM) (CADR X]) (BUILDTESTRELQ [LAMBDA (X) (* ; "Edited 16-Jun-87 12:41 by jrb:") (PROG ([VAR (COND ((LITATOM (CADR X)) (CADR X)) (T '$$1] FORM) [SETQ FORM (CONS 'OR (for R in (MSVBTABLES (CAR X)) collect (LIST 'TESTTABLE VAR (LIST (COND ((CADDR X) 'CDDR) (T 'CADR)) (LIST 'FASSOC (KWOTE R) 'MSDATABASELST] (RETURN (COND ((EQ VAR (CADR X)) FORM) (T (LIST (LIST 'LAMBDA (LIST VAR) FORM) (CADR X]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS GETRELQ MACRO (X (BUILDGETRELQ X))) (PUTPROPS TESTRELQ MACRO (X (BUILDTESTRELQ X))) ) ) (DEFINEQ (MSERASE [LAMBDA (ATOMS) (* lmm " 1-JUN-81 22:56") (DECLARE (SPECVARS ERASESET)) (COND ((EQ ATOMS T) (SETQ MSCHANGEDARRAY) (SETQ MSDATABASELST) (SETQ MSFILETABLE) (SETQ MSARGTABLE) (SETQ MSDBEMPTY T)) (T (for AT in ATOMS do (MSSTOREDATA AT]) ) (DEFINEQ (DUMPDATABASE [LAMBDA (FNLST) (* lmm "12-APR-81 15:57") (PROG (DUMPEDFLG) (DECLARE (SPECVARS DUMPEDFLG DUMPTABLE)) (COND (FNLST (MAPC FNLST (FUNCTION UPDATEFN))) (T (UPDATECHANGED))) (PRINT '(READATABASE)) (PRIN1 '%() (TERPRI) [for DUMPTABLE in MSDATABASELST when (NOT (MEMB (CAR DUMPTABLE) NODUMPRELATIONS)) do (SETQ DUMPEDFLG NIL) [COND ((OR (NOT FNLST) (EQ (CDDR DUMPTABLE) T)) (* either dumping everything, or this is a permanent table which should be  dumped in entirity (e.g. templates)) (MAPTABLE (CADR DUMPTABLE) (FUNCTION DUMPDATABASE1))) (T (MAPC FNLST (FUNCTION (LAMBDA (FN) (DUMPDATABASE1 (GETTABLE FN (CADR DUMPTABLE)) FN] (COND (DUMPEDFLG (PRINT] (TERPRI) (PRIN1 '%)) (TERPRI]) (DUMPDATABASE1 [LAMBDA (VALUE FN) (* rmk%: "24-OCT-79 10:02") (COND (FN (COND ((NOT DUMPEDFLG) (SETQ DUMPEDFLG (PRIN2 (CAR DUMPTABLE))) (SPACES 1))) (PRIN2 FN) (SPACES 1) (PRIN2 VALUE) (SPACES 1]) (READATABASE [LAMBDA NIL (* ; "Edited 3-Jun-88 12:34 by jrb:") [SELECTQ (RATOM) ((%[ %()) (HELP '(BAD DATABASE] (MSINIT) (SETQ MSDBEMPTY) (PROG (TAB FN NEWREL NAME) (while (SETQ NAME (READ)) do (SELECTQ NAME (USERTEMPLATES (while (SETQ FN (READ)) do (TEMPLATE FN (READ) T))) (COND ((SETQ TAB (FASSOC NAME MSDATABASELST)) (while (SETQ FN (READ)) do (PUTHASH FN T MSCHANGEDARRAY) (SETQ NEWREL (MKLIST (READ))) (STORETABLE FN TAB NEWREL) (PUTHASH FN NIL MSCHANGEDARRAY))) (T (LISPXPRINT "*** incompatible MASTERSCOPE data base" T T) (while (READ]) ) (RPAQQ DATABASECOMS ((E (DUMPDATABASE)))) (ADDTOVAR GAINSPACEFORMS (MSDATABASELST "erase current Masterscope database" (%. ERASE))) (RPAQQ MSCHECKBLOCKSCOMS ((FNS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE GLOBALVARP PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT) (BLOCKS (MSCHECKBLOCKS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT (LOCALFREEVARS SEEN BLKFNS V ERRORS SFLG LF BLKAPPLYCALLERS U LF1 SHOULDBESPECVARS) (NOLINKFNS . T) (SPECVARS SPECVARS LOCALVARS RETFNS BLKAPPLYFNS BLKLIBRARY NOLINKFNS LINKFNS LOCALFREEVARS DONTCOMPILEFNS ENTRIES) (GLOBALVARS SYSLOCALVARS SYSSPECVARS FILELST MSCRATCHASH) GLOBALVARP)))) (DEFINEQ (MSCHECKBLOCKS [LAMBDA (FILES) (* ; "Edited 2-Jun-88 13:45 by jrb:") (PROG ((LOCALVARS SYSLOCALVARS) (SPECVARS T) FNS BLOCKS NOBLOCKFNS TEM) [COND ((NULL FILES) (SETQ FILES FILELST)) ((NLISTP FILES) (SETQ FILES (OR (GETP FILES 'FILEGROUP) (LIST FILES] [for FL in FILES do (MSNOTICEFILE FL) (SETQ BLOCKS (NCONC (FILECOMSLST FL 'BLOCKS) BLOCKS)) (* ;;  "JRB - Check now gathers everything analyzable, not just FNS") (MAPC [SETQ TEM (for FT in MSFNTYPES join (FILECOMSLST FL (ffetch (MSANALYZABLE FILEPKGNAME) of FT] (FUNCTION UPDATEFN)) (SETQ FNS (NCONC TEM FNS)) (COND ((SETQ TEM (FILECOMSLST FL 'LOCALVARS)) (APPLY (FUNCTION LOCALVARS) TEM))) (COND ((SETQ TEM (FILECOMSLST FL 'SPECVARS)) (APPLY (FUNCTION SPECVARS) TEM))) (COND ((SETQ TEM (FILECOMSLST FL 'GLOBALVARS)) (* ;; "Ordinarily a noop, since noticing the file sets up GLOBALVARS (unlike SPECVARS and LOCALVARS, which are EVAL@COMPILE); however, user might have edited coms since then") (APPLY (FUNCTION ADDTOVAR) (CONS 'GLOBALVARS TEM] (UPDATECHANGED) (TAB 0 0) (COND ((SETQ NOBLOCKFNS (for FN in FNS unless [OR (MEMB FN DONTCOMPILEFNS) (for BLOCK in BLOCKS thereis (MEMB FN (CDR BLOCK] collect FN)) (MSCHECKBLOCK (CONS (COND [BLOCKS (APPEND '("no block - ") (COND [(CDDDDR NOBLOCKFNS) (APPEND (LDIFF NOBLOCKFNS (CDDDDR NOBLOCKFNS )) '("--"] (T NOBLOCKFNS] (T (CONS "File" FILES))) NOBLOCKFNS) FNS BLOCKS))) (for BLOCK in BLOCKS do (MSCHECKBLOCK BLOCK FNS BLOCKS]) (MSCHECKBLOCK [LAMBDA (BLOCK FNS BLOCKS) (* ; "Edited 3-Jun-88 10:50 by jrb:") (LET ((SPECVARS SPECVARS) (LOCALVARS LOCALVARS) (BLKNAME (CAR BLOCK)) BLKAPPLYFNS ENTRIES LOCALFREEVARS BLKFNS FREEVARS TEM TEM2 BOUNDFREE BLKAPPLYCALLERS ERRORS SHOULDBESPECVARS (GLOBALVARS GLOBALVARS) (RETFNS RETFNS) (BLKLIBRARY BLKLIBRARY) (NOLINKFNS NOLINKFNS) (LINKFNS LINKFNS) (DONTCOMPILEFNS DONTCOMPILEFNS)) (DECLARE (SPECVARS GLOBALVARS RETFNS BLKLIBRARY NOLINKFNS LINKFNS DONTCOMPILEFNS)) (COND ((LISTP BLKNAME) (SETQ BLKNAME NIL))) [COND (BLKNAME (SETQ LOCALVARS T) (SETQ SPECVARS (COND ((NEQ SPECVARS T) (UNION SYSSPECVARS SPECVARS)) (T SYSSPECVARS] [for X in (CDR BLOCK) do (* ; "set up declarations and BLKFNS") (COND ((LISTP X) [SETQ TEM (COND ((EQ (CADR X) '*) (EVAL (CADDR X))) (T (CDR X] (SET (CAR X) (COND ((NLISTP (CDR X)) (CDR X)) ([LISTP (SETQ TEM2 (EVALV (CAR X] (APPEND TEM TEM2)) (T TEM))) (* ;; "ASSERT: ((REMOTE EVAL) SPECVARS LOCALVARS LOCALFREEVARS GLOBALVARS BLKLIBRARY SYSSPECVARS BLKAPPLYFNS ENTRIES LINKFNS NOLINKFNS RETFNS SYSLOCALVARS)") (SELECTQ (CAR X) (SPECVARS (COND ((EQ TEM T) (SETQ LOCALVARS SYSLOCALVARS)))) (LOCALVARS (COND ((EQ TEM T) (SETQ SPECVARS SYSSPECVARS)))) ((LOCALFREEVARS GLOBALVARS BLKLIBRARY SYSSPECVARS BLKAPPLYFNS ENTRIES LINKFNS NOLINKFNS RETFNS SYSLOCALVARS)) (DOERROR (CAR X) "unrecognized item in block declaration"))) ((MEMB X BLKFNS) (DOERROR X "on block twice")) (T (SETQ BLKFNS (CONS X BLKFNS] (COND (BLKNAME (MSCHECKBLOCKBASIC BLOCK BLKNAME)) (T (COND (BLKAPPLYFNS (DOERROR BLKAPPLYFNS "BLKAPPLYFNS but not a real block" NIL T))) (SETQ BLKLIBRARY NIL))) (for FN in BLKFNS do (OR (FMEMB FN FNS) (FMEMB FN BLKLIBRARY) (DOERROR FN "not on the file")) (COND (BLKNAME (* ; "a real block") (MSCHECKFNINBLOCK FN BLOCK BLOCKS))) [for VAR in (UNION (SETQ TEM (GETRELQ (BIND NOTUSE) FN)) (GETRELQ (USE CL:LOCALLY) FN)) do [OR (FMEMB VAR BOUNDFREE) (FMEMB VAR SYSSPECVARS) (GLOBALVARP VAR) (COND ((TESTRELQ (USE FREELY) VAR T) (* ;  "i.e. it is bound in this block, and used freely by someone else") (SETQ BOUNDFREE (CONS VAR BOUNDFREE))) ((SPECVARP VAR FN) (AND (NEQ SPECVARS T) (UNECCSPEC FN VAR))) ((FMEMB VAR TEM) (DOERROR FN "binds and never uses" VAR T] (COND ((AND (FMEMB VAR (GETRELQ (USE INDIRECTLY) FN)) (NOT (SPECVARP VAR FN))) (DOERROR VAR "should be SPECVAR (used in functional arg) in" FN T] (SETQ FREEVARS (UNION (GETRELQ (USE FREELY) FN) FREEVARS))) (MSCHECKBOUNDFREE BOUNDFREE BLKNAME) [for VAR in FREEVARS unless (OR (FMEMB VAR SHOULDBESPECVARS) (FMEMB VAR SYSSPECVARS) (FMEMB VAR (LISTP SPECVARS)) (FMEMB VAR LOCALFREEVARS) (FMEMB VAR GLOBALVARS) (GETPROP VAR 'GLOBALVAR) (CL:CONSTANTP VAR) (GET VAR 'GLOBALLY-SPECIAL)) do (COND ((NULL (SETQ TEM (for FN in (GETRELQ (USE FREELY) VAR T) when (FMEMB FN BLKFNS) collect FN))) (* ; "Nobody uses it??") ) ((TESTRELQ BIND VAR T) (DOERROR VAR "not declared, used freely by " TEM 0)) ((NOT (BOUNDP VAR)) (DOERROR VAR "not declared, never bound, no top-level value, used freely by" TEM T)) (T (DOERROR VAR "not bound, not a GLOBALVAR, used freely by" TEM T] (for DEC in BLOCK when (LISTP DEC) do (SELECTQ (CAR DEC) ((SPECVARS LOCALVARS LOCALFREEVARS GLOBALVARS) (for VAR in (CDR DEC) unless (OR (FMEMB VAR BOUNDFREE) (FMEMB VAR FREEVARS) (for FN in (GETRELQ BIND VAR T) thereis (FMEMB FN BLKFNS))) do (DOERROR VAR "not mentioned in block, but on" (CAR DEC) T))) NIL)) (COND (ERRORS (OR (ZEROP (POSITION)) (TERPRI)) (TERPRI) (PRIN1 "<<<<< In "))) [MSMSGPRINT (OR (CAR BLOCK) (CONS NIL (NCONC (for X in (CDR BLOCK) collect X repeatuntil (NLISTP X)) '(--] (COND (ERRORS (PRIN1 ": >>>>>") (MAPC (SETQ ERRORS (DREVERSE ERRORS)) (FUNCTION PRINTERROR)) (PRIN1 "---------------- ")) (T (PRIN1 ", "]) (MSCHECKFNINBLOCK [LAMBDA (FN BLOCK BLOCKS) (* bvm%: "26-Mar-84 12:02") (* * Checks things related to FN in a real block) (PROG (INDIRECTCALLERS MACRODEF ISCALLEDP) (COND ([AND (SETQ MACRODEF (GETPROP FN 'MACRO)) (OR (NULL (CAR MACRODEF)) (LISTP (CAR MACRODEF))) (NOT (FMEMB FN ENTRIES)) (NOT (MSFIND MACRODEF 'IGNOREMACRO] (* no point in having it in the block, since all of the other block fns would  get the -  however, computed macros might return IGNOREMACRO) (DOERROR FN "internal block function with MACRO property" NIL T))) (COND ((AND (NOT (FMEMB FN ENTRIES)) (NOT (FMEMB FN BLKLIBRARY))) (* Check that internal FN is not called from outside the block) (SETQ ISCALLEDP NIL) [for FN2 in (UNION (SETQ INDIRECTCALLERS (GETRELQ (CALL INDIRECTLY) FN T)) (GETRELQ (CALL DIRECTLY) FN T)) do (* FN2 calls FN) (COND ((AND (NEQ FN2 FN) (FMEMB FN2 BLKFNS)) (* is called by somebody in the  block) (SETQ ISCALLEDP T))) (COND [(NOT (FMEMB FN2 BLKFNS)) (COND ([NOT (for OTHERBLOCK in BLOCKS thereis (AND (NEQ OTHERBLOCK BLOCK) (MEMB FN (CDR OTHERBLOCK)) (OR (NULL (CAR OTHERBLOCK)) (MEMB FN2 (CDR OTHERBLOCK] (* called by FN2 outside the block, and FN is not also a member of a block  containing FN2) (DOERROR FN "not an entry, called from outside the block by" FN2] ((FMEMB FN2 INDIRECTCALLERS) (* called indirectly) (OR (FMEMB FN RETFNS) (FMEMB FN BLKAPPLYFNS) (DOERROR FN "not an entry or on RETFNS or BLKAPPLYFNS, called indirectly by" FN2] (COND ((AND (NOT ISCALLEDP) (NOT (FMEMB FN BLKAPPLYFNS))) (DOERROR FN "not an entry, not called from inside the block"]) (MSCHECKBLOCKBASIC [LAMBDA (BLOCK BLKNAME) (* bvm%: "26-Mar-84 11:45") (* check for things having to do  with real blocks) [COND ((AND (NULL ENTRIES) (MEMB BLKNAME BLKFNS)) (COND ((NEQ BLKNAME (CADR BLOCK)) (DOERROR BLKNAME "must also be the FIRST function in the block"] [COND ((AND (EQ BLKNAME (CAR ENTRIES)) (NULL (CDR ENTRIES)) (NULL BLKAPPLYFNS)) (* MKENTRIES treats the case of ENTRIES=NIL specially by not setting up a  separate BLOCK.) (SETQ ENTRIES NIL)) ((AND (NULL ENTRIES) BLKAPPLYFNS) (* Above caper only works if no  BLKAPPLYFNS) (SETQ ENTRIES (LIST BLKNAME] (COND ((MEMB BLKNAME ENTRIES) (DOERROR BLKNAME "can't be both entry and block name"))) (for X in [APPEND BLKAPPLYFNS (OR ENTRIES (SETQ ENTRIES (LIST BLKNAME] do (OR (MEMB X BLKFNS) (DOERROR X "on ENTRIES or BLKAPPLYFNS but not in block"))) (for FN in BLKLIBRARY when (AND [NOT (FMEMB FN '(EQUAL GETPROP GETP NTH TAILP MEMBER] (for Y in (GETRELQ (CALL NOTERROR) FN T) thereis (FMEMB Y BLKFNS))) do (COND ((NULL (GETPROP FN 'BLKLIBRARYDEF)) (DOERROR FN "on BLKLIBRARY but no BLKLIBRARYDEF property" NIL T))) (SETQ BLKFNS (NCONC1 BLKFNS FN))) (COND ([AND BLKAPPLYFNS (NOT (SETQ BLKAPPLYCALLERS (for X in '(BLKAPPLY BLKAPPLY*) join (for Y in (GETRELQ (CALL NOTERROR) X T) when (FMEMB Y BLKFNS) collect Y] (DOERROR BLKAPPLYFNS "BLKAPPLYFNS but no calls to BLKAPPLY in block" NIL T]) (MSCHECKBOUNDFREE [LAMBDA (BOUNDFREE BLKNAME) (* bvm%: "26-Mar-84 12:08") (for V in BOUNDFREE do (SCRATCHASH SEEN (PROG ((USERS (GETRELQ (USE FREELY) V T)) (LF (FMEMB V LOCALFREEVARS)) (BINDERS (GETRELQ BIND V T)) LF1 SFLG) (CLRHASH SEEN) (for X in USERS do (PUTHASH X -1 SEEN)) (for X in BINDERS do (PUTHASH X 1 SEEN)) (for U in USERS do (COND ((FMEMB U BLKFNS) (COND ((FMEMB U BINDERS) (NECCSPEC V U U))) (SETQ LF1 LF))) (MSCHECKVARS1 U)) (COND ((AND (NULL SFLG) (OR BLKNAME (EQ LOCALVARS T)) (NEQ SPECVARS T)) (for X in BINDERS when (FMEMB X BLKFNS) do (SELECTQ (GETHASH X SEEN) (2) (-1) (AND (SPECVARP V X) (UNECCSPEC X V]) (GLOBALVARP [LAMBDA (X) (* lmm "31-DEC-78 15:23") (OR (FMEMB X GLOBALVARS) (GETPROP X 'GLOBALVAR]) (PRINTERROR [LAMBDA (ERR) (* lmm "24-FEB-79 21:15") (PROG ((MSG (CAR ERR)) (VALS (CDDR ERR)) NEWPRS PR POS POS2 (LL (IDIFFERENCE (LINELENGTH) 30)) POS3) (SELECTQ (CAR MSG) (0 (SETQ MSG (CDR MSG)) (PRIN1 " (note) ")) (T (SETQ MSG (CDR MSG)) (PRIN1 " (possible error) ")) (PRIN1 " (probable error) ")) (COND (VALS (for X inside VALS do (PRIN2 X) (SPACES 1)) (PRIN1 '-) (for X inside MSG do (SPACES 1) (PRIN1 X)) (PRIN1 '%.) (TERPRI))) [for PRL on (DREVERSE (CADR ERR)) do [COND ([NULL (CDDR (SETQ PR (CAR PRL] (for ERR in (CDR PRL) do (COND ((EQUAL (CDR ERR) (CDR PR)) (FRPLACA ERR (CONS (CAR PR) (CAR ERR))) (FRPLACA PR NIL) (RETURN] (AND (CAR PR) (SETQ NEWPRS (CONS PR NEWPRS] (COND (NEWPRS (TAB 0 0) (SHORTLST (CAAR NEWPRS) 4) (SETQ POS (POSITION)) (PRIN1 " - ") (for X inside MSG do (PRIN1 X) (SPACES 1)) (SETQ POS2 (POSITION)) [COND ((OR (ILESSP POS2 (IDIFFERENCE POS 3)) (IGREATERP POS2 LL)) (SETQ POS2 (IPLUS POS 10] (SETQ POS3 (IDIFFERENCE (IQUOTIENT (IPLUS POS POS2) 2) 4)) (PRIN1 " -") (SHORTLST (CDAR NEWPRS) 4) (PRIN1 '". ") (MAPC (CDR NEWPRS) (FUNCTION (LAMBDA (PR) (SHORTLST (CAR PR) 4) (TAB POS T) (PRIN1 " -") (TAB POS3 T) (PRIN1 " %"%" ") (TAB POS2 T) (PRIN1 "-") (SHORTLST (CDR PR) 4) (PRIN1 ". "]) (MSCHECKVARS1 [LAMBDA (FN) (* lmm "16-Jul-84 14:54") [COND ((AND LF1 (FMEMB FN ENTRIES)) (DOERROR V [CONS "on LOCALFREEVARS" (COND ((EQ U FN) "but used freely by the entry") (T (LIST "but the entry" FN "can reach functions using it freely"] U T) (SETQ LF (SETQ LF1 NIL] (PROG ((CALLERS (GETRELQ (CALL NOTERROR) FN T)) (VAL 3)) [COND ((FMEMB FN BLKAPPLYFNS) (SETQ CALLERS (UNION BLKAPPLYCALLERS CALLERS] (* interpretation of SEEN codes -  0 recursive call -  -1 uses var -  1 binds var -  2 binds var, path from it to user -  T always bound above -  3 no callers -  4 not always bound above) (for X in CALLERS do (SELECTQ (GETHASH X SEEN) ((0 -1 4)) (3 (SETQ VAL 4)) (1 (* we have found a path from a user up to a binder -  if the path is entirely in the block, then LOCALFREEVAR is ok, -  if the path is outside the block, then it doesn't matter, otherwise SPECVAR) (COND ((FMEMB X BLKFNS) (* if the binder isn't in this  block, ignore) (* should just be SPECVAR if not entirely within the block) (NECCSPEC V X U))) (PUTHASH X 2 SEEN) (COND ((EQ VAL 3) (SETQQ VAL T)))) ((T 2) (COND ((EQ VAL 3) (SETQQ VAL T)))) (NIL (* now check recursively) (PUTHASH X 0 SEEN) (PUTHASH X (MSCHECKVARS1 X) SEEN)) (SHOULDNT 4))) (RETURN VAL]) (UNECCSPEC [LAMBDA (FN VAR) (* lmm "30-AUG-78 03:36") (OR (GLOBALVARP VAR) (FMEMB VAR (GETRELQ (USE INDIRECTLY) FN)) (DOERROR VAR "might not need to be a specvar in" FN T]) (NECCSPEC [LAMBDA (VAR BINDER) (* lmm "21-SEP-78 04:21") (COND ((NOT (OR SFLG (SPECVARP VAR BINDER))) (SETQ SFLG T) (SETQ SHOULDBESPECVARS (CONS VAR SHOULDBESPECVARS)) (DOERROR VAR (LIST "(used freely in)" U "is not a SPECVAR in") BINDER T]) (SPECVARP [LAMBDA (X FN) (* lmm "25-JUN-78 01:15") (COND ((FMEMB X (GETRELQ (DECLARE LOCALVARS) FN)) NIL) ((FMEMB X (GETRELQ (DECLARE SPECVARS) FN)) T) ((NEQ LOCALVARS T) (NOT (FMEMB X LOCALVARS))) (T (OR (EQ SPECVARS T) (FMEMB X SPECVARS) (FMEMB X LOCALFREEVARS) (FMEMB X GLOBALVARS) (GETP X 'GLOBALVAR]) (SHORTLST [LAMBDA (X N) (* lmm " 9-AUG-77 03:18") (COND ((NULL X) N) ((LISTP X) (SHORTLST (CDR X) (SHORTLST (CAR X) N))) (T (COND ((IGREATERP (SETQ N (SUB1 N)) 0) (SPACES 1) (PRIN2 X)) ((ZEROP N) (PRIN1 " etc"))) N]) (DOERROR [LAMBDA (AT MSG ARG QUESTIONABLE) (* lmm "21-Mar-85 08:29") [COND (QUESTIONABLE (SETQ MSG (CONS QUESTIONABLE MSG] (PROG ([L (CDR (OR (SASSOC MSG ERRORS) (CAR (SETQ ERRORS (CONS (CONS MSG (CONS)) ERRORS] (AT AT)) (COND (ARG [SETQ AT (OR (FASSOC AT (CAR L)) (CAAR (FRPLACA L (CONS (CONS AT) (CAR L] (OR (MEMBER ARG (CDR AT)) (NCONC1 AT ARG))) ((NOT (FMEMB AT (CDR L))) (FRPLACD L (CONS AT (CDR L]) (MSMSGPRINT [LAMBDA (MSG) (* ; "Edited 3-Jun-88 12:39 by jrb:") (* ;; "Prints messages Masterscope builds as lists - only atoms get prin2'ed.") (COND ((STRINGP MSG) (PRIN1 MSG)) ((CL:CONSP MSG) (PRIN1 "(") (MSMSGPRINT (pop MSG)) (while (CL:CONSP MSG) do (PRIN1 " ") (MSMSGPRINT (pop MSG))) (if MSG then (PRIN1 " . ") (MSMSGPRINT MSG)) (PRIN1 ")")) (T (PRIN2 MSG]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSCHECKBLOCKS MSCHECKBLOCKS MSCHECKBLOCK MSCHECKFNINBLOCK MSCHECKBLOCKBASIC MSCHECKBOUNDFREE PRINTERROR MSCHECKVARS1 UNECCSPEC NECCSPEC SPECVARP SHORTLST DOERROR MSMSGPRINT (LOCALFREEVARS SEEN BLKFNS V ERRORS SFLG LF BLKAPPLYCALLERS U LF1 SHOULDBESPECVARS) (NOLINKFNS . T) (SPECVARS SPECVARS LOCALVARS RETFNS BLKAPPLYFNS BLKLIBRARY NOLINKFNS LINKFNS LOCALFREEVARS DONTCOMPILEFNS ENTRIES) (GLOBALVARS SYSLOCALVARS SYSSPECVARS FILELST MSCRATCHASH) GLOBALVARP) ) (RPAQQ MSPATHSCOMS [(FNS MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN) (BLOCKS (MSPATHSBLOCK (ENTRIES MSPATHS MSONPATH MSPATHS2) MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN (LOCALFREEVARS TABS NAMED LINENUM LL BELOWCNT MARKING SEEN INVERTED TO NOTRACE AVOIDING SEPARATE) (GLOBALVARS MSBLIP MSCRATCHASH) (NOLINKFNS . T]) (DEFINEQ (MSPATHS [LAMBDA (FROM TO INVERTED AVOIDING SEPARATE NOTRACE MARKING) (* ; "Edited 3-Jun-88 12:37 by jrb:") (* ;; "Display paths; must print all of FROM, with separate tree for all of SEPARATE (considered as a subset of FROM). Stop when you get to a function in NOTRACE, or if DEPTH is exceeded -- unless TO is NIL, only print paths that eventually reach an element of TO. If INVERTED is not NIL, print inverted tree. Do not print out functions in AVOIDING") (SCRATCHASH SEEN (PROG (TABS (LL (LINELENGTH)) (BELOWCNT 0) (LINENUM 0) (FIRST T) X NAMED TEM (UNDONE (MSLISTSET FROM T))) (COND (INVERTED (PRINTOUT T "inverted tree" T))) [MAPC UNDONE (FUNCTION (LAMBDA (X) (PUTHASH X (COND ((AND NOTRACE (MSMEMBSET X NOTRACE)) -1) (T 0)) SEEN] (TAB 0 0) [RESETVARS ((MSPRINTFLG)) (do (COND (NAMED (OR FIRST (DASHES (GETHASH (CAR NAMED) SEEN))) (SETQ FIRST) (PUTHASH (CAR NAMED) 0 SEEN) (MSPATHS1 (CAR NAMED) NIL T) (SETQ NAMED (CDR NAMED))) (UNDONE [COND ([OR (NULL (SETQ TEM (GETHASH (CAR UNDONE) SEEN))) (EQ TEM 0) (AND (LISTP TEM) (NULL (CAR TEM] (PUTHASH (CAR UNDONE) (LIST NIL) SEEN) (SETQ NAMED (LIST (CAR UNDONE] (SETQ UNDONE (CDR UNDONE))) (T (TERPRI) (RETURN] (RETURN]) (MSPATHS1 [LAMBDA (FROM FIRST LAST) (* lmm " 4-AUG-83 23:45") (PROG (TEM THISLINE POS (XT TABS)) [COND ((NOT FIRST) (TERPRI) (SETQ LINENUM (ADD1 LINENUM)) (* if NOT (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS) then) (PRIN1 LINENUM) (PRIN1 ".") (DOTABS (CDR TABS] (SETQ THISLINE LINENUM) (AND TABS (TAB (CAR TABS) 0)) (AND LAST (SETQ TABS (CDR TABS))) (SETQ POS (MSPATHSPRINTFN FROM)) (MSPATHS2 FROM) (COND [(NEQ (SETQ TEM (GETHASH FROM SEEN)) 0) (* Already expanded on a previous line -  or is a NOTRACE) (COND ((EQ TEM MSBLIP) (SHOULDNT 5)) ((OR (NOT (NUMBERP TEM)) (NOT (MINUSP TEM))) (PRIN1 " {") (PRIN1 (COND ((NLISTP TEM) (* Either line number or overflow  line letter) TEM) [(LISTP TEM) (* A list means that this must be a  sub-tree) (COND ((CAR TEM)) (T (FRPLACA TEM (BELOWMARKER)) (SETQ NAMED (NCONC1 NAMED FROM)) (CAR TEM] (T TEM))) (PRIN1 "}"] (T (PROG ((TABS TABS) (FIRST T) NEXTLEVEL TEM) (PUTHASH FROM (IDIFFERENCE -1 THISLINE) SEEN) (OR (SETQ NEXTLEVEL (for Y in (COND ((NOT INVERTED) (GETRELQ CALL FROM)) (T (GETRELQ CALL FROM T))) when (MSPATHS2 Y) collect Y)) (RETURN)) (* AND (SETQ TEM (FASSOC  (QUOTE SORT) PRINTOPTIONS))  (SORT NEXTLEVEL (CDR TEM))) (COND ([AND XT (OR (SETQ TEM (AND SEPARATE (MSMEMBSET FROM SEPARATE))) (SOME NEXTLEVEL (FUNCTION (LAMBDA (FN) (IGREATERP (IPLUS (NCHARS FN) POS 6) LL] (* NOT (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS)) (SETQ NAMED (NCONC1 NAMED FROM)) (PRIN1 " {") [PRIN1 (COND (TEM (CAR (PUTHASH FROM (LIST (BELOWMARKER)) SEEN))) (T (PUTHASH FROM (BELOWMARKER) SEEN] (PRIN1 "}") (RETURN))) (SETQ TABS (CONS POS TABS)) (PUTHASH FROM THISLINE SEEN) (for X on NEXTLEVEL do (MSPATHS1 (CAR X) FIRST (NULL (CDR X))) (SETQ FIRST]) (MSPATHS2 [LAMBDA (FN FLG) (* lmm "20-Jul-84 14:36") (* Returns T if FN should be PRINTED -  The SEEN table contains one of the following entries for a function -  MSBLIP %: don't print the function at all -  n a number %: don't trace it, it was expanded previously -  -n %: don't trace it, it was printed earlier, though it had no sub-functions  -  0 %: yes, print and trace it -  -1 %: yes, print it, but don't trace it -  (NIL)%: it should be given a separate tree, as yet unnamed -  (letter)%: give it a separate tree with this letter name -  letter %: the function is expanded in an OVERFLOW table below) (* When below MSPATHS4 for ON PATH sets  (and CALL SOMEHOW) the SEEN table contains either 0 %: not traced yet, MSBLIP  %: don't print, -1 print, don't trace, T %: top set  (e.g. for CALLED SOMEHOW BY X, X is originally marked T) 1 already seen and  traced) (NEQ [OR (GETHASH FN SEEN) (PROGN (OR INVERTED (UPDATEFN FN NIL 0)) (COND ((AND AVOIDING (MSMEMBSET FN AVOIDING)) (* If it is avoiding, then no) (PUTHASH FN MSBLIP SEEN)) ((AND (NULL FLG) NOTRACE (MSMEMBSET FN NOTRACE)) (* Will not be traced%: entry should be either MSBLIP or -1 depending on  whether the function should be printed) (COND ((MSPATHS2 FN T) (PUTHASH FN -1 SEEN)) (T MSBLIP))) ((NULL TO) (PUTHASH FN (COND ((AND (NULL INVERTED) (GETD FN) (NOT (TESTRELQ KNOWN FN))) MSBLIP) (T 0)) SEEN)) ((MSMEMBSET FN TO) (* If it is in the TO set, then definitly YES) (PUTHASH FN 0 SEEN)) (T (* Will a path through this function eventually print out an element of TO?) (PUTHASH FN MSBLIP SEEN) (* assume not) (COND ((OR (NULL FLG) (NULL NOTRACE) (NOT (MSMEMBSET FN NOTRACE))) (for Y in (COND ((NOT INVERTED) (GETRELQ CALL FN)) (T (GETRELQ CALL FN T))) when (MSPATHS2 Y) do (RETURN (PUTHASH FN 0 SEEN)) finally (RETURN MSBLIP))) (T MSBLIP] MSBLIP]) (MSONPATH [LAMBDA (SETREP) (* ; "Edited 15-Aug-90 11:53 by jds") (PROG ((FROM (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of SETREP))) (TO (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of SETREP))) (AVOIDING (fetch (PATHOPTIONS AVOIDING) of (fetch MSPATHOPTIONS of SETREP) )) (NOTRACE (fetch (PATHOPTIONS NOTRACE) of (fetch MSPATHOPTIONS of SETREP))) INVERTED (TOPFLG (fetch (PATHOPTIONS TOPFLG) of (fetch MSPATHOPTIONS of SETREP))) (SEEN (HASHARRAY 20)) TEM) (COND ((NULL FROM) (SETQ INVERTED T) (SETQ FROM TO) (SETQ TO NIL))) (SETQ TEM (MSLISTSET FROM T)) [MAPC TEM (FUNCTION (LAMBDA (X) (PUTHASH X 0 SEEN] (* 0 means yes expand, not expanded  yet) [MAPC TEM (FUNCTION (LAMBDA (X) (MSPATHS4 X TOPFLG] (RETURN SEEN]) (MSPATHS4 [LAMBDA (FROM TOP) (* lmm "25-JUN-78 01:10") (* traces paths from FROM. When done, the SEEN array will contain MSBLIP or  NIL for entries not expanded, 0 for entries which should be expanded but  weren't for some reason (probably a bug)%, 1 for entries which were below the "top"  and T for entries which were above the top only) (PROG (TEM) (COND ((MSPATHS2 FROM) (COND ((EQ (SETQ TEM (GETHASH FROM SEEN)) 0) (PUTHASH FROM (COND (TOP T) (T 1)) SEEN) (for Y in (COND (INVERTED (GETRELQ CALL FROM T)) (T (GETRELQ CALL FROM))) do (MSPATHS4 Y))) ((AND (EQ TEM T) (NOT TOP)) (PUTHASH FROM 1 SEEN]) (DASHES [LAMBDA (MARKER) (* lmm "21-JAN-79 14:28") (TERPRI) (FRPTQ (IDIFFERENCE LL 20) (PRIN1 '-)) (PRIN1 (COND ((LISTP MARKER) (* OR (EQMEMB (QUOTE NOLINE)  PRINTOPTIONS)) (PRIN1 "------------ ") (OR (CAR MARKER) '"")) (T (PRIN1 "--- overflow - ") MARKER]) (DOTABS [LAMBDA (LST) (* lmm%: 19 MAY 75 146) (COND ((NULL LST) NIL) (T (DOTABS (CDR LST)) (TAB (CAR LST) 0) (PRIN1 "|"]) (BELOWMARKER [LAMBDA NIL (* lmm "22-JUN-78 00:15") (* lmm%: 26 MAY 75 1751) (PROG1 [COND ((ILESSP BELOWCNT 26) (FCHARACTER (IPLUS 97 BELOWCNT))) (T (PACK* (FCHARACTER (IPLUS 97 (IREMAINDER BELOWCNT 26))) (IQUOTIENT BELOWCNT 26] (SETQ BELOWCNT (ADD1 BELOWCNT]) (MSPATHSPRINTFN [LAMBDA (FN) (* lmm "16-MAY-78 02:27") (AND MARKING (MSMEMBSET FN MARKING) (PRIN1 ">")) (PRIN2 FN) (ADD1 (POSITION]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSPATHSBLOCK (ENTRIES MSPATHS MSONPATH MSPATHS2) MSPATHS MSPATHS1 MSPATHS2 MSONPATH MSPATHS4 DASHES DOTABS BELOWMARKER MSPATHSPRINTFN (LOCALFREEVARS TABS NAMED LINENUM LL BELOWCNT MARKING SEEN INVERTED TO NOTRACE AVOIDING SEPARATE) (GLOBALVARS MSBLIP MSCRATCHASH) (NOLINKFNS . T)) ) (DEFINEQ (MSFIND [LAMBDA (IN X) (* lmm "24-JAN-79 15:16") (OR (EQ IN X) (AND (LISTP IN) (OR (MSFIND (CAR IN) X) (MSFIND (CDR IN) X]) (MSEDITF [LAMBDA ARGCOUNT (* ; "Edited 31-May-88 17:58 by jrb:") (LET [(FNAME (ARG ARGCOUNT 1)) (FEDITCOMS (for X from 2 to ARGCOUNT collect (ARG ARGCOUNT X] (for FPTYPE in MSFNTYPES bind FPNAME when (HASDEF FNAME (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE))) do (if (EQ FPTYPE 'FNS) then (APPLY 'EDITF (CONS FNAME FEDITCOMS)) else (EDITE (GETDEF FNAME FPNAME NIL '(NOERROR NOCOPY EDIT)) FEDITCOMS FNAME FPNAME)) (RETURN FNAME]) (MSEDITE [LAMBDA ARGCOUNT (* ; "Edited 24-Oct-2018 16:25 by rmk:") (* ;  "Edited 22-Jun-93 12:14 by sybalsky:mv:envos") (* ;; "Edit something, NAME is arg 1, DEF-TO-EDIT is arg 2, FPTYPE is arg 3, TTYCOMS is args 4-n. Used when we have to fetch the definition above MSEDITF, e.g. for finding SHOW WHERE places, and it's a definer that copies when you getdef it.") (LET [(FNAME (ARG ARGCOUNT 1)) (FNDEF (ARG ARGCOUNT 2)) (FPTYPE (OR (ARG ARGCOUNT 3) 'FNS)) FPNAME (FEDITCOMS (for X from 4 to ARGCOUNT collect (ARG ARGCOUNT X] (SETQ FPNAME (ffetch (MSANALYZABLE FILEPKGNAME) of FPTYPE)) (COND ((EQ FPTYPE 'FNS) (APPLY 'EDITF (CONS FNAME FEDITCOMS))) (T (EDITE FNDEF FEDITCOMS FNAME FPNAME))) FPNAME]) (EDITGETDEF [LAMBDA (NAME TYPE) (* ;  "Edited 23-Jun-93 10:24 by sybalsky:mv:envos") (* ;; "This is meant to encapsulate the notion of asking the active editor, %"Are you editing the definition for this object? If so, give me the true definition you're editing%". Called from MSGETDEF to get the REALDEF for an object to be EDIT WHERE'd, so the editor == command works right.") (AND (EQ (EDITMODE) 'SEDIT:SEDIT) (bind SEDIT::WINDOW for SEDIT::CONTEXT in SEDIT::CONTEXTS when (AND NAME (CL:EQUAL NAME (fetch SEDIT::ICON-TITLE of SEDIT::CONTEXT)) (EQ TYPE (fetch SEDIT::EDIT-TYPE of SEDIT::CONTEXT))) do (* ;; "we found a context that matches, return it.") (RETURN (fetch CL:STRUCTURE of (SEDIT::SUBNODE 1 (fetch SEDIT::ROOT of SEDIT::CONTEXT]) ) (RPAQQ MSBLIP "sysout and inform Masinter@PARC") (* ;; "List of (FILEPKGTYPE FILEPKGTYPE GETDEF-fn MARKASCHANGED-fn) for types that Masterscope knows how to analyze. LOOPSMS, for example, adds LOOPS constructs to this lists using MSADDANALYZE." ) (RPAQ? MSFNTYPES '((FNS FNS GETDEF))) (* ; "SCRATCHASH") (RPAQ? MSCRATCHASH ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS SCRATCHASH MACRO [(ARRAYNAME . FORMS) ([LAMBDA (ARRAYNAME) (SETQ MSCRATCHASH) (PROG1 (PROGN . FORMS) (SETQ MSCRATCHASH ARRAYNAME] (COND (MSCRATCHASH (CLRHASH MSCRATCHASH) MSCRATCHASH) (T (HASHARRAY 20 (FUNCTION MSREHASH]) ) ) (* ; "marking changed") (DEFINEQ (MSMARKCHANGED [LAMBDA (NAME TYPE REASON) (* ; "Edited 8-Apr-88 10:17 by jrb:") (* ;; "Called from inside MARKASCHANGED") (* ;; "JRB - Some things need to be MARKASCHANGED strangely (FUNCTIONS that are actually DEFMACROS need to have CHANGEMACRO called, but not MSMARKCHANGE1, for instance). If there is a function in the MARKCHANGED-FN slot of the appropriate MSANALYZABLE record, and it returns non-NIL, MSMARKCHANGE1 gets called.") (AND MSDATABASELST (LET (ATYPEREC MSMCFN) (if (OR (NULL TYPE) (SETQ ATYPEREC (ASSOC TYPE MSFNTYPES))) then (COND ((EQ REASON 'DELETED) (MSERASE (LIST NAME))) ((OR (NOT (SETQ MSMCFN (fetch (MSANALYZABLE MARKCHANGED-FN) ATYPEREC))) (APPLY* MSMCFN NAME TYPE REASON)) (MSMARKCHANGE1 NAME 0))) (SELECTQ TYPE ((VARS VARIABLES T) (CHANGEVAR NAME TYPE REASON)) (MACROS (CHANGEMACRO NAME TYPE REASON)) (I.S.OPRS (CHANGEI.S. NAME TYPE REASON)) NIL]) (CHANGEMACRO [LAMBDA (NAME TYPE REASON) (* ; "Edited 3-Jun-88 12:17 by jrb:") (* ;; "We don't do anything if the item is being defined. This is a heuristic that compensates for the fact that a database can be loaded from a file before the definitions that it knows about come in. We don't want a subsequent LOADFROM of a file to generate all sorts of probably spurious messages.") (AND MSDATABASELST (NEQ REASON 'DEFINED) (MSNEEDUNSAVE (GETRELATION NAME '(CALL DIRECTLY) T) (FILEPKGTYPE TYPE 'DESCRIPTION) (EQ (GETTEMPLATE NAME T) 'MACRO]) (CHANGEVAR [LAMBDA (NAME TYPE REASON) (* rmk%: "19-FEB-81 15:22") (DECLARE (GLOBALVARS COMPILE.TIME.CONSTANTS)) (AND MSDATABASELST (FMEMB NAME COMPILE.TIME.CONSTANTS) (MSNEEDUNSAVE (GETRELATION NAME '(USE FREELY) T) "constants"]) (CHANGEI.S. [LAMBDA (NAME TYPE REASON) (* ; "Edited 3-Jun-88 12:18 by jrb:") (AND MSDATABASELST (SELECTQ REASON (DEFINED (* ;; "If it has a function definition, then defining it as an i.s.opr has no effect (at least for interpreted code)") (AND (NOT (GETD NAME)) (MSNEEDUNSAVE (GETRELATION NAME '(CALL DIRECTLY) T) '(i.s.oprs as functions) T))) ((CHANGED DELETED) (MSNEEDUNSAVE (UNION (GETRELATION NAME '(USE I.S.OPRS) T) (AND (U-CASEP NAME) (GETRELATION (L-CASE NAME) '(USE I.S.OPRS) T))) "i.s. oprs" T)) NIL]) (CHANGERECORD [LAMBDA (RNAME RFIELDS OLDFLG) (* ; "Edited 3-Jun-88 12:12 by jrb:") (AND MSDATABASELST OLDFLG (MSNEEDUNSAVE (PROG ((FNLIST (GETRELATION RNAME '(USE RECORDS) T))) (for F in RFIELDS do (SETQ FNLIST (UNION (GETRELATION F '(USE FIELDS) T) FNLIST))) (RETURN FNLIST)) "records" MSRECORDTRANFLG]) (MSNEEDUNSAVE [LAMBDA (FNS MSG MARKCHANGEFLG) (* rmk%: "22-MAY-81 13:23") (AND MARKCHANGEFLG (MSMARKCHANGE1 FNS)) (COND ((AND CHECKUNSAVEFLG (SETQ FNS (for FN inside FNS when (NOT (OR (EXPRP (OR (GETP FN 'BROKEN) (GETP FN 'ADVISED) FN)) (FMEMB FN MSNEEDUNSAVE))) collect FN))) (COND ((EQ CHECKUNSAVEFLG '!) (UNSAVEFNS FNS)) (T (printout T "The functions " .PARA2 0 0 FNS " use " MSG " which have changed." T "Call UNSAVEFNS() to load and/or UNSAVEDEF them." T) (/SETATOMVAL 'MSNEEDUNSAVE (NCONC FNS MSNEEDUNSAVE]) (UNSAVEFNS [LAMBDA (FNS) (* ; "Edited 3-Jun-88 12:24 by jrb:") (OR FNS (SETQ FNS (APPEND MSNEEDUNSAVE))) (for FN in FNS when FN bind FNTYPE do [SETQ FNTYPE (for FNREC in MSFNTYPES when (HASDEF FN (fetch (MSANALYZABLE FILEPKGNAME) FNREC) '? '(NOERROR)) do (RETURN (fetch (MSANALYZABLE FILEPKGNAME) FNREC] [OR (EXPRP (OR (GETP FN 'BROKEN) (GETP FN 'ADVISED) FN)) (PROG NIL (COND ((FGETD FN) (VIRGINFN FN T) (SAVEDEF FN))) (SELECTQ RECOMPILEDEFAULT (CHANGES (* don't mark as changed) (RESETVARS (MSDATABASELST) (* ASSERT%: ((REMOTE CALL)  MSMARKCHANGED)) (MARKASCHANGED FN FNTYPE))) (EXPRS (for FL in (WHEREIS FN FNTYPE FILELST) unless [OR (FMEMB FL NOTCOMPILEDFILES) (CDR (GETP FL 'FILE] do (/SETATOMVAL 'NOTCOMPILEDFILES (CONS FL NOTCOMPILEDFILES) ))) NIL) (COND ((HASDEF FN FNTYPE 'SAVED) (PRINTOUT T "unsaving " FN T) (UNSAVEDEF FN FNTYPE)) (T (PRINTOUT T "loading " FN T) (LOADDEF FN FNTYPE '?] (/SETATOMVAL 'MSNEEDUNSAVE (REMOVE FN MSNEEDUNSAVE))) (AND FNS (EQ RECOMPILEDEFAULT 'CHANGES) (printout T "WARNING: you must set RECOMPILEDEFAULT to EXPRS in order to have these functions recompiled automatically" T]) ) (ADDTOVAR COMPILE.TIME.CONSTANTS ) (RPAQQ RECORDCHANGEFN CHANGERECORD) (RPAQ? CHECKUNSAVEFLG T) (RPAQ? MSNEEDUNSAVE ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS GETWORDTYPE MACRO [(WORD TYPE) (CDR (FASSOC TYPE (GETHASH WORD MSWORDS]) ) ) (* ; "interactive routines") (RPAQ MASTERSCOPEDATE "24-Oct-20") (ADDTOVAR HISTORYCOMS %.) (DEFINEQ (%. [NLAMBDA MASTERSCOPECOMMAND (* lmm "16-MAY-78 01:07") (MASTERSCOPE MASTERSCOPECOMMAND]) (MASTERSCOPE [LAMBDA (MASTERSCOPECOMMAND TOPFLG) (* ; "Edited 5-Dec-86 06:08 by lmm") (* ;; "Top level entry. If given a sentence, parse it and return; otherwise, enter into USEREXEC-like loop") (COND (MASTERSCOPECOMMAND (MSINTERPRET (MKLIST MASTERSCOPECOMMAND) (NOT TOPFLG))) (T (PRINTOUT T "Type Masterscope commands to the exec using the . command, e.g." T ". WHO CALLS 'MASTERSCOPE" T]) (MASTERSCOPE1 [LAMBDA NIL (* ; "Edited 28-Jan-88 11:28 by jrb:") (* ;  "merged from smL Loops Masterscope by JRB") (printout T "Masterscope " MASTERSCOPEDATE T) (PROG (X (*PACKAGE* (CL:FIND-PACKAGE "IL"))) ERLP [ERSETQ (PROGN (PROMPTCHAR "_. " T LISPXHISTORY) (SELECTQ (SETQ X (LISPXREAD T T)) ((E _) (LISPX (LISPXREAD T T) '_)) ((OK STOP) (RETFROM (FUNCTION MASTERSCOPE1))) (LISPX X '_ NIL (FUNCTION MASTERSCOPEXEC] (GO ERLP]) (MASTERSCOPEXEC [LAMBDA (X LINE) (* ; "Edited 17-Jun-87 16:57 by jrb:") (* Called via the LISPX in  MASTERSCOPE) (* ;  "Merged from smL Loops Masterscope by JRB") (PROG (MASTERSCOPECOMMAND) (AND [OR [COND ((NULL LINE) (* Single entry on line) (OR (NOT (LITATOM X)) (OR (NEQ (EVALV X) 'NOBIND) (STRPOSL CLISPCHARRAY X] (AND (LITATOM X) (FGETD X) (LISTP LINE) (OR [COND ((NULL (CDR LINE)) (* "EDITF ] " OR SETQ  (A B) TYPE ENTRY) (OR (NULL (CAR LINE)) (LISTP (CAR LINE] (EQ (ARGTYPE X) 3] (RETURN)) (* If MASTERSCOPEXEC returns NIL, then LISPX will handle the event as a  normal typin) (SETQ MASTERSCOPECOMMAND (CONS X LINE)) (SELECTQ (CAR MASTERSCOPECOMMAND) ((OK STOP BYE ok stop) (RETFROM 'MASTERSCOPE1 NIL T)) NIL) LISPXVALUE [AND (LISTP LISPXHIST) (FRPLACA LISPXHIST (CONS '%. (CAR LISPXHIST] (* Make sure the event shows up with a %.  in it) (SETQ LISPXVALUE (MSINTERPRET MASTERSCOPECOMMAND)) (RETURN T]) ) (* ; "Interpreting commands") (DEFINEQ (MSINTERPRETSET [LAMBDA (SET OP ARG) (* ; "Edited 15-Aug-90 11:50 by jds") (* ;; "DECLARATIONS%%: (RECORDS SENTENCE MSSETPHRASE)")  (* ; "Edited 3-Jun-88 12:42 by jrb:") (PROG (TEM TYPE (REP (fetch (MSSETPHRASE REP) of SET))) START [COND [(NLISTP REP) (OR (NULL REP) (SHOULDNT (LIST REP TEM TYPE ARG))) [COND ((fetch (MSSETPHRASE TYPE) of SET) [replace (MSSETPHRASE REP) of SET with (create INRELATION HTABLES _ (for TYPE inside (fetch (MSSETPHRASE TYPE) of SET) join (GETVERBTABLES 'IS TYPE)) OSET _ (create MSSETPHRASE DET _ 'ANY] (RETURN (MSINTERPRETSET SET OP ARG] (RETURN (SELECTQ OP (CHECK ARG) (LIST MSBLIP) (HARD (LISTHARD SET)) (MEMB T) (SHOULDNT 8] (T (RETURN (SELECTQ (fetch (SENTENCE ID) of REP) (APPLY (SELECTQ OP (CHECK ARG) (HARD (LISTHARD SET)) (LIST MSBLIP) (MEMB (APPLY* (fetch (APPLY PRED) of REP) ARG)) (SHOULDNT 9))) (NOT (SELECTQ OP (CHECK (MSINTERPRETSET (fetch NEGATED of REP) 'CHECK ARG)) (HARD (LISTHARD SET)) (LIST MSBLIP) (MEMB (NOT (MSINTERPRETSET (fetch NEGATED of REP) 'MEMB ARG))) (SHOULDNT 10))) (INRELATION (SELECTQ OP (CHECK ARG) ((LIST HARD) (* ;; "got a list of dotted pairs of hash tables and another set; want to know the set of all things which have the given relation to any in the other set") (PROG ((HTABS (fetch (INRELATION HTABLES) of REP)) (INVERTED (fetch (INRELATION INVERTED) of REP)) (OTHERSET (fetch (INRELATION OSET) of REP)) V SET2VAL) (SETQ SET2VAL (MSINTERPRETSET OTHERSET 'LIST)) [COND [(EQ SET2VAL MSBLIP) (for R in HTABS do (MAPTABLE (COND (INVERTED (CDR R)) (T (CAR R))) (FUNCTION MSINTERPA] (T (for R in HTABS do (for X in SET2VAL do (SETQ V (UNION [GETTABLE X (COND (INVERTED (CAR R)) (T (CDR R] V] (RETURN V))) (MEMB [PROG ((HTABS (fetch (INRELATION HTABLES) of REP)) (OTHERSET (fetch (INRELATION OSET) of REP)) (INVERTED (fetch (INRELATION INVERTED) of REP))) (RETURN (find R in HTABS suchthat (find Z in [GETTABLE ARG (COND (INVERTED (CDR R)) (T (CAR R] suchthat (MSINTERPRETSET OTHERSET 'MEMB Z]) (SHOULDNT 11))) (GETHASH (SELECTQ OP (CHECK ARG) ((LIST HARD) (PROG (V) [for X in (fetch (GETHASH HTABLE) of REP) do (SETQ V (MSHASHLIST X V NIL (fetch (GETHASH BADMARKS) of REP] (RETURN V))) (MEMB [SOME (fetch (GETHASH HTABLE) of REP) (FUNCTION (LAMBDA (H) (AND (SETQ H (GETTABLE ARG H)) (NEQ H MSBLIP) (NOT (EQMEMB H (fetch (GETHASH BADMARKS) of REP]) (SHOULDNT 12))) (QUOTE (SELECTQ OP (CHECK (COND (ARG (SETQ NEEDUPDATE (UNION NEEDUPDATE (fetch QUOTED of REP))) NIL))) ((HARD LIST) (SETQ TYPE (OR (fetch (MSSETPHRASE TYPE) of SET) (fetch (MSSETPHRASE DEFAULTTYPE) of SET))) (COND ([AND ARG (NEQ ARG 'FILES) (NEQ TYPE 'FILES) (FMEMB (SETQ TEM (fetch QUOTED of REP)) FILELST) (COND ((EQ ARG 'KNOWN) (NOT (OR (TESTRELQ KNOWN TEM) (GETD TEM] (replace (MSSETPHRASE TYPE) of SET with (COND ((EQ ARG 'KNOWN) 'FNS) (T ARG))) (SETQ TEM (for FILE in (fetch QUOTED of REP) join (ONFILE FILE ARG))) (printout T (fetch QUOTED of REP) " => ON " (fetch QUOTED of REP) T) (replace QUOTED of (fetch (MSSETPHRASE REP) of SET) with TEM)) (T (COND ([AND (EQ TYPE 'FNS) (GETP (fetch QUOTED of REP) 'CLISPWORD) (NOT (GETD (fetch QUOTED of REP] (printout T "Warning: " (fetch QUOTED of REP) "is a CLISP word and is not treated like a function!" T))) (fetch QUOTED of REP)))) (MEMB (FMEMB ARG (fetch QUOTED of REP))) (SHOULDNT 13))) (OR (* ;; "I.e. WHO ON MYFILE OR @ EXPRP CALL X --- if either of the sets need to be KNOWN and are 'vague' then the entire world needs to be updated") (SELECTQ OP (CHECK ([LAMBDA (X) (OR (MSINTERPRETSET (fetch (CSET SET2) of REP) 'CHECK ARG) X] (MSINTERPRETSET (fetch (CSET SET1) of REP) 'CHECK ARG))) ((LIST HARD) [PROG (S1 S2) (RETURN (COND ((EQ MSBLIP (SETQ S1 (MSINTERPRETSET (fetch (CSET SET1) of REP) OP))) MSBLIP) ((EQ MSBLIP (SETQ S2 (MSINTERPRETSET (fetch (CSET SET2) of REP) OP))) (OR [EQ 'QUOTE (fetch (SENTENCE ID) of (fetch (MSSETPHRASE REP) of (fetch (CSET SET1) of REP] (replace (MSSETPHRASE REP) of (fetch (CSET SET1) of REP) with (create QUOTE QUOTED _ S1))) MSBLIP) (T (UNION S1 S2]) (MEMB (OR (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB ARG) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB ARG))) (SHOULDNT 14))) (AND (* ; "I.e. WHO ON MYFILE AND @ EXPRP CALL Z -- only if both sets are vague does the world need updating") (SELECTQ OP (CHECK ([LAMBDA (X) (OR (MSINTERPRETSET (fetch (CSET SET2) of REP) 'CHECK ARG) X] (MSINTERPRETSET (fetch (CSET SET1) of REP) 'CHECK ARG))) ((HARD LIST) [PROG (S1 S2) (RETURN (COND [[EQ MSBLIP (SETQ S1 (MSINTERPRETSET (fetch (CSET SET1) of REP) 'LIST] (COND ((EQ MSBLIP (SETQ S2 (MSINTERPRETSET (fetch (CSET SET2) of REP) OP))) MSBLIP) (T (SUBSET S2 (FUNCTION (LAMBDA (X) (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB X] (T (SUBSET S1 (FUNCTION (LAMBDA (X) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB X]) (MEMB (AND (MSINTERPRETSET (fetch (CSET SET1) of REP) 'MEMB ARG) (MSINTERPRETSET (fetch (CSET SET2) of REP) 'MEMB ARG))) (SHOULDNT 15))) (ANDNOT (replace (SENTENCE ID) of REP with 'AND) [replace (MSSETPHRASE REP) of (fetch SET2 of REP) with (create NOT NEGATED _ (create MSSETPHRASE using (fetch SET2 of REP) REP _ (fetch (MSSETPHRASE REP) of (fetch SET2 of REP] (GO RETRY)) (IN [SETQ REP (create QUOTE QUOTED _ (MKLIST (CL:EVAL (fetch (IN EXPRESSION) of REP] (GO RETRY)) (BLOCKS (* ; "Block set") (SELECTQ OP (CHECK [[LAMBDA (X Y) (OR X Y] (AND (fetch FNS of REP) (MSINTERPRETSET (fetch FNS of REP) 'CHECK)) (AND (fetch FILES of REP) (MSINTERPRETSET (fetch FILES of REP) 'CHECK]) (PROGN [SETQ REP (create QUOTE QUOTED _ (MSGETBLOCKDEC (fetch TYPES of REP) (fetch FNS of REP) (AND (fetch FILES of REP) (MSINTERPRETSET (fetch FILES of REP) 'HARD] (GO RETRY)))) (FIELDS (SELECTQ OP (CHECK (MSINTERPRETSET (fetch RECS of REP) OP)) (PROGN [SETQ REP (create QUOTE QUOTED _ (PROG (VAL) (for X in (MSLISTSET (fetch RECS of REP) T) do (SETQ VAL (UNION (RECORDFIELDNAMES X) VAL))) (RETURN VAL] (GO RETRY)))) (THAT (PROG (TABLES (MSVERB (fetch (THAT MSVERB) of REP)) VALUE (OS (fetch (THAT OTHERSET) of REP))) (SELECTQ (fetch (MSVERB ROOT) of MSVERB) ((AND OR ANDNOT) [SETQ REP (create CSET ID _ (fetch (CVERB C) of (fetch VPART of MSVERB)) SET1 _ (create MSSETPHRASE using SET REP _ (create THAT MSVERB _ (create MSVERB TENSE _ (fetch TENSE of MSVERB) VPART _ (fetch (CVERB VB1) of (fetch VPART of MSVERB))) OTHERSET _ OS)) SET2 _ (create MSSETPHRASE using SET REP _ (create THAT MSVERB _ (create MSVERB TENSE _ (fetch TENSE of MSVERB) VPART _ (fetch (CVERB VB2) of (fetch VPART of MSVERB))) OTHERSET _ OS] (GO RETRY)) (CALL (COND ((EQ (fetch (MSVERB MODIFIER) of MSVERB) 'SOMEHOW) [SETQ REP (create PATHS MSPATHOPTIONS _ (COND ((EQ (fetch TENSE of MSVERB) 'ED) (create PATHOPTIONS FROM _ OS TO _ (create MSSETPHRASE) TOPFLG _ T)) (T (create PATHOPTIONS TO _ OS TOPFLG _ T] (GO RETRY)))) (CONTAIN (COND ((EQ (fetch DET of OS) 'WHICH) (SHOULDNT 16))) (* ;; "JRB - Default types on files are now ignored - removed (|fetch| (MSSETPHRASE DEFAULTTYPE) |of| SET) from ORs below.") [SETQ REP (create QUOTE QUOTED _ (SELECTQ (fetch TENSE of MSVERB) (ED (ONFILE (MSINTERPRETSET OS 'HARD) (OR (fetch (MSVERB MODIFIER) of MSVERB) (fetch (MSSETPHRASE TYPE) of SET) 'ALL))) (ONFILE NIL (OR (fetch (MSVERB MODIFIER) of MSVERB) (fetch (MSSETPHRASE TYPE) of OS) 'ALL) (OR (MSINTERPRETSET OS 'HARD) T] (GO RETRY)) NIL) (SELECTQ OP (CHECK (SETQ VALUE (MSINTERPRETSET OS 'CHECK (fetch KNOWN of OS)))) NIL) (SETQ TABLES (GETVERBTABLES (fetch (MSVERB ROOT) of MSVERB ) (fetch (MSVERB MODIFIER) of MSVERB))) (replace REP of SET with (SETQ REP (create INRELATION INVERTED _ (EQ (fetch TENSE of MSVERB) 'ED) HTABLES _ TABLES OSET _ OS))) OUT (RETURN (OR (MSINTERPRETSET SET OP ARG) VALUE)))) (PATHS (COND ((EQ OP 'CHECK) (CHECKPATHS (fetch MSPATHOPTIONS of REP))) (T (SETQ REP (create GETHASH HTABLE _ (LIST (MSONPATH REP)) BADMARKS _ T)) (GO RETRY)))) (SHOULDNT 17] RETRY (replace REP of SET with REP) (GO START]) (MSINTERPA [LAMBDA (VAL KEY) (* DECLARATIONS%: (RECORDS SETPHRASE)) (* ; "Edited 12-Jan-87 01:20 by jds") (AND (NOT (FMEMB KEY V)) [COND ((AND (NULL (fetch (MSSETPHRASE TYPE) of OTHERSET)) (NULL (fetch REP of OTHERSET))) VAL) (T (find Z in VAL suchthat (MSINTERPRETSET OTHERSET 'MEMB Z] (SETQ V (CONS KEY V]) (MSGETBLOCKDEC [LAMBDA (TYPE FNSET FILES) (* lmm "24-FEB-79 20:50") (PROG (VAL) [for FILE inside (OR FILES FILELST) do ([for BLOCK in (FILECOMSLST FILE 'BLOCKS) when [OR (NULL FNSET) (SOME BLOCK (FUNCTION (LAMBDA (FILE) (AND (LITATOM FILE) (MSMEMBSET FILE FNSET] do ([SELECTQ TYPE ((BLKFNS BLOCK NIL) (for FILE in (CDR BLOCK) when (AND (LITATOM FILE) (NOT (FMEMB FILE VAL))) do (SETQ VAL (CONS FILE VAL)))) (for Y in BLOCK when (AND (LISTP Y) (EQMEMB (CAR Y) TYPE)) do (SETQ VAL (UNION (COND ((EQ (CADR Y) '*) (EVAL (CADDR Y))) (T (CDR Y))) VAL] (COND ((AND (EQ TYPE 'ENTRIES) (CAR BLOCK) (FMEMB (CAR BLOCK) (CDR BLOCK)) (NOT (FMEMB (CAR BLOCK) VAL))) (SETQ VAL (CONS (CAR BLOCK) VAL] (OR FNSET (SETQ VAL (UNION (FILECOMSLST FILE (SELECTQ TYPE (BLKFNS 'FNS) TYPE)) VAL] (RETURN VAL]) (LISTHARD [LAMBDA (SET) (* DECLARATIONS%: (RECORDS  MSSETPHRASE)) (* ; "Edited 12-Jan-87 00:59 by jds") (PROG (VAL) [for TYPE inside (OR (fetch (MSSETPHRASE TYPE) of SET) (fetch (MSSETPHRASE DEFAULTTYPE) of SET)) do (for TABLE in (GETVERBTABLES 'IS (COND ((AND (EQ TYPE 'FNS) (fetch (MSSETPHRASE KNOWN) of SET)) 'KNOWN) (T TYPE))) do (SETQ VAL (MSHASHLIST (CAR TABLE) VAL SET] (RETURN VAL]) (MSMEMBSET [LAMBDA (ITEM SET) (* lmm%: 25-JAN-76 2 20) (MSINTERPRETSET SET 'MEMB ITEM]) (MSLISTSET [LAMBDA (SET TRYHARD TYPE) (* lmm " 8-JUL-78 02:11") (* Interpret set as List -  return list of elements in set S, or MSBLIP if can't) (MSINTERPRETSET SET (COND (TRYHARD 'HARD) (T 'LIST)) TYPE]) (MSHASHLIST [LAMBDA (HTABLE PREVVALUE OTHERSET BADMARKS) (* lmm " 8-AUG-77 15:17") (MAPTABLE HTABLE (FUNCTION MSHASHLIST1)) PREVVALUE]) (MSHASHLIST1 [LAMBDA (VAL KEY) (* lmm " 8-AUG-77 15:16") (AND (NEQ VAL MSBLIP) (NOT (EQMEMB VAL BADMARKS)) (NOT (FMEMB KEY PREVVALUE)) (OR (NULL OTHERSET) (MSMEMBSET KEY OTHERSET)) (SETQ PREVVALUE (CONS KEY PREVVALUE]) (CHECKPATHS [LAMBDA (OPTIONS VAL) (* lmm "20-DEC-78 20:03") (PROG (VAL) (for PR in OPTIONS when (FMEMB (CAR PR) '(FROM TO AVOIDING NOTRACE MARKING SEPARATE)) do (AND (MSINTERPRETSET (CDR PR) 'CHECK (EQ (CAR PR) 'FROM)) (SETQ VAL T))) (RETURN (OR VAL (NULL (FASSOC 'FROM OPTIONS]) (ONFILE [LAMBDA (FILES TYPES FINDITEMS) (* ; "Edited 2-Jun-88 11:19 by jrb:") (* ;  "MSHASHFILE uses cause GETRELATION barfs if CONTAINS table doesn't exist.") (PROG (VAL) (* ;; "JRB - TYPES of 'ALL means gather all types Masterscope knows about") [AND (EQ TYPES 'ALL) (SETQ TYPES (for FT in MSFNTYPES collect (fetch (MSANALYZABLE FILEPKGNAME) of FT] [for FILE (FNSONLY _ (AND MSHASHFILE (SELECTQ (COND ((AND (LISTP TYPES) (NULL (CDR TYPES)) (CAR TYPES))) (T TYPES)) ((FNS KNOWN NIL) T) NIL))) inside (OR FILES FILELST) do (* ;  "Don't notice the file if we only care about FNS and the file is known to the database.") (COND [(AND FNSONLY (NOT (MEMB FILE FILELST)) (GETRELATION FILE 'CONTAINS] (T (MSNOTICEFILE FILE))) (for TYPE inside TYPES do (SETQ TYPE (SELECTQ TYPE ((FNS KNOWN NIL) 'FNS) TYPE)) (COND [FINDITEMS (OR (FMEMB FILE VAL) (AND (find X inside FINDITEMS suchthat (INFILECOMS? X TYPE (FILECOMS FILE))) (SETQ VAL (CONS FILE VAL] (T (SETQ VAL (UNION (FILECOMSLST FILE TYPE) VAL] [COND ((AND MSHASHFILE (NULL VAL) (find TYPE inside TYPES suchthat (SELECTQ TYPE ((FNS KNOWN NIL) T) NIL))) (* ;  "Didn't find it in core; perhaps the CONTAINS table knows") (COND [FILES (for FILE inside FILES do (COND (FINDITEMS (for X inside FINDITEMS when (TESTRELATION X 'CONTAINS FILE T) do (pushnew VAL FILE))) (T (SETQ VAL (UNION (GETRELATION FILE 'CONTAINS) VAL] (FINDITEMS (* ;; "No files: should use all known files, but that information isn't explicitly kept by MSHASH. Soooo, we'll only do the case where FINDITEMS is given") (for X inside FINDITEMS do (SETQ VAL (UNION (GETRELATION X 'CONTAINS T) VAL] (RETURN VAL]) ) (DEFINEQ (MSINTERPRET [LAMBDA (COMMAND SUBROUTINE) (* ; "Edited 15-Aug-90 11:54 by jds") (RESETLST [PROG (VAL EDITQUIETFLG) (SELECTQ (CAR COMMAND) ((; * -) (RETURN)) NIL) (SETQ VAL (MSPARSE COMMAND)) (COND ((EQ MSPRINTFLG T) (PRINT VAL T))) (COND ((EQ (CAR VAL) 'OUTPUT) (MSOUTPUT (CADR VAL)) (SETQ VAL (CDDR VAL)) (MAPRINT COMMAND NIL ". " " "))) (* ;; "Now to interpret") [COND ((AND (EQ (CAR VAL) 'ERASE) (NULL (CDR VAL))) (MSERASE T) (RETURN 'ok] (MSINIT) (RETURN (SELECTQ (fetch (SENTENCE ID) of VAL) (REANALYZE (* ;  "Definitly don't want to CHECKFORCHANGED before the ANALYZE is done") (* ;; "From Lanning's Loops changes for Masterscope...") (* ;;  "(MAPC (MSLISTSET (CDR VAL) T 'KNOWN) (FUNCTION (LAMBDA (X) (UPDATEFN X T)))) (CL:VALUES)") (* ;; "JRB - The MSANALYZEFNS hashtable hook is hereby flushed.") (LET* [[SETTYPE (COND ((fetch (MSSETPHRASE TYPE) of (CDR VAL))) ((fetch (MSSETPHRASE DEFAULTTYPE) of (CDR VAL] (SET (MSLISTSET (CDR VAL) T 'KNOWN] (* ;; "SETTYPE is allowed to be NIL here...") (if [AND SETTYPE (NULL (for MT in MSFNTYPES thereis (EQ SETTYPE (fetch (MSANALYZABLE SETNAME) of MT] then (PRINTOUT T "Sorry, can't analyze " SETTYPE T) (ERROR!) else (for X in SET do (UPDATEFN X T)) (CL:VALUES)))) (ANALYZE (CHECKFORCHANGED (SETQ VAL (CDR VAL))) (* ;; "From Lanning's Loops changes for Masterscope...") (* ;; "(COND ((EQ (SETQ VAL (MSLISTSET VAL NIL 'KNOWN)) MSBLIP) (|printout| T %"Sorry, can't figure out which functions you mean.%" T) (ERROR!))) (MAPC VAL (FUNCTION UPDATEFN)) (CL:VALUES)") [LET* [[SETTYPE (COND ((fetch (MSSETPHRASE TYPE) of VAL)) ((fetch (MSSETPHRASE DEFAULTTYPE) of VAL] (SET (MSLISTSET VAL T 'KNOWN] (* ;; "SETTYPE is allowed to be NIL here...") (COND ([AND SETTYPE (NULL (for MT in MSFNTYPES thereis (EQ SETTYPE (fetch (MSANALYZABLE SETNAME) of MT] (PRINTOUT T "Sorry, can't analyze " SETTYPE T) (ERROR!)) ((EQ SET MSBLIP) (PRINTOUT T "Sorry, can't figure out which items you mean. " T) (ERROR!)) (T (for X in SET do (UPDATEFN X T NIL SETTYPE)) (CL:VALUES]) ((EDIT SHOW) [PROG (DONE NEEDUPDATE UPDATEALL TYPE (EDIT (fetch (SENTENCE ID) of VAL)) REL SHOWSET (EDITCOMS (fetch OTHERSTUFF of VAL)) (SUBJECT (fetch (SENTENCE SUBJECT) of VAL)) (MSPRED (fetch (SENTENCE MSPRED) of VAL)) REP) (DECLARE (SPECVARS TYPE SHOWSET EDIT EDITCOMS DONE)) [COND ((NULL MSPRED) (* ;  "EDIT ANY CALLING FOO -- just call EDITFNS") (CHECKFORCHANGED SUBJECT) (RETURN (MAPC (MSLISTSET SUBJECT T) (FUNCTION (LAMBDA (FN) (PRIN2 FN T) (PRIN1 " : " T) (OR (NLSETQ (PRINT (APPLY 'MSEDITF (CONS FN EDITCOMS) ) T)) (PRINT "failed" T] [SETQ REL (fetch (THAT MSVERB) of (SETQ REP (fetch (MSSETPHRASE REP) of MSPRED] (SETQ SHOWSET (fetch (THAT OTHERSET) of REP)) [COND ((EQ (fetch TENSE of REL) 'ED) (replace TENSE of REL with 'S) (SETQ MSPRED (create MSSETPHRASE REP _ (create THAT MSVERB _ REL OTHERSET _ (SETQ SHOWSET (PROG1 SUBJECT (SETQ SUBJECT SHOWSET] (SETQ TYPE (VERBNOTICELIST (fetch VPART of REL))) (SETQ UPDATEALL (MSINTERPRETSET SUBJECT 'CHECK T)) [for FN in NEEDUPDATE do (COND ((GETHASH FN MSCHANGEDARRAY) (MSSHOWUSE FN TYPE SHOWSET EDIT NIL EDITCOMS) (SETQ DONE (CONS FN DONE))) (T (UPDATEFN FN] (COND (UPDATEALL [MAPHASH MSCHANGEDARRAY (FUNCTION (LAMBDA (VAL KEY) (AND (OR (EQ VAL T) (TESTRELQ KNOWN KEY) (TESTRELQ (CALL NOTERROR) KEY T)) (COND ((MSSHOWUSE KEY TYPE SHOWSET EDIT 'CHANGED EDITCOMS) (SETQ DONE (CONS KEY DONE] (MSCHECKEMPTY))) (MAPC (MSLISTSET (MSJOINSET 'AND MSPRED SUBJECT) T) (FUNCTION (LAMBDA (AT) (AND (NOT (FMEMB AT DONE)) (MSSHOWUSE AT TYPE SHOWSET EDIT NIL EDITCOMS ] (CL:VALUES)) (? [CHECKFORCHANGED (SETQ VAL (MSJOINSET 'AND (fetch MSPRED of VAL) (fetch SUBJECT of VAL] (OR SUBROUTINE (TAB 0 0)) (MSSOLVE VAL)) (PATHS (PROG ([INVERTED (for X on (CDR VAL) bind FROMFOUND do (SELECTQ (CAAR X) (FROM (SETQ FROMFOUND T)) (TO (RETURN (NOT FROMFOUND))) NIL) finally (RETURN (COND (FROMFOUND NIL) (T (FRPLACD VAL (CONS [CONS 'FROM (create MSSETPHRASE REP _ (create THAT MSVERB _ (create MSVERB ROOT _ 'IS MODIFIER _ 'KNOWN) OTHERSET _ (create MSSETPHRASE] (CDR VAL))) NIL] NEEDUPDATE UPDATEALL TEM) (SETQ UPDATEALL (CHECKPATHS (fetch MSPATHOPTIONS of VAL))) (for X in NEEDUPDATE do (UPDATEFN X)) (COND (UPDATEALL (UPDATECHANGED) (MSCHECKEMPTY))) (COND ((SETQ TEM (fetch (PATHOPTIONS OUTPUT) of (CDR VAL))) (MSOUTPUT TEM))) (AND (SETQ TEM (fetch (PATHOPTIONS LINELENGTH) of (CDR VAL))) (RESETSAVE (LINELENGTH TEM))) (* ;; "Display paths; must print all of FROM, with separate tree for all of SEPARATE (considered as a subset of FROM). Stop when you get to a function in NOTRACE, -- unless TO is NIL, only print paths that eventually reach an element of TO. If INVERTED is not NIL, print inverted tree. Do not print out functions in AVOIDING") [SETQ MSTHOSE (MSPATHS [COND (INVERTED (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of VAL))) (T (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of VAL] [COND (INVERTED (fetch (PATHOPTIONS FROM) of (fetch MSPATHOPTIONS of VAL))) (T (fetch (PATHOPTIONS TO) of (fetch MSPATHOPTIONS of VAL] INVERTED (fetch (PATHOPTIONS AVOIDING) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS SEPARATE) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS NOTRACE) of (fetch MSPATHOPTIONS of VAL)) (fetch (PATHOPTIONS MARKING) of (fetch MSPATHOPTIONS of VAL] (RETURN (CL:VALUES)))) (ERASE (* ;  "case of plain ERASE taken care of earlier") (MSERASE (MSLISTSET (CDR VAL) T 'KNOWN)) (PRIN1 "Erased." T) (CL:VALUES)) (DESCRIBE (CHECKFORCHANGED (CDR VAL) NIL T) (* ;  "Need to update the world since will print out CALLED BY:") (TAB 0 0) (MAPC (MSLISTSET (CDR VAL) T) (FUNCTION MSDESCRIBE))) (FOR (CHECKFORCHANGED (CADDDR VAL)) (FRPLACA (CDDDR VAL) (KWOTE (MSLISTSET (CADDDR VAL) T))) (EVAL VAL)) (CHECK (CHECKFORCHANGED (CDR VAL)) [MSCHECKBLOCKS (AND (CDR VAL) (MSLISTSET (CDR VAL) 'HARD 'FILES]) (SHOULDNT 18])]) (VERBNOTICELIST [LAMBDA (VPART) (* ; "Edited 12-Jun-87 16:37 by jrb:") (* ;;; " NOTE: The call to MSVBTABLES used to be a call to the macro MSVBNOTICED. The macro, however, existed only on the file MSANALYZE. Further, there was an EXPR definintion for the fn MSVBNOTICED, but BvM could find no reference to it in any file. What is going on? - smL") (COND [(type? CVERB VPART) (UNION (VERBNOTICELIST (fetch (CVERB VB1) of VPART)) (VERBNOTICELIST (fetch (CVERB VB2) of VPART] (T (OR (MSVBTABLES (fetch (VPART ROOT) of VPART) (fetch (VPART MODIFIER) of VPART)) (PROGN (printout T "can't SHOW or EDIT where things " (fetch (VPART ROOT) of VPART) %, (OR (fetch (VPART MODIFIER) of VPART) "") "!" T) (ERROR!]) (MSOUTPUT (LAMBDA (FILE) (* ; "Edited 12-Jun-90 20:43 by teruuchi") (* ;; "OUTPUT is already RESETSAVE'd") (COND ((OPENP FILE (QUOTE OUTPUT)) (OUTPUT FILE)) (T (OUTFILE FILE) (SETQ FILE (OUTPUT)) (RESETSAVE NIL (LIST (QUOTE CLOSEF) FILE)))) (* ;; "output to file, reset LINELENGTH") (LINELENGTH FILELINELENGTH)) ) (MSCHECKEMPTY [LAMBDA NIL (* lmm "20-JAN-79 14:08") (PROG (Q CF) (COND (MSDBEMPTY (printout T "No functions have been analyzed!" T) (UPDATEFILES) (SETQ CF (FILEPKGCHANGES 'FNS)) [COND ((AND [SETQ Q (APPEND (AND FILELST (LIST 'ON '%' FILELST)) (AND CF FILELST '(OR)) (AND CF (LIST 'IN '%' CF] (EQ [ASKUSER (AND (FIXP DWIMWAIT) (ITIMES 10 DWIMWAIT)) '(Y) (CONS "want to ." (SETQ Q (APPEND '(ANALYZE THE FNS) Q))) '((Y "es ") (N "o "] 'Y)) (MASTERSCOPE Q) (COND (MSDBEMPTY (printout T "Sorry, no functions were found to analyze!" T)) (T (RETURN] (ERROR!]) (CHECKFORCHANGED [LAMBDA (SET NOTTHISONE UPDATEALL) (* lmm "25-JUN-78 01:03") (PROG (NEEDUPDATE) (SETQ UPDATEALL (OR (MSINTERPRETSET SET 'CHECK (AND (NOT NOTTHISONE) (fetch KNOWN of SET))) UPDATEALL)) (for X in NEEDUPDATE do (UPDATEFN X)) (COND (UPDATEALL (UPDATECHANGED) (MSCHECKEMPTY]) (MSSOLVE [LAMBDA (SET) (* ; "Edited 15-Aug-90 11:52 by jds") (SETQ MSTHOSE (MSLISTSET SET T)) (PROG (ND QT OSET REP) (SETQ REP (fetch REP of SET)) [OR (SELECTQ (fetch (SENTENCE ID) of REP) (AND (SETQ ND (fetch SET2 of REP)) (AND (EQ [fetch (SENTENCE ID) of (SETQ REP (fetch REP of (fetch SET1 of REP] 'INRELATION) (EQ (fetch DET of (SETQ OSET (fetch (INRELATION OSET) of REP))) 'WHICH))) (INRELATION (EQ (fetch DET of (SETQ OSET (fetch (INRELATION OSET) of REP))) 'WHICH)) NIL) (RETURN (COND ((EQ (fetch (MSSETPHRASE DET) of SET) 'WHICH) (* ; "Edited by TT (29-May-1990)") (if (EQ (OUTPUT) T) then MSTHOSE else (PRINT MSTHOSE) (CL:VALUES))) (T (if (EQ (OUTPUT) T) then (NOT (NULL MSTHOSE)) else (PRINT (NOT (NULL MSTHOSE))) (CL:VALUES] (replace REP of SET with REP) (replace (INRELATION INVERTED) of REP with (NOT (fetch (INRELATION INVERTED ) of REP))) [replace (INRELATION OSET) of REP with (create MSSETPHRASE REP _ (create QUOTE QUOTED _ (SETQ QT (LIST NIL] [MAPC MSTHOSE (FUNCTION (LAMBDA (FN) (PRIN2 FN) (PRIN1 " -- ") (FRPLACA QT FN) (PRINT (SUBSET (MSLISTSET SET T) (FUNCTION (LAMBDA (X) (MSMEMBSET X OSET] (RETURN (CL:VALUES]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD GETHASH (ID HTABLE . BADMARKS) ID _ 'GETHASH) (RECORD INRELATION (ID (INVERTED . HTABLES) . OSET) ID _ 'INRELATION) (ASSOCRECORD PATHOPTIONS (TO FROM AVOIDING SEPARATE NOTRACE TOPFLG OUTPUT LINELENGTH MARKING) (* CHECKPATHS assumes that this is  an ASSOCRECORD) ) (RECORD MSANALYZABLE (FILEPKGNAME SETNAME GETDEF-FN MARKCHANGED-FN)) ) ) (FILESLOAD MSCOMMON) (DECLARE%: DONTCOPY (RPAQQ MSCOMPILETIME [[P (MAPC '(GETRELQ TESTRELQ SCRATCHASH) (FUNCTION (LAMBDA (X) (PUTHASH X 'MACRO USERTEMPLATES] (BLOCKS (NIL %. MSMARKCHANGE1 MSFIND (LOCALVARS . T)) (MSSTOREDATA MSSTOREDATA MSCOLLECTDATA (LOCALFREEVARS FNDATA) (NOLINKFNS . T)) (MASTERSCOPEBLOCK MSINTERPRETSET CHANGEI.S. CHANGERECORD CHANGEVAR CHECKFORCHANGED CHECKPATHS DUMPDATABASE DUMPDATABASE1 FMAPRINT GETRELATION GETTEMPLATE GETVERBTABLES LISTHARD MAPRELATION MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC MSCHECKEMPTY MSCLOSEFILES MSDESCRIBE MSDESCRIBE1 MSERASE MSGETBLOCKDEC MSHASHLIST MSHASHLIST1 MSINIT MSINTERPA MSINTERPRET MSLISTSET MSMARKCHANGED MSMEMBSET MSNEEDUNSAVE MSNLAMBDACHECK MSNOTICEFILE MSOUTPUT MSPRINTHELPFILE MSSHOWUSE MSSOLVE MSUPDATE MSUPDATEFN1 ONFILE PARSERELATION PARSERELATION1 READATABASE SETTEMPLATE TEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN VERBNOTICELIST ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE (ENTRIES CHANGERECORD DUMPDATABASE DUMPDATABASE1 GETRELATION GETTEMPLATE MAPRELATION MASTERSCOPE MASTERSCOPEXEC MSCLOSEFILES MSHASHLIST1 MSINTERPA MSMARKCHANGED MSMEMBSET MSLISTSET MSNEEDUNSAVE MSNOTICEFILE MSSHOWUSE PARSERELATION READATABASE SETTEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN MSLISTSET MSDESCRIBE ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (RETFNS MASTERSCOPE1) (SPECVARS ANYFOUND BADMARKS FNDATA NEEDUPDATE OTHERSET PREVVALUE SHOWFN V VARS) (NOLINKFNS . T))) (GLOBALVARS CHECKUNSAVEFLG CLISPCHARRAY CLISPIFYPRETTYFLG DWIMIFYCOMPFLG DWIMWAIT FILELINELENGTH FILELST FILERDTBL LISPXHISTORY MASTERSCOPEDATE MSBLIP MSCHANGEDARRAY MSDATABASEINIT NODUMPRELATIONS MSDBEMPTY MSERRORFN MSFILELST MSHELPFILE MSNEEDUNSAVE MSOPENFILES MSPRINTCNT MSPRINTFLG MSRECORDTRANFLG MSTEMPLATES MSTHOSE NOTCOMPILEDFILES RECOMPILEDEFAULT TABLE.TO.NOTICED USERTEMPLATES MSDATABASELST MSHASHFILE ANALYZEUSERFNS) (DECLARE%: EVAL@COMPILE (P (CLISPDEC 'FAST]) [MAPC '(GETRELQ TESTRELQ SCRATCHASH) (FUNCTION (LAMBDA (X) (PUTHASH X 'MACRO USERTEMPLATES] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: NIL %. MSMARKCHANGE1 MSFIND (LOCALVARS . T)) (BLOCK%: MSSTOREDATA MSSTOREDATA MSCOLLECTDATA (LOCALFREEVARS FNDATA) (NOLINKFNS . T)) (BLOCK%: MASTERSCOPEBLOCK MSINTERPRETSET CHANGEI.S. CHANGERECORD CHANGEVAR CHECKFORCHANGED CHECKPATHS DUMPDATABASE DUMPDATABASE1 FMAPRINT GETRELATION GETTEMPLATE GETVERBTABLES LISTHARD MAPRELATION MASTERSCOPE MASTERSCOPE1 MASTERSCOPEXEC MSCHECKEMPTY MSCLOSEFILES MSDESCRIBE MSDESCRIBE1 MSERASE MSGETBLOCKDEC MSHASHLIST MSHASHLIST1 MSINIT MSINTERPA MSINTERPRET MSLISTSET MSMARKCHANGED MSMEMBSET MSNEEDUNSAVE MSNLAMBDACHECK MSNOTICEFILE MSOUTPUT MSPRINTHELPFILE MSSHOWUSE MSSOLVE MSUPDATE MSUPDATEFN1 ONFILE PARSERELATION PARSERELATION1 READATABASE SETTEMPLATE TEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN VERBNOTICELIST ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE (ENTRIES CHANGERECORD DUMPDATABASE DUMPDATABASE1 GETRELATION GETTEMPLATE MAPRELATION MASTERSCOPE MASTERSCOPEXEC MSCLOSEFILES MSHASHLIST1 MSINTERPA MSMARKCHANGED MSMEMBSET MSLISTSET MSNEEDUNSAVE MSNOTICEFILE MSSHOWUSE PARSERELATION READATABASE SETTEMPLATE TESTRELATION UNSAVEFNS UPDATECHANGED UPDATECHANGED1 UPDATEFN MSLISTSET MSDESCRIBE ADDTEMPLATEWORD MSADDANALYZE MSADDMODIFIER MSADDRELATION MSADDTYPE) (RETFNS MASTERSCOPE1) (SPECVARS ANYFOUND BADMARKS FNDATA NEEDUPDATE OTHERSET PREVVALUE SHOWFN V VARS) (NOLINKFNS . T)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CHECKUNSAVEFLG CLISPCHARRAY CLISPIFYPRETTYFLG DWIMIFYCOMPFLG DWIMWAIT FILELINELENGTH FILELST FILERDTBL LISPXHISTORY MASTERSCOPEDATE MSBLIP MSCHANGEDARRAY MSDATABASEINIT NODUMPRELATIONS MSDBEMPTY MSERRORFN MSFILELST MSHELPFILE MSNEEDUNSAVE MSOPENFILES MSPRINTCNT MSPRINTFLG MSRECORDTRANFLG MSTEMPLATES MSTHOSE NOTCOMPILEDFILES RECOMPILEDEFAULT TABLE.TO.NOTICED USERTEMPLATES MSDATABASELST MSHASHFILE ANALYZEUSERFNS) ) (DECLARE%: EVAL@COMPILE (CLISPDEC 'FAST) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA %.) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MSEDITE MSEDITF MSEDITF) ) (PUTPROPS MASTERSCOPE COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1993 1994 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3597 20245 (UPDATEFN 3607 . 5101) (MSEDITF 5103 . 6103) (MSGETDEF 6105 . 7511) ( MSNOTICEFILE 7513 . 9906) (MSSHOWUSE 9908 . 15411) (MSUPDATEFN1 15413 . 16101) (MSUPDATE 16103 . 18529 ) (MSNLAMBDACHECK 18531 . 19413) (MSCOLLECTDATA 19415 . 20243)) (20246 21145 (UPDATECHANGED 20256 . 20619) (UPDATECHANGED1 20621 . 21143)) (21719 22142 (MSCLOSEFILES 21729 . 22140)) (22823 27255 ( MSDESCRIBE 22833 . 25621) (MSDESCRIBE1 25623 . 26686) (FMAPRINT 26688 . 27253)) (27348 27788 ( MSPRINTHELPFILE 27358 . 27786)) (27838 30938 (TEMPLATE 27848 . 29269) (GETTEMPLATE 29271 . 29406) ( SETTEMPLATE 29408 . 30936)) (31808 36732 (ADDTEMPLATEWORD 31818 . 32490) (MSADDANALYZE 32492 . 33990) (MSADDMODIFIER 33992 . 35073) (MSADDRELATION 35075 . 35822) (MSADDTYPE 35824 . 36730)) (38233 43454 ( MSMARKCHANGE1 38243 . 39037) (MSINIT 39039 . 40220) (GETVERBTABLES 40222 . 40775) (MSSTOREDATA 40777 . 42456) (STORETABLE 42458 . 43452)) (44855 49925 (PARSERELATION 44865 . 45465) (PARSERELATION1 45467 . 46922) (GETRELATION 46924 . 47953) (MAPRELATION 47955 . 49089) (TESTRELATION 49091 . 49923)) (49926 51566 (ADDHASH 49936 . 50414) (SUBHASH 50416 . 50644) (MAKEHASH 50646 . 50790) (MSREHASH 50792 . 51245) (EQMEMBHASH 51247 . 51564)) (51905 58120 (MSVBTABLES 51915 . 57694) (MSUSERVBTABLES 57696 . 58118)) (58203 60414 (BUILDGETRELQ 58213 . 59319) (BUILDTESTRELQ 59321 . 60412)) (60585 60973 (MSERASE 60595 . 60971)) (60974 64206 (DUMPDATABASE 60984 . 62321) (DUMPDATABASE1 62323 . 62668) (READATABASE 62670 . 64204)) (65288 94347 (MSCHECKBLOCKS 65298 . 69118) (MSCHECKBLOCK 69120 . 77740) ( MSCHECKFNINBLOCK 77742 . 80742) (MSCHECKBLOCKBASIC 80744 . 83164) (MSCHECKBOUNDFREE 83166 . 85065) ( GLOBALVARP 85067 . 85234) (PRINTERROR 85236 . 88452) (MSCHECKVARS1 88454 . 91407) (UNECCSPEC 91409 . 91687) (NECCSPEC 91689 . 92036) (SPECVARP 92038 . 92565) (SHORTLST 92567 . 93023) (DOERROR 93025 . 93735) (MSMSGPRINT 93737 . 94345)) (95491 110319 (MSPATHS 95501 . 98903) (MSPATHS1 98905 . 103140) ( MSPATHS2 103142 . 106552) (MSONPATH 106554 . 107782) (MSPATHS4 107784 . 108866) (DASHES 108868 . 109394) (DOTABS 109396 . 109637) (BELOWMARKER 109639 . 110102) (MSPATHSPRINTFN 110104 . 110317)) ( 110705 114129 (MSFIND 110715 . 110990) (MSEDITF 110992 . 111992) (MSEDITE 111994 . 113031) (EDITGETDEF 113033 . 114127)) (115135 123736 (MSMARKCHANGED 115145 . 116869) (CHANGEMACRO 116871 . 117576) ( CHANGEVAR 117578 . 117894) (CHANGEI.S. 117896 . 119229) (CHANGERECORD 119231 . 120102) (MSNEEDUNSAVE 120104 . 121096) (UNSAVEFNS 121098 . 123734)) (124175 127665 (%. 124185 . 124325) (MASTERSCOPE 124327 . 124853) (MASTERSCOPE1 124855 . 125723) (MASTERSCOPEXEC 125725 . 127663)) (127704 165363 ( MSINTERPRETSET 127714 . 155207) (MSINTERPA 155209 . 155743) (MSGETBLOCKDEC 155745 . 158258) (LISTHARD 158260 . 159478) (MSMEMBSET 159480 . 159625) (MSLISTSET 159627 . 159992) (MSHASHLIST 159994 . 160161) (MSHASHLIST1 160163 . 160489) (CHECKPATHS 160491 . 161131) (ONFILE 161133 . 165361)) (165364 188530 ( MSINTERPRET 165374 . 182227) (VERBNOTICELIST 182229 . 183339) (MSOUTPUT 183341 . 183658) (MSCHECKEMPTY 183660 . 184864) (CHECKFORCHANGED 184866 . 185386) (MSSOLVE 185388 . 188528))))) STOP \ No newline at end of file diff --git a/library/MATCH b/library/MATCH new file mode 100644 index 00000000..5a5b4908 --- /dev/null +++ b/library/MATCH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "12-Jun-90 10:02:15" {DSK}local>lde>lispcore>library>MATCH.;2 106667 changes to%: (VARS MATCHCOMS) previous date%: "10-Apr-84 21:34:35" {DSK}local>lde>lispcore>library>MATCH.;1) (* ; " Copyright (c) 1982, 1984, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MATCHCOMS) (RPAQQ MATCHCOMS ((FNS MAKEMATCH QMATCHSUBPAT QMATCHWM QMATCH$ QMATCH! QMATCH$= QMATCHELT1 QMATCHELT SIMPLEFN DOSIDE CHECKSETQ DOREPLACE DOREPLACE1) (FNS PATLEN $? ELT? SIMPLELT? ARB? NULLPAT? NILPAT CANMATCHNIL CANMATCHNILLIST REPLACEIN) (FNS EASYTORECOMPUTE GENSYML MAKESUBST DOSUBST DOSUBST1 SUBSTVAR BINDVAR SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH PATNARGS) (FNS QNLEFT QNOT QNULL QNOT1 QNOTLESSPLENGTH QNTH QOR QPLUS QREPLACE MKAND QCAR QCDR QEQ QEQLENGTH QEQUAL QLAST QAPPLY* QLDIFF QFOR QLISTP QNCONC) (FNS PATERR PATHELP LOOKLIST VALUELOOKUP LOOK) (FNS MKAND2 CHECKSLISTP EQUALUNCROP) (FNS PATPARSE PATPARSE1 PATUNPACKINFIX1 PARSEDEFAULT VARCHECK PATUNPACK PATUNPACKINFIX PATGETFNNAME PATGETEXPR PATPARSEAT MAKE!PAT MAKESUBPAT NEGATEPAT PACKLDIFF) (VARS PATCHARS PATTERNINFIXES PATTERNINFIXES1 PATTERNREPLACEOPRS PATTERNITEMS NEVERNILFUNCTIONS PATNONNILFUNCTIONS [PATTERNCHARRAY (MAKEBITTABLE (NCONC (MAPCAR PATCHARS 'CAAR) (MAPCAR PATTERNITEMS 'CAR] PATGENSYMVARS (PATVARDEFAULT '=) MAXCDDDDRS (PATCHECKLENGTH T) (PATLISTPCHECK (EQ 'VAX (SYSTEMTYPE))) (PATVARSMIGHTBENIL T)) (VARS PATCHARS PATTERNINFIXES PATTERNINFIXES1 PATTERNREPLACEOPRS PATTERNITEMS NEVERNILFUNCTIONS PATNONNILFUNCTIONS SIMPLE.PREDICATES [PATTERNCHARRAY (MAKEBITTABLE (NCONC (MAPCAR PATCHARS 'CAAR) (MAPCAR PATTERNITEMS 'CAR] PATGENSYMVARS) (P (OR (BOUNDP 'MATCHSTATS) (SETQ MATCHSTATS))) (VARS PATVARDEFAULT MAXCDDDDRS (PATCHECKLENGTH T) (PATLISTPCHECK NIL) (PATVARSMIGHTBENIL T)) (BLOCKS * MATCHBLOCKS))) (DEFINEQ (MAKEMATCH [LAMBDA (MATCHEXPRESSION PATTERN) (* lmm "22-NOV-82 12:08") (PROG ((LOCALDECLARATION (GETLOCALDEC EXPR FAULTFN)) %#LIST %#LISTUSED BOUNDVARS BOUNDVALS CHECKLENGTH LISTPCHECK VARDEFAULT PATVARSNIL (GENSYMVARLIST PATGENSYMVARS) CONSTRUCT POSTPONEDRPLACS POSTPONEDSETQS (LASTEFFECTCANBENIL T) MUSTRETURN WMLST WATCHPOSTPONELST SUBLIST PAT MATCHEFFECTS VAR X INASOME) (* POSTPONEDSETQS and POSTPONEDRPLACS are used to collect postponed side  effects -  LASTEFFECTCANBENIL is a flag which should be set whenever a SETQ is postponed  for determining whether the extra T at the end is necessary -  BOUNDVARS and BOUNDVALS will be list of bindings that need to be done -  MUSTRETURN will be the * expression, if any) (* CHECKINGLENGTH is the flag whether the length should be checked  (used for example in (-- %'A & &) already done the NLEFT which implicitly  checks) -  -  INASOME is a stack, car of which is a that says that we are, at this level,  after a -- type pattern, so that if another --  is encountered, just reset INASOME to the match expression for what comes after  the second --; this is so (-- A -- B --) will generate  (MEMB %'B (MEMB %'A X)) instead of (SOME X  (F/L (Z) (Z%:1='A AND %'B MEMB |Z::1|))) -  WMLST is a stack used by *GLITCH for remembering when a !  (SUBPAT --) is encountered to expand it, but remember the tail after the  !SUBPAT and return (by RPLAC'ing into the corresponding entry in WMLIST) the  expression for "WHAT MATCHED" -  SUBLIST is the list where substitutions in the final pattern are collected) (* WATCHPOSTPONELST is a list of those vars which, when a POSTPONE involving  them is encountered, the corresponding entry in WATCHPOSTPONELST should be  rplac'ed ; used to tell whether SOME variables should be local or global) (SETQ CHECKLENGTH (VALUELOOKUP 'PATCHECKLENGTH)) (SETQ LISTPCHECK (VALUELOOKUP 'PATLISTPCHECK)) (SETQ VARDEFAULT (VALUELOOKUP 'PATVARDEFAULT)) (SETQ PATVARSNIL (VALUELOOKUP 'PATVARSMIGHTBENIL)) (* Look up global variables,  checking the local declaration) (SETQ CLISPCHANGE T) (* Tell DWIM that if the match fails not to try to parse it as CLISP) [COND (PATTERN (* Old way of calling MAKEMATCH) (SETQ MATCHEXPRESSION (LIST 'match MATCHEXPRESSION 'with PATTERN] (SELECTQ (CAR MATCHEXPRESSION) ((match MATCH) (DWIMIFY0? (CDR MATCHEXPRESSION) MATCHEXPRESSION (CDR MATCHEXPRESSION) T T FAULTFN) [SELECTQ (CADDR MATCHEXPRESSION) ((with WITH)) (COND ((FIXSPELL (CADDR MATCHEXPRESSION) 70 '(WITH) T (CDDR MATCHEXPRESSION))) ((AND (LISTP (CADDR MATCHEXPRESSION)) (FIXSPELL1 (CADDR MATCHEXPRESSION) (CONS 'with (CADDR MATCHEXPRESSION)) NIL T)) (/ATTACH 'with (CDDR MATCHEXPRESSION))) (T (PATERR 'NOWITH (CDDR MATCHEXPRESSION] [SELECTQ (CAR (CDDDDR MATCHEXPRESSION)) ((NIL -> =>)) (PATERR "Expression after pattern not preceded by => or ->" (CAR (CDDDDR MATCHEXPRESSION]) (HELP "Bad arg to MAKEMATCH")) (* Make sure expression is in right  form) [SETQ PAT (PROG ((TOPPAT (CADDDR MATCHEXPRESSION))) (RETURN (PATPARSE TOPPAT] (* Parse the pattern into internal  format) [SETQ CONSTRUCT (AND (CDDDDR MATCHEXPRESSION) (PROG ((VARS (APPEND %#LIST VARS))) (DWIMIFY0? (CDR (CDDDDR MATCHEXPRESSION)) MATCHEXPRESSION T NIL NIL FAULTFN) (RETURN (CDR (CDDDDR MATCHEXPRESSION] (* Get any expression after => or ->) [SETQ VAR (COND ((EASYTORECOMPUTE (CADR MATCHEXPRESSION)) (CADR MATCHEXPRESSION)) (T (SUBSTVAR (CADR MATCHEXPRESSION] (SETQ X (QMATCHSUBPAT VAR PAT)) (SETQ SUBLIST (DREVERSE SUBLIST)) [AND CONSTRUCT (EQ (CAR (CDDDDR MATCHEXPRESSION)) '->) (SETQ CONSTRUCT (LIST (LIST 'TOPREPLACE VAR (MKPROGN CONSTRUCT] [SETQ MATCHEFFECTS (NCONC (DREVERSE POSTPONEDSETQS) (DREVERSE POSTPONEDRPLACS) (COND (CONSTRUCT) (MUSTRETURN (LIST MUSTRETURN)) ((AND LASTEFFECTCANBENIL (NULL POSTPONEDRPLACS)) (LIST T] [SETQ X (DOSUBST (COND [MATCHEFFECTS `(COND (%, X %,@ MATCHEFFECTS] (T X] (RETURN (COND (BOUNDVARS `([LAMBDA %, BOUNDVARS %, X] %,@ BOUNDVALS)) (T X]) (QMATCHSUBPAT [LAMBDA (VAR PATELT NOLISTPCHECK) (* lmm "10-AUG-78 15:47") (PROG ((CHECKINGLENGTH T) (INASOME (CONS NIL INASOME))) (* Rebind INASOME since this is on a  different level; also CHECKINGLENGTH) (RETURN (COND ((AND LISTPCHECK (NOT NOLISTPCHECK)) (MKAND (QLISTP VAR) (QMATCHWM VAR PATELT))) (T (QMATCHWM VAR PATELT]) (QMATCHWM [LAMBDA (VAR PAT FN) (* lmm "10-AUG-78 15:47") (* Creates an expression which will return non-NIL if and only if the value of  the VAR expression will match the parsed pattern PAT, and the expression  generated by applying DOSIDE to (the expression giving What-Matched the first  pattern element of PAT) and FN if FN is non-NIL -  is non-nil as well.) (PROG (TEM1 TEM2) [COND ((NULL PAT) (RETURN (OR (NOT CHECKLENGTH) (NOT CHECKINGLENGTH) (QNULL VAR] [COND ((NLISTP (CAR PAT)) (* The only NLISTP patterns are &,  $, --, NIL, T, strings and numbers) (RETURN (SELECTQ (CAR PAT) (($ --) (QMATCH$ VAR PAT FN)) (QMATCHELT1 VAR PAT FN] (SELECTQ (CAAR PAT) ((= == %' SUBPAT ~ *ANY*) (* For now, ~'s can only refer to = == %' and subpats %, i.e.  elementary patterns) (RETURN (QMATCHELT1 VAR PAT FN))) (! (RETURN (QMATCH! VAR PAT FN))) ($= (RETURN (QMATCH$= VAR PAT FN))) (@ (COND [(ELT? (CDDAR PAT)) (COND [(AND (OR (NEQ (CAR INASOME) 'FASTINASOME) (NEQ (CDDAR PAT) '&)) (SIMPLEFN (CADAR PAT))) (* Put simple tests first %, unless it is just &@SIMPLEFN, in which case we  want to go thru QMATCHELT1 so that the FASTINASOME will catch the &@FN;  for example, in ($ &@LISTP %' A $) find a list and look for A after it, rather  than find a list followed by A) (RETURN (MKAND (QAPPLY* (CADAR PAT) (QCAR VAR)) (QMATCHWM VAR (CONS (CDDAR PAT) (CDR PAT)) FN] (T (RETURN (QMATCHELT1 VAR PAT FN] [(CDR PAT) (* SEGMENT@FN followed by something) (COND [(AND (NULL FN) ($? (CDDAR PAT)) (ARB? (CADR PAT) T)) (* $@FN followed by $ or $@) [SETQ TEM1 (QFOR 'OLD (SETQ TEM1 (GENSYML)) VAR (MKAND (QAPPLY* (CADAR PAT) (QLDIFF VAR TEM1)) (QMATCHWM TEM1 (CDR PAT))) T (CANMATCHNILLIST (CDR PAT] (COND ((CAR INASOME) (FRPLACA INASOME TEM1) (RETURN T)) (T (RETURN TEM1] (T (* segment@FN followed by more pattern -  cannot assume that the INASOME check is legit since  ($ (%' A $ %' B) @FOO $) check the B MUST repeatedly be checked for) (RETURN (PROG ((INASOME (CONS NIL INASOME))) (RETURN (QMATCHWM VAR [LIST (CDDAR PAT) (CONS '@ (CONS (QAPPLY* (CADAR PAT) (QLDIFF VAR '@)) (MAKE!PAT (MAKESUBPAT (CDR PAT] FN] (T (GO OTHER)))) (GO OTHER)) OTHER (RETURN (QMATCHWM VAR (CONS (CDDAR PAT) (CDR PAT)) (CONS (CAR PAT) FN]) (QMATCH$ [LAMBDA (VAR PAT FN) (* lmm "10-AUG-78 15:47") (PROG (TEM1 TEM2 ZLENFLG (SKIPEDLEN 0) TAIL) (RETURN (COND ((NULL (CDR PAT)) (* Pattern ends in $ -  What matched is the whole thing) (DOSIDE FN VAR)) ((CAR INASOME) (* We are within a tail which began with --  or $; thus, we should not return the match here but instead, smash car of  INASOME to the match expression here and return T -  since there is no point in checking this match expression repeatedly) (COND ((LISTP (CAR INASOME)) (PATHELP "INASOME mismatch"))) [DOWATCH (FRPLACA INASOME (PROG ((INASOME (CONS NIL INASOME))) (RETURN (QMATCHWM VAR PAT FN] (* Want to check for postponed variables -  Now just return T, and let the call that rebound INASOME pick up the expression) T) ((ARB? (CADR PAT)) (PATERR "Two $ or -- patterns in a row, ambiguous") (* Must mean the second is LAST) ) [[AND (NULL FN) (PROGN [SETQ TAIL (SOME (CDR PAT) (FUNCTION (LAMBDA (ELT) (COND ((EQ ELT '&) (SETQ SKIPEDLEN (QPLUS 1 SKIPEDLEN)) NIL) ((EQ (CAR ELT) '$=) (SETQ SKIPEDLEN (QPLUS SKIPEDLEN (CDR ELT))) NIL) (T] (* Returns to the first TAIL of PAT which doesn't begin with a $i or a $$foo -  Sets the variable "LEN" to the total length of things skipped over) (NOT (ZEROP SKIPEDLEN] (* Special check here, since might  have (|...| -- $4) or not need any  QNLEFT's) (COND ((OR (NULL TAIL) (NULLPAT? TAIL)) (QNOTLESSPLENGTH VAR SKIPEDLEN)) ((NUMBERP SKIPEDLEN) (* Change ($ $4 |...|) to  ($4 $ |...|)) (QMATCHWM (QNTH VAR (ADD1 SKIPEDLEN)) (CONS (CAR PAT) TAIL))) (T (* same here; only the NTH  expression is NOT to be substituted) (QMATCHWM [QCDR (QCDR (SETQ TEM1 (SUBSTVAR (QNTH VAR SKIPEDLEN ] (CONS (CAR PAT) TAIL] [[NILPAT (SETQ TAIL (SOME (CDR PAT) (FUNCTION (LAMBDA (ELT TEM) (COND ((NULL (SETQ TEM (PATLEN ELT))) T) ((ZEROP TEM) (SETQ ZLENFLG T) NIL) (T (SETQ SKIPEDLEN (QPLUS SKIPEDLEN TEM)) NIL] (* Scans PAT until a pattern element which matches an arbitrary length segment  is hit -  Adds the length skipped to the variable SKIPEDLEN;  and sets ZLENFLG if finds any of zero length) (* Skipping over any arbitrary  patterns (though might have setqs in  them) check if ends in NIL) (PROG (CHECKINGLENGTH) (* If pat ends in (|...| -- & & &) then just match  (NLEFT var 3) against & & &; CHECKINGLENGTH = NIL will keep a  (NULL (CDDDR x)) check away) [SETQ TEM1 (COND [[OR (ZEROP SKIPEDLEN) (AND (EQ (CAR (LISTP VAR)) 'CDR) (NOT (ELT? (CADR PAT))) (REPLACEIN (CADR PAT] (* Check |var::-skipedlen|) (QCDR (SUBSTVAR (QNLEFT (COND ((EQ (CAR (LISTP VAR)) 'CDR) (CADR VAR)) (T VAR)) (QPLUS SKIPEDLEN 1) NIL ZLENFLG] (T (SUBSTVAR (QNLEFT VAR SKIPEDLEN NIL ZLENFLG] (RETURN (MKAND (OR (NOT (CANMATCHNILLIST (CDR PAT))) TEM1) (MKAND (QMATCHWM TEM1 (CDR PAT)) (OR (NULL FN) (DOSIDE FN (QLDIFF VAR TEM1] [[AND (NULL FN) (EQ TAIL (CDDR PAT)) (EQ SKIPEDLEN 1) (NULLPAT? TAIL) (EQ (CAADR PAT) 'SUBPAT) (OR (EQ (CAR PAT) '$) (EVERY (CDDR (CADR PAT)) (FUNCTION ARB?))) [COND [(NLISTP (CADR (CADR PAT))) (NOT (FMEMB (CADR (CADR PAT)) '(& $ --] (T (FMEMB (CAR (CADR (CADR PAT))) '(= == %'] (FMEMB [CAR (SETQ TEM1 (QMATCHELT 'DUMMY (CADR (CADR PAT] '(EQ EQUAL EQP STREQUAL] (* PAT%: (-- (SUBPAT EQTYPE? ARB?)  --)) (PROG [TEM2 (VAR (LIST (SELECTQ (CAR TEM1) (EQ (LOOK 'ASSOC VAR)) 'SASSOC) (CADDR TEM1) VAR)) (PAT (CONS '& (CDDR (CADR PAT] (RETURN (QMATCHSUBPAT (SUBSTVAR VAR) PAT T] (T (PROG ({OLD} {FINALLY}EXPR {UNTIL}EXPR {ON}VAR [INASOME (FRPLACA INASOME (COND ((CAR INASOME) (PATHELP "INASOME mismatch")) ((EQ (CAR PAT) '$) 'FASTINASOME) (T 'INASOME] (WATCHPOSTPONELST (CONS (SETQ TEM1 (GENSYML)) WATCHPOSTPONELST))) (* WATCHPOSTPONELST is reset so that postponed uses of it can be detected;  needed to set {OLD}) (COND ((AND (EQ (CAR (LISTP VAR)) 'CDR) [for X in (CDR PAT) do (COND ((ELT? X) (RETURN)) ((REPLACEIN X) (RETURN T] (SETQ {ON}VAR (CADR VAR))) (SETQ TEM2 (QCDR TEM1))) (T (SETQ {ON}VAR VAR) (SETQ TEM2 TEM1))) (SETQ {UNTIL}EXPR (QMATCHWM TEM2 (CDR PAT))) [SETQ {FINALLY}EXPR (COND [(EQ {UNTIL}EXPR T) (SELECTQ (CAR INASOME) ((INASOME FASTINASOME NIL) (PATHELP "bad pattern tail")) (PROGN (SETQ {UNTIL}EXPR (CAR INASOME)) (OR (NULL FN) (DOSIDE FN (QLDIFF VAR TEM2] (T (MKAND (DOSIDE FN (QLDIFF VAR TEM2)) (OR [NEQ (FMEMB (CAR INASOME) '(INASOME FASTINASOME NIL] (CAR INASOME] (SETQ {OLD} (EQ (CAR WATCHPOSTPONELST) 'FOUND)) (RETURN (QFOR {OLD} TEM1 {ON}VAR {UNTIL}EXPR {FINALLY}EXPR (CANMATCHNILLIST (CDR PAT]) (QMATCH! [LAMBDA (VAR PAT FN) (* lmm "10-AUG-78 15:47") (PROG (TEM1) (RETURN (COND ((NILPAT (CDR PAT)) (MKAND [COND ((EQ (CADAR PAT) 'SUBPAT) (* This isn't really a subpat and so  don't rebind CHECKINGLENGTH etc as  in QMATCHSUBPAT) (QMATCHWM VAR (CDDAR PAT))) (T (QMATCHELT VAR (CDAR PAT] (DOSIDE FN VAR))) ((NLISTP (CAR PAT)) (PATERR "Invalid '!'" PAT)) (T (SELECTQ (CADAR PAT) (= (* != X -  Go down VAR and X simultaneously,  looking for EQUAL subelements) [PROG ((TEMVAR (BINDVAR (GENSYML))) (TAILVAR (BINDVAR (GENSYML))) AFTEREXP) [SETQ AFTEREXP (MKAND (DOSIDE FN (QLDIFF VAR TAILVAR)) (QMATCHWM TAILVAR (CDR PAT] (RETURN (SUBPAIR '(TAILVAR VAR TEMVAR ONVAR FINALLY) [LIST TAILVAR VAR TEMVAR (CDDAR PAT) (COND [(EQ AFTEREXP T) (QOR (LIST (QNULL TEMVAR) (QEQUAL TEMVAR TAILVAR] ((NOT (CANMATCHNILLIST (CDR PAT))) (MKAND (QNULL TEMVAR) AFTEREXP)) (T (MKAND (QOR (LIST (QNULL TEMVAR) (QEQUAL TEMVAR TAILVAR))) AFTEREXP] '(PROG NIL (SETQ TEMVAR ONVAR) (SETQ TAILVAR VAR) $$LP (COND ((NLISTP TEMVAR) (RETURN FINALLY)) ([OR (NLISTP TAILVAR) (NOT (EQUAL (CAR TEMVAR) (CAR TAILVAR] (RETURN))) (SETQ TAILVAR (CDR TAILVAR)) (SETQ TEMVAR (CDR TEMVAR)) (GO $$LP]) (== [COND [(NULLPAT? (CDR PAT)) (PROG ((CHECKLENGTH T)) (RETURN (QMATCHWM VAR (LIST (CAR PAT)) FN] (T (PATERR '!AT (CDAR PAT]) (%' (COND [[OR (NLISTP (CDDAR PAT)) (CDR (LAST (CDDAR PAT] (COND [(NULLPAT? (CDR PAT)) (PROG ((CHECKLENGTH T)) (RETURN (QMATCHWM VAR (LIST (CAR PAT)) FN] (T (PATERR '!AT (CDAR PAT] (T (QMATCHWM VAR (CONS [CONS '! (CONS 'SUBPAT (MAPCAR (CDDAR PAT) (FUNCTION (LAMBDA (X) (CONS '%' X] (CDR PAT)) FN)))) (SUBPAT (* Use the *GLITCH kludge to get the  whatmatched of the rest of the thing) [COND [(NULL FN) (QMATCHWM VAR (APPEND (CDDAR PAT) (CDR PAT] (T (PROG ((WMLST (CONS NIL WMLST))) (RETURN (MKAND [QMATCHWM VAR (APPEND (CDDAR PAT) (LIST (CONS '*GLITCH (CONS WMLST (MAKE!PAT (MAKESUBPAT (CDR PAT] (DOSIDE FN (QLDIFF VAR (CAR WMLST]) (PATERR "Invalid use of ! in pattern" (CADAR PAT]) (QMATCH$= [LAMBDA (VAR PAT FN) (* lmm "10-AUG-78 15:47") (PROG ((SKIPEDLEN 0) TEM1 TEM2 TAIL) (RETURN (COND ((NILPAT (CDR PAT)) (MKAND (OR (NOT CHECKINGLENGTH) (QEQLENGTH VAR (CDAR PAT))) (DOSIDE FN VAR))) [(AND (NULL FN) (COND ([NULLPAT? (SETQ TAIL (SOME (CDR PAT) (FUNCTION (LAMBDA (ELT) (COND ((EQ ELT '&) (SETQ SKIPEDLEN (QPLUS 1 SKIPEDLEN )) NIL) ((EQ (CAR ELT) '$=) (SETQ SKIPEDLEN (QPLUS SKIPEDLEN (CDR ELT))) NIL) (T] [SETQ TEM2 (OR (NOT CHECKINGLENGTH) (QNOTLESSPLENGTH VAR (QPLUS (CDAR PAT) SKIPEDLEN] (COND ((CAR INASOME) (DOWATCH (CAR (FRPLACA INASOME TEM2))) T) (T TEM2))) ((NULL TAIL) (QEQLENGTH VAR (QPLUS (CDAR PAT) SKIPEDLEN] [(ZEROP (CDAR PAT)) (MKAND (DOSIDE FN (QLDIFF VAR VAR)) (QMATCHWM VAR (CDR PAT] (T [SETQ TEM1 (COND ((AND (NUMBERP (CDAR PAT)) (ILESSP (CDAR PAT) MAXCDDDDRS)) (QNTH VAR (CDAR PAT))) (T (SUBSTVAR (QNTH VAR (CDAR PAT] (MKAND (OR (NOT CHECKINGLENGTH) (NOT (CANMATCHNILLIST (CDR PAT))) TEM1) (MKAND (DOSIDE FN (QLDIFF VAR (QCDR TEM1))) (QMATCHWM (QCDR TEM1) (CDR PAT]) (QMATCHELT1 [LAMBDA (VAR PAT FN) (* lmm "10-AUG-78 15:47") (MKAND [OR (NOT CHECKINGLENGTH) (COND ((CDR PAT) (COND ((AND (CANMATCHNIL (CAR PAT)) (CANMATCHNILLIST (CDR PAT))) VAR) (T T))) ((CANMATCHNIL (CAR PAT)) (QEQLENGTH VAR 1)) (T (QNULL (QCDR VAR] (MKAND (QMATCHELT (QCAR VAR) (CAR PAT)) (MKAND (DOSIDE FN (QCAR VAR)) (OR (NULL (CDR PAT)) (COND ([AND (EQ (CAR INASOME) 'FASTINASOME) (COND [(LISTP (CAR PAT)) (FMEMB (CAAR PAT) '(= == %' *ANY* @ SUBPAT] (T (NOT (FMEMB (CAR PAT) '($1 &] [FRPLACA INASOME (PROG ((INASOME (CONS NIL INASOME))) (RETURN (QMATCHWM (QCDR VAR) (CDR PAT] T) (T (QMATCHWM (QCDR VAR) (CDR PAT]) (QMATCHELT [LAMBDA (VAR PATELT) (* lmm "10-AUG-78 15:47") (* This function matches VAR against  PATELT when PATELT is a pattern  element) (COND ((NLISTP PATELT) (SELECTQ PATELT (($ -- &) T) (QEQUAL VAR PATELT))) (T (SELECTQ (CAR PATELT) (== (QEQ VAR (CDR PATELT))) (@ [COND [(SIMPLEFN (CADR PATELT)) (MKAND (QAPPLY* (CADR PATELT) VAR) (QMATCHELT VAR (CDDR PATELT] (T (MKAND (QMATCHELT VAR (CDDR PATELT)) (QAPPLY* (CADR PATELT) VAR]) (*ANY* [QOR (MAPCAR (CDR PATELT) (FUNCTION (LAMBDA (X) (QMATCHELT VAR X]) (~ (QNOT (QMATCHELT VAR (CDR PATELT)))) (%' (QEQUAL VAR (KWOTE (CDR PATELT)))) (= (QEQUAL VAR (CDR PATELT))) (SUBPAT (QMATCHSUBPAT VAR (CDR PATELT))) ($= (COND [CHECKINGLENGTH (COND (CHECKLENGTH (QEQLENGTH VAR (CDR PATELT))) (T (QNOTLESSPLENGTH VAR (CDR PATELT] (T T))) (PATHELP "MATCHELT invalid pattern"]) (SIMPLEFN [LAMBDA (FN) (* lmm%: "17-NOV-76 19:20:38") (* Cheap test if FN is "simple" ; here, just means LISTP NLISTP, EXPRP,  LITATOM, etc; want to know if it is cheaper to match pattern first, or to check  FN first) (FMEMB FN SIMPLE.PREDICATES]) (DOSIDE [LAMBDA (WHATTODO X) (* lmm "22-NOV-82 12:24") (OR (NULL WHATTODO) (MKAND (SELECTQ (CAAR WHATTODO) (<- [OR (CHECKSETQ X WHATTODO) (MKPROGN (CONS (LIST 'SETQ (CADAR WHATTODO) X) (AND (CANMATCHNIL (CDDAR WHATTODO)) (LIST T]) (_ (OR (CHECKSETQ X WHATTODO) (PROGN (DOWATCH (CADAR WHATTODO)) (DOWATCH X) (PUSH POSTPONEDSETQS (LIST 'SETQ (CADAR WHATTODO) X)) (SETQ LASTEFFECTCANBENIL (CANMATCHNIL (CDDAR WHATTODO))) T))) (-> (QREPLACE X (CADAR WHATTODO))) (% (DOWATCH (CADAR WHATTODO)) (DOWATCH X) (SETQ POSTPONEDRPLACS (CONS (QREPLACE X (CADAR WHATTODO)) POSTPONEDRPLACS)) T) (@ (QAPPLY* (CADAR WHATTODO) X)) (*GLITCH (FRPLACA (CADAR WHATTODO) X) (DOWATCH X) T) (PATHELP "MATCH FUNARG MISMATCH" WHATTODO)) (DOSIDE (CDR WHATTODO) X]) (CHECKSETQ [LAMBDA (X ARGS) (COND ((FMEMB (CADAR ARGS) %#LIST) [COND ((FMEMB (CADAR ARGS) %#LISTUSED) (MAP INASOME (FUNCTION (LAMBDA (SL) (AND (OR (EQ (CAR SL) 'INASOME) (EQ (CAR SL) 'FASTINASOME)) (RPLACA SL NIL] (MAKESUBST (CADAR ARGS) X 'WATCH) T) ((EQ (CADAR ARGS) '*) (DOWATCH X) (SETQ MUSTRETURN X) T]) (DOREPLACE [LAMBDA (EXPRESSION SUBSTDONE) (PROG NIL LP [SETQ EXPRESSION (OR (DOREPLACE1 (CADR EXPRESSION) (CADDR EXPRESSION) (EQ (CAR EXPRESSION) 'TOPREPLACE) SUBSTDONE) (PROGN [AND (NOT SUBSTDONE) (SETQ SUBSTDONE T) (SETQ EXPRESSION (CONS (CAR EXPRESSION) (OR (DOSUBST1 (CDR EXPRESSION)) (CDR EXPRESSION] (GO LP] (RETURN (COND (SUBSTDONE EXPRESSION) (T (OR (DOSUBST1 EXPRESSION) EXPRESSION]) (DOREPLACE1 [LAMBDA (EXPR1 EXPR2 TOPFLG SUBSTDONE) (* lmm "10-AUG-78 18:32") (OR (EQUAL EXPR1 EXPR2) (AND TOPFLG (SELECTQ (CAR EXPR2) ((CONS LIST) (MKAND2 (DOREPLACE1 (QCAR EXPR1) (CADR EXPR2) T T) (OR (AND (EQ (CAR EXPR2) 'LIST) (NULL (CDDR EXPR2))) (DOREPLACE1 (QCDR EXPR1) (COND ((EQ (CAR EXPR2) 'LIST) (CONS 'LIST (CDDR EXPR2))) (T (CADDR EXPR2))) T T)))) NIL)) (SELECTQ (CAR EXPR1) (CAR (LIST (LOOK 'RPLACA) (CADR EXPR1) EXPR2)) (CDR (LIST (LOOK 'RPLACD) (CADR EXPR1) EXPR2)) (LDIFF (DOREPLACE1 (CADR EXPR1) (QNCONC EXPR2 (CADDR EXPR1)) TOPFLG SUBSTDONE)) (AND SUBSTDONE (LOOKLIST 'RPLNODE2 EXPR1 EXPR2]) ) (DEFINEQ (PATLEN [LAMBDA (PATELT !ED) (PROG NIL LP (RETURN (COND [(NLISTP PATELT) (SELECTQ PATELT (($ --) NIL) (& (AND (NOT !ED) 1)) (COND (!ED 0) (T 1] (T (SELECTQ (CAR PATELT) (SUBPAT (COND [!ED (for PE1 in (CDR PATELT) bind (PLEN _ 0) finally (RETURN PLEN) do (SETQ PLEN (QPLUS PLEN (OR (PATLEN PE1) (RETURN NIL] (T 1))) ($= (CDR PATELT)) ((_ -> <- % @ *GLITCH) (SETQ PATELT (CDDR PATELT)) (GO LP)) (! (SETQ PATELT (CDR PATELT)) (SETQ !ED T) (GO LP)) (*ANY* (COND (!ED NIL) (T 1))) (%' (COND (!ED (LENGTH (CDR PATELT))) (T 1))) ((= == ~) (* Currently, ~ can only refer to  subpatterns, =, ==, and %') (AND (NOT !ED) 1)) (($> $<) NIL) (PATHELP "PATLEN invalid pattern" PATELT]) ($? [LAMBDA (PATELT) (OR (EQ PATELT '--) (EQ PATELT '$]) (ELT? [LAMBDA (PATELT) (COND [(NLISTP PATELT) (OR (NUMBERP PATELT) (STRINGP PATELT) (FMEMB PATELT '(& NIL T] (T (SELECTQ (CAR PATELT) ((= == %' SUBPAT ~ *ANY*) (* Currently, ~ can only refer to =,  ==, %' %, and subpatterns) T) ((_ -> <- % @ *GLITCH) (ELT? (CDDR PATELT))) NIL]) (SIMPLELT? [LAMBDA (PATELT) (OR (NLISTP PATELT) (SELECTQ (CAR PATELT) (@ (SIMPLELT? (CDDR PATELT))) ((_ -> <- %) NIL) T]) (ARB? [LAMBDA (PATELT @OKFLG) (COND ((NLISTP PATELT) ($? PATELT)) (T (SELECTQ (CAR PATELT) (! NIL) (@ @OKFLG) ((<- % _ -> *GLITCH) (ARB? (CDDR PATELT) @OKFLG)) NIL]) (NULLPAT? [LAMBDA (PAT) (COND ((NULL PAT) (NOT CHECKLENGTH)) (T (EVERY PAT (FUNCTION $?]) (NILPAT [LAMBDA (PATLIST) (AND CHECKLENGTH (NULL PATLIST]) (CANMATCHNIL [LAMBDA (PATELT) (* Returns T if PATELT matches NIL, NIL if it doesn't, and something ELSE  (maybe) if it might (e.g., =FOO)) (COND ((NLISTP PATELT) (AND (FMEMB PATELT '(& NIL $ --)) T)) ((NLISTP (CAR PATELT)) (SELECTQ (CAR PATELT) (@ (AND (CANMATCHNIL (CDDR PATELT)) (NOT (FMEMB (CADR PATELT) PATNONNILFUNCTIONS)) '(MAYBE, MAYBE NOT))) (SUBPAT (AND (NOT LISTPCHECK) (CANMATCHNILLIST (CDR PATELT)))) ($< T) ($= (OR (NOT (NUMBERP (CDR PATELT))) (ILESSP (CDR PATELT) 1))) ($> NIL) ((_ -> % <- *GLITCH) (CANMATCHNIL (CDDR PATELT))) (! [COND ((EQ (CADR PATELT) 'SUBPAT) (CANMATCHNILLIST (CDDR PATELT))) (T (CANMATCHNIL (CDR PATELT]) (%' (NULL (CDR PATELT))) ((= ==) [NOT (COND [(LITATOM (CDR PATELT)) (OR (EQ (CDR PATELT) T) (AND (CDR PATELT) (NOT PATVARSNIL] (T (OR (NLISTP (CDR PATELT)) (FMEMB (GETP (CAR (CDR PATELT)) 'CLISPCLASS) '(+ * ^ RPLACA RPLACD / - +-)) (FMEMB (CAR (CDR PATELT)) NEVERNILFUNCTIONS]) (*ANY* (SOME (CDR PATELT) (FUNCTION CANMATCHNIL))) (~ (CDR PATELT)) (PATHELP "CANMATCHNIL invalid pattern" PATELT))) (T (PATHELP "CANMATCHNIL invalid pattern"]) (CANMATCHNILLIST [LAMBDA (PATLIST) (EVERY PATLIST (FUNCTION (LAMBDA (PE) (AND (OR (NOT CHECKINGLENGTH) (NOT (ELT? PE))) (CANMATCHNIL PE]) (REPLACEIN [LAMBDA (PATELT) (AND (LISTP PATELT) (SELECTQ (CAR PATELT) ((-> % *GLITCH) (* the *GLITCH might or might not be  a replace, but can't take any  chances) T) ((@ _ <-) (REPLACEIN (CDDR PATELT))) (! (REPLACEIN (CDR PATELT))) (SUBPAT (SOME (CDR PATELT) (FUNCTION REPLACEIN))) (($= = == %' $< $> ~ *ANY*) (* All of these cannot be pointing  at a REPLACE) NIL) (PATHELP "Invalid pattern REPLACEIN" PATELT]) ) (DEFINEQ (EASYTORECOMPUTE [LAMBDA (EXPRESSION) (* If the EXPRESSION is some  cadddaars of a variable, return that  variable (something needs to check  for VARS bound IN somes and internal  forms for WHEN it can't use it for  the *'s value)) (OR (AND (NLISTP EXPRESSION) EXPRESSION) (AND [OR (GETP (CAR EXPRESSION) 'CROPS) (FMEMB (CAR EXPRESSION) '(CAR CDR] (EASYTORECOMPUTE (CADR EXPRESSION]) (GENSYML [LAMBDA NIL (bind TEM until (NOT (FMEMB (SETQ TEM (OR (CAR (SETQ GENSYMVARLIST (CDR GENSYMVARLIST))) (GENSYM))) VARS)) finally (RETURN TEM]) (MAKESUBST [LAMBDA (VAR VAL FLG) [COND ((NULL VAR) (SETQ VAR (GENSYML] (COND ((EQ FLG 'WATCH) (DOWATCH VAR) (DOWATCH VAL))) (SETQ SUBLIST (CONS (CONS VAR (CONS VAL (SELECTQ FLG (T T) (WATCH (NEQ (EASYTORECOMPUTE VAL))) NIL))) SUBLIST)) VAR]) (DOSUBST [LAMBDA (EXPRESSION) (* This function does the post substitution in the EXPRESSION;  it uses SUBLIST to substitute; an entry in SUBLIST is  (VAR NEWVALUE . FOUND) where FOUND is initially NIL;  when the VAR is found for the first time, the FOUND field is smashed with a  pointer to that place of substitution; then if it is found again, the old place  is smashed with a (SETQ $$I VALUE) and then the newvalue is made $$I, and "FOUND"  is changed to T -  thus, if an expression occurs once, it is substituted directly;  more than once and (SETQ $$I -) is put in the first place and $$I in the rest) (OR (COND [(NLISTP EXPRESSION) (CAR (DOSUBST1 (LIST EXPRESSION] (T (DOSUBST1 EXPRESSION))) EXPRESSION]) (DOSUBST1 [LAMBDA (EXPRESSION) (* lmm "22-NOV-82 12:24") (PROG (TEM1 TEM2) (RETURN (COND ((NLISTP EXPRESSION) NIL) [[AND (NLISTP (CAR EXPRESSION)) (SETQ TEM1 (find X in SUBLIST suchthat (COND [(NLISTP X) (COND ((EQ X (CAR EXPRESSION) ) (RETURN] (T (EQ (CAR X) (CAR EXPRESSION] (* (CAR EXPRESSION) needs to be  substituted for) (SETQ EXPRESSION (CONS (CAR EXPRESSION) (CDR EXPRESSION))) [COND ((LISTP (CDDR TEM1)) (* We have already substituted for  it) (SETQ TEM2 (BINDVAR (GENSYML))) (FRPLACA (CDDR TEM1) (LIST 'SETQ TEM2 (CADDR TEM1))) (FRPLACA (CDR TEM1) TEM2) (FRPLACD (CDR TEM1) T) (* Mark it that it's been found  twice) ) ((NULL (CDDR TEM1)) (* Haven't seen it before -  if CADR TEM1 is NLISTP this means that CAR TEM1 -> CADR TEM1 directly -  none of this SETQ jazz; so we put T there;  otherwise, we save EXPRESSION so that if TEM1%:1 occurs again we can go back  and wrap setq around the computation of TEM1%:2) (FRPLACD (CDR TEM1) (COND ((NLISTP (CADR TEM1)) T) (T EXPRESSION] (FRPLACA EXPRESSION (CADR TEM1)) (* Might need to substitutions  within substituted EXPRESSION) (COND ((NLISTP (CAR EXPRESSION)) (OR (DOSUBST1 EXPRESSION) EXPRESSION)) (T (FRPLACA EXPRESSION (OR (DOSUBST1 (CAR EXPRESSION)) (CAR EXPRESSION))) (FRPLACD EXPRESSION (OR (DOSUBST1 (CDR EXPRESSION)) (CDR EXPRESSION] (T (SELECTQ (CAR EXPRESSION) (LAMBDA (* Don't want to substitute for lambda variables within the lambda;  this is so that the same variable can be used for a some tail within the some  and outside of it) [PROG ((SUBLIST (APPEND (CADR EXPRESSION) SUBLIST)) TEM) (RETURN (COND ((SETQ TEM (DOSUBST1 (CDDR EXPRESSION))) (CONS (CAR EXPRESSION) (CONS (CADR EXPRESSION) TEM]) (PROG [PROG (V TEM FLG) [SETQ V (MAPCAR (CADR EXPRESSION) (FUNCTION (LAMBDA (X) (COND ([AND (LISTP X) (SETQ TEM (DOSUBST1 (CDR X] (SETQ FLG T) (CONS (CAR X) TEM)) (T X] (RETURN (PROG ((SUBLIST (NCONC [MAPCAR (CADR EXPRESSION) (FUNCTION (LAMBDA (X) (COND ((LISTP X) (CAR X)) (T X] SUBLIST))) (RETURN (COND ((OR (SETQ TEM (DOSUBST1 (CDDR EXPRESSION ))) FLG) (CONS (CAR EXPRESSION) (CONS V (OR TEM (CDDR EXPRESSION]) (QUOTE NIL) ((TOPREPLACE REPLACE) (DOREPLACE EXPRESSION)) (COND [(SELECTQ (CAR EXPRESSION) ((CAR CDR) (SELECTQ (CAADR EXPRESSION) ((CAR CDR) T) NIL)) NIL) (SETQ TEM1 (OR (DOSUBST1 (CADR EXPRESSION)) (CADR EXPRESSION))) (COND ((EQ (CAR EXPRESSION) 'CDR) (QCDR TEM1)) (T (QCAR TEM1] (T (PROG (A D) (SETQ A (DOSUBST1 (CAR EXPRESSION))) (SETQ D (DOSUBST1 (CDR EXPRESSION))) (COND ((EQ (CAR EXPRESSION) 'DUMMY) (AND D (FRPLACD EXPRESSION D)) (RETURN))) (RETURN (AND (OR A D) (CONS (OR A (CAR EXPRESSION)) (OR D (CDR EXPRESSION]) (SUBSTVAR [LAMBDA (X) (* lmm%: "27-JUN-77 12:23") (MAKESUBST (GENSYML) X]) (BINDVAR [LAMBDA (VAR VAL) (* lmm "22-NOV-82 12:07") (PUSH BOUNDVARS VAR) (PUSH BOUNDVALS VAL) VAR]) (SELFQUOTEABLE [LAMBDA (EXPRESSION) (OR (NUMBERP EXPRESSION) (STRINGP EXPRESSION) (NULL EXPRESSION) (EQ EXPRESSION T]) (FINDIN0 [LAMBDA (VAR X) (* lmm%: "27-JUN-77 12:23") (OR (FINDIN1 VAR X) (SOME SUBLIST (FUNCTION (LAMBDA (X) (AND (FINDIN1 (CAR X) X) (FINDIN1 VAR (CDR X]) (FINDIN1 [LAMBDA (AT LST) (* CHEAP EDITFINDP) (OR (EQ AT LST) (AND (LISTP LST) (OR (FINDIN1 AT (CAR LST)) (FINDIN1 AT (CDR LST]) (DOWATCH [LAMBDA (X) (* lmm%: "27-JUN-77 12:23") (AND WATCHPOSTPONELST (MAP WATCHPOSTPONELST (FUNCTION (LAMBDA (X) (AND (NEQ (CAR X) 'FOUND) (FINDIN0 (CAR X) X) (FRPLACA X 'FOUND]) (PATNARGS [LAMBDA (X) (OR (GETP X 'NARGS) (NARGS X]) ) (DEFINEQ (QNLEFT [LAMBDA (EXPRESSION N TAIL NOTFASTFLG) (* lmm%: 25-FEB-76 2 19) (COND (TAIL (LIST (LOOK 'NLEFT) EXPRESSION N TAIL)) ((ZEROP N) (* NO LOOKUP DONE SINCE FLAST  DOESN'T MAKE SENSE HERE) (LIST 'CDR (LIST 'LAST EXPRESSION))) [(EQ N 1) (COND (NOTFASTFLG (LIST 'LAST EXPRESSION)) (T (QLAST EXPRESSION] (T (LIST (LOOK 'NLEFT) EXPRESSION N]) (QNOT [LAMBDA (X) (QNOT1 X 'NOT]) (QNULL [LAMBDA (X) (QNOT1 X 'NULL]) (QNOT1 [LAMBDA (X FNNAME) (COND ((NLISTP X) (SELECTQ X ((NIL T) (PATERR "NULL check of T or NIL; possibly a bad pattern")) (LIST FNNAME X))) (T (SELECTQ (CAR X) ((NOT NULL) (CADR X)) (EQ (FRPLACA X 'NEQ)) (NEQ (FRPLACA X 'EQ)) (LISTP (FRPLACA X 'NLISTP)) (NLISTP (FRPLACA X 'LISTP)) (LIST FNNAME X]) (QNOTLESSPLENGTH [LAMBDA (X N) (COND ((ZEROP N) T) (T (QNTH X N]) (QNTH [LAMBDA (VAR LEN) (COND ((OR (NOT (SMALLP LEN)) (ILESSP LEN 1)) (LIST (COND (CHECKINGLENGTH (LOOK 'NTH)) (T 'FNTH)) VAR LEN)) ((IGREATERP LEN MAXCDDDDRS) (while (EQ (CAR (LISTP VAR)) 'CDR) do (SETQ LEN (IPLUS LEN 1)) (SETQ VAR (CADR VAR))) (LIST 'NTH VAR LEN)) (T (while (IGREATERP (SETQ LEN (SUB1 LEN)) 0) do (SETQ VAR (LIST 'CDR VAR))) VAR]) (QOR [LAMBDA (LISTOFEXPRESSIONS) (COND ((CDR LISTOFEXPRESSIONS) (CONS 'OR LISTOFEXPRESSIONS)) (T (CAR LISTOFEXPRESSIONS]) (QPLUS [LAMBDA (EXPR1 EXPR2) (COND ((AND (NUMBERP EXPR1) (NUMBERP EXPR2)) (IPLUS EXPR1 EXPR2)) (T (LIST 'IPLUS EXPR1 EXPR2]) (QREPLACE [LAMBDA (VAR EXPRESSION) (LIST 'REPLACE VAR EXPRESSION]) (MKAND [LAMBDA (X Y) (* lmm "10-AUG-78 23:00") (OR (MKAND2 X Y) (LIST 'AND X Y]) (QCAR [LAMBDA (X) (LIST 'CAR X]) (QCDR [LAMBDA (X) (LIST 'CDR X]) (QEQ [LAMBDA (VAR EXPRESSION) (COND ((NULL EXPRESSION) (QNULL VAR)) ((ZEROP EXPRESSION) (LIST 'ZEROP VAR)) (T (LIST 'EQ VAR EXPRESSION]) (QEQLENGTH [LAMBDA (VAR LEN) (* lmm%: 25-FEB-76 2 10) (COND ((ZEROP LEN) (QNULL VAR)) ((EQ (CAR (LISTP VAR)) 'CDR) (QEQLENGTH (CADR VAR) (QPLUS 1 LEN))) (T (LIST (LOOK 'EQLENGTH) VAR LEN]) (QEQUAL [LAMBDA (VAR EXPRESSION) [COND ([AND (LISTP EXPRESSION) (EQ (CAR EXPRESSION) 'QUOTE) (SELFQUOTEABLE (CAR (LISTP (CDR EXPRESSION] (SETQ EXPRESSION (CADR EXPRESSION] (COND ((NULL EXPRESSION) (QNULL VAR)) ((EQ EXPRESSION T) (QEQ VAR EXPRESSION)) (T (LIST (COND ([OR (SMALLP EXPRESSION) (AND (LISTP EXPRESSION) (EQ (CAR EXPRESSION) 'QUOTE) (LITATOM (CAR (LISTP (CDR EXPRESSION] 'EQ) ((NUMBERP EXPRESSION) 'EQP) ((STRINGP EXPRESSION) 'STREQUAL) (T 'EQUAL)) VAR EXPRESSION]) (QLAST [LAMBDA (X) (LIST (LOOK 'LAST X) X]) (QAPPLY* [LAMBDA (FNNAME VAR) (COND ((OR (NLISTP FNNAME) (EQ (CAR FNNAME) 'LAMBDA)) (LIST FNNAME VAR)) (T (SUBST VAR '@ FNNAME]) (QLDIFF [LAMBDA (X Y) (* lmm%: 25-FEB-76 2 18) (LIST (LOOK 'LDIFF) X Y]) (QFOR [LAMBDA ({OLD} I.V. {ON}VAR {UNTIL}EXPR {FINALLY}EXPR NOSOMEFLG) (* lmm "22-NOV-82 12:16") (PROG (TEM1) (AND (EQ {UNTIL}EXPR T) (PATHELP " a SOME with null terminator" (LIST {OLD} I.V. {ON}VAR {FINALLY}EXPR))) (AND (EQ {UNTIL}EXPR I.V.) (PATERR 'BACKTRACK)) (AND NOSOMEFLG (GO DOPROG)) [COND ((AND (EQ (CAR (LISTP {UNTIL}EXPR)) 'AND) (EQ (CADR {UNTIL}EXPR) I.V.)) (SETQ {UNTIL}EXPR (COND ((CDDDR {UNTIL}EXPR) (CONS 'AND (CDDR {UNTIL}EXPR))) (T (CADDR {UNTIL}EXPR] [SETQ TEM1 (OR (SELECTQ (CAR (LISTP {UNTIL}EXPR)) (EQ (AND (EQUAL (CADR {UNTIL}EXPR) (QCAR I.V.)) (LOOKLIST 'MEMB (CADDR {UNTIL}EXPR) {ON}VAR))) (EQUAL (AND (EQUAL (CADR {UNTIL}EXPR) (QCAR I.V.)) (LIST 'MEMBER (CADDR {UNTIL}EXPR) {ON}VAR))) NIL) (LIST 'SOME {ON}VAR (PROG ((ARGS (LIST (GENSYML) I.V.))) (RETURN (LIST 'FUNCTION (COND ([AND (EQ (CADR {UNTIL}EXPR) (CAR ARGS)) (OR (AND (EQLENGTH {UNTIL}EXPR 2) (EQ (PATNARGS (CAR {UNTIL}EXPR)) 1)) (AND (EQ (PATNARGS (CAR {UNTIL}EXPR)) 1) (EQLENGTH {UNTIL}EXPR 3) (EQ (CADDR {UNTIL}EXPR) (CADR ARGS] (CAR {UNTIL}EXPR)) (T (LIST 'LAMBDA ARGS {UNTIL}EXPR] (RETURN (COND ((OR {OLD} (NEQ {FINALLY}EXPR T)) (MAKESUBST I.V. TEM1) (* OLD on means that I.V. is going to be used later on.  Thus, we set up to substitute TEM1 for I.V.  later, and return I.V. now) (RETURN (MKAND I.V. {FINALLY}EXPR))) (T TEM1))) DOPROG (RETURN `(PROG %, [COND ((NOT {OLD}) (LIST (LIST I.V. {ON}VAR] %,@ [COND ({OLD} `((SETQ %, (BINDVAR I.V.) %, {ON}VAR] $$SOMELP (COND (%, (NEGATE {UNTIL}EXPR) (COND ((LISTP %, I.V.) (SETQ %, I.V. (CDR %, I.V.)) (GO $$SOMELP))) (RETURN)) (T (RETURN %, {FINALLY}EXPR]) (QLISTP [LAMBDA (X) (LIST 'LISTP X]) (QNCONC [LAMBDA (EXPR1 EXPR2) (* lmm%: 17 MAY 75 417) (COND ((NULL EXPR2) EXPR1) ((EQ (CAR (LISTP EXPR1)) 'LIST) (for Y in (REVERSE (CDR EXPR1)) do (SETQ EXPR2 (LIST 'CONS Y EXPR2))) EXPR2) ((AND (EQ (CAR (LISTP EXPR2)) 'LIST) (NULL (CDDR EXPR2))) (LOOKLIST 'NCONC1 EXPR1 (CADR EXPR2))) (T (LOOKLIST 'NCONC EXPR1 EXPR2]) ) (DEFINEQ (PATERR [LAMBDA (MSG AT) (LISPXPRIN1 (SELECTQ MSG (BACKTRACK "This pattern contains an empty test after a -- or $") (CLISP "The pattern matcher is confused by what it thinks is CLISP within a pattern - please recode this patNIL") (BADNOT "Cannot negate a non-element pattern") (TWO! "Two !'s in a row") (BAD* "invalid *") (BAD# "invalid #") (BADELT "Pattern item not atom or list ") (NOWITH "no WITH") (AMBIG "ambiguous pattern") (!AT "!atom in middle of pattern") (OR MSG "bad pattern")) T) (LISPXTERPRI T) (COND (AT (LISPXPRIN1 " at: " T) (LISPXPRINT AT T T))) (LISPXPRIN1 " in: " T) (LISPXPRINT MATCHEXPRESSION T T) (ERROR!]) (PATHELP [LAMBDA (MESS1 MESS2) (LISPXPRIN1 "error in Pattern Match" T) (LISPXTERPRI T) (HELP MESS1 MESS2]) (LOOKLIST [LAMBDA (FN ARG ARG') (LIST (LOOK FN ARG ARG') ARG ARG']) (VALUELOOKUP [LAMBDA (VAR) (* lmm%: 25-FEB-76 2 2) (COND (LOCALDECLARATION (CLISPLOOKUP0 VAR (CADR MATCHEXPRESSION) NIL LOCALDECLARATION NIL 'VALUE)) (T (GETATOMVAL VAR]) (LOOK [LAMBDA (FN ARG ARG') (PROG (CLASS CLASSDEF (LISPFN (OR (GETP FN 'LISPFN) FN))) (RETURN (COND ([AND LOCALDECLARATION (SETQ CLASSDEF (GETP FN 'CLISPCLASSDEF] (CLISPLOOKUP0 FN ARG ARG' LOCALDECLARATION LISPFN (GETP FN 'CLISPCLASS) CLASSDEF)) (T LISPFN]) ) (DEFINEQ (MKAND2 [LAMBDA (EXPR1 EXPR2) (* lmm "10-AUG-78 23:00") (* If the two expressions when ANDed, can be simplified, return the simplified  expression otherwise NIL) (PROG (TEM TEM2) (RETURN (COND ((EQ EXPR1 T) EXPR2) ((EQ EXPR2 T) EXPR1) ((EQUALUNCROP EXPR1 EXPR2) EXPR2) ((EQUALUNCROP EXPR2 EXPR1) EXPR1) (T (OR (SELECTQ (CAR (LISTP EXPR1)) (LISTP (CHECKSLISTP EXPR1 EXPR2)) (PROGN (* (AND (AND |...|  X) Y) combine X and Y) (COND ((SETQ TEM2 (MKAND2 [CAR (SETQ TEM (LAST (LISTP EXPR1] EXPR2)) (NCONC1 (LDIFF (LISTP EXPR1) TEM) TEM2)))) (AND (* (AND (AND |...|  X) Y) combine X and Y) [COND ((SETQ TEM2 (MKAND2 [CAR (SETQ TEM (LAST (LISTP EXPR1] EXPR2)) (MKAND [COND ((EQ (CDDR (LISTP EXPR1)) TEM) (CADR EXPR1)) (T (CONS 'AND (LDIFF (CDR (LISTP EXPR1)) TEM] TEM2)) (T (APPEND EXPR1 (LIST EXPR2]) (SETQ (AND (EQUALUNCROP (CADR EXPR1) EXPR2) (SUBST EXPR1 (CADR EXPR1) EXPR2))) NIL) (SELECTQ (CAR (LISTP EXPR2)) (AND [COND [(SETQ TEM (MKAND2 EXPR1 (CADR EXPR2))) (MKAND TEM (COND ((CDDDR EXPR2) (CONS 'AND (CDDR EXPR2))) (T (CADDR EXPR2] (T (CONS 'AND (CONS EXPR1 (CDR EXPR2]) NIL]) (CHECKSLISTP [LAMBDA (EXPR1 EXPR2) (* lmm "10-AUG-78 18:47") (* EXPR1 is an expression (LISTP form) -  if (AND EXPR1 EXPR2) can be reduced, return the reduced form which returns the  same value) (COND ((EQUAL (CADR EXPR1) EXPR2) (* (AND (LISTP X) X) =>  (LISTP X)) EXPR1) ((NLISTP EXPR2) (* (AND (LISTP X) Y)) NIL) ((SELECTQ (CAR EXPR2) ((MEMB MEMBER ASSOC SASSOC) (AND (EQUAL (CADDR EXPR2) (CADR EXPR1)) EXPR2)) ((SOME NLEFT LAST NTH EQLENGTH) (AND (EQUAL (CADR EXPR2) (CADR EXPR1)) EXPR2)) NIL)) (T (SELECTQ (CAR EXPR2) ((CAR CDR FNTH FLAST LISTP NLEFT LAST SOME NTH EQLENGTH) [AND (SETQ EXPR1 (CHECKSLISTP EXPR1 (CADR EXPR2))) (CONS (CAR EXPR2) (CONS EXPR1 (CDDR EXPR2]) ((EQUAL EQ STREQUAL EQP) [AND (CADDR EXPR2) [OR (SELFQUOTEABLE (CADDR EXPR2)) (AND (EQ (CAR (LISTP (CADDR EXPR2))) 'QUOTE) (CADR (CADDR EXPR2] (SETQ EXPR1 (CHECKSLISTP EXPR1 (CADR EXPR2))) (CONS (CAR EXPR2) (CONS EXPR1 (CDDR EXPR2]) ((FMEMB FASSOC MEMB MEMBER ASSOC SASSOC) (COND ((SETQ EXPR1 (CHECKSLISTP EXPR1 (CADDR EXPR2))) (LIST (CAR EXPR2) (CADR EXPR2) EXPR1)))) NIL]) (EQUALUNCROP [LAMBDA (EXPR1 EXPR2) (* lmm "10-AUG-78 23:10") (* predicate (AND EXPR1 EXPR2) =  EXPR2 -  i.e. EXPR2 non-NIL implies EXPR1  non-NIL) (OR (EQUAL EXPR1 EXPR2) (AND (LISTP EXPR2) (COND ((GETP (CAR EXPR2) 'CROPS) (EQUALUNCROP EXPR1 (CADR EXPR2))) (T (SELECTQ (CAR EXPR2) ((CAR CDR NTH NLEFT LAST FLAST FNTH SOME LISTP) (EQUALUNCROP EXPR1 (CADR EXPR2))) ((MEMB FMEMB MEMBER ASSOC SASSOC FASSOC) (EQUALUNCROP EXPR1 (CADDR EXPR2))) ((EQ EQUAL EQP IEQP) (AND [OR (EQ (CADDR EXPR2) T) (NUMBERP (CADDR EXPR2)) (AND (EQ (CAR (LISTP (CADDR EXPR2))) 'QUOTE) (CADR (CADDR EXPR2] (EQUALUNCROP EXPR1 (CADR EXPR2)))) NIL]) ) (DEFINEQ (PATPARSE [LAMBDA (PAT) (OR (LISTP PAT) (PATHELP "bad input" PAT)) (PROG (DEFAULTLST) (RETURN (PATPARSE1 PAT]) (PATPARSE1 [LAMBDA (PAT PREFIX) (* DECLARATIONS%: UNDOABLE) (* lmm%: "27-JUN-77 12:35") (PROG (TEM TEM2 TEM3 CARPAT CDRPAT NOTFOUND) (OR PAT (RETURN)) RETRY [AND (CDR PAT) (NLISTP (CDR PAT)) (SETQ PAT (LIST (CAR PAT) '%. (CDR PAT] (* Take care of (a . b) by changing  it to (a %. b)) (SETQ CARPAT (CAR PAT)) [AND (EQ CARPAT COMMENTFLG) (NULL NORMALCOMMENTSFLG) (SETQ CARPAT (CAR (GETCOMMENT PAT] (SETQ CDRPAT (CDR PAT)) [COND [(LISTP CARPAT) (SELECTQ (CAR CARPAT) (*ANY* [SETQ CARPAT (CONS (CAR CARPAT) (PROG ((TOPPAT CARPAT)) (RETURN (PATPARSE1 (CDR CARPAT] (OR (EVERY CARPAT (FUNCTION SIMPLELT?)) (PATERR "*ANY*/*EVERY* construct too compicated" PAT))) (QUOTE (* This is so (-- (QUOTE A) --) means (--  %' A --); this kludge is necessary now since DWIMIFY1B sometimes parses the %'  A into (QUOTE A)) [COND ((NOT (ATOM (CADR CARPAT))) (/RPLNODE PAT '%' (CONS (CADR CARPAT) CDRPAT))) (T (/RPLACA PAT (PACK (LIST '%' (CADR CARPAT] (GO RETRY)) (LAMBDA (* (-- (LAMBDA (X) --) --) means  (-- &@ (LAMBDA (X) --))) (/ATTACH '&@ PAT) (GO RETRY)) (PROGN (* Otherwise, it's a sub-pattern) (SETQ CARPAT (MAKESUBPAT (PROG ((TOPPAT CARPAT)) (RETURN (PATPARSE1 CARPAT] ((NOT (LITATOM CARPAT)) (* Strings and numbers parse to  themselves) (OR (STRINGP CARPAT) (NUMBERP CARPAT) (PATERR 'BADELT CARPAT))) (T (SELECTQ CARPAT ((T NIL & -- $)) ($$ (SETQQ CARPAT --)) ($1 (SETQQ CARPAT &)) (($2 $3 $4 $5 $6 $7 $8 $9) (SETQ CARPAT (CONS '$= (NTHCHAR CARPAT 2)))) ((== = $> $< $=) (SETQ TEM2 (PATGETEXPR CDRPAT PAT)) [SETQ CARPAT (COND ((AND (EQ CARPAT '$=) (EQ (CAR TEM2) 1)) '&) (T (CONS CARPAT (CAR TEM2] (SETQ CDRPAT (CDR TEM2))) ((! %.) (SETQ TEM2 (PATPARSE1 CDRPAT)) (RETURN (CONS (MAKE!PAT (CAR TEM2) TEM2 PAT PREFIX) (CDR TEM2)))) (~ (SETQ TEM2 (PATPARSE1 CDRPAT)) (RETURN (CONS (NEGATEPAT (CAR TEM2) PAT) (CDR TEM2)))) (%' (SETQ CARPAT (CONS '%' (CAR CDRPAT))) (SETQ CDRPAT (CDR CDRPAT))) (COND ((SETQ TEM (PATUNPACK PAT)) (SETQ PAT TEM) (* Now, either we have a "DEFAULT"  condition, or else a var infix  condition) (GO RETRY)) (T (SETQ NOTFOUND PAT] (* By now, CARPAT is set to the parsing of the first thing in PAT;  and CDRPAT is the appropriate tail; want to check for infix operators;  if NOTFOUND is non-nil, then CARPAT was an atom which wasn't parseable as a  pattern; might be a variable if followed by a _ or a %# or a *) REINFIX [COND ((AND CDRPAT (NLISTP CDRPAT)) (SETQ CDRPAT (LIST '%. CDRPAT] (COND ((SETQ TEM (AND CDRPAT (FASSOC (CAR CDRPAT) PATTERNREPLACEOPRS))) [COND [NOTFOUND (* CARPAT is not a pattern, and followed by a _;  want to know if the next thing is a pattern or something else;  it is assumed that var_pattern is meant;  I could change it to mean pat_var) [COND ((FMEMB CARPAT %#LIST)) ((STRPOS "#" CARPAT 1 NIL 1) (SETQ %#LIST (CONS CARPAT %#LIST](* Check if a %# type variable) (SETQ TEM3 (PATPARSE1 (CDR CDRPAT) CDRPAT)) (RETURN (CONS (CONS (CADR TEM) (CONS CARPAT (CAR TEM3))) (CDR TEM3] (T (SETQ CARPAT (CONS (CADDR TEM) (CONS [CAR (SETQ CDRPAT (PATGETEXPR (CDR CDRPAT] CARPAT))) (SETQ CDRPAT (CDR CDRPAT] (GO REINFIX)) (NOTFOUND (COND ((AND (EQ (NTHCHAR (CAR CDRPAT) 1) '_) (IGREATERP (NCHARS (CAR CDRPAT)) 1)) (/RPLNODE CDRPAT '_ (CONS (MKATOM (SUBSTRING (CAR CDRPAT) 2 -1)) (CDR CDRPAT))) (GO REINFIX))) (COND (PREFIX (PATERR (COND ((STRPOSL CLISPCHARRAY (CAR PAT)) 'CLISP) (T 'AMBIG)) PAT))) (SETQ PAT (PARSEDEFAULT PAT NIL PREFIX)) (SETQ NOTFOUND) (GO RETRY)) ((EQ (CAR CDRPAT) '@) (SETQ CDRPAT (OR (PATUNPACKINFIX1 (CDR CDRPAT)) (CDR CDRPAT))) (SETQ CARPAT (CONS '@ (CONS (PATGETFNNAME CDRPAT) CARPAT))) (SETQ CDRPAT (CDR CDRPAT)) (GO REINFIX)) ((SETQ TEM (PATUNPACKINFIX CDRPAT)) (SETQ CDRPAT TEM) (GO REINFIX))) (RETURN (CONS CARPAT (PATPARSE1 CDRPAT]) (PATUNPACKINFIX1 [LAMBDA (L) (PATPARSEAT L PATTERNINFIXES1]) (PARSEDEFAULT [LAMBDA (PAT LOCALVARDEFAULT PREFIX) (* lmm "22-MAY-80 21:37") (* Turns PAT%:1 (which is a LITATOM) into the "DEFAULT" pattern -  I.e. PAT%:1 couldn't be parsed as a pattern -  It is assumed that the default for an atom is an element pattern) (OR (AND (LITATOM (CAR PAT)) (NEQ (CAR PAT) T) (CAR PAT)) (PATHELP "MAKEDEFAULT" (CAR PAT))) (PROG (SMASHFLG NEWPAT) (COND ((FMEMB (CAR PAT) DEFAULTLST) (* Second occurance of a "DEFAULT"  is defaulted to =) (SETQQ LOCALVARDEFAULT =)) ([COND ((STRPOS "#" (CAR PAT) 1 NIL 1) (OR (NUMBERP (SUBATOM (CAR PAT) 2 -1)) (PATERR 'BAD# PAT))) ((STRPOS "*" (CAR PAT)) (OR (EQ (CAR PAT) '*) (PATERR 'BAD* PAT] (* %#n is defaulted to _ the first  time) (SETQQ LOCALVARDEFAULT SETQ)) ((AND (NLISTP (CAR PAT)) (STRPOSL CLISPCHARRAY (CAR PAT))) (PATERR 'CLISP PAT))) RETRY [SETQ NEWPAT (SELECTQ (OR LOCALVARDEFAULT (AND (NLISTP VARDEFAULT) VARDEFAULT)) ((_ SETQ SET) (SETQ DEFAULTLST (CONS (CAR PAT) DEFAULTLST)) [CONS (CAR PAT) (CONS '_ (CONS '& (CDR PAT]) ('%' [COND (SMASHFLG (/ATTACH '%' PAT)) (T (RETURN (CONS '%' PAT]) ((= EQUAL) [COND (SMASHFLG (/ATTACH '= PAT)) (T (RETURN (CONS '= PAT]) ((== EQ) [COND (SMASHFLG (/ATTACH '== PAT)) (T (RETURN (CONS '== PAT]) ((@ APPLY*) [COND (SMASHFLG (/ATTACH '$1@ PAT)) (T (RETURN (CONS '$1 (CONS '@ PAT]) (PROGN (SETQ SMASHFLG T) [SETQ LOCALVARDEFAULT (COND (LOCALVARDEFAULT (PATERR (COND (VARDEFAULT "invalid PATTERNVARDEFAULT" ) (T 'AMBIG)) PAT)) ((EQ 1 (GETP (CAR PAT) 'NARGS)) (SETQ SMASHFLG) '@) ((VARCHECK (CAR PAT) T T T) '=) ((LISTP VARDEFAULT) (CAR VARDEFAULT)) (T '?] (GO RETRY] (COND (SMASHFLG (/RPLNODE2 PAT NEWPAT) (RETURN PAT)) (T (RETURN NEWPAT]) (VARCHECK [LAMBDA (VAR NOMESSFLG SPELLFLG PROPFLG) (* Checks if VAR is really a variable -  Used by MAKEDEFAULT to avoid bad parsings) (OR (AND (LITATOM VAR) (OR (FMEMB VAR VARS) (NEQ (EVALV VAR) 'NOBIND)) VAR) (AND (NOT NOMESSFLG) (ERROR VAR "NOT A VARIABLE" T]) (PATUNPACK [LAMBDA (PAT) (* lmm "22-MAY-80 21:37") (* THIS WOULD BE SIMPLER IF THERE WERNT THINGS LIKE $N AROUND --  THIS FUNCTION UNPACKS (CAR PAT) ALONG THE LINES OF PATTERN OPERATORS -  I'LL MAKE IT SIMPLER BY ASSUMING THAT THINGS ARE OK  (I.E. WILL UNPACK) (AND (STRPOSL PATTERNCHARRAY  (CAR PAT)) (PROG ((CHARS (UNPACK (CAR PAT))) RESULTS) RETRY  (for CHR on CHARS do (for X in PATCHRLST bind TAIL do  (SETQ TAIL CHR) (COND ((for Z in (CDR X) always  (COND ((EQ Z (CAR TAIL)) (SETQ TAIL (CDR TAIL)) T)))  (* CHARS IS (|...| PATCHRSTRING |...|);  WE TAKE AND PUT ON RESULTS THE UNPACKING OF THE FIRST AND REST)  (SETQ RESULTS (NCONC RESULTS (COND ((NEQ CHR CHARS)  (LIST (PACK (LDIFF CHARS CHR)))) (T NIL))  (LIST (CAR X)))) (SETQ CHARS TAIL) (GO RETRY)))))  (RETURN (AND RESULTS (NCONC1 RESULTS (PACK CHARS))  (RETURN RESULTS)))))) (PATPARSEAT PAT PATCHARS]) (PATUNPACKINFIX [LAMBDA (L) (PATPARSEAT L PATTERNINFIXES1]) (PATGETFNNAME [LAMBDA (L) (* wt%: "14-JUN-78 10:59") (OR (LISTP (CAR L)) (FGETD (CAR L)) (FIXSPELL (CAR L) 70 SPELLINGS2 T L (FUNCTION GETD) NIL NIL T) (FIXSPELL (CAR L) 70 USERWORDS T L (FUNCTION GETD) T)) (CAR L]) (PATGETEXPR [LAMBDA (L UP) (* lmm%: "19-SEP-76 23:26:14") (OR L (PATERR "missing an expression" UP)) (SETQ L (OR (PATUNPACKINFIX L) L)) [COND ((LISTP (CAR L)) (PROG ((VARS (APPEND %#LIST VARS))) (RETURN (DWIMIFY0? (CAR L) (CAR L) NIL NIL NIL FAULTFN] (for X in %#LIST when (AND (NOT (FMEMB X %#LISTUSED)) (FINDIN1 X (CAR L))) do (SETQ %#LISTUSED (CONS X %#LISTUSED))) L]) (PATPARSEAT [LAMBDA (PAT CHRS) (* lmm "22-MAY-80 21:38") (* Breaks apart (CAR PAT) if possible, replaces the parsing into the beginning  of PAT ; otherwise return NIL if can't -  CHRS is a list of args as if to STRPOS, i.e.  check (STRPOS X%:1 PAT%:1 1 NIL X%:2) for X in CHRS -  X%:1 is the char list, X%:2 is ANCHOR) (PROG (TEM DONEANYTHING LST POS) (OR (AND (NLISTP (CAR PAT)) (STRPOSL PATTERNCHARRAY (CAR PAT))) (RETURN)) (SETQ LST (UNPACK (CAR PAT))) LP (COND ((NULL CHRS) (RETURN)) ((EQ (CADDR (CAR CHRS)) (CAR PAT)) (RETURN)) ([NOT (SETQ POS (COND [(NULL (CADAR CHRS)) (find X on LST suchthat (for Z in (CAAR CHRS) as ZZ in X always (EQ Z ZZ] ((for Z in (CAAR CHRS) as ZZ in LST always (EQ Z ZZ)) LST] (SETQ CHRS (CDR CHRS)) (GO LP))) (* Found one -  POS is now the tail of LST which begins with one of the operators) [SETQ PAT (CONS (CAR PAT) (COND ([SETQ TEM (FNTH POS (ADD1 (FLENGTH (CAAR CHRS] (CONS (PACK TEM) (CDR PAT))) (T (CDR PAT] [SETQ TEM (COND ([AND TEM (EQ (CADDR (CAR CHRS)) '$) (NOT (FMEMB (CAR TEM) '(_ @ = < >] '$=) (T (CADDR (CAR CHRS] (COND [(NEQ POS LST) (RPLNODE PAT (PACKLDIFF LST POS) (CONS TEM (CDR PAT] (T (FRPLACA PAT TEM))) (RETURN PAT]) (MAKE!PAT [LAMBDA (PATELT PATALL REALPAT PREFIX) (COND ((AND (EQ (CAR REALPAT) '!) (EQ PATELT (CAR PATALL)) (OR (EQ (CAR PATELT) '_) (EQ (CAR PATELT) '<-)) (NOT (FMEMB (CADR PATELT) DEFAULTLST))) (* Change PATALL to  ((_ var ! subpat %.  all of it)) from (  (_ var . part1) part2)) [FRPLACD (CDR PATELT) (MAKE!PAT (MAKESUBPAT (CONS (CDDR PATELT) (CDR PATALL] (FRPLACD PATALL NIL) PATELT) (T (OR (COND ((NLISTP PATELT) (SELECTQ PATELT (& '$) (($ --) '$) NIL)) (T (SELECTQ (CAR PATELT) (! (PATERR 'TWO! PATELT)) ((_ <- % -> @) (FRPLACD (CDR PATELT) (MAKE!PAT (CDDR PATELT))) PATELT) (* (CONS (CAR PATELT) (MAKE!PAT (CDR PATELT)))) (SUBPAT (AND (NULL (CDDR PATELT)) (NOT (ELT? (CADR PATELT))) (CADR PATELT))) ($= PATELT) NIL))) (CONS '! PATELT]) (MAKESUBPAT [LAMBDA (PATLST) (COND ((NULL PATLST) NIL) ([OR (EQUAL PATLST '(--)) (EQUAL PATLST '($] '&) (T (CONS 'SUBPAT PATLST]) (NEGATEPAT [LAMBDA (PE REALPAT) (PROG NIL [COND ((NLISTP PE) (SELECTQ PE ((& $) (PATERR "Cannot negate this type of pattern" PE)) T)) (T (SELECTQ (CAR PE) ((= == %' SUBPAT)) ((_ % <- ->) [RETURN (CONS (CAR PE) (CONS (CADR PE) (NEGATEPAT (CDDR PE]) (@) (PATERR 'BADNOT REALPAT] (RETURN (CONS '~ PE]) (PACKLDIFF [LAMBDA (LST1 LST2) (PROG (TEM1 TEM2) (FRPLACD (OR (SETQ TEM1 (NLEFT LST1 1 LST2)) (HELP)) NIL) (RETURN (PROG1 (PACK LST1) (FRPLACD TEM1 TEM2]) ) (RPAQQ PATCHARS ((($ <) T $<) (($ >) T $>) (($ =) T $=) ((%') T %') ((!) T !) ((= =) T ==) ((=) T =) ((~) T ~) ((< -) NIL <-) ((@) NIL @) ((_) NIL _) (($) T $))) (RPAQQ PATTERNINFIXES (((_) T _) ((< -) T <-) ((@) T @))) (RPAQQ PATTERNINFIXES1 (((_) NIL _) ((< -) NIL <-) ((@) NIL @))) (RPAQQ PATTERNREPLACEOPRS ((_ _ %) (__ <- ->) (_!!_!_ _ %) (<- <- ->))) (RPAQQ PATTERNITEMS ((&) (--) ($$ --) (T) (NIL) (&) (--) ($) ($1 &) ($2 ($= . 2)) ($3 ($= . 3)) ($4 ($= . 4)) ($5 ($= . 5)) ($6 ($= . 6)))) (RPAQQ NEVERNILFUNCTIONS (CONS LIST QUOTE ABS ADD1 SUB1 CONCAT REMAINDER FREMAINDER IREMAINDER LOGOR LOGAND LOGXOR)) (RPAQQ PATNONNILFUNCTIONS (GETD NUMBERP STRINGP ZEROP LISTP SMALLP)) (RPAQ PATTERNCHARRAY [MAKEBITTABLE (NCONC (MAPCAR PATCHARS 'CAAR) (MAPCAR PATTERNITEMS 'CAR]) (RPAQQ PATGENSYMVARS (GENSYMVARS%: $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 $$17)) (RPAQQ PATVARDEFAULT =) (RPAQQ MAXCDDDDRS 5) (RPAQQ PATCHECKLENGTH T) (RPAQ PATLISTPCHECK (EQ 'VAX (SYSTEMTYPE))) (RPAQQ PATVARSMIGHTBENIL T) (RPAQQ PATCHARS ((($ <) T $<) (($ >) T $>) (($ =) T $=) ((%') T %') ((!) T !) ((= =) T ==) ((=) T =) ((~) T ~) ((< -) NIL <-) ((@) NIL @) ((_) NIL _) (($) T $))) (RPAQQ PATTERNINFIXES (((_) T _) ((< -) T <-) ((@) T @))) (RPAQQ PATTERNINFIXES1 (((_) NIL _) ((< -) NIL <-) ((@) NIL @))) (RPAQQ PATTERNREPLACEOPRS ((_ _ %) (__ <- ->) (_!!_!_ _ %) (<- <- ->))) (RPAQQ PATTERNITEMS ((&) (--) ($$ --) (T) (NIL) (&) (--) ($) ($1 &) ($2 ($= . 2)) ($3 ($= . 3)) ($4 ($= . 4)) ($5 ($= . 5)) ($6 ($= . 6)))) (RPAQQ NEVERNILFUNCTIONS (CONS LIST QUOTE ABS ADD1 SUB1 CONCAT REMAINDER FREMAINDER IREMAINDER LOGOR LOGAND LOGXOR)) (RPAQQ PATNONNILFUNCTIONS (GETD NUMBERP STRINGP ZEROP LISTP SMALLP)) (RPAQQ SIMPLE.PREDICATES (LISTP LITATOM NLISTP CAR CDR NULL)) (RPAQ PATTERNCHARRAY [MAKEBITTABLE (NCONC (MAPCAR PATCHARS 'CAAR) (MAPCAR PATTERNITEMS 'CAR]) (RPAQQ PATGENSYMVARS (GENSYMVARS%: $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 $$17)) (OR (BOUNDP 'MATCHSTATS) (SETQ MATCHSTATS)) (RPAQQ PATVARDEFAULT =) (RPAQQ MAXCDDDDRS 5) (RPAQQ PATCHECKLENGTH T) (RPAQQ PATLISTPCHECK NIL) (RPAQQ PATVARSMIGHTBENIL T) (RPAQQ MATCHBLOCKS ((MATCHBLOCK (ENTRIES MAKEMATCH) (GLOBALVARS PATCHARS MAXCDDDDRS PATNONNILFUNCTIONS PATGENSYMVARS PATTERNREPLACEOPRS PATTERNINFIXES1 PATTERNCHARRAY NEVERNILFUNCTIONS MATCHSTATS SIMPLE.PREDICATES USERWORDS SPELLINGS2 CLISPCHARRAY NORMALCOMMENTSFLG COMMENTFLG) (LOCALFREEVARS WATCHPOSTPONELST SUBLIST INASOME CHECKINGLENGTH WMLST LASTEFFECTCANBENIL POSTPONEDSETQS MUSTRETURN BOUNDVARS BOUNDVALS GENSYMVARLIST SKIPEDLEN ZLENFLG LOCALDECLARATION MATCHEXPRESSION MATCHEFFECTS CHECKLENGTH %#LIST %#LISTUSED PATVARSNIL POSTPONEDRPLACS LISTPCHECK DEFAULTLST VARDEFAULT) (SPECVARS EXPR FAULTFN VARS CLISPCHANGE) MAKEMATCH QMATCHSUBPAT QMATCHWM QMATCH$ QMATCH! QMATCH$= QMATCHELT1 QMATCHELT SIMPLEFN DOSIDE CHECKSETQ DOREPLACE DOREPLACE1 PATLEN $? ELT? SIMPLELT? ARB? NULLPAT? NILPAT CANMATCHNIL CANMATCHNILLIST REPLACEIN EASYTORECOMPUTE GENSYML MAKESUBST DOSUBST DOSUBST1 SUBSTVAR BINDVAR SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH PATNARGS QNLEFT QNCONC QNOT QNULL QNOT1 QNOTLESSPLENGTH QNTH QOR QPLUS QREPLACE MKAND QCAR QCDR QEQ QEQLENGTH QEQUAL QLAST QAPPLY* QLDIFF QFOR QLISTP PATERR PATHELP LOOKLIST VALUELOOKUP LOOK MKAND2 CHECKSLISTP EQUALUNCROP PATPARSE PATPARSE1 PATUNPACKINFIX1 PARSEDEFAULT VARCHECK PATUNPACK PATUNPACKINFIX PATGETFNNAME PATGETEXPR PATPARSEAT MAKE!PAT MAKESUBPAT NEGATEPAT PACKLDIFF))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MATCHBLOCK (ENTRIES MAKEMATCH) (GLOBALVARS PATCHARS MAXCDDDDRS PATNONNILFUNCTIONS PATGENSYMVARS PATTERNREPLACEOPRS PATTERNINFIXES1 PATTERNCHARRAY NEVERNILFUNCTIONS MATCHSTATS SIMPLE.PREDICATES USERWORDS SPELLINGS2 CLISPCHARRAY NORMALCOMMENTSFLG COMMENTFLG) (LOCALFREEVARS WATCHPOSTPONELST SUBLIST INASOME CHECKINGLENGTH WMLST LASTEFFECTCANBENIL POSTPONEDSETQS MUSTRETURN BOUNDVARS BOUNDVALS GENSYMVARLIST SKIPEDLEN ZLENFLG LOCALDECLARATION MATCHEXPRESSION MATCHEFFECTS CHECKLENGTH %#LIST %#LISTUSED PATVARSNIL POSTPONEDRPLACS LISTPCHECK DEFAULTLST VARDEFAULT) (SPECVARS EXPR FAULTFN VARS CLISPCHANGE) MAKEMATCH QMATCHSUBPAT QMATCHWM QMATCH$ QMATCH! QMATCH$= QMATCHELT1 QMATCHELT SIMPLEFN DOSIDE CHECKSETQ DOREPLACE DOREPLACE1 PATLEN $? ELT? SIMPLELT? ARB? NULLPAT? NILPAT CANMATCHNIL CANMATCHNILLIST REPLACEIN EASYTORECOMPUTE GENSYML MAKESUBST DOSUBST DOSUBST1 SUBSTVAR BINDVAR SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH PATNARGS QNLEFT QNCONC QNOT QNULL QNOT1 QNOTLESSPLENGTH QNTH QOR QPLUS QREPLACE MKAND QCAR QCDR QEQ QEQLENGTH QEQUAL QLAST QAPPLY* QLDIFF QFOR QLISTP PATERR PATHELP LOOKLIST VALUELOOKUP LOOK MKAND2 CHECKSLISTP EQUALUNCROP PATPARSE PATPARSE1 PATUNPACKINFIX1 PARSEDEFAULT VARCHECK PATUNPACK PATUNPACKINFIX PATGETFNNAME PATGETEXPR PATPARSEAT MAKE!PAT MAKESUBPAT NEGATEPAT PACKLDIFF) ) (PUTPROPS MATCH COPYRIGHT ("Venue & Xerox Corporation" 1982 1984 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2592 44543 (MAKEMATCH 2602 . 8852) (QMATCHSUBPAT 8854 . 9436) (QMATCHWM 9438 . 14213) ( QMATCH$ 14215 . 26166) (QMATCH! 26168 . 32303) (QMATCH$= 32305 . 35806) (QMATCHELT1 35808 . 37508) ( QMATCHELT 37510 . 39236) (SIMPLEFN 39238 . 39582) (DOSIDE 39584 . 41340) (CHECKSETQ 41342 . 42054) ( DOREPLACE 42056 . 43004) (DOREPLACE1 43006 . 44541)) (44544 51006 (PATLEN 44554 . 46605) ($? 46607 . 46681) (ELT? 46683 . 47191) (SIMPLELT? 47193 . 47391) (ARB? 47393 . 47701) (NULLPAT? 47703 . 47824) ( NILPAT 47826 . 47894) (CANMATCHNIL 47896 . 49887) (CANMATCHNILLIST 49889 . 50151) (REPLACEIN 50153 . 51004)) (51007 62641 (EASYTORECOMPUTE 51017 . 51869) (GENSYML 51871 . 52136) (MAKESUBST 52138 . 52623) (DOSUBST 52625 . 53493) (DOSUBST1 53495 . 60920) (SUBSTVAR 60922 . 61076) (BINDVAR 61078 . 61249) ( SELFQUOTEABLE 61251 . 61403) (FINDIN0 61405 . 61756) (FINDIN1 61758 . 61988) (DOWATCH 61990 . 62567) ( PATNARGS 62569 . 62639)) (62642 71146 (QNLEFT 62652 . 63249) (QNOT 63251 . 63298) (QNULL 63300 . 63349 ) (QNOT1 63351 . 63832) (QNOTLESSPLENGTH 63834 . 63935) (QNTH 63937 . 64517) (QOR 64519 . 64672) ( QPLUS 64674 . 64843) (QREPLACE 64845 . 64921) (MKAND 64923 . 65074) (QCAR 65076 . 65118) (QCDR 65120 . 65162) (QEQ 65164 . 65351) (QEQLENGTH 65353 . 65692) (QEQUAL 65694 . 66558) (QLAST 66560 . 66627) ( QAPPLY* 66629 . 66817) (QLDIFF 66819 . 66964) (QFOR 66966 . 70601) (QLISTP 70603 . 70649) (QNCONC 70651 . 71144)) (71147 72979 (PATERR 71157 . 72071) (PATHELP 72073 . 72197) (LOOKLIST 72199 . 72290) ( VALUELOOKUP 72292 . 72567) (LOOK 72569 . 72977)) (72980 79572 (MKAND2 72990 . 76115) (CHECKSLISTP 76117 . 78121) (EQUALUNCROP 78123 . 79570)) (79573 99520 (PATPARSE 79583 . 79733) (PATPARSE1 79735 . 87322) (PATUNPACKINFIX1 87324 . 87398) (PARSEDEFAULT 87400 . 91749) (VARCHECK 91751 . 92135) ( PATUNPACK 92137 . 93218) (PATUNPACKINFIX 93220 . 93293) (PATGETFNNAME 93295 . 93659) (PATGETEXPR 93661 . 94356) (PATPARSEAT 94358 . 96703) (MAKE!PAT 96705 . 98444) (MAKESUBPAT 98446 . 98634) (NEGATEPAT 98636 . 99267) (PACKLDIFF 99269 . 99518))))) STOP \ No newline at end of file diff --git a/library/MATMULT b/library/MATMULT new file mode 100644 index 00000000..ed5b2d08 --- /dev/null +++ b/library/MATMULT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "12-Jun-90 10:07:44" {DSK}local>lde>lispcore>library>MATMULT.;2 16402 changes to%: (VARS MATMULTCOMS) previous date%: "22-Apr-87 09:55:51" {DSK}local>lde>lispcore>library>MATMULT.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MATMULTCOMS) (RPAQQ MATMULTCOMS ( (* ;;; "User entry points") (DECLARE%: DONTCOPY DOEVAL@COMPILE (FILES FLOAT-ARRAY-SUPPORT)) (FUNCTIONS %%MATMULT-N33 %%MATMULT-N44 DEGREES-TO-RADIANS IDENTITY-3-BY-3 IDENTITY-4-BY-4 MAKE-HOMOGENEOUS-3-BY-3 MAKE-HOMOGENEOUS-3-VECTOR MAKE-HOMOGENEOUS-4-BY-4 MAKE-HOMOGENEOUS-4-VECTOR MAKE-HOMOGENEOUS-N-BY-3 MAKE-HOMOGENEOUS-N-BY-4 MATMULT-133 MATMULT-144 MATMULT-331 MATMULT-333 MATMULT-441 MATMULT-444 MATMULT-N33 MATMULT-N44 PERSPECTIVE-4-BY-4 PROJECT-AND-FIX-3-VECTOR PROJECT-AND-FIX-4-VECTOR PROJECT-AND-FIX-N-BY-3 PROJECT-AND-FIX-N-BY-4 ROTATE-3-BY-3 ROTATE-4-BY-4-ABOUT-X ROTATE-4-BY-4-ABOUT-Y ROTATE-4-BY-4-ABOUT-Z SCALE-3-BY-3 SCALE-4-BY-4 TRANSLATE-3-BY-3 TRANSLATE-4-BY-4) (* ;;; "Compiler options") (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)) (PROP FILETYPE MATMULT))) (* ;;; "User entry points") (DECLARE%: DONTCOPY DOEVAL@COMPILE (FILESLOAD FLOAT-ARRAY-SUPPORT) ) (DEFMACRO %%MATMULT-N33 (N A-BASE B-BASE RESULT-BASE) `(CL:DO ((I 0 (CL:1+ I)) (SOURCE-BASE ,A-BASE (\ADDBASE SOURCE-BASE 6)) (DEST-BASE ,RESULT-BASE (\ADDBASE DEST-BASE 6)) (MATRIX-BASE ,B-BASE)) ((EQ I ,N)) (%%MATMULT-133 SOURCE-BASE MATRIX-BASE DEST-BASE))) (DEFMACRO %%MATMULT-N44 (N A-BASE B-BASE RESULT-BASE) `(CL:DO ((I 0 (CL:1+ I)) (SOURCE-BASE ,A-BASE (\ADDBASE SOURCE-BASE 8)) (DEST-BASE ,RESULT-BASE (\ADDBASE DEST-BASE 8)) (MATRIX-BASE ,B-BASE)) ((EQ I ,N)) (%%MATMULT-144 SOURCE-BASE MATRIX-BASE DEST-BASE))) (CL:DEFUN DEGREES-TO-RADIANS (DEGREES) (CL:* (FLOAT DEGREES) (CONSTANT (/ CL:PI 180.0)))) (CL:DEFUN IDENTITY-3-BY-3 (&OPTIONAL RESULT) (LET [(MATRIX (%%INSURE-ARRAY RESULT (3 3] (FILL-ARRAY MATRIX 0.0) (CL:DOTIMES (I 3) (ASET 1.0 MATRIX I I)) MATRIX)) (CL:DEFUN IDENTITY-4-BY-4 (&OPTIONAL RESULT) (LET [(MATRIX (%%INSURE-ARRAY RESULT (4 4] (FILL-ARRAY MATRIX 0.0) (CL:DOTIMES (I 4) (ASET 1.0 MATRIX I I)) MATRIX)) (CL:DEFUN MAKE-HOMOGENEOUS-3-BY-3 (&KEY A00 A01 A10 A11 A20 A21) (LET [(MATRIX (CL:MAKE-ARRAY '(3 3) :ELEMENT-TYPE 'CL:SINGLE-FLOAT] (CL:IF A00 (ASET (FLOAT A00) MATRIX 0 0)) (CL:IF A01 (ASET (FLOAT A01) MATRIX 0 1)) (CL:IF A10 (ASET (FLOAT A10) MATRIX 1 0)) (CL:IF A11 (ASET (FLOAT A11) MATRIX 1 1)) (CL:IF A20 (ASET (FLOAT A20) MATRIX 2 0)) (CL:IF A21 (ASET (FLOAT A21) MATRIX 2 1)) (ASET 1.0 MATRIX 2 2) MATRIX)) (CL:DEFUN MAKE-HOMOGENEOUS-3-VECTOR (&OPTIONAL X Y) (LET [(V (MAKE-VECTOR 3 :ELEMENT-TYPE 'CL:SINGLE-FLOAT] (CL:IF X (ASET (FLOAT X) V 0)) (CL:IF Y (ASET (FLOAT Y) V 1)) (ASET 1.0 V 2) V)) (CL:DEFUN MAKE-HOMOGENEOUS-4-BY-4 (&KEY A00 A01 A02 A03 A10 A11 A12 A13 A20 A21 A22 A23 A30 A31 A32) (LET [(MATRIX (CL:MAKE-ARRAY '(4 4) :ELEMENT-TYPE 'CL:SINGLE-FLOAT] (CL:IF A00 (ASET (FLOAT A00) MATRIX 0 0)) (CL:IF A01 (ASET (FLOAT A01) MATRIX 0 1)) (CL:IF A02 (ASET (FLOAT A02) MATRIX 0 2)) (CL:IF A03 (ASET (FLOAT A03) MATRIX 0 3)) (CL:IF A10 (ASET (FLOAT A10) MATRIX 1 0)) (CL:IF A11 (ASET (FLOAT A11) MATRIX 1 1)) (CL:IF A12 (ASET (FLOAT A12) MATRIX 1 2)) (CL:IF A13 (ASET (FLOAT A13) MATRIX 1 3)) (CL:IF A20 (ASET (FLOAT A20) MATRIX 2 0)) (CL:IF A21 (ASET (FLOAT A21) MATRIX 2 1)) (CL:IF A22 (ASET (FLOAT A22) MATRIX 2 2)) (CL:IF A23 (ASET (FLOAT A23) MATRIX 2 3)) (CL:IF A30 (ASET (FLOAT A30) MATRIX 3 0)) (CL:IF A31 (ASET (FLOAT A31) MATRIX 3 1)) (CL:IF A32 (ASET (FLOAT A32) MATRIX 3 2)) (ASET 1.0 MATRIX 3 3) MATRIX)) (CL:DEFUN MAKE-HOMOGENEOUS-4-VECTOR (&OPTIONAL X Y Z) (LET [(V (MAKE-VECTOR 4 :ELEMENT-TYPE 'CL:SINGLE-FLOAT] (CL:IF X (ASET (FLOAT X) V 0)) (CL:IF Y (ASET (FLOAT Y) V 1)) (CL:IF Z (ASET (FLOAT Z) V 2)) (ASET 1.0 V 3) V)) (CL:DEFUN MAKE-HOMOGENEOUS-N-BY-3 (N &KEY INITIAL-ELEMENT) (LET [(MATRIX (CL:MAKE-ARRAY (LIST N 3) :ELEMENT-TYPE 'CL:SINGLE-FLOAT] (CL:IF INITIAL-ELEMENT (FILL-ARRAY MATRIX (FLOAT INITIAL-ELEMENT))) (CL:DOTIMES (I N) (ASET 1.0 MATRIX I 2)) MATRIX)) (CL:DEFUN MAKE-HOMOGENEOUS-N-BY-4 (N &KEY INITIAL-ELEMENT) (LET [(MATRIX (CL:MAKE-ARRAY (LIST N 4) :ELEMENT-TYPE 'CL:SINGLE-FLOAT] (CL:IF INITIAL-ELEMENT (FILL-ARRAY MATRIX (FLOAT INITIAL-ELEMENT))) (CL:DOTIMES (I N) (ASET 1.0 MATRIX I 3)) MATRIX)) (CL:DEFUN MATMULT-133 (VECTOR MATRIX &OPTIONAL RESULT) (%%TEST-ARRAY VECTOR (3)) (%%TEST-ARRAY MATRIX (3 3)) (SETQ RESULT (%%INSURE-ARRAY RESULT (3))) (CL:IF (EQ VECTOR RESULT) (CL:ERROR "Results undefined if VECTOR reused")) (%%MATMULT-133 (%%GET-FLOAT-ARRAY-BASE VECTOR) (%%GET-FLOAT-ARRAY-BASE MATRIX) (%%GET-FLOAT-ARRAY-BASE RESULT)) RESULT) (CL:DEFUN MATMULT-144 (VECTOR MATRIX &OPTIONAL RESULT) (%%TEST-ARRAY VECTOR (4)) (%%TEST-ARRAY MATRIX (4 4)) (SETQ RESULT (%%INSURE-ARRAY RESULT (4))) (CL:IF (EQ VECTOR RESULT) (CL:ERROR "Results undefined if VECTOR reused")) (%%MATMULT-144 (%%GET-FLOAT-ARRAY-BASE VECTOR) (%%GET-FLOAT-ARRAY-BASE MATRIX) (%%GET-FLOAT-ARRAY-BASE RESULT)) RESULT) (CL:DEFUN MATMULT-331 (MATRIX VECTOR &OPTIONAL RESULT) (%%TEST-ARRAY MATRIX (3 3)) (%%TEST-ARRAY VECTOR (3)) (SETQ RESULT (%%INSURE-ARRAY RESULT (3))) (CL:IF (EQ MATRIX RESULT) (CL:ERROR "Results undefined if MATRIX reused")) (%%MATMULT-331 (%%GET-FLOAT-ARRAY-BASE MATRIX) (%%GET-FLOAT-ARRAY-BASE VECTOR) (%%GET-FLOAT-ARRAY-BASE RESULT)) RESULT) (CL:DEFUN MATMULT-333 (MATRIX-1 MATRIX-2 &OPTIONAL RESULT) (%%TEST-ARRAY MATRIX-1 (3 3)) (%%TEST-ARRAY MATRIX-2 (3 3)) (SETQ RESULT (%%INSURE-ARRAY RESULT (3 3))) (CL:IF (EQ MATRIX-1 RESULT) (CL:ERROR "Results undefined if MATRIX-1 reused")) (%%MATMULT-333 (%%GET-FLOAT-ARRAY-BASE MATRIX-1) (%%GET-FLOAT-ARRAY-BASE MATRIX-2) (%%GET-FLOAT-ARRAY-BASE RESULT)) RESULT) (CL:DEFUN MATMULT-441 (MATRIX VECTOR &OPTIONAL RESULT) (%%TEST-ARRAY MATRIX (4 4)) (%%TEST-ARRAY VECTOR (4)) (SETQ RESULT (%%INSURE-ARRAY RESULT (4))) (CL:IF (EQ MATRIX RESULT) (CL:ERROR "Results undefined if MATRIX reused")) (%%MATMULT-441 (%%GET-FLOAT-ARRAY-BASE MATRIX) (%%GET-FLOAT-ARRAY-BASE VECTOR) (%%GET-FLOAT-ARRAY-BASE RESULT)) RESULT) (CL:DEFUN MATMULT-444 (MATRIX-1 MATRIX-2 &OPTIONAL RESULT) (%%TEST-ARRAY MATRIX-1 (4 4)) (%%TEST-ARRAY MATRIX-2 (4 4)) (SETQ RESULT (%%INSURE-ARRAY RESULT (4 4))) (CL:IF (EQ MATRIX-1 RESULT) (CL:ERROR "Results undefined if MATRIX-1 reused")) (%%MATMULT-444 (%%GET-FLOAT-ARRAY-BASE MATRIX-1) (%%GET-FLOAT-ARRAY-BASE MATRIX-2) (%%GET-FLOAT-ARRAY-BASE RESULT)) RESULT) (CL:DEFUN MATMULT-N33 (MATRIX-1 MATRIX-2 &OPTIONAL RESULT) (%%TEST-ARRAY MATRIX-1 (CL:* 3)) (%%TEST-ARRAY MATRIX-2 (3 3)) (SETQ RESULT (%%INSURE-ARRAY RESULT (CL:* 3) (CL:ARRAY-DIMENSIONS MATRIX-1))) (CL:IF (EQ MATRIX-1 RESULT) (CL:ERROR "Results undefined if MATRIX-1 reused")) (LET ((N (CL:ARRAY-DIMENSION MATRIX-1 0))) (CL:IF (NOT (EQ N (CL:ARRAY-DIMENSION RESULT 0))) (CL:ERROR "Dimensional mismatch")) (%%MATMULT-N33 N (%%GET-FLOAT-ARRAY-BASE MATRIX-1) (%%GET-FLOAT-ARRAY-BASE MATRIX-2) (%%GET-FLOAT-ARRAY-BASE RESULT)) RESULT)) (CL:DEFUN MATMULT-N44 (MATRIX-1 MATRIX-2 &OPTIONAL RESULT) (%%TEST-ARRAY MATRIX-1 (CL:* 4)) (%%TEST-ARRAY MATRIX-2 (4 4)) (SETQ RESULT (%%INSURE-ARRAY RESULT (CL:* 4) (CL:ARRAY-DIMENSIONS MATRIX-1))) (CL:IF (EQ MATRIX-1 RESULT) (CL:ERROR "Results undefined if MATRIX-1 reused")) (LET ((N (CL:ARRAY-DIMENSION MATRIX-1 0))) (CL:IF (NOT (EQ N (CL:ARRAY-DIMENSION RESULT 0))) (CL:ERROR "Dimensional mismatch")) (%%MATMULT-N44 N (%%GET-FLOAT-ARRAY-BASE MATRIX-1) (%%GET-FLOAT-ARRAY-BASE MATRIX-2) (%%GET-FLOAT-ARRAY-BASE RESULT)) RESULT)) (CL:DEFUN PERSPECTIVE-4-BY-4 (PX PY PZ &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-4-BY-4 RESULT))) (ASET (FLOAT PX) MATRIX 0 3) (ASET (FLOAT PY) MATRIX 1 3) (ASET (FLOAT PZ) MATRIX 2 3) MATRIX)) (CL:DEFUN PROJECT-AND-FIX-3-VECTOR (3-VECTOR &OPTIONAL 2-VECTOR) (%%TEST-ARRAY 3-VECTOR (3)) (COND [(NULL 2-VECTOR) (SETQ 2-VECTOR (CL:MAKE-ARRAY '(2] ([NOT (TYPEP 2-VECTOR '(CL:ARRAY CL:* (2] (CL:ERROR "Not a 2 vector: ~s" 2-VECTOR))) (LET ((3-VECTOR-BASE (%%GET-FLOAT-ARRAY-BASE 3-VECTOR))) (CL:DOTIMES (J 2) (ASET (UFIX (\GETBASEFLOATP 3-VECTOR-BASE (LLSH J 1))) 2-VECTOR J)) 2-VECTOR)) (CL:DEFUN PROJECT-AND-FIX-4-VECTOR (4-VECTOR &OPTIONAL 2-VECTOR) (%%TEST-ARRAY 4-VECTOR (4)) (COND [(NULL 2-VECTOR) (SETQ 2-VECTOR (CL:MAKE-ARRAY '(2] ([NOT (TYPEP 2-VECTOR '(CL:ARRAY CL:* (2] (CL:ERROR "Not a 2 vector: ~s" 2-VECTOR))) (LET* ((4-VECTOR-BASE (%%GET-FLOAT-ARRAY-BASE 4-VECTOR)) (DIVISOR (\GETBASEFLOATP 4-VECTOR-BASE 6))) (DECLARE (TYPE FLOATP DIVISOR)) (CL:IF (UFEQP DIVISOR 1.0) (CL:DOTIMES (J 2) (ASET (UFIX (\GETBASEFLOATP 4-VECTOR-BASE (LLSH J 1))) 2-VECTOR J)) (CL:DOTIMES (J 2) (ASET (UFIX (FQUOTIENT (\GETBASEFLOATP 4-VECTOR-BASE (LLSH J 1)) DIVISOR)) 2-VECTOR J))) 2-VECTOR)) (CL:DEFUN PROJECT-AND-FIX-N-BY-3 (N-3-MATRIX &OPTIONAL N-2-MATRIX) (%%TEST-ARRAY N-3-MATRIX (CL:* 3)) (COND [(NULL N-2-MATRIX) (SETQ N-2-MATRIX (CL:MAKE-ARRAY (LIST (CL:ARRAY-DIMENSION N-3-MATRIX 0) 2] ([NOT (TYPEP N-2-MATRIX '(CL:ARRAY CL:* (CL:* 2] (CL:ERROR "Not an N by 2 array: ~s" N-2-MATRIX))) (LET ((N (CL:ARRAY-DIMENSION N-3-MATRIX 0))) (CL:IF (NOT (EQ N (CL:ARRAY-DIMENSION N-2-MATRIX 0))) (CL:ERROR "Dimensional mismatch")) (CL:DO ((I 0 (CL:1+ I)) (N-3-BASE (%%GET-FLOAT-ARRAY-BASE N-3-MATRIX) (\ADDBASE N-3-BASE 6))) ((EQ I N)) (CL:DOTIMES (J 2) (ASET (UFIX (\GETBASEFLOATP N-3-BASE (LLSH J 1))) N-2-MATRIX I J))) N-2-MATRIX)) (CL:DEFUN PROJECT-AND-FIX-N-BY-4 (N-4-MATRIX &OPTIONAL N-2-MATRIX) (%%TEST-ARRAY N-4-MATRIX (CL:* 4)) (COND [(NULL N-2-MATRIX) (SETQ N-2-MATRIX (CL:MAKE-ARRAY (LIST (CL:ARRAY-DIMENSION N-4-MATRIX 0) 2] ([NOT (TYPEP N-2-MATRIX '(CL:ARRAY CL:* (CL:* 2] (CL:ERROR "Not an N by 2 array: ~s" N-2-MATRIX))) (LET ((N (CL:ARRAY-DIMENSION N-4-MATRIX 0))) (CL:IF (NOT (EQ N (CL:ARRAY-DIMENSION N-2-MATRIX 0))) (CL:ERROR "Dimensional mismatch")) (CL:DO ((I 0 (CL:1+ I)) (N-4-BASE (%%GET-FLOAT-ARRAY-BASE N-4-MATRIX) (\ADDBASE N-4-BASE 8))) ((EQ I N)) [LET ((DIVISOR (\GETBASEFLOATP N-4-BASE 6))) (DECLARE (TYPE FLOATP DIVISOR)) (CL:IF (UFEQP DIVISOR 1.0) (CL:DOTIMES (J 2) (ASET (UFIX (\GETBASEFLOATP N-4-BASE (LLSH J 1))) N-2-MATRIX I J)) (CL:DOTIMES (J 2) (ASET (UFIX (FQUOTIENT (\GETBASEFLOATP N-4-BASE (LLSH J 1)) DIVISOR)) N-2-MATRIX I J)))]) N-2-MATRIX)) (CL:DEFUN ROTATE-3-BY-3 (RADIANS &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-3-BY-3 RESULT)) (COSPHI (CL:COS RADIANS)) (SINPHI (CL:SIN RADIANS))) (ASET COSPHI MATRIX 0 0) (ASET (- SINPHI) MATRIX 0 1) (ASET SINPHI MATRIX 1 0) (ASET COSPHI MATRIX 1 1) MATRIX)) (CL:DEFUN ROTATE-4-BY-4-ABOUT-X (RADIANS &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-4-BY-4 RESULT)) (COSPHI (CL:COS RADIANS)) (SINPHI (CL:SIN RADIANS))) (ASET COSPHI MATRIX 1 1) (ASET (- SINPHI) MATRIX 1 2) (ASET SINPHI MATRIX 2 1) (ASET COSPHI MATRIX 2 2) MATRIX)) (CL:DEFUN ROTATE-4-BY-4-ABOUT-Y (RADIANS &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-4-BY-4 RESULT)) (COSPHI (CL:COS RADIANS)) (SINPHI (CL:SIN RADIANS))) (ASET COSPHI MATRIX 0 0) (ASET (- SINPHI) MATRIX 2 0) (ASET SINPHI MATRIX 0 2) (ASET COSPHI MATRIX 2 2) MATRIX)) (CL:DEFUN ROTATE-4-BY-4-ABOUT-Z (RADIANS &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-4-BY-4 RESULT)) (COSPHI (CL:COS RADIANS)) (SINPHI (CL:SIN RADIANS))) (ASET COSPHI MATRIX 0 0) (ASET (- SINPHI) MATRIX 0 1) (ASET SINPHI MATRIX 1 0) (ASET COSPHI MATRIX 1 1) MATRIX)) (CL:DEFUN SCALE-3-BY-3 (SX SY &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-3-BY-3 RESULT))) (ASET (FLOAT SX) MATRIX 0 0) (ASET (FLOAT SY) MATRIX 1 1) MATRIX)) (CL:DEFUN SCALE-4-BY-4 (SX SY SZ &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-4-BY-4 RESULT))) (ASET (FLOAT SX) MATRIX 0 0) (ASET (FLOAT SY) MATRIX 1 1) (ASET (FLOAT SZ) MATRIX 2 2) MATRIX)) (CL:DEFUN TRANSLATE-3-BY-3 (TX TY &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-3-BY-3 RESULT))) (ASET (FLOAT TX) MATRIX 2 0) (ASET (FLOAT TY) MATRIX 2 1) MATRIX)) (CL:DEFUN TRANSLATE-4-BY-4 (TX TY TZ &OPTIONAL RESULT) (LET ((MATRIX (IDENTITY-4-BY-4 RESULT))) (ASET (FLOAT TX) MATRIX 3 0) (ASET (FLOAT TY) MATRIX 3 1) (ASET (FLOAT TZ) MATRIX 3 2) MATRIX)) (* ;;; "Compiler options") (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS MATMULT FILETYPE CL:COMPILE-FILE) (PUTPROPS MATMULT COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/library/MINISERVE b/library/MINISERVE new file mode 100644 index 00000000..447d2744 --- /dev/null +++ b/library/MINISERVE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "12-Jun-90 10:11:57" {DSK}local>lde>lispcore>library>MINISERVE.;2 15952 changes to%: (RECORDS TIMEXIP) (VARS MINISERVECOMS) previous date%: "17-Apr-87 11:37:51" {DSK}local>lde>lispcore>library>MINISERVE.;1) (* ; " Copyright (c) 1984, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MINISERVECOMS) (RPAQQ MINISERVECOMS [(FNS STARTMINISERVER) (FNS \NSTIMESERVER \HANDLE.NS.TIMEREQ) (FNS \PUPTIMESERVER \HANDLE.PUP.ALTOTIMEREQ) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TIMEPUPCONTENTS TIMEXIP) (CONSTANTS \TIMESOCKET \XIPT.EXCHANGE \EXTYPE.TIME \XIPT.OLDTIME \TIMEVERSION \TIMEOP.TIMEREQUEST \TIMEOP.TIMERESPONSE \NSTIMELENGTH) (CONSTANTS \PUPSOCKET.MISCSERVICES \PT.ALTOTIMEREQUEST \PT.ALTOTIMERESPONSE \PUPOVLEN \TIMEPUPLENGTH) (GLOBALVARS \BeginDST \EndDST \TimeZoneComp)) (COMS (* PUPIDSERVER) (FNS \PUP.ID.SERVER \HANDLE.PUP.LOOKUP \GET.PUP#.FROM.NS#) (INITVARS NS.TO.PUP.ALIST NS.TO.PUP.FILE) (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS NS.TO.PUP.ALIST NS.TO.PUP.FILE) (FILES (LOADCOMP) LLNS]) (DEFINEQ (STARTMINISERVER [LAMBDA NIL (* ; "Edited 16-Apr-87 18:52 by raf") (ADD.PROCESS '(\PUPTIMESERVER) 'RESTARTABLE 'HARDRESET) (ADD.PROCESS '(\NSTIMESERVER) 'RESTARTABLE 'HARDRESET) (ADD.PROCESS '(\PUP.ID.SERVER) 'RESTARTABLE 'HARDRESET) T]) ) (DEFINEQ (\NSTIMESERVER [LAMBDA (TRACEFLG) (* edited%: "15-May-85 18:54") (RESETLST (PROG ((SOC (OPENNSOCKET \TIMESOCKET T)) XIP EVENT) (RESETSAVE NIL (LIST 'CLOSENSOCKET SOC)) (SETQ EVENT (NSOCKETEVENT SOC)) (do (COND ((SETQ XIP (GETXIP SOC)) (\HANDLE.NS.TIMEREQ SOC XIP TRACEFLG)) (T (AWAIT.EVENT EVENT]) (\HANDLE.NS.TIMEREQ [LAMBDA (SOC XIP TRACEFLG) (* jl " 7-Nov-85 12:21") (PROG ((BUF (fetch (XIP XIPCONTENTS) of XIP)) TIME) (COND ([NOT (AND (OR (EQ (fetch (XIP XIPTYPE) of XIP) \XIPT.EXCHANGE) (EQ (fetch (XIP XIPTYPE) of XIP) 123)) (EQ (fetch (TIMEBODY TIMEOP) of BUF) \TIMEOP.TIMEREQUEST) (COND [(EQ \MACHINETYPE \DANDELION) (NOT (EQP 0 (fetch (IOPAGE DLTODVALID) of \IOPAGE] (T T)) (NOT (EQUAL \MY.NSHOSTNUMBER (fetch (XIP XIPSOURCEHOST) of XIP] (RELEASE.XIP XIP)) (T (* * PUT STUFF IN XIP) (COND (TRACEFLG (printout TRACEFLG "Serving time to " .PPVTL (fetch (XIP XIPSOURCEHOST) of XIP) T))) (SETQ TIME (LISP.TO.ALTO.DATE (IDATE))) (replace (XIP XIPLENGTH) of XIP with (IPLUS \XIPOVLEN (UNFOLD 15 BYTESPERWORD))) (* * USED NO TO WORK WITH THAT %: (replace  (PACKETEXCHANGEXIP PACKETEXCHANGETYPE) of XIP with \EXTYPE.RESPONSE)) (replace (TIMEBODY TIMEOP) of BUF with \TIMEOP.TIMERESPONSE) (replace (TIMEBODY TIMEVERSION) of BUF with \TIMEVERSION) (COND ((ILESSP \TimeZoneComp 0) (replace (TIMEBODY TIMEZONESIGN) of BUF with 1)) (T (replace (TIMEBODY TIMEZONESIGN) of BUF with 0))) (replace (TIMEBODY TIMEZONEHOURS) of BUF with (ABS \TimeZoneComp)) (replace (TIMEBODY TIMEZONEMINUTES) of BUF with 0) (replace (TIMEBODY TIMEBEGINDST) of BUF with \BeginDST) (replace (TIMEBODY TIMEENDDST) of BUF with \EndDST) (replace (TIMEBODY TIMEVALUEHI) of BUF with (fetch (FIXP HINUM) of TIME)) (replace (TIMEBODY TIMEVALUELO) of BUF with (fetch (FIXP LONUM) of TIME)) (replace (TIMEBIG OVER1) of BUF with 0) (replace (TIMEBIG OVER2) of BUF with 65535) (replace (TIMEBIG OVER3) of BUF with 65535) (SWAPXIPADDRESSES XIP) (replace (XIP XIPSOURCEHOST) of XIP with (\LOCALNSHOSTNUMBER)) (replace (XIP XIPSOURCENET) of XIP with (\LOCALNSNETNUMBER)) (replace EPREQUEUE of XIP with 'FREE) (SENDXIP SOC XIP]) ) (DEFINEQ (\PUPTIMESERVER [LAMBDA NIL (* bvm%: "23-Jan-84 16:21") (PROG ((PUPSOC (OPENPUPSOCKET \PUPSOCKET.MISCSERVICES T)) EVENT PUP) (RESETSAVE NIL (LIST 'CLOSEPUPSOCKET PUPSOC)) (SETQ EVENT (PUPSOCKETEVENT PUPSOC)) LP (COND ((SETQ PUP (GETPUP PUPSOC)) (SELECTC (fetch (PUP PUPTYPE) of PUP) (\PT.ALTOTIMEREQUEST (\HANDLE.PUP.ALTOTIMEREQ PUPSOC PUP)) NIL) (BLOCK)) (T (* Wait for a Pup) (AWAIT.EVENT EVENT))) (GO LP]) (\HANDLE.PUP.ALTOTIMEREQ [LAMBDA (MISCSOC PUP) (* bvm%: "16-NOV-83 10:48") (* * Alto time request) (PROG [(DATA (fetch (PUP PUPCONTENTS) of PUP)) (TIME (ALTO.TO.LISP.DATE (IDATE] (SWAPPUPPORTS PUP) (replace TIMEPUPVALUEHI of DATA with (\HINUM TIME)) (replace TIMEPUPVALUELO of DATA with (\LONUM TIME)) (COND ((MINUSP \TimeZoneComp) (replace TIMEPUPEASTP of DATA with T) (replace TIMEPUPHOURS of DATA with (IMINUS \TimeZoneComp))) (T (replace TIMEPUPEASTP of DATA with NIL) (replace TIMEPUPHOURS of DATA with \TimeZoneComp))) (replace TIMEPUPMINUTES of DATA with 0) (replace TIMEPUPBEGINDST of DATA with \BeginDST) (replace TIMEPUPENDDST of DATA with \EndDST) (replace (PUP PUPTYPE) of PUP with \PT.ALTOTIMERESPONSE) (replace (PUP PUPLENGTH) of PUP with (CONSTANT (IPLUS \PUPOVLEN \TIMEPUPLENGTH))) (SENDPUP MISCSOC PUP) (\RELEASE.ETHERPACKET PUP]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (BLOCKRECORD TIMEPUPCONTENTS ((TIMEPUPVALUEHI WORD) (TIMEPUPVALUELO WORD) (TIMEPUPEASTP FLAG) (TIMEPUPHOURS BITS 7) (TIMEPUPMINUTES BITS 8) (TIMEPUPBEGINDST WORD) (TIMEPUPENDDST WORD)) (* format of alto time response) ) (ACCESSFNS TIMEXIP ((TIMEBODY (fetch (PACKETEXCHANGEXIP PACKETEXCHANGEBODY) of DATUM))) [BLOCKRECORD TIMEBODY ((TIMEVERSION WORD) (* Protocol version) (TIMEOP WORD) (* What kind of request/response) (TIMEVALUE FIXP) (TIMEZONESIGN WORD) (* 0 = west of prime meridian, 1 =  east) (TIMEZONEHOURS WORD) (* Hours from prime meridian) (TIMEZONEMINUTES WORD) (* Minutes |...|) (TIMEBEGINDST WORD) (* Day of year when DST starts) (TIMEENDDST WORD) (* Day of year when DST stops) ) (BLOCKRECORD TIMEBODY ((NIL 2 WORD) (TIMEVALUEHI WORD) (TIMEVALUELO WORD]) ) (DECLARE%: EVAL@COMPILE (RPAQQ \TIMESOCKET 8) (RPAQQ \XIPT.EXCHANGE 4) (RPAQQ \EXTYPE.TIME 1) (RPAQQ \XIPT.OLDTIME 123) (RPAQQ \TIMEVERSION 2) (RPAQQ \TIMEOP.TIMEREQUEST 1) (RPAQQ \TIMEOP.TIMERESPONSE 2) (RPAQQ \NSTIMELENGTH 24) (CONSTANTS \TIMESOCKET \XIPT.EXCHANGE \EXTYPE.TIME \XIPT.OLDTIME \TIMEVERSION \TIMEOP.TIMEREQUEST \TIMEOP.TIMERESPONSE \NSTIMELENGTH) ) (DECLARE%: EVAL@COMPILE (RPAQQ \PUPSOCKET.MISCSERVICES 4) (RPAQQ \PT.ALTOTIMEREQUEST 134) (RPAQQ \PT.ALTOTIMERESPONSE 135) (RPAQQ \PUPOVLEN 22) (RPAQQ \TIMEPUPLENGTH 10) (CONSTANTS \PUPSOCKET.MISCSERVICES \PT.ALTOTIMEREQUEST \PT.ALTOTIMERESPONSE \PUPOVLEN \TIMEPUPLENGTH) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \BeginDST \EndDST \TimeZoneComp) ) ) (* PUPIDSERVER) (DEFINEQ (\PUP.ID.SERVER [LAMBDA (TRACEFLG) (* bvm%: "28-OCT-83 15:59") (* * Server that provides pup numbers given NS numbers.  Works off alist NS.TO.PUP.ALIST) (RESETLST (PROG ((SOC (OPENNSOCKET \NS.WKS.PUPLOOKUP T)) XIP EVENT) (RESETSAVE NIL (LIST 'CLOSENSOCKET SOC)) (COND (TRACEFLG (printout TRACEFLG "Pup ID server started at " (DATE) T))) RETRY [COND ((NLISTP NS.TO.PUP.ALIST) (COND (NS.TO.PUP.FILE (SETQ NS.TO.PUP.ALIST (READFILE NS.TO.PUP.FILE))) ((GETD 'NetDirNameLookup) (* For use with GATEWAY, we are ok) ) (T (ERROR "NS.TO.PUP.ALIST is empty, and there is no NS.TO.PUP.FILE to read from" ) (GO RETRY] (SETQ EVENT (NSOCKETEVENT SOC)) LP (COND ((SETQ XIP (GETXIP SOC)) (\HANDLE.PUP.LOOKUP SOC XIP TRACEFLG)) (T (AWAIT.EVENT EVENT))) (GO LP]) (\HANDLE.PUP.LOOKUP [LAMBDA (NSOC XIP TRACEFILE) (* bvm%: "12-Jun-84 15:14") (* * Handle requests for Pup lookup from NS hosts.  This is designed to be called both from withing GATEWAY and in the standalone  PUPIDSERVER) (DECLARE (GLOBALVARS \10MBLOCALNDB)) (PROG (BUF PUP# NSHOST#) (COND ((OR (NEQ (fetch (XIP XIPTYPE) of XIP) \XIPT.PUPLOOKUP) (NEQ (fetch (PACKETEXCHANGEXIP PACKETEXCHANGETYPE) of XIP) \EXTYPE.REQUEST)) (RELEASE.XIP XIP)) (T (SETQ NSHOST# (\LOADNSHOSTNUMBER (fetch (PACKETEXCHANGEXIP PACKETEXCHANGEBODY) of XIP))) (* Note%: The following only handles 32 bit host numbers at the moment!) [COND [(SETQ PUP# (\GET.PUP#.FROM.NS# NSHOST#)) [AND \10MBLOCALNDB (push (ffetch (NDB NDBTRANSLATIONS) of \10MBLOCALNDB) (CONS (fetch PUPHOST# of PUP#) (LIST NSHOST# (CLOCK 0] (* Add pup/ns translation to our table) (replace (XIP XIPLENGTH) of XIP with (IPLUS \XIPOVLEN (UNFOLD 6 BYTESPERWORD))) (* Data%: 2 words for ID, 1 for PACKETEXCHANGETYPE, 1 for PUP#.  That's only 4, but Mesa 10.0 seems to want 6 words, the last 2 being zero) (replace (PACKETEXCHANGEXIP PACKETEXCHANGETYPE) of XIP with \EXTYPE.RESPONSE) (SETQ BUF (fetch (PACKETEXCHANGEXIP PACKETEXCHANGEBODY) of XIP)) (\PUTBASE BUF 0 PUP#) (\PUTBASE BUF 1 0) (\PUTBASE BUF 2 0) (COND (TRACEFILE (PRINTNSHOSTNUMBER NSHOST# TRACEFILE) (printout TRACEFILE " = " (PORTSTRING PUP#) T] (T (RETURN (RELEASE.XIP XIP))) (NIL (* This is what to do for a negative response.  However, the current state of the world is that we can't reliably give negative  responses (someone else might know better)%, so skip this) (replace (PACKETEXCHANGEXIP PACKETEXCHANGETYPE) of XIP with \EXTYPE.NEGATIVE) (replace (XIP XIPLENGTH) of XIP with (IPLUS \XIPOVLEN (UNFOLD 3 BYTESPERWORD))) (COND (TRACEFILE (printout TRACEFILE "No pup number for ") (PRINTNSHOSTNUMBER NSHOST# TRACEFILE) (TERPRI TRACEFILE] (SWAPXIPADDRESSES XIP) (replace (XIP XIPSOURCEHOST) of XIP with (\LOCALNSHOSTNUMBER)) (replace (XIP XIPSOURCENET) of XIP with (\LOCALNSNETNUMBER)) (replace EPREQUEUE of XIP with 'FREE) (SENDXIP NSOC XIP]) (\GET.PUP#.FROM.NS# [LAMBDA (NSHOST#) (* ; "Edited 17-Apr-87 11:36 by raf") (CDR (SASSOC NSHOST# NS.TO.PUP.ALIST]) ) (RPAQ? NS.TO.PUP.ALIST NIL) (RPAQ? NS.TO.PUP.FILE NIL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS NS.TO.PUP.ALIST NS.TO.PUP.FILE) ) (FILESLOAD (LOADCOMP) LLNS) ) (PUTPROPS MINISERVE COPYRIGHT ("Venue & Xerox Corporation" 1984 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1390 1728 (STARTMINISERVER 1400 . 1726)) (1729 5723 (\NSTIMESERVER 1739 . 2261) ( \HANDLE.NS.TIMEREQ 2263 . 5721)) (5724 7649 (\PUPTIMESERVER 5734 . 6468) (\HANDLE.PUP.ALTOTIMEREQ 6470 . 7647)) (10557 15633 (\PUP.ID.SERVER 10567 . 11965) (\HANDLE.PUP.LOOKUP 11967 . 15456) ( \GET.PUP#.FROM.NS# 15458 . 15631))))) STOP \ No newline at end of file diff --git a/library/MSANALYZE b/library/MSANALYZE new file mode 100644 index 00000000..0a5d211d --- /dev/null +++ b/library/MSANALYZE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Aug-90 13:13:24" |{PELE:MV:ENVOS}LIBRARY>MSANALYZE.;5| 62596 changes to%: (VARS MSANALYZECOMS) previous date%: "12-Jun-90 17:27:56" |{PELE:MV:ENVOS}LIBRARY>MSANALYZE.;4|) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. The following program was created in 1982 but has not been published within the meaning of the copyright law, is furnished under license, and may not be used, copied and/or disclosed except in accordance with the terms of said license. ") (PRETTYCOMPRINT MSANALYZECOMS) (RPAQQ MSANALYZECOMS [(PROP FILETYPE MSANALYZE) (COMS (FNS VARS FREEVARS CALLS COLLECTFNDATA CALLS3) (VARS MSMACROPROPS (NOPACKCALLSFLG)) (BLOCKS (CALLS CALLS COLLECTFNDATA CALLS3 (LOCALFREEVARS CALLSDATA) (NOLINKFNS . T) (GLOBALVARS INVISIBLEVARS COMPILEUSERFN NOPACKCALLSFLG LAMBDASPLST MSRECORDTRANFLG)) (NIL VARS FREEVARS (LOCALVARS . T))) (DECLARE%: EVAL@COMPILE (VARS MS.VERB.TO.NOTICED) DONTCOPY (MACROS MSVBNOTICED))) [COMS (FNS ALLCALLS MSINITFNDATA MSPRGE MSPRGMACRO MSPRGCALL MSBINDVAR MSPRGRECORD MSPRGERR MSPRGTEMPLATE1 MSPRGTEMPLATE MSPRGLAMBDA MSPRGLST ADDTO NLAMBDAFNP MSPRGDWIM MSDWIMTRAN) (E (MAPC MSFNDATA (FUNCTION RPLACD))) (VARS MSFNDATA MSERRORFN (MSRECORDTRANFLG)) (ADDVARS (INVISIBLEVARS $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 $$17)) (DECLARE%: DONTCOPY (MACROS INCLISP LTEMPLATE)) (BLOCKS (ALLCALLS ALLCALLS ADDTO MSBINDVAR MSDWIMTRAN MSPRGCALL MSPRGDWIM MSPRGE MSPRGMACRO MSPRGERR MSPRGLAMBDA MSPRGLST MSPRGRECORD MSPRGTEMPLATE MSPRGTEMPLATE1 NLAMBDAFNP (NOLINKFNS . T) (LOCALFREEVARS FNNAME ERRORS FNDEF INCLISP ONLYRELS PARENTCONTEXT TOPVARS PARENT EACHTIME VARS) (GLOBALVARS CLISPARRAY MSERRORFN MSRECORDTRANFLG MSFNDATA INVISIBLEVARS CLISPARRAY MSTEMPLATES USERTEMPLATES MSRECORDTRANFLG NLAMA NLAML DWIMFLG CLISPTRANFLG DWIMESSGAG) (NOLINKFNS . T)) (NIL MSINITFNDATA NLAMBDAFNP MSPRGDWIM (LOCALVARS . T) (GLOBALVARS NLAMA NLAML MSFNDATA DWIMFLG DWIMESSGAG))) (P (PUTDQ? MSWORDNAME (LAMBDA (X) X] (COMS (VARS (MSTEMPLATES (HASHARRAY 160)) (USERTEMPLATES (HASHARRAY 10))) (FILEVARS INITIALTEMPLATES) (* ;;; "INITIALTEMPLATES is not needed after loading up") [P (MAPC INITIALTEMPLATES (FUNCTION (LAMBDA (X) (MAPC (CDR X) (FUNCTION (LAMBDA (Y) (PUTHASH Y (CAR X) MSTEMPLATES] (DECLARE%: EVAL@COMPILE DONTCOPY (PROP MACRO LTEMPLATE))) (COMS (FNS MSFINDP) (BLOCKS (MSFINDP MSFINDP]) (PUTPROPS MSANALYZE FILETYPE :COMPILE-FILE) (DEFINEQ (VARS (LAMBDA (FN USEDATABASE) (* lmm%: 29-DEC-75 23 22) (CDR (CALLS FN USEDATABASE T)))) (FREEVARS (LAMBDA (FN USEDATABASE) (* lmm%: 5-DEC-75 11 8) (CADDR (CALLS FN USEDATABASE 'FREEVARS)))) (CALLS [LAMBDA (EXPR USEDATABASE VARSFLG) (* ; "Edited 12-Jun-90 17:25 by teruuchi") (* ;  "This FNS is for the User Interface Function in MSANALYZE(MasterScope)") (* ;  "Edited by Tomoru Teruuchi(12-June-90 : for AR#10020)") (PROG (FREES (GLOBALS NIL) FNDEF FLG) [COND ((AND USEDATABASE (LITATOM EXPR) (GETD 'UPDATEFN)) (UPDATEFN EXPR NIL 'ERROR) [SETQ FREES (GETRELATION EXPR '(USE FREELY] [SETQ FREES (SUBSET FREES (FUNCTION (LAMBDA (VAR) (* ;  "This Function is The Predicate whether the variable is global or not.") (if (OR (FMEMB VAR GLOBALVARS) (EQ (GETPROP VAR 'GLOBALVAR) T)) then (pushnew GLOBALS VAR) NIL else T] (* ;  "Edited by TT (Date : 8-May-1990)") (RETURN (LIST [AND (NOT VARSFLG) (GETRELATION EXPR '(CALL NOTERROR] (AND (NEQ VARSFLG 'FREEVARS) (GETRELATION EXPR 'BIND)) FREES GLOBALS] GETDLP (SETQ FNDEF (COND [(LITATOM EXPR) (OR (GETD (OR (GETP EXPR 'BROKEN) EXPR)) (GETP EXPR 'EXPR) (AND (NEQ EXPR (SETQ EXPR (FNCHECK EXPR NIL NIL T))) (GO GETDLP] (T EXPR))) (RETURN (COND ((NULL FNDEF) NIL) ((SUBRP FNDEF) NIL) ((CCODEP FNDEF) (SETQ FNDEF (CALLSCCODE FNDEF)) [OR NOPACKCALLSFLG (for X on (CAR FNDEF) do (FRPLACA X (PACK* '; (CAR X) ';] (FRPLACA (CDR FNDEF) (NCONC (CADR FNDEF) (CAR FNDEF))) (SETQ FLG) (CALLS3 (CDDR FNDEF)) (CALLS3 (CDDDR FNDEF)) (CDR FNDEF)) [(EXPRP FNDEF) (* Note that EXPR can be a piece of a function definition, and calls will still  work.) (RESETVARS ((MSRECORDTRANFLG T)) (RETURN (PROG (CALLSDATA LAMFLG) [COND ((FMEMB (CAR FNDEF) LAMBDASPLST) (SETQ LAMFLG T) (COND ((OR (AND (EQ (CAR (CADDR FNDEF)) '*) (EQ (CADR (CADDR FNDEF)) 'DECLARATIONS%:)) (EQ (CAR (CADDR FNDEF)) 'CLISP%:)) (MSPRGDWIM FNDEF EXPR FNDEF))) (SELECTQ (CAR FNDEF) ([LAMBDA NLAMBDA] NIL) (SETQ FNDEF (OR (AND COMPILEUSERFN (APPLY* COMPILEUSERFN NIL FNDEF)) FNDEF] (SETQ CALLSDATA (ALLCALLS FNDEF LAMFLG [UNION (CONSTANT (MSVBNOTICED 'USE 'FREELY)) (AND (NEQ VARSFLG 'FREEVARS) (UNION (CONSTANT (MSVBNOTICED 'BIND)) (AND (NULL VARSFLG) (CONSTANT (MSVBNOTICED 'CALL 'NOTERROR] EXPR T)) [SETQ FREES (NCONC FREES (COLLECTFNDATA (CONSTANT (MSVBNOTICED 'USE 'FREELY] [SETQ FREES (SUBSET FREES (FUNCTION (LAMBDA (VAR) (if (OR (FMEMB VAR GLOBALVARS) (EQ (GETPROP VAR 'GLOBALVAR) T)) then (pushnew GLOBALS VAR) NIL else T] (* ;  "Edited by TT (Date : 8-May-1990)") (RETURN (LIST [COLLECTFNDATA (CONSTANT (MSVBNOTICED 'CALL 'NOTERROR] [COLLECTFNDATA (CONSTANT (MSVBNOTICED 'BIND] FREES GLOBALS] (T '?]) (COLLECTFNDATA (LAMBDA (LST) (* lmm "21-DEC-78 22:56") (COND ((NLISTP LST) (CDR (FASSOC LST CALLSDATA))) (T (PROG (VAL) (for X in LST do (SETQ VAL (UNION (COLLECTFNDATA X) VAL))) (RETURN VAL)))))) (CALLS3 (LAMBDA (LST) (* lmm " 6-JUL-78 00:23") (* lmm%: 13-DEC-75 4 51) (PROG (FLG) (for X on (CAR LST) do (OR (NOT (FMEMB (CAR X) INVISIBLEVARS)) (SETQ FLG (FRPLACA X)))) (COND (FLG (FRPLACA LST (DREMOVE NIL (CAR LST)))))))) ) (RPAQQ MSMACROPROPS (ALTOMACRO DMACRO BYTEMACRO MACRO)) (RPAQQ NOPACKCALLSFLG NIL) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: CALLS CALLS COLLECTFNDATA CALLS3 (LOCALFREEVARS CALLSDATA) (NOLINKFNS . T) (GLOBALVARS INVISIBLEVARS COMPILEUSERFN NOPACKCALLSFLG LAMBDASPLST MSRECORDTRANFLG)) (BLOCK%: NIL VARS FREEVARS (LOCALVARS . T)) ) (DECLARE%: EVAL@COMPILE (RPAQQ MS.VERB.TO.NOTICED ((BIND (NIL BIND ARG)) [CALL (DIRECTLY CALL EFFECT PREDICATE NLAMBDA) (EFFECT EFFECT) (INDIRECTLY APPLY STACK) (NIL CALL ERROR APPLY EFFECT PREDICATE NLAMBDA STACK) (NOTERROR APPLY CALL EFFECT PREDICATE NLAMBDA STACK) (PREDICATE PREDICATE) (TESTING PREDICATE) (VALUE CALL) (NLAMBDA NLAMBDA] (CREATE (NIL CREATE)) (DECLARE (LOCALVARS LOCALVARS) (NIL LOCALVARS SPECVARS) (SPECVARS SPECVARS)) (FETCH (NIL FETCH)) (REFERENCE (FIELDS FETCH) (FREELY REFFREE) (CL:LOCALLY REF) (NIL REFFREE REF)) (REPLACE (NIL REPLACE)) (SET (FIELDS FETCH REPLACE) (FREELY SETFREE) (CL:LOCALLY SET) (NIL SETFREE SET)) (SMASH (FIELDS FETCH REPLACE) (FREELY SMASHFREE) (CL:LOCALLY SMASH) (NIL SMASHFREE SMASH)) (TEST (FREELY TESTFREE) (CL:LOCALLY TEST) (NIL TESTFREE TEST)) (USE (FIELDS FETCH REPLACE) (FREELY SETFREE SMASHFREE REFFREE TESTFREE) (I.S.OPRS CLISP) (INDIRECTLY LOCALFREEVARS) (CL:LOCALLY SET SMASH REF TEST) (NIL SETFREE SET SMASHFREE SMASH REFFREE REF TESTFREE TEST) (PREDICATE TEST TESTFREE) (PROPNAMES PROP) (RECORDS RECORD CREATE) (TESTING TEST TESTFREE) (VALUE SMASH SMASHFREE REF REFFREE) (TYPE TYPE)))) DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS MSVBNOTICED MACRO [OPENLAMBDA (VERB MOD) (CDR (ASSOC MOD (CDR (ASSOC VERB MS.VERB.TO.NOTICED]) ) ) (DEFINEQ (ALLCALLS [LAMBDA (FNDEF LAMFLG ONLYRELS FNNAME INTERNALFLG EACHTIME) (* ; "Edited 21-Apr-88 16:31 by jrb:") (LET (VARS TOPVARS INCLISP ERRORS (PARENT FNDEF) (NOSPELLFLG T)) (DECLARE (CL:SPECIAL NOSPELLFLG)) (MSINITFNDATA) [COND (LAMFLG (MSPRGLAMBDA FNDEF 'ARG)) (T (MSPRGE FNDEF NIL 'RETURN] (COND (INTERNALFLG MSFNDATA) (T (for X in MSFNDATA when (CDR X) collect (CONS (CAR X) (CDR X]) (MSINITFNDATA (LAMBDA NIL (* MSFNDATA is an association list of the "noticed" types, e.g.  CALL, BIND, etc. -- the FRPLACD resets the pointer) (for Y in MSFNDATA do (FRPLACD Y NIL)))) (MSPRGE (LAMBDA (EXPR SUPEXPR EVALCONTEXT) (* lmm "27-May-86 04:44") (* ;; "analyzes EXPR; SUPEXPR is the parent expression and is used in the SHOWUSE case where we are printing occurrances of various things rather than updating data base; EVALCONTEXT is a type of reference for this expression from the template: SMASH etc") (PROG (TEM CALLED CLISP) (COND ((NLISTP EXPR) (RETURN (COND ((AND (LITATOM EXPR) EXPR (NEQ EXPR T) (NOT (FMEMB EXPR INVISIBLEVARS))) (* ; "A variable reference") (COND ((OR (FMEMB EXPR VARS) (SOME TOPVARS (FUNCTION (LAMBDA (Z) (* ;  "bound higher up in the function but but used in a functional argument") (COND ((FMEMB EXPR Z) (ADDTO 'LOCALFREEVARS EXPR SUPEXPR) T)))))) (* ;  "Things were added to VARS only if they were 'noticeable'") (SELECTQ EVALCONTEXT ((SMASH TEST SET) (ADDTO EVALCONTEXT EXPR SUPEXPR)) (CHANGE (ADDTO 'SET EXPR SUPEXPR)) (ADDTO 'REF EXPR SUPEXPR))) (T (SELECTQ EVALCONTEXT (SMASH (ADDTO 'SMASHFREE EXPR SUPEXPR)) (TEST (ADDTO 'TESTFREE EXPR SUPEXPR)) ((SET CHANGE) (ADDTO 'SETFREE EXPR SUPEXPR)) (ADDTO 'REFFREE EXPR SUPEXPR))))))))) (COND ((EQ EVALCONTEXT 'SET) (* ; "in a 'SET' context, but not a variable") (MSPRGERR PARENT))) (COND ((LISTP (SETQ CALLED (CAR EXPR))) (MSPRGLAMBDA CALLED NIL (SELECTQ EVALCONTEXT ((TEST EFFECT SMASH) EVALCONTEXT) NIL)) (SELECTQ (CAR CALLED) (LAMBDA (MSPRGLST (CDR EXPR) EXPR)) NIL) (RETURN))) (COND ((SETQ TEM (LTEMPLATE CALLED)) (RETURN (MSPRGTEMPLATE EXPR TEM EVALCONTEXT)))) (COND ((NOT (FGETD (OR (GETP CALLED 'BROKEN) CALLED))) (COND ((AND DWIMFLG (SETQ TEM (GETPROP CALLED 'CLISPWORD))) (* E.G. IF, FOR, etc.) (SETQ CLISP (MSDWIMTRAN EXPR)) (RETURN (COND (CLISP (COND (TEM (SELECTQ (CAR TEM) (RECORDTRAN (OR (MSPRGRECORD EXPR EVALCONTEXT) MSRECORDTRANFLG (RETURN)) (* optionally also look at translation) ) (IFWORD) (CHANGETRAN (MSPRGE (CADR EXPR) EXPR 'CHANGE)) (for X in EXPR when (AND (LITATOM X) (EQ (CAR TEM) (CAR (GETPROP X 'CLISPWORD)))) do (ADDTO 'CLISP X EXPR))))) (* Analyze the CLISP translation) (PROG ((INCLISP (INCLISP EXPR))) (MSPRGE CLISP EXPR EVALCONTEXT))) ((OR (NULL (GETPROP (CAR EXPR) 'CLISPWORD)) (NEQ (CAR EXPR) CALLED)) (RETURN (MSPRGE EXPR SUPEXPR EVALCONTEXT))) (T (SELECTQ (CAR TEM) (RECORDTRAN (MSPRGRECORD EXPR EVALCONTEXT)) (CHANGETRAN (MSPRGE (CADR EXPR) EXPR 'CHANGE) (MSPRGLST (CDDR EXPR) EXPR)) (PROGN (* CLISP word wouldn't DWIMIFY) (MSPRGCALL CALLED EXPR EVALCONTEXT) (MSPRGERR EXPR) (MSPRGLST (CDR EXPR) EXPR))))))) ((SETQ TEM (CL:MACRO-FUNCTION CALLED)) (LET ((ME (CL:MACROEXPAND EXPR))) (COND ((AND (NOT (EQUAL ME EXPR)) (NOT (EQUAL ME INCLISP))) (MSPRGCALL (CAR EXPR) EXPR EVALCONTEXT) (PROG ((INCLISP (INCLISP EXPR)) (EXPR EXPR)) (MSPRGE ME EXPR 'EVAL)) (RETURN T)))))))) (COND ((NLAMBDAFNP CALLED) (ADDTO 'NLAMBDA CALLED EXPR) (COND ((AND MSMACROPROPS (SETQ TEM (GETMACROPROP CALLED MSMACROPROPS)) (MSPRGMACRO EXPR TEM EVALCONTEXT)) (RETURN))) (MSPRGCALL CALLED EXPR EVALCONTEXT)) (T (* ; "normal lambda function call") (MSPRGCALL CALLED EXPR EVALCONTEXT) (MSPRGLST (CDR EXPR) EXPR 'EVAL)))))) (MSPRGMACRO (LAMBDA (FORM MACDEF CONTEXT) (* lmm "13-DEC-82 23:45") (PROG ((ME (MACROEXPANSION FORM MACDEF))) (COND ((AND (NOT (EQUAL ME FORM)) (NOT (EQUAL ME INCLISP))) (MSPRGCALL (CAR FORM) FORM CONTEXT) (PROG ((INCLISP (INCLISP FORM)) (EXPR FORM)) (MSPRGE ME FORM 'EVAL)) (RETURN T)))))) (MSPRGCALL (LAMBDA (FN PRNT CONTEXT) (* lmm "22-DEC-78 12:57") (ADDTO (COND (TOPVARS 'APPLY) (T (SELECTQ CONTEXT (TEST 'PREDICATE) (EFFECT 'EFFECT) 'CALL))) FN PRNT))) (MSBINDVAR (LAMBDA (VAR TYPE EXPR) (* lmm " 6-JUL-78 00:23") (COND ((AND VAR (LITATOM VAR) (NEQ VAR T)) (COND ((NOT (FMEMB VAR INVISIBLEVARS)) (ADDTO (OR TYPE 'BIND) VAR (OR EXPR PARENT)))) (SETQ VARS (CONS VAR VARS))) (T (MSPRGERR (COND ((LITATOM VAR) (OR EXPR PARENT)) (T VAR))))))) (MSPRGRECORD [LAMBDA (PRNT CNTXT) (* ; "Edited 8-Apr-88 14:49 by jrb:") (* ANALYZE RECORD EXPRESSION PRNT -  RETURN NIL IF ANALYZED SUCCESSFULLY) (PROG (Z) (MSPRGTEMPLATE PRNT (SELECTQ (CAR PRNT) ((create CREATE) (ADDTO 'CREATE (CADR PRNT) PRNT) (SETQ Z (CDDR PRNT)) [while Z do (COND ([EQ 'RECORDTRAN (CAR (GETPROP (CAR Z) 'CLISPWORD] (* e.g. USING or COPYING) (MSPRGE (CADR Z) PRNT (SELECTQ (CAR Z) ((smashing SMASHING) 'SMASH) NIL)) (SETQ Z (CDDR Z))) ((EQ (CADR Z) '_) (* If dwimified correctly, the fields should be separated by _'s) (ADDTO 'REPLACE (CAR Z) PRNT) (MSPRGE (CADDR Z) PRNT) (SETQ Z (CDDDR Z))) ((EQ (CAAR Z) 'SETQ) (* partially dwimified) (ADDTO 'REPLACE (CADAR Z) PRNT) (MSPRGE (CADDAR Z) PRNT) (SETQ Z (CDR Z))) (T (* shouldn't happen, but) (MSPRGE (CAR Z) PRNT) (SETQ Z (CDR Z] (RETURN)) ((fetch FETCH ffetch FFETCH) [LET [(OF? (OR (EQ (CL:THIRD PRNT) 'OF) (EQ (CL:THIRD PRNT) 'of] (COND [(EQ CNTXT 'CHANGE) `(NIL (IF LISTP (BOTH (NIL |..| FETCH (BOTH FETCH REPLACE)) (|..| RECORD NIL)) (BOTH FETCH REPLACE)) ,@(if OF? then '(NIL EVAL |..| PPE) else '(EVAL |..| PPE] (T `(NIL (IF LISTP (BOTH (NIL |..| FETCH) (|..| RECORD NIL)) FETCH) ,@(if OF? then '(NIL EVAL |..| PPE) else '(EVAL |..| PPE]) ((REPLACE /REPLACE replace /replace freplace FREPLACE) (LET* [[OF? (OR (EQ (CL:THIRD PRNT) 'OF) (EQ (CL:THIRD PRNT) 'of] (WITHSLOT (if OF? then (CL:FIFTH PRNT) else (CL:FOURTH PRNT))) (WITH? (OR (EQ WITHSLOT 'WITH) (EQ WITHSLOT 'with] `(NIL (IF LISTP (BOTH (NIL |..| FETCH REPLACE) (|..| RECORD NIL)) REPLACE) ,@(if OF? then '(NIL) else NIL) SMASH ,@(if WITH? then '(NIL) else NIL) EVAL))) ((type? TYPE?) '(CLISP RECORD EVAL . PPE)) ((initrecord INITRECORD) '(CLISP RECORD . PPE)) ((WITH with) [COND ((SETQ Z (RECORDFIELDNAMES (CADR PRNT))) (ADDTO 'RECORD (CADR PRNT) PRNT) (MSPRGE (CADDR PRNT) PRNT) (for X in (PROG1 [for X on MSFNDATA when (FMEMB (CAAR X) '(SETFREE TESTFREE REFFREE)) collect (LIST (CAR X) (RPLACA X (LIST (CAAR X] (PROG [ONLYRELS (EACHTIME (AND EACHTIME (for X inside (PROGN EACHTIME) when [NOT (FMEMB X '(SETFREE TESTFREE REFFREE] collect X] (MSPRGLST (CDDDR PRNT) PRNT))) do (for Y in (PROG1 (CDR (CAADR X)) (RPLACA (CADR X) (CAR X))) do (ADDTO (COND ((FMEMB Y Z) (SELECTQ (CAAR X) (SETFREE 'REPLACE) 'FETCH)) (T (CAAR X))) Y PRNT))) (RETURN)) (T '(RECORD |..| EVAL]) (RETURN T]) (MSPRGERR (LAMBDA (EXPR) (* lmm "21-DEC-78 22:44") (SETQ ERRORS T) (ADDTO 'ERROR MSERRORFN EXPR))) (MSPRGTEMPLATE1 [LAMBDA (X TEMPLATE) (* ; "Edited 19-Feb-88 16:56 by jrb:") (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE ((EVAL SMASH TEST EFFECT SET) (MSPRGE X PARENT TEMPLATE)) ((FUNCTION FUNCTIONAL) (* This is a functional arg to something -  the marker FUNCTIONAL means that it will be a separate function while  FUNCTION is reserved for those things which compile open -  e.g. MAPC is marked (EVAL FUNCTION FUNCTION . PPE) while SORT is marked  (EVAL FUNCTIONAL . PPE)) [OR (COND ((AND (LISTP X) (NULL (CDDR X))) (COND ((EQ (CAR X) 'F/L) (MSPRGDWIM X FNNAME FNDEF))) (SELECTQ (CAR X) ((FUNCTION QUOTE) (MSPRGTEMPLATE (CADR X) (COND ((LISTP (CADR X)) (SELECTQ TEMPLATE (FUNCTIONAL '(REMOTE LAMBDA)) 'LAMBDA)) ((OR (NEQ (CAR X) 'FUNCTION) (EQ TEMPLATE 'FUNCTIONAL)) '(REMOTE CALL)) (T 'CALL)) X) T) NIL))) (EQ X T) (NULL X) (PROGN (* arbitrary expression as  functional argument) (ADDTO 'ERROR 'apply PARENT) (MSPRGE X PARENT 'FUNCTIONAL]) (STACK (* arg to stack fn, e.g.  RETFROM) [OR (AND (LISTP X) (SELECTQ (CAR X) ((FUNCTION QUOTE) (ADDTO 'STACK (CADR X) PARENT) T) NIL)) (PROGN (ADDTO 'ERROR 'stackfn PARENT) (MSPRGE X PARENT 'EVAL]) (PROP (COND ((AND (LISTP X) (EQ (CAR X) 'QUOTE)) (for Y inside (CADR X) do (ADDTO 'PROP Y PARENT))) (T (MSPRGE X PARENT TEMPLATE)))) (NIL (* not used) NIL) (RETURN (* this is sometimes the value of  PARENT expression) (MSPRGTEMPLATE1 X (SELECTQ PARENTCONTEXT ((TEST EFFECT) PARENTCONTEXT) 'EVAL))) (TESTRETURN (* if PARENT is tested, then so is  this) (MSPRGTEMPLATE1 X (SELECTQ PARENTCONTEXT (TEST PARENTCONTEXT) 'EVAL))) (BIND (MSBINDVAR X)) (LAMBDA (MSPRGLAMBDA X)) (PPE (* paren error if not NIL) (COND (X (MSPRGERR PARENT) (MSPRGLST X PARENT)))) (CALL (MSPRGCALL X PARENT PARENTCONTEXT)) (EVALQT [COND ((EQ (CAR X) 'QUOTE) (MSPRGTEMPLATE (CADR X) '(REMOTE EVAL) PARENT)) (T (MSPRGE X PARENT 'EVAL]) (ADDTO TEMPLATE X PARENT T))) (T (SELECTQ (CAR TEMPLATE) (IF [PROG ((EXPR X)) (DECLARE (SPECVARS EXPR)) (MSPRGTEMPLATE1 X (COND ((COND ((LISTP (CADR TEMPLATE)) (* ASSERT%: ((REMOTE EVAL) EXPR)) (EVAL (CADR TEMPLATE))) (T (APPLY* (CADR TEMPLATE) X))) (CADDR TEMPLATE)) (T (CADDDR TEMPLATE]) (|..| [COND [(AND (CADR TEMPLATE) (NULL (CDDR TEMPLATE))) (* Special case to handle most  common cases) (MAPC X (FUNCTION (LAMBDA (X) (MSPRGTEMPLATE1 X (CADR TEMPLATE] (T (FRPTQ (IDIFFERENCE (LENGTH X) (LENGTH (CDDR TEMPLATE))) (MSPRGTEMPLATE1 (CAR X) (CADR TEMPLATE)) (SETQ X (CDR X))) (MSPRGTEMPLATE1 X (CDDR TEMPLATE]) (MACRO (ADDTO 'CALL (CAR X) PARENT) (MSPRGMACRO X (CDR TEMPLATE))) (BOTH (MSPRGTEMPLATE1 X (CADR TEMPLATE)) (MSPRGTEMPLATE1 X (CADDR TEMPLATE))) (@ [PROG ((EXPR X)) (DECLARE (SPECVARS EXPR)) (MSPRGTEMPLATE1 (EVAL (CADR TEMPLATE)) (EVAL (CADDR TEMPLATE]) (REMOTE (PROG (VARS (TOPVARS (CONS VARS TOPVARS))) (MSPRGTEMPLATE1 X (CADR TEMPLATE)))) (KEYWORDS (* ;; "KEYWORDS list of keys...") (* ;; "Specifies list of legal keywords") (* ;; "(FOO (LAMBDA... (BAR :BAZ DREK))) is recorded in the database as") (* ;; "(ADDTO 'KEYCALLS '(BAR . :BAZ) '(BAR :BAZ DREK))") (* ;;  "i.e. there is a table for each keyword relating functions that call functions specifying them.") [LET [(LEGAL-KEYS (OR (CDR TEMPLATE) (GETRELATION (CAR PARENT) 'KEYACCEPT] (while X bind (ALLOW-OTHER-KEYS _ (MEMQ '&ALLOW-OTHER-KEYS LEGAL-KEYS)) KEYSUSED? do (if (AND (CL:KEYWORDP (CAR X)) (OR ALLOW-OTHER-KEYS (MEMQ (CAR X) LEGAL-KEYS))) then (ADDTO 'KEYSPECIFY (CAR X) PARENT) (SETQ KEYSUSED? T) else (* ; "log bogus keyword as ppe") (MSPRGERR PARENT)) (pop X) (if X then (MSPRGTEMPLATE1 (CAR X) 'EVAL) (pop X) else (MSPRGERR PARENT) (* ; "log no value for keyword as ppe") ) finally (if KEYSUSED? then (ADDTO 'KEYCALL (CAR PARENT) PARENT]) (COND ((LISTP X) (MSPRGTEMPLATE1 (CAR X) (CAR TEMPLATE)) (MSPRGTEMPLATE1 (CDR X) (CDR TEMPLATE]) (MSPRGTEMPLATE (LAMBDA (PARENT TEMPLATE PARENTCONTEXT) (* lmm "23-Jul-86 00:15") (BLOCK) (*  "Masterscope should block every once and a while. This is one place to do it.") (PROG ((VARS VARS) TEM) (COND ((EQ TEMPLATE 'MACRO) (COND ((SETQ TEM (GETMACROPROP (CAR PARENT) MSMACROPROPS)) (MSPRGMACRO PARENT TEM)) (T (MSPRGTEMPLATE1 PARENT '(CALL .. EVAL))))) (T (MSPRGTEMPLATE1 PARENT TEMPLATE)))))) (MSPRGLAMBDA [LAMBDA (EXPR FLG TYPE) (* ; "Edited 3-Jun-88 10:23 by jrb:") (SELECTQ (CAR (LISTP EXPR)) (CL:LAMBDA [LET ((PARENT EXPR) (PARENTCONTEXT TYPE) (VARS VARS)) [bind (ARGS _ (CADR EXPR)) ARG (EVALCOUNT _ 0) KEYS? KEYLIST while ARGS do (SETQ ARG (pop ARGS)) (* ;; "We can be in one of two states - keyword scanning or not") [COND [(CL:SYMBOLP ARG) (* ;; "Check and see if it's a keyword thingy") (COND ((EQ ARG '&KEY) (SETQ KEYS? T)) [(FMEMB ARG CL:LAMBDA-LIST-KEYWORDS) (SETQ KEYS? NIL) (if (EQ ARG '&ALLOW-OTHER-KEYS) then (ADDTO 'KEYACCEPT (CAR (push KEYLIST ' &ALLOW-OTHER-KEYS )) (CADR EXPR] (T (if KEYS? then (ADDTO 'KEYACCEPT (CAR (push KEYLIST (MAKE-KEYWORD ARG))) (CADR EXPR)) else (CL:INCF EVALCOUNT)) (MSBINDVAR ARG] [(CL:CONSP ARG) (* ;  "Strangely enough they all EVAL their CADRs.") (MSPRGTEMPLATE1 (CADR ARG) 'EVAL) (if KEYS? then (if (CL:SYMBOLP (CAR ARG)) then (MSBINDVAR (CAR ARG)) (ADDTO 'KEYACCEPT [CAR (push KEYLIST (MAKE-KEYWORD (CAR ARG] (CADR EXPR)) else (ADDTO 'KEYACCEPT [CAR (push KEYLIST (MAKE-KEYWORD (CAAR ARG] (CADR EXPR)) (MSBINDVAR (CADAR ARG))) else (CL:IF (CL:SYMBOLP (CAR ARG)) (MSBINDVAR (CAR ARG)) (MSBINDVAR (CADAR ARG))) (OR (NULL (CDDR ARG)) (NOT (CL:SYMBOLP (CADDR ARG))) (MSBINDVAR ARG] (T (MSPRGTEMPLATE1 ARG 'PPE] finally (if KEYLIST then (* ;;  "Look at old template; if there isn't one or it looks like one we put out") (* ;; "(of the form (EVAL* KEYWORDS keys...))") (* ;;  "replace it with a new template (and somehow mark everything that calls FNNAME for reanalysis") [LET ((OLDTEMP (GETTEMPLATE FNNAME)) (EC EVALCOUNT)) (* ;;  "First pop off all the EVALs at the front and count them") (while (EQ (CAR OLDTEMP) 'EVAL) do (CL:DECF EC) (pop OLDTEMP)) (if (OR (NULL OLDTEMP) (EQ (CAR OLDTEMP) 'KEYWORDS)) then (pop OLDTEMP) (if (AND (CL:ZEROP EC) (NULL (CL:SET-DIFFERENCE OLDTEMP KEYLIST )) (NULL (CL:SET-DIFFERENCE KEYLIST OLDTEMP ))) then (* ; "it matches, don't replace it") NIL else (* ;  "It looks like one of ours; replace it") (SETQ KEYLIST (CONS 'KEYWORDS (CL:NREVERSE KEYLIST))) (while (CL:PLUSP EVALCOUNT) do (push KEYLIST 'EVAL) (CL:DECF EVALCOUNT)) (SETTEMPLATE FNNAME KEYLIST) (* ;; "These templates shouldn't show up in FILES?, since they're solely for Masterscope internal use...") (UNMARKASCHANGED FNNAME 'TEMPLATES) (* ;; "The SETTEMPLATE call marked everyone who calls FNNAME to be reanalyzed; it also marked FNNAME - this gets rid of that") (PUTHASH FNNAME NIL MSCHANGEDARRAY] else (* ;; "It's possible that we created an old template for this function and it no longer has keywords, so we MAY need to delete it") (LET ((OLDTEMP (GETTEMPLATE FNNAME))) (while (EQ (CAR OLDTEMP) 'EVAL) do (pop OLDTEMP)) (if (EQ (CAR OLDTEMP) 'KEYWORDS) then (SETTEMPLATE FNNAME NIL) (* ;; "These templates shouldn't show up in FILES?, since they're solely for Masterscope internal use...") (UNMARKASCHANGED FNNAME 'TEMPLATES) (* ;; "The SETTEMPLATE call marked everyone who calls FNNAME to be reanalyzed; it also marked FNNAME - this gets rid of that") (PUTHASH FNNAME NIL MSCHANGEDARRAY] (MSPRGTEMPLATE1 (CDDR EXPR) '(|..| EVAL RETURN]) ([LAMBDA NLAMBDA OPENLAMBDA] (MSPRGTEMPLATE EXPR '(NIL (IF LISTP (|..| BIND) (IF (PROGN EXPR) BIND)) |..| EFFECT RETURN) TYPE)) (PROG (CLISP TEM) (COND ((AND (SETQ TEM (ASSOC (CAR EXPR) LAMBDATRANFNS)) (SETQ CLISP (CL:FUNCALL (CADR TEM) EXPR))) (PROG ((INCLISP (INCLISP EXPR))) (MSPRGLAMBDA CLISP FLG T))) ((AND DWIMFLG (SETQ CLISP (MSDWIMTRAN EXPR))) (* has a CLISP translation  (e.g. DLAMBDA)) (PROG ((INCLISP (INCLISP EXPR))) (* rebind INCLISP, and try again on  the translation) (MSPRGLAMBDA CLISP FLG TYPE))) (T (MSPRGERR EXPR) (MSPRGE EXPR]) (MSPRGLST (LAMBDA (L PARNT CNTX) (* lmm "27-JUN-78 01:57") (for X in L do (MSPRGE X PARNT CNTX)))) (ADDTO (LAMBDA (RELATION WHAT PRNT FLG) (* lmm "24-DEC-78 11:51") (PROG ((PTR (FASSOC RELATION MSFNDATA))) (OR PTR (COND (FLG (RETURN)) (T (SHOULDNT)))) (OR (NULL ONLYRELS) (FMEMB RELATION ONLYRELS) (RETURN)) (AND EACHTIME (EQMEMB RELATION (CAR EACHTIME)) (APPLY* (CADR EACHTIME) WHAT (CADDR EACHTIME) (CADDDR EACHTIME) PRNT INCLISP)) LP (COND ((NULL (CDR PTR)) (FRPLACD PTR (LIST WHAT))) ((EQ (CAR (SETQ PTR (CDR PTR))) WHAT) (RETURN)) (T (GO LP)))))) (NLAMBDAFNP (LAMBDA (FN) (* lmm "26-Mar-85 12:37") (AND (NOT (EQMEMB 'EVAL (GETPROP FN 'INFO))) (COND ((OR (FGETD (SETQ FN (OR (GETPROP FN 'BROKEN) FN))) (SETQ FN (GETLIS FN '(EXPR CODE)))) (* if the function is defined, check its argtype to tell you whether it is  NLAMBDA or LAMBDA) (SELECTQ (ARGTYPE FN) ((1 3) T) NIL)) (T (* otherwise, rely on NLAMA or NLAML) (OR (FMEMB FN NLAMA) (FMEMB FN NLAML))))))) (MSPRGDWIM [LAMBDA (X FN DEF) (* ; "Edited 8-Apr-88 11:55 by jrb:") (AND DWIMFLG (LET ((NOSPELLFLG T) FILEPKGFLG) (DECLARE (SPECVARS NOSPELLFLG)) (RESETVARS ((DWIMESSGAG T)) (* ;; "JRB Made these RESETVARS to placate the PavCompiler") (PROG (LISPXHIST) (* ASSERT%: ((REMOTE EVAL)  DWIMESSGAG FILEPKGFLG NOSPELLFLG)) (DWIMIFY0 X (OR (AND (LITATOM FN) FN) '?) VARS DEF]) (MSDWIMTRAN (LAMBDA (EXPR) (* DD%: "28-DEC-81 13:46") (AND DWIMFLG (COND ((AND CLISPARRAY (GETHASH EXPR CLISPARRAY))) ((AND CLISPTRANFLG (EQ (CAR (LISTP EXPR)) CLISPTRANFLG)) (CADR EXPR)) (T (MSPRGDWIM EXPR FNNAME FNDEF) (OR (AND CLISPARRAY (GETHASH EXPR CLISPARRAY)) (AND CLISPTRANFLG (EQ (CAR (LISTP EXPR)) CLISPTRANFLG) (CADR EXPR)))))))) ) (RPAQQ MSFNDATA ((BIND) (CALL) (EFFECT) (PREDICATE) (CLISP) (PROP) (SETFREE) (SET) (SMASHFREE) (SMASH) (REFFREE) (REF) (FETCH) (REPLACE) (RECORD) (ERROR) (ARG) (CREATE) (LOCALVARS) (SPECVARS) (APPLY) (TESTFREE) (TEST) (LOCALFREEVARS) [NLAMBDA] (TYPE) (STACK) (KEYACCEPT) (KEYSPECIFY) (KEYCALL) (FLET) (LABEL) (MACROLET) (COMPILER-LET))) (RPAQQ MSERRORFN ppe) (RPAQQ MSRECORDTRANFLG NIL) (ADDTOVAR INVISIBLEVARS $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 $$17) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS INCLISP MACRO ((.X.) (COND ((AND INCLISP EACHTIME (NOT (MSFINDP INCLISP .X.))) INCLISP) (T .X.)))) (PUTPROPS LTEMPLATE MACRO [LAMBDA (Y) (DECLARE (LOCALVARS Y)) (AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES) (GETHASH Y MSTEMPLATES] Y]) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: ALLCALLS ALLCALLS ADDTO MSBINDVAR MSDWIMTRAN MSPRGCALL MSPRGDWIM MSPRGE MSPRGMACRO MSPRGERR MSPRGLAMBDA MSPRGLST MSPRGRECORD MSPRGTEMPLATE MSPRGTEMPLATE1 NLAMBDAFNP (NOLINKFNS . T) (LOCALFREEVARS FNNAME ERRORS FNDEF INCLISP ONLYRELS PARENTCONTEXT TOPVARS PARENT EACHTIME VARS ) (GLOBALVARS CLISPARRAY MSERRORFN MSRECORDTRANFLG MSFNDATA INVISIBLEVARS CLISPARRAY MSTEMPLATES USERTEMPLATES MSRECORDTRANFLG NLAMA NLAML DWIMFLG CLISPTRANFLG DWIMESSGAG) (NOLINKFNS . T)) (BLOCK%: NIL MSINITFNDATA NLAMBDAFNP MSPRGDWIM (LOCALVARS . T) (GLOBALVARS NLAMA NLAML MSFNDATA DWIMFLG DWIMESSGAG)) ) [PUTDQ? MSWORDNAME (LAMBDA (X) X] (RPAQ MSTEMPLATES (HASHARRAY 160)) (RPAQ USERTEMPLATES (HASHARRAY 10)) (RPAQQ INITIALTEMPLATES (((CALL (REMOTE (IF LITATOM CALL LAMBDA)) (IF LITATOM EVAL NIL)) FUNCTION) ((NIL NIL |..| EVAL RETURN) CL:BLOCK) ((CALL |..| EVAL) CL:CATCH CL:THROW) ((NIL NIL EVAL) CL:RETURN-FROM) ([IF (EQ (CADR EXPR) 'ASSERT%:) (NIL NIL |..| (IF LISTP (@ (CDR EXPR) (LIST '|..| (MSWORDNAME (CAR EXPR] *) ((NIL (BOTH (|..| (IF LISTP (NIL EVAL |..| EFFECT) NIL)) (|..| (IF LISTP (BIND) BIND))) |..| EFFECT RETURN) LET CL:COMPILER-LET) ((NIL (|..| (IF LISTP (BIND EVAL . PPE) BIND)) |..| EFFECT RETURN) LET*) ((NIL |..| (IF LISTP EFFECT)) CL:TAGBODY) ((NIL (BOTH (|..| (IF LISTP (NIL EVAL |..| EFFECT) NIL)) (|..| (IF LISTP (BIND) BIND))) |..| (IF LISTP EFFECT)) PROG) (MACRO RESETVARS) ((CALL EVAL) XNLSETQ NLSETQ ERSETQ) ((CALL |..| EVAL) RESETFORM FRPTQ) ((CALL EVAL EVAL FUNCTIONAL FUNCTIONAL . PPE) MAP2C) ((CALL EVAL EVAL SMASH . PPE) /DSUBST DSUBST) ((CALL EVAL FUNCTION FUNCTION . PPE) MAPCAR MAPCON MAPCONC MAPLIST SUBSET EVERY NOTEVERY ANY NOTANY SOME MAPC MAP) ((CALL EVAL FUNCTIONAL . PPE) MAPHASH) ((CALL EVAL PROP . PPE) GETP GETLIS GET GETPROP LISTGET LISTGET1 REMPROP /REMPROP) ((CALL EVAL PROP EVAL . PPE) PUT /PUT PUTPROP /PUTPROP LISTPUT LISTPUT1) ((CALL EVAL SMASH . PPE) /ATTACH ATTACH) ((CALL FUNCTIONAL . PPE) MAPATOMS) ((CALL FUNCTIONAL |..| EVAL) APPLY* BLKAPPLY* APPLY BLKAPPLY) ((CALL EVAL SMASH . PPE) DREMOVE /DREMOVE) ((CALL SET EVAL EVAL . PPE) RESETVAR) ((CALL SET EVAL . PPE) SETN) ((CALL SMASH . PPE) DREVERSE) ((CALL SMASH EVAL . PPE) RPLACD /RPLACD RPLACA /RPLACA RPLNODE2 /RPLNODE2 FRPLACD FRPLNODE2 TCONC /TCONC LCONC /LCONC NCONC1 /NCONC1 FRPLACA) ((CALL SMASH EVAL EVAL . PPE) RPLNODE FRPLNODE /RPLNODE) ((CALL SMASH FUNCTIONAL . PPE) SORT) ((CALL (BOTH SET EVAL) . PPE) ADD1VAR SUB1VAR) ((CALL (IF NULL NIL (IF ATOM SET EVAL)) EVAL . PPE) RESETSAVE) ((CALL (IF (EQ (CAR (LISTP EXPR)) 'QUOTE) (NIL SET) EVAL) EVAL . PPE) SET /SET SETTOPVAL /SETTOPVAL SETATOMVAL /SETATOMVAL) ((CALL (IF (EQ (CAR (LISTP EXPR)) 'QUOTE) (NIL SET) EVAL) EVAL EVAL EVAL . PPE) SAVESET) ((CALL (IF (EQ (CAR (LISTP EXPR)) 'QUOTE) (NIL EVAL) EVAL) |..| EVAL) GETATOMVAL EVAL EVALV) ((NIL |..| TESTRETURN RETURN) OR) ((NIL |..| TEST RETURN) AND) ((NIL |..| EFFECT RETURN) PROGN) ((NIL TEST RETURN RETURN) CL:IF) ((NIL |..| (IF CDR (TEST |..| EFFECT RETURN) (TESTRETURN . PPE))) COND) ([CALL |..| (@ EXPR (CONS NIL (SELECTQ (CAR (LISTP EXPR)) (LOCALVARS '(IF LISTP (|..| LOCALVARS) LOCALVARS)) (SPECVARS '(IF LISTP (|..| SPECVARS) SPECVARS)) NIL] DECLARE) ((NIL RETURN) CLISP% ) ((NIL EVAL . PPE) LISTP NLISTP RETURN) ((NIL TEST . PPE) NOT NULL) ((CALL EVAL |..| (NIL |..| EFFECT RETURN) RETURN) SELECTQ SELCHARQ) ((CALL EVAL |..| (EVAL |..| EFFECT RETURN) RETURN) SELECTC) ((CALL EVAL |..| ((IF LISTP (|..| EVAL) EVAL) |..| EFFECT RETURN) RETURN) SELECT) ((NIL EVAL EVAL . PPE) EQ NEQ) ((NIL NIL . PPE) QUOTE GO) ((NIL EVAL . PPE) CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CDAAR CADDR CDADR CDDAR CDDDR CAAAAR CAAADR CAADAR CAADDR CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR) ((NIL RETURN |..| EFFECT) PROG1) ((NIL SET NIL . PPE) SETQQ) ((NIL SET EVAL . PPE) SETQ ADV-SETQ SAVESETQ) ([@ EXPR (CONS NIL (MAPCON (CDR EXPR) [FUNCTION (LAMBDA (X) (if (LITATOM (CAR X)) then (LIST 'SET 'EVAL) else (LIST 'SMASH 'EVAL] (FUNCTION (LAMBDA (X) (CDDR X] CL:SETQ CL:SETF) ((CALL EVAL (BOTH (@ 'RPTN 'BIND) RETURN) . PPE) RPTQ) ((CALL EVALQT |..| EVAL) EVAL ERRORSET) ((BOTH [IF (EQ (CAR (LISTP (CADDR EXPR))) 'QUOTE) (NIL NIL (NIL (|..| (BIND] (CALL EVALQT EVAL . PPE)) EVALA) ((CALL EVALQT STACK STACK EVAL EVAL . PPE) ENVEVAL) ((CALL FUNCTIONAL EVALQT STACK STACK EVAL EVAL . PPE) ENVAPPLY) ((CALL STACK EVAL EVAL EVAL . PPE) STKAPPLY) ((CALL STACK EVALQT EVAL EVAL . PPE) RETEVAL STKEVAL) ((CALL STACK EVAL EVAL . PPE) RETFROM RETTO) ((NIL NIL RETURN) THE))) (* ;;; "INITIALTEMPLATES is not needed after loading up") [MAPC INITIALTEMPLATES (FUNCTION (LAMBDA (X) (MAPC (CDR X) (FUNCTION (LAMBDA (Y) (PUTHASH Y (CAR X) MSTEMPLATES] (DECLARE%: EVAL@COMPILE DONTCOPY (PUTPROPS LTEMPLATE MACRO [LAMBDA (Y) (DECLARE (LOCALVARS Y)) (AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES) (GETHASH Y MSTEMPLATES] Y]) ) (DEFINEQ (MSFINDP (LAMBDA (STRUC SUB) (* lmm "14-Aug-84 16:38") (PROG NIL LP (RETURN (OR (EQ SUB STRUC) (AND (LISTP STRUC) (OR (MSFINDP (CAR STRUC) SUB) (PROGN (SETQ STRUC (CDR STRUC)) (GO LP))))))))) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSFINDP MSFINDP) ) (PUTPROPS MSANALYZE COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3790 11309 (VARS 3800 . 3941) (FREEVARS 3943 . 4096) (CALLS 4098 . 10439) ( COLLECTFNDATA 10441 . 10820) (CALLS3 10822 . 11307)) (13562 52644 (ALLCALLS 13572 . 14251) ( MSINITFNDATA 14253 . 14497) (MSPRGE 14499 . 21573) (MSPRGMACRO 21575 . 22066) (MSPRGCALL 22068 . 22392 ) (MSBINDVAR 22394 . 22913) (MSPRGRECORD 22915 . 29828) (MSPRGERR 29830 . 29998) (MSPRGTEMPLATE1 30000 . 39161) (MSPRGTEMPLATE 39163 . 39843) (MSPRGLAMBDA 39845 . 49440) (MSPRGLST 49442 . 49610) (ADDTO 49612 . 50403) (NLAMBDAFNP 50405 . 51157) (MSPRGDWIM 51159 . 51978) (MSDWIMTRAN 51980 . 52642)) (61970 62397 (MSFINDP 61980 . 62395))))) STOP \ No newline at end of file diff --git a/library/MSCOMMON b/library/MSCOMMON new file mode 100644 index 00000000..33a21be9 --- /dev/null +++ b/library/MSCOMMON @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED " 4-May-92 13:10:53" |{PELE:MV:ENVOS}LIBRARY>MSCOMMON.;3| 23489 |changes| |to:| (TEMPLATES CL:DECF CL:INCF CL:PUSH) |previous| |date:| "12-Jun-90 10:17:31" |{PELE:MV:ENVOS}LIBRARY>MSCOMMON.;2|) ; Copyright (c) 1988, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT MSCOMMONCOMS) (RPAQQ MSCOMMONCOMS ((PROP FILETYPE MSCOMMON) (FNS FUNCTIONSMSGETDEF FUNCTIONSMSMC VARIABLESMSGETDEF) (* |;;| "Templates for CL stuff that need them.") (TEMPLATES ADD-EXEC CL:ADJOIN CL:ADJUST-ARRAY CL:APPLY CL:APPLYHOOK ASET CL:ASSOC CL:CLOSE CLRHASH CL:COMPILE CL:COMPILE-FILE CL:COMPILER-LET CL:COUNT CL:COUNT-IF CL:COUNT-IF-NOT CL:DECF DECLARE CL:DELETE CL:DELETE-DUPLICATES CL:DELETE-IF CL:DELETE-IF-NOT CL:EVAL-WHEN CL:EVALHOOK EXEC EXEC-EVAL CL:FILL FILL-VECTOR CL:FIND CL:FIND-IF CL:FIND-IF-NOT CL:FLET CL:FUNCTION CL:GETF CL:IN-PACKAGE CL:INCF CL:INTERSECTION CL:LABELS CL:LOAD CL:MACROLET CL:MAKE-ARRAY COMPILER:MAKE-CONTEXT CL:MAKE-HASH-TABLE CL:MAKE-LIST CL:MAKE-PACKAGE CL:MAKE-PATHNAME CL:MAKE-SEQUENCE CL:MAKE-STRING CL:MAPC CL:MAPCAN CL:MAPCAR CL:MAPCON CL:MAPHASH CL:MAPL CL:MAPLIST CL:MEMBER CL:MEMBER-IF CL:MEMBER-IF-NOT CL:MERGE CL:MISMATCH CL:MULTIPLE-VALUE-CALL CL:MULTIPLE-VALUE-PROG1 CL:MULTIPLE-VALUE-SETQ CL:NINTERSECTION CL:NRECONC CL:NREVERSE CL:NSET-DIFFERENCE CL:NSET-EXCLUSIVE-OR CL:NSTRING-CAPITALIZE CL:NSTRING-DOWNCASE CL:NSTRING-UPCASE CL:NSUBLIS CL:NSUBST CL:NSUBST-IF CL:NSUBST-IF-NOT CL:NSUBSTITUTE CL:NSUBSTITUTE-IF CL:NSUBSTITUTE-IF-NOT CL:NUNION OPEN CL:PARSE-INTEGER CL:PARSE-NAMESTRING CL:POP CL:POSITION CL:POSITION-IF CL:POSITION-IF-NOT CL:PROGV CL:PSETF CL:PSETQ CL:PUSH CL:PUSHNEW CL:RASSOC CL:READ-FROM-STRING CL:REDUCE CL:REMF CL:REMOVE CL:REMOVE-DUPLICATES CL:REMOVE-IF CL:REMOVE-IF-NOT CL:REPLACE CL:ROTATEF CL:SEARCH CL:SET-DIFFERENCE CL:SET-EXCLUSIVE-OR CL:SHIFTF CL:SORT CL:STABLE-SORT CL:STRING-CAPITALIZE CL:STRING-DOWNCASE STRING-EQUAL CL:STRING-GREATERP CL:STRING-LESSP CL:STRING-NOT-EQUAL CL:STRING-NOT-GREATERP CL:STRING-NOT-LESSP CL:STRING-UPCASE CL:STRING/= CL:STRING< CL:STRING<= CL:STRING= CL:STRING> CL:STRING>= CL:SUBLIS CL:SUBSETP CL:SUBST CL:SUBST-IF CL:SUBST-IF-NOT CL:SUBSTITUTE CL:SUBSTITUTE-IF CL:SUBSTITUTE-IF-NOT CL:TREE-EQUAL CL:UNION CL:VECTOR-PUSH CL:VECTOR-PUSH-EXTEND WRITE CL:WRITE-LINE CL:WRITE-STRING CL:WRITE-TO-STRING) (P (* |;;| "First tell Masterscope how to find FUNCTIONS and VARIABLES") (MSADDANALYZE 'VARIABLES 'VARIABLE 'VARIABLES 'VARIABLESMSGETDEF) (MSADDANALYZE 'FUNCTIONS 'FUNCTION 'FUNCTIONS 'FUNCTIONSMSGETDEF 'FUNCTIONSMSMC) (* |;;|  "Then add KEYWORD support. Templates may now contain the following as their last element:") (* |;;| "... KEYWORDS list of keywords accepted)") (* |;;| "No (list of keywords accepted) means use keywords gathered from analyzed source. This must naturally be last in a template.") (MSADDRELATION '(ACCEPT ACCEPTS ACCEPTING ACCEPTED) '(KEYACCEPT)) (MSADDRELATION '(SPECIFY SPECIFIES SPECIFYING SPECIFIED) '(KEYSPECIFY)) (MSADDRELATION '(KEYCALL KEYCALLS KEYCALLING KEYCALLED)) (MSADDMODIFIER 'ACCEPT 'KEYWORD 'KEYACCEPT) (MSADDMODIFIER 'ACCEPT 'KEYWORDS 'KEYACCEPT) (MSADDMODIFIER 'SPECIFY 'KEYWORD 'KEYSPECIFY) (MSADDMODIFIER 'SPECIFY 'KEYWORDS 'KEYSPECIFY) (* |;;|  "Stuff for locally-defined things. We don't attempt to handle them (*sigh*), just record them.") (MSADDRELATION '(FLET FLETS FLETTING FLET)) (MSADDRELATION '(LABEL LABELS LABELLING LABELLED)) (MSADDRELATION '(MACROLET MACROLETS MACROLETTING MACROLET)) (MSADDRELATION '(LOCAL-DEFINE LOCAL-DEFINES LOCAL-DEFINING LOCAL-DEFINED) '(FLET LABEL MACROLET)) (* |;;| "What the heck, track COMPILER-LETs.") (MSADDRELATION '(COMPILER-LET COMPILER-LETS COMPILER-LETTING COMPILER-LETTED)) (* |;;| "Finally, copy the templates over into MSTEMPLATES and clear the USERTEMPLATES table now; no need for the Common Lisp templates to live there.") (MAPHASH USERTEMPLATES #'(LAMBDA (VAL KEY) (PUTHASH KEY VAL MSTEMPLATES))) (CLRHASH USERTEMPLATES)))) (PUTPROPS MSCOMMON FILETYPE :COMPILE-FILE) (DEFINEQ (FUNCTIONSMSGETDEF (LAMBDA (NAME TYPE SOURCE OPTIONS) (* \; "Edited 31-Mar-88 17:31 by jrb:") (LET ((BODY (REMOVE-COMMENTS (GETDEF NAME 'FUNCTIONS SOURCE OPTIONS)))) (AND BODY (SELECTQ (CAR BODY) (DEFMACRO (OR (GETTEMPLATE NAME) (SETTEMPLATE NAME 'MACRO)) NIL) (CL:DEFUN (* |;;| "Body is of the form:") (* |;;| "(DEFUN name (args...) bodies...)") (* |;;| "We want to hand Masterscope a massaged form it will understand.") (* |;;| "Which I believe is of this form:") `(CL:LAMBDA ,(CADDR BODY) ,@(CDDDR BODY))) NIL))))) (FUNCTIONSMSMC (LAMBDA (NAME TYPE REASON) (* \; "Edited 1-Apr-88 13:47 by jrb:") (* |;;| "Trick here is we don't want to mark FUNCTIONS macros as changed because they really don't get analyzed, but we do want to call CHANGEMACRO for them") (|if| (EQ (CAR (GETDEF NAME 'FUNCTIONS NIL '(NOERROR))) 'DEFMACRO) |then| (CHANGEMACRO NAME TYPE REASON) NIL |else| T))) (VARIABLESMSGETDEF (LAMBDA (NAME TYPE SOURCE OPTIONS) (* \; "Edited 19-Feb-88 19:46 by jrb:") (LET ((BODY (GETDEF NAME 'VARIABLES SOURCE OPTIONS)) SPECVARP) (AND BODY (* |;;| "We have to return something here so Masterscope can get hold of the init form, and so It'll stop looking for other things") `(CL:LAMBDA NIL ,(IF (CADDR BODY) THEN `(SETQ ,(CADR BODY) ,(CADDR BODY)))))))) ) (* |;;| "Templates for CL stuff that need them.") (SETTEMPLATE 'ADD-EXEC '(KEYWORDS :PROFILE :REGION :TTY :EXEC :ID)) (SETTEMPLATE 'CL:ADJOIN '(EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY)) (SETTEMPLATE 'CL:ADJUST-ARRAY '(SMASH EVAL KEYWORDS :ELEMENT-TYPE :INITIAL-ELEMENT :INITIAL-CONTENTS :FILL-POINTER :DISPLACED-TO :DISPLACED-INDEX-OFFSET :FATP :DISPLACED-TO-BASE)) (SETTEMPLATE 'CL:APPLY '((! NIL EXPR (|if| (LITATOM (CAR EXPR)) |then| (LIST 'SET 'EVAL) |else| (LIST 'SMASH 'EVAL))))) (SETTEMPLATE 'CL:APPLYHOOK '((! NIL EXPR (|if| (LITATOM (CAR EXPR)) |then| (LIST 'SET 'EVAL) |else| (LIST 'SMASH 'EVAL))))) (SETTEMPLATE 'ASET '(EVAL SMASH |..| EVAL)) (SETTEMPLATE 'CL:ASSOC '(EVAL EVAL KEYWORDS :TEST :TEST-NOT)) (SETTEMPLATE 'CL:CLOSE '(EVAL KEYWORDS :ABORT)) (SETTEMPLATE 'CLRHASH '((! NIL EXPR (|if| (LITATOM (CAR EXPR)) |then| (LIST 'SET 'EVAL) |else| (LIST 'SMASH 'EVAL))))) (SETTEMPLATE 'CL:COMPILE '(EVAL EVAL KEYWORDS :LAP)) (SETTEMPLATE 'CL:COMPILE-FILE '(EVAL KEYWORDS :OUTPUT-FILE :ERROR-FILE :ERRORS-TO-TERMINAL :LAP-FILE :LOAD :FILE-MANAGER-FORMAT :PROCESS-ENTIRE-FILE)) (SETTEMPLATE 'CL:COMPILER-LET '(! NIL (BOTH (|..| (IF LISTP (NIL EVAL |..| EFFECT) NIL)) (|..| (IF LISTP ((BOTH BIND COMPILER-LET)) (BOTH BIND COMPILER-LET)))) |..| EFFECT RETURN)) (SETTEMPLATE 'CL:COUNT '(EVAL EVAL KEYWORDS :FROM-END :TEST :TEST-NOT :START :END :KEY)) (SETTEMPLATE 'CL:COUNT-IF '(EVAL EVAL KEYWORDS :FROM-END :START :END :KEY)) (SETTEMPLATE 'CL:COUNT-IF-NOT '(EVAL EVAL KEYWORDS :FROM-END :START :END :KEY)) (SETTEMPLATE 'CL:DECF '(! NIL @ EXPR (|if| (LITATOM (CAR EXPR)) |then| '(SET EVAL) |else| '(SMASH EVAL)))) (SETTEMPLATE 'DECLARE '(|..| (@ EXPR (CONS NIL (SELECTQ (CAR (LISTP EXPR)) (LOCALVARS '(IF LISTP (|..| LOCALVARS) LOCALVARS)) ((SPECVARS CL:SPECIAL) '(IF LISTP (|..| SPECVARS) SPECVARS)) NIL))))) (SETTEMPLATE 'CL:DELETE '(EVAL SMASH KEYWORDS :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY)) (SETTEMPLATE 'CL:DELETE-DUPLICATES '(SMASH KEYWORDS :FROM-END :TEST :TEST-NOT :START :END :KEY)) (SETTEMPLATE 'CL:DELETE-IF '(CL:FUNCTION EVAL KEYWORDS :FROM-END :START :END :COUNT :KEY)) (SETTEMPLATE 'CL:DELETE-IF-NOT '(CL:FUNCTION EVAL KEYWORDS :FROM-END :START :END :COUNT :KEY)) (SETTEMPLATE 'CL:EVAL-WHEN '(NIL |..| EFFECT RETURN)) (SETTEMPLATE 'CL:EVALHOOK '((! NIL EXPR (|if| (LITATOM (CAR EXPR)) |then| (LIST 'SET 'EVAL) |else| (LIST 'SMASH 'EVAL))))) (SETTEMPLATE 'EXEC '(KEYWORDS :TOP-LEVEL-P :WINDOW :TITLE :COMMAND-TABLES :ENVIRONMENT :PROMPT :FUNCTION :PROFILE :ID)) (SETTEMPLATE 'EXEC-EVAL '(EVAL EVAL KEYWORDS :PROMPT :ID :TYPE)) (SETTEMPLATE 'CL:FILL '(SMASH EVAL KEYWORDS :START :END)) (SETTEMPLATE 'FILL-VECTOR '(SMASH EVAL KEYWORDS :START :END)) (SETTEMPLATE 'CL:FIND '(EVAL EVAL KEYWORDS :FROM-END :TEST :TEST-NOT :START :END :KEY)) (SETTEMPLATE 'CL:FIND-IF '(EVAL EVAL KEYWORDS :FROM-END :START :END :KEY)) (SETTEMPLATE 'CL:FIND-IF-NOT '(EVAL EVAL KEYWORDS :FROM-END :START :END :KEY)) (SETTEMPLATE 'CL:FLET '((|..| (FLET)) |..| EFFECT RETURN)) (SETTEMPLATE 'CL:FUNCTION '((REMOTE (IF LITATOM CALL LAMBDA)) (IF LITATOM EVAL NIL))) (SETTEMPLATE 'CL:GETF '(EVAL PROP EVAL)) (SETTEMPLATE 'CL:IN-PACKAGE '(EVAL KEYWORDS :NICKNAMES :USE)) (SETTEMPLATE 'CL:INCF '(! NIL @ EXPR (|if| (LITATOM (CAR EXPR)) |then| '(SET EVAL) |else| '(SMASH EVAL)))) (SETTEMPLATE 'CL:INTERSECTION '(EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY)) (SETTEMPLATE 'CL:LABELS '((|..| (LABEL)) |..| EFFECT RETURN)) (SETTEMPLATE 'CL:LOAD '(EVAL KEYWORDS :VERBOSE :PRINT :IF-DOES-NOT-EXIST :PACKAGE :LOADFLG)) (SETTEMPLATE 'CL:MACROLET '((|..| (MACROLET)) |..| EFFECT RETURN)) (SETTEMPLATE 'CL:MAKE-ARRAY '(EVAL KEYWORDS :ELEMENT-TYPE :INITIAL-ELEMENT :INITIAL-CONTENTS :ADJUSTABLE :FILL-POINTER :DISPLACED-TO :DISPLACED-INDEX-OFFSET :FATP :EXTENDABLE :READ-ONLY-P :DISPLACED-TO-BASE)) (SETTEMPLATE 'COMPILER:MAKE-CONTEXT '(KEYWORDS :TOP-LEVEL-P :VALUES-USED :PREDICATE-P)) (SETTEMPLATE 'CL:MAKE-HASH-TABLE '(KEYWORDS :TEST :SIZE :REHASH-SIZE :REHASH-THRESHOLD)) (SETTEMPLATE 'CL:MAKE-LIST '(EVAL KEYWORDS :INITIAL-ELEMENT)) (SETTEMPLATE 'CL:MAKE-PACKAGE '(EVAL KEYWORDS :NICKNAMES :USE :PREFIX-NAME :INTERNAL-SYMBOLS :EXTERNAL-SYMBOLS :EXTERNAL-ONLY)) (SETTEMPLATE 'CL:MAKE-PATHNAME '(KEYWORDS :HOST :DEVICE :DIRECTORY :NAME :TYPE :VERSION :DEFAULTS)) (SETTEMPLATE 'CL:MAKE-SEQUENCE '(EVAL EVAL KEYWORDS :INITIAL-ELEMENT)) (SETTEMPLATE 'CL:MAKE-STRING '(EVAL KEYWORDS :INITIAL-ELEMENT)) (SETTEMPLATE 'CL:MAPC '(FUNCTION |..| EVAL)) (SETTEMPLATE 'CL:MAPCAN '(FUNCTION |..| EVAL)) (SETTEMPLATE 'CL:MAPCAR '(FUNCTION |..| EVAL)) (SETTEMPLATE 'CL:MAPCON '(FUNCTION |..| EVAL)) (SETTEMPLATE 'CL:MAPHASH '(FUNCTION EVAL)) (SETTEMPLATE 'CL:MAPL '(FUNCTION |..| EVAL)) (SETTEMPLATE 'CL:MAPLIST '(FUNCTION |..| EVAL)) (SETTEMPLATE 'CL:MEMBER '(EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY)) (SETTEMPLATE 'CL:MEMBER-IF '(EVAL EVAL KEYWORDS :KEY)) (SETTEMPLATE 'CL:MEMBER-IF-NOT '(EVAL EVAL KEYWORDS :KEY)) (SETTEMPLATE 'CL:MERGE '(EVAL EVAL EVAL EVAL KEYWORDS :KEY)) (SETTEMPLATE 'CL:MISMATCH '(EVAL EVAL KEYWORDS :FROM-END :TEST :TEST-NOT :KEY :START1 :START2 :END1 :END2)) (SETTEMPLATE 'CL:MULTIPLE-VALUE-CALL '(FUNCTION |..| EVAL)) (SETTEMPLATE 'CL:MULTIPLE-VALUE-PROG1 '(RETURN |..| EFFECT)) (SETTEMPLATE 'CL:MULTIPLE-VALUE-SETQ '((|..| SET) EVAL)) (SETTEMPLATE 'CL:NINTERSECTION '(SMASH EVAL KEYWORDS :TEST :TEST-NOT :KEY)) (SETTEMPLATE 'CL:NRECONC '((! NIL EXPR (|if| (LITATOM (CAR EXPR)) |then| (LIST 'SET 'EVAL) |else| (LIST 'SMASH 'EVAL))))) (SETTEMPLATE 'CL:NREVERSE '((! NIL EXPR (|if| (LITATOM (CAR EXPR)) |then| (LIST 'SET 'EVAL) |else| (LIST 'SMASH 'EVAL))))) (SETTEMPLATE 'CL:NSET-DIFFERENCE '(SMASH EVAL KEYWORDS :TEST :TEST-NOT :KEY)) (SETTEMPLATE 'CL:NSET-EXCLUSIVE-OR '(SMASH SMASH KEYWORDS :TEST :TEST-NOT :KEY)) (SETTEMPLATE 'CL:NSTRING-CAPITALIZE '(SMASH KEYWORDS :START :END)) (SETTEMPLATE 'CL:NSTRING-DOWNCASE '(SMASH KEYWORDS :START :END)) (SETTEMPLATE 'CL:NSTRING-UPCASE '(SMASH KEYWORDS :START :END)) (SETTEMPLATE 'CL:NSUBLIS '(EVAL SMASH KEYWORDS :TEST :TEST-NOT :KEY)) (SETTEMPLATE 'CL:NSUBST '(EVAL EVAL SMASH KEYWORDS :TEST :TEST-NOT :KEY)) (SETTEMPLATE 'CL:NSUBST-IF '(EVAL FUNCTION SMASH KEYWORDS :KEY)) (SETTEMPLATE 'CL:NSUBST-IF-NOT '(EVAL FUNCTION SMASH KEYWORDS :KEY)) (SETTEMPLATE 'CL:NSUBSTITUTE '(EVAL EVAL SMASH KEYWORDS :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY)) (SETTEMPLATE 'CL:NSUBSTITUTE-IF '(EVAL FUNCTION SMASH KEYWORDS :FROM-END :START :END :COUNT :KEY)) (SETTEMPLATE 'CL:NSUBSTITUTE-IF-NOT '(EVAL FUNCTION SMASH KEYWORDS :FROM-END :START :END :COUNT :KEY) ) (SETTEMPLATE 'CL:NUNION '(SMASH SMASH KEYWORDS :TEST :TEST-NOT :KEY)) (SETTEMPLATE 'OPEN '(EVAL KEYWORDS :DIRECTION :ELEMENT-TYPE :IF-EXISTS :IF-DOES-NOT-EXIST)) (SETTEMPLATE 'CL:PARSE-INTEGER '(EVAL KEYWORDS :START :END :RADIX :JUNK-ALLOWED)) (SETTEMPLATE 'CL:PARSE-NAMESTRING '(EVAL EVAL EVAL KEYWORDS :START :END :JUNK-ALLOWED)) (SETTEMPLATE 'CL:POP '(! NIL EXPR (IF (ATOM (CAR EXPR)) THEN '(SET) ELSE '(SMASH)))) (SETTEMPLATE 'CL:POSITION '(EVAL EVAL KEYWORDS :FROM-END :TEST :TEST-NOT :START :END :KEY)) (SETTEMPLATE 'CL:POSITION-IF '(EVAL EVAL KEYWORDS :FROM-END :START :END :KEY)) (SETTEMPLATE 'CL:POSITION-IF-NOT '(EVAL EVAL KEYWORDS :FROM-END :START :END :KEY)) (SETTEMPLATE 'CL:PROGV '(EVAL EVAL |..| EFFECT RETURN)) (SETTEMPLATE 'CL:PSETF '(! @ EXPR (CONS NIL (MAPCON (CDR EXPR) (FUNCTION (LAMBDA (X) (|if| (LITATOM (CAR X)) |then| (LIST 'SET 'EVAL) |else| (LIST 'SMASH 'EVAL)))) (FUNCTION (LAMBDA (X) (CDDR X))))))) (SETTEMPLATE 'CL:PSETQ '(! @ EXPR (CONS NIL (MAPCON (CDR EXPR) (FUNCTION (LAMBDA (X) (|if| (LITATOM (CAR X)) |then| (LIST 'SET 'EVAL) |else| (LIST 'SMASH 'EVAL)))) (FUNCTION (LAMBDA (X) (CDDR X))))))) (SETTEMPLATE 'CL:PUSH '(! NIL @ EXPR (IF (ATOM (CADR EXPR)) THEN '(EVAL SET) ELSE '(EVAL SMASH)))) (SETTEMPLATE 'CL:PUSHNEW '(@ EXPR `(EVAL ,(IF (ATOM (CADDR EXPR)) THEN 'SET ELSE 'SMASH) KEYWORDS :TEST :TEST-NOT :KEY))) (SETTEMPLATE 'CL:RASSOC '(EVAL EVAL KEYWORDS :TEST :TEST-NOT)) (SETTEMPLATE 'CL:READ-FROM-STRING '(EVAL EVAL EVAL KEYWORDS :START :END :PRESERVE-WHITESPACE)) (SETTEMPLATE 'CL:REDUCE '(FUNCTION EVAL KEYWORDS :FROM-END :START :END :INITIAL-VALUE)) (SETTEMPLATE 'CL:REMF '(@ EXPR (IF (ATOM (CAR EXPR)) THEN '(SET PROP) ELSE '(SMASH PROP)))) (SETTEMPLATE 'CL:REMOVE '(EVAL EVAL KEYWORDS :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY)) (SETTEMPLATE 'CL:REMOVE-DUPLICATES '(EVAL KEYWORDS :FROM-END :TEST :TEST-NOT :START :END :KEY)) (SETTEMPLATE 'CL:REMOVE-IF '(EVAL EVAL KEYWORDS :FROM-END :START :END :COUNT :KEY)) (SETTEMPLATE 'CL:REMOVE-IF-NOT '(EVAL EVAL KEYWORDS :FROM-END :START :END :COUNT :KEY)) (SETTEMPLATE 'CL:REPLACE '(SMASH EVAL KEYWORDS :START1 :END1 :START2 :END2)) (SETTEMPLATE 'CL:ROTATEF '(|..| (IF (ATOM EXPR) SET SMASH))) (SETTEMPLATE 'CL:SEARCH '(EVAL EVAL KEYWORDS :FROM-END :TEST :TEST-NOT :KEY :START1 :START2 :END1 :END2)) (SETTEMPLATE 'CL:SET-DIFFERENCE '(EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY)) (SETTEMPLATE 'CL:SET-EXCLUSIVE-OR '(EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY)) (SETTEMPLATE 'CL:SHIFTF '(|..| (IF (ATOM EXPR) SET SMASH) EVAL)) (SETTEMPLATE 'CL:SORT '(EVAL FUNCTION KEYWORDS :KEY)) (SETTEMPLATE 'CL:STABLE-SORT '(EVAL FUNCTION KEYWORDS :KEY)) (SETTEMPLATE 'CL:STRING-CAPITALIZE '(EVAL KEYWORDS :START :END)) (SETTEMPLATE 'CL:STRING-DOWNCASE '(EVAL KEYWORDS :START :END)) (SETTEMPLATE 'STRING-EQUAL '(EVAL EVAL KEYWORDS :START1 :END1 :START2 :END2)) (SETTEMPLATE 'CL:STRING-GREATERP '(EVAL EVAL KEYWORDS :START1 :END1 :START2 :END2)) (SETTEMPLATE 'CL:STRING-LESSP '(EVAL EVAL KEYWORDS :START1 :END1 :START2 :END2)) (SETTEMPLATE 'CL:STRING-NOT-EQUAL '(EVAL EVAL KEYWORDS :START1 :END1 :START2 :END2)) (SETTEMPLATE 'CL:STRING-NOT-GREATERP '(EVAL EVAL KEYWORDS :START1 :END1 :START2 :END2)) (SETTEMPLATE 'CL:STRING-NOT-LESSP '(EVAL EVAL KEYWORDS :START1 :END1 :START2 :END2)) (SETTEMPLATE 'CL:STRING-UPCASE '(EVAL KEYWORDS :START :END)) (SETTEMPLATE 'CL:STRING/= '(EVAL EVAL KEYWORDS :START1 :END1 :START2 :END2)) (SETTEMPLATE 'CL:STRING< '(EVAL EVAL KEYWORDS :START1 :END1 :START2 :END2)) (SETTEMPLATE 'CL:STRING<= '(EVAL EVAL KEYWORDS :START1 :END1 :START2 :END2)) (SETTEMPLATE 'CL:STRING= '(EVAL EVAL KEYWORDS :START1 :END1 :START2 :END2)) (SETTEMPLATE 'CL:STRING> '(EVAL EVAL KEYWORDS :START1 :END1 :START2 :END2)) (SETTEMPLATE 'CL:STRING>= '(EVAL EVAL KEYWORDS :START1 :END1 :START2 :END2)) (SETTEMPLATE 'CL:SUBLIS '(EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY)) (SETTEMPLATE 'CL:SUBSETP '(EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY)) (SETTEMPLATE 'CL:SUBST '(EVAL EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY)) (SETTEMPLATE 'CL:SUBST-IF '(EVAL EVAL EVAL KEYWORDS :KEY)) (SETTEMPLATE 'CL:SUBST-IF-NOT '(EVAL EVAL EVAL KEYWORDS :KEY)) (SETTEMPLATE 'CL:SUBSTITUTE '(EVAL EVAL EVAL KEYWORDS :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY)) (SETTEMPLATE 'CL:SUBSTITUTE-IF '(EVAL EVAL EVAL KEYWORDS :FROM-END :START :END :COUNT :KEY)) (SETTEMPLATE 'CL:SUBSTITUTE-IF-NOT '(EVAL EVAL EVAL KEYWORDS :FROM-END :START :END :COUNT :KEY)) (SETTEMPLATE 'CL:TREE-EQUAL '(EVAL EVAL KEYWORDS :TEST :TEST-NOT)) (SETTEMPLATE 'CL:UNION '(EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY)) (SETTEMPLATE 'CL:VECTOR-PUSH '(EVAL SMASH)) (SETTEMPLATE 'CL:VECTOR-PUSH-EXTEND '(EVAL SMASH EVAL)) (SETTEMPLATE 'WRITE '(EVAL KEYWORDS :STREAM :ESCAPE :RADIX :BASE :CIRCLE :PRETTY :LEVEL :LENGTH :CASE :GENSYM :ARRAY)) (SETTEMPLATE 'CL:WRITE-LINE '(EVAL EVAL KEYWORDS :START :END)) (SETTEMPLATE 'CL:WRITE-STRING '(EVAL EVAL KEYWORDS :START :END)) (SETTEMPLATE 'CL:WRITE-TO-STRING '(EVAL KEYWORDS :ESCAPE :RADIX :BASE :CIRCLE :PRETTY :LEVEL :LENGTH :CASE :GENSYM :ARRAY)) (* |;;| "First tell Masterscope how to find FUNCTIONS and VARIABLES") (MSADDANALYZE 'VARIABLES 'VARIABLE 'VARIABLES 'VARIABLESMSGETDEF) (MSADDANALYZE 'FUNCTIONS 'FUNCTION 'FUNCTIONS 'FUNCTIONSMSGETDEF 'FUNCTIONSMSMC) (* |;;| "Then add KEYWORD support. Templates may now contain the following as their last element:") (* |;;| "... KEYWORDS list of keywords accepted)") (* |;;| "No (list of keywords accepted) means use keywords gathered from analyzed source. This must naturally be last in a template.") (MSADDRELATION '(ACCEPT ACCEPTS ACCEPTING ACCEPTED) '(KEYACCEPT)) (MSADDRELATION '(SPECIFY SPECIFIES SPECIFYING SPECIFIED) '(KEYSPECIFY)) (MSADDRELATION '(KEYCALL KEYCALLS KEYCALLING KEYCALLED)) (MSADDMODIFIER 'ACCEPT 'KEYWORD 'KEYACCEPT) (MSADDMODIFIER 'ACCEPT 'KEYWORDS 'KEYACCEPT) (MSADDMODIFIER 'SPECIFY 'KEYWORD 'KEYSPECIFY) (MSADDMODIFIER 'SPECIFY 'KEYWORDS 'KEYSPECIFY) (* |;;| "Stuff for locally-defined things. We don't attempt to handle them (*sigh*), just record them.") (MSADDRELATION '(FLET FLETS FLETTING FLET)) (MSADDRELATION '(LABEL LABELS LABELLING LABELLED)) (MSADDRELATION '(MACROLET MACROLETS MACROLETTING MACROLET)) (MSADDRELATION '(LOCAL-DEFINE LOCAL-DEFINES LOCAL-DEFINING LOCAL-DEFINED) '(FLET LABEL MACROLET)) (* |;;| "What the heck, track COMPILER-LETs.") (MSADDRELATION '(COMPILER-LET COMPILER-LETS COMPILER-LETTING COMPILER-LETTED)) (* |;;| "Finally, copy the templates over into MSTEMPLATES and clear the USERTEMPLATES table now; no need for the Common Lisp templates to live there.") (MAPHASH USERTEMPLATES #'(LAMBDA (VAL KEY) (PUTHASH KEY VAL MSTEMPLATES))) (CLRHASH USERTEMPLATES) (PUTPROPS MSCOMMON COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1992)) (DECLARE\: DONTCOPY (FILEMAP (NIL (5000 6811 (FUNCTIONSMSGETDEF 5010 . 5804) (FUNCTIONSMSMC 5806 . 6286) ( VARIABLESMSGETDEF 6288 . 6809))))) STOP \ No newline at end of file diff --git a/library/MSPARSE b/library/MSPARSE new file mode 100644 index 00000000..7968141c --- /dev/null +++ b/library/MSPARSE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Aug-90 13:02:12" |{PELE:MV:ENVOS}LIBRARY>MSPARSE.;5| 75369 changes to%: (VARS MSPARSECOMS) (FNS MSKNOWN MSDOES MSSETSETTYPE MSJOINSET MSPARSE MSFIXUPTYPES MSVERBTYPE MSSETREP MSSEEKPHRASE MSCOMMAND MSSUBJTYPE MSOBJTYPE MSSIMPLESET MSMATCHRATING FIXVERBSETTYPE) previous date%: "12-Jun-90 18:23:48" |{PELE:MV:ENVOS}LIBRARY>MSPARSE.;4|) (* ; " Copyright (c) 1984, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MSPARSECOMS) (RPAQQ MSPARSECOMS [(FNS MSKNOWN MSDOES MSSETSETTYPE MS-SMASH-PACKAGE MSFAIL MSJOINSET MSBLOCK MSPATHOPTIONS MSPARSE MSFIXUPTYPES MSVERBTYPE MSSETREP MSSEEKPHRASE MSTYPEMATCHRATING MSTRYSPELL MSTRYPARSE MSCOMMAND MSSUBJTYPE MSOBJTYPE MSVERB MSSPLST MSWORD? MSSEEK-WORD MSSEEKTYPE MSRESPELL MSJOIN MSSIMPLESET MSMATCHRATING MSVERBED MSCANT MSJOINDETS MSNEGATESET MSNEXTWORD MSPRED CHECKSYNONYM MSSETWORDTYPE MSEAT MSTRYSPELLTYPE MSSETPHRASE MSQUOTED FIXVERBSETTYPE SETSYNONYM MSSETUP) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS * PARSERRECORDS) (MACROS GETWORDTYPE)) (VARS CONJUNCTABLE (MSSPLST)) (FILEVARS INITWORDLIST) (P (APPLY 'MSSETUP INITWORDLIST)) (FUNCTIONS MSSEEK SEEKWORD) (COMMANDS ".") (BLOCKS (MSPARSEBLOCK MSKNOWN MSDOES MSSETSETTYPE MS-SMASH-PACKAGE MSFAIL MSJOINSET MSBLOCK MSPATHOPTIONS MSPARSE MSFIXUPTYPES MSVERBTYPE MSSETREP MSSEEKPHRASE MSTYPEMATCHRATING MSTRYSPELL MSTRYPARSE MSCOMMAND MSSUBJTYPE MSOBJTYPE MSVERB MSSPLST MSWORD? MSSEEKTYPE MSRESPELL MSJOIN MSSIMPLESET MSMATCHRATING MSVERBED MSCANT MSJOINDETS MSNEGATESET MSNEXTWORD MSPRED CHECKSYNONYM MSEAT MSTRYSPELLTYPE MSSETPHRASE MSQUOTED FIXVERBSETTYPE (ENTRIES MSPARSE MSJOINSET MSTRYSPELL SETSYNONYM MSSETUP) (RETFNS MSTRYPARSE) (SPECVARS SPELLING) (LOCALFREEVARS CONJUNCTIONS LASTADVERB LASTPARSED NEXTWORD PARSED S SEEKING SENTENCE RESETS) (BLKAPPLYFNS MSDOES MSVERBED MSBLOCK MSPATHOPTIONS MSSETREP MSCOMMAND MSVERB MSPRED MSSETPHRASE) (LOCALFREEVARS SETTYPE SETDET) (NOLINKFNS . T) (GLOBALVARS MSWORDS MSSPLST CONJUNCTABLE) MSSETUP MSSETWORDTYPE SETSYNONYM MSSEEK-WORD) (NIL (LOCALVARS . T) (GLOBALVARS MSWORDS))) (PROP FILETYPE MSPARSE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (DEFINEQ (MSKNOWN [LAMBDA (SET) (* ; "Edited 15-Aug-90 12:53 by jds") (* lmm%: 16-MAR-76 15 34) (replace (MSSETPHRASE KNOWN) of SET with T) '(MSSETSETTYPE SET 'FNS) (* ;  "don't set the type, since now things other than FNS can call") (SELECTQ (fetch (SENTENCE ID) of (fetch (MSSETPHRASE REP) of SET)) (NOT (MSKNOWN (fetch (NOT NEGATED) of (fetch (MSSETPHRASE REP) of SET)))) ((AND OR ANDNOT) (MSKNOWN (fetch (CSET SET1) of SET)) (MSKNOWN (fetch (CSET SET2) of SET))) NIL]) (MSDOES [LAMBDA NIL (* ; "Edited 15-Aug-90 12:48 by jds") (AND (SEEKWORD DOES DO) (create MSSETPHRASE REP _ (create THAT OTHERSET _ (OR (MSSEEK MSSETPHRASE) (MSCANT)) MSVERB _ (PROGN (COND ((NOT (MSSEEK MSVERB S)) (MSCANT))) (replace (MSVERB TENSE) of LASTPARSED with 'ED) LASTPARSED]) (MSSETSETTYPE [LAMBDA (SET TYPE) (* ; "Edited 15-Aug-90 12:53 by jds") [AND SET TYPE (PROG (REP) (* ;; "We no longer care if the default type is matched or not.") (* ;; "((NOT (EQUAL (OR (|fetch| (MSSETPHRASE TYPE) |of| SET) (|fetch| (MSSETPHRASE DEFAULTTYPE) |of| SET)) TYPE)) (|printout| T %"Expecting %" TYPE %" but supplied %" (OR (|fetch| (MSSETPHRASE TYPE) |of| SET) (|fetch| (MSSETPHRASE DEFAULTTYPE) |of| SET)) %".%" T))") (COND ((AND (NULL (fetch (MSSETPHRASE TYPE) of SET)) (NULL (fetch (MSSETPHRASE DEFAULTTYPE) of SET))) (replace (MSSETPHRASE DEFAULTTYPE) of SET with TYPE) (SELECTQ (fetch (SENTENCE ID) of (SETQ REP (fetch (MSSETPHRASE REP) of SET))) (THAT (FIXVERBSETTYPE SET)) (NOT (MSSETSETTYPE (fetch (NOT NEGATED) of (fetch (MSSETPHRASE REP) of SET)) TYPE)) ((AND OR ANDNOT) (MSSETSETTYPE (fetch (CSET SET1) of REP) TYPE) (MSSETSETTYPE (fetch (CSET SET2) of REP) TYPE)) NIL) (* ;; "JRB - Hack to make filenames in non-IL packages work right...") (if (AND (EQ TYPE 'FILES) (EQ (fetch (SENTENCE ID) of REP) 'QUOTE)) then (SETQ SET (MS-SMASH-PACKAGE SET (CL:FIND-PACKAGE "INTERLISP"] SET]) (MS-SMASH-PACKAGE [LAMBDA (THING PACKAGE) (* ; "Edited 6-Jun-88 20:53 by jrb:") (COND ((NULL THING) NIL) [(CL:CONSP THING) (LET ((CARPART (MS-SMASH-PACKAGE (CAR THING) PACKAGE)) (CDRPART (MS-SMASH-PACKAGE (CDR THING) PACKAGE))) (if (AND (EQ (CAR THING) CARPART) (EQ (CDR THING) CDRPART)) then THING else (CONS CARPART CDRPART] ((CL:SYMBOLP THING) (if (EQ (CL:SYMBOL-PACKAGE THING) PACKAGE) then THING else (CL:INTERN (CL:STRING-UPCASE (CL:SYMBOL-NAME THING)) PACKAGE))) (T THING]) (MSFAIL [LAMBDA (FLG) (* ; "Edited 25-Nov-86 21:08 by lmm") (PROG (POS) (OR FLG (GO ERR)) SEARCH (OR (SETQ POS (STKPOS (FUNCTION MSTRYPARSE) 1 (STKNTH -1 POS POS) POS)) (GO ERR)) (COND ((EQ (STKARG 1 POS) 'MSCOMMAND) (RETFROM POS NIL T))) (GO SEARCH) ERR (printout T "Sorry, couldn't parse that!" T) (ERROR!]) (MSJOINSET [LAMBDA (C SET1 SET2) (* ; "Edited 15-Aug-90 12:51 by jds") [PROG (TYPE) (COND ([AND (EQ C 'AND) (EQ (fetch (SENTENCE ID) of (fetch (MSSETPHRASE REP) of SET1)) 'QUOTE) (LITATOM (fetch 'QUOTED of (fetch (MSSETPHRASE REP) of SET1))) (EQ (fetch (SENTENCE ID) of (fetch (MSSETPHRASE REP) of SET2)) 'QUOTE) (LITATOM (fetch 'QUOTED of (fetch (MSSETPHRASE REP) of SET2] (printout T (fetch 'QUOTED of (fetch (MSSETPHRASE REP) of SET2)) %, C %, (fetch 'QUOTED of (fetch (MSSETPHRASE REP) of SET1)) " -> " (fetch 'QUOTED of (fetch (MSSETPHRASE REP) of SET2)) %, (SETQQ C OR) %, (fetch 'QUOTED of (fetch (MSSETPHRASE REP) of SET1)) "."))) (replace (MSSETPHRASE DET) of SET1 with (MSJOINDETS C (fetch (MSSETPHRASE DET) of SET1) (fetch (MSSETPHRASE DET) of SET2))) (replace (MSSETPHRASE TYPE) of SET1 with (MSJOIN C (fetch (MSSETPHRASE TYPE) of SET1) (fetch (MSSETPHRASE TYPE) of SET2))) [MSSETSETTYPE SET1 (SETQ TYPE (MSJOIN C (fetch (MSSETPHRASE DEFAULTTYPE) of SET1) (fetch (MSSETPHRASE DEFAULTTYPE) of SET2] (MSSETSETTYPE SET2 TYPE) (COND ((fetch (MSSETPHRASE KNOWN) of SET2) (MSKNOWN SET1)) ((fetch (MSSETPHRASE KNOWN) of SET1) (MSKNOWN SET2))) (replace (MSSETPHRASE REP) of SET1 with (COND ((AND (EQ C 'AND) (NULL (fetch (MSSETPHRASE REP) of SET1))) (fetch (MSSETPHRASE REP) of SET2)) ((AND (EQ C 'AND) (NULL (fetch (MSSETPHRASE REP) of SET2))) (fetch (MSSETPHRASE REP) of SET1)) (T (create CSET ID _ C SET1 _ (create MSSETPHRASE using SET1) SET2 _ SET2] SET1]) (MSBLOCK [LAMBDA NIL (* ; "Edited 25-Nov-86 21:08 by lmm") (SEEKWORD ANY THE A AN) (PROG (TYPES FNS FILES) (SETQ TYPES (OR (MSSEEKTYPE 'BLOCKS) (RETURN))) [COND ((SEEKWORD OF) (SETQ FNS (OR (MSSEEK MSSETPHRASE FNS) (RETURN] [COND ((SEEKWORD ON) (SETQ FILES (OR (MSSEEK MSSETPHRASE FILES) (RETURN))) (OR FNS (AND (SEEKWORD OF) (SETQ FNS (OR (MSSEEK MSSETPHRASE FNS) (RETURN] (OR FNS FILES (RETURN)) (RETURN (create BLOCKS TYPES _ TYPES FNS _ FNS FILES _ FILES]) (MSPATHOPTIONS [LAMBDA (FLG) (* ; "Edited 25-Nov-86 21:08 by lmm") (while (MSSEEKTYPE 'PATH) collect (CONS LASTPARSED (OR (SELECTQ LASTPARSED ((OUTPUT LINELENGTH) (COND (FLG (printout T LASTPARSED "not meaningful except in a SHOW PATHS command!" T))) (MSEAT)) (FROM (MSSEEK MSSETPHRASE FNS T)) (MSSEEK MSSETPHRASE FNS)) (MSCANT]) (MSPARSE [LAMBDA (SENTENCE) (* ; "Edited 15-Aug-90 12:49 by jds") (PROG (NEXTWORD LASTADVERB CONJUNCTIONS VAL RESETS LASTPARSED FLG SEEKING SPELLING RESPELL POSS PARSED (S SENTENCE) OUTPUTFILE) PARSE (OR (SETQ VAL (MSSEEK MSCOMMAND)) (GO MSFAIL)) [COND ((SEEKWORD OUTPUT) (SETQ OUTPUTFILE (MSEAT] (AND (MSNEXTWORD) (GO MSFAIL)) (COND (LASTADVERB (GO MSFAIL))) (MSFIXUPTYPES PARSED) [COND (CONJUNCTIONS (for X in (DREVERSE CONJUNCTIONS) do (SETQ POSS (for Y in (fetch (CONJUNCTION POSSIBLES) of X) when [AND (EQ (fetch (PARSED ENDING) of Y) (fetch (CONJUNCTION START) of X)) (EQ (CAR (fetch (PARSED SOUGHT) of Y)) (CAR (fetch (PARSED SOUGHT) of (fetch (CONJUNCTION PARSED ) of X] collect Y)) [COND ((NULL POSS) (MSFAIL)) ((CDR POSS) (SETQ POSS (SORT (for Y in POSS collect (CONS (MSMATCHRATING (fetch (CONJUNCTION PARSED) of X) Y (fetch (CONJUNCTION C) of X)) Y)) T)) (COND ((EQ (CAAR POSS) (CAADR POSS)) (printout T "ambiguous conjunction, guessing... "))) (SETQ POSS (CDAR POSS))) (T (SETQ POSS (CAR POSS] (SELECTQ (CAR (fetch (PARSED SOUGHT) of POSS)) ((MSSETPHRASE MSPRED MSDOES) (MSJOINSET (fetch (CONJUNCTION C) of X) (fetch (PARSED ITEM) of POSS) (fetch (PARSED ITEM) of (fetch (CONJUNCTION PARSED ) of X)))) (MSVERB [replace (MSVERB VPART) of (fetch (PARSED ITEM) of POSS) with (create CVERB C _ (fetch (CONJUNCTION C) of X) VB1 _ (fetch (MSVERB VPART) of (fetch (PARSED ITEM) of POSS)) VB2 _ (fetch (MSVERB VPART) of (fetch (PARSED ITEM) of (fetch (CONJUNCTION PARSED) of X]) (SHOULDNT] (COND (SPELLING (* I.e. succeeded after spelling  correction) (LISPXPRIN2 SPELLING T T) (LISPXPRIN1 "->" T) (COND ((CAR RESPELL) (LISPXPRIN2 (CAR RESPELL) T T) (LISPXSPACES 1 T))) (LISPXPRINT (CADR RESPELL) T T))) (RETURN (COND (OUTPUTFILE (CONS 'OUTPUT (CONS OUTPUTFILE VAL))) (T VAL))) MSFAIL (COND (NOSPELLFLG (MSFAIL)) ((NULL SPELLING) (SETQ SPELLING (LIST (LIST SENTENCE))) (GO REPARSE)) ((LISTP SPELLING) [for X in SPELLING when (CDR X) do (COND ((SETQ RESPELL (MSRESPELL (SETQ NEXTWORD (CAAR X)) (CAR X) (CDR X))) (SETQ SPELLING NEXTWORD) (GO REPARSE] (* That didn't work, try to respell  things as adverbs) [for X in SPELLING when (CDR X) do (COND ((SETQ RESPELL (MSRESPELL (SETQ SPELLING (CAAR X)) (CAR X) (MSSPLST))) (GO REPARSE] (* If can't, fall through) (MSFAIL)) (T (COND ((CAR RESPELL) (FRPLNODE RESPELL SPELLING (CDDR RESPELL))) (T (FRPLACA (CDR RESPELL) SPELLING))) (* UNDO the spelling correcting  since it was wrong) (MSFAIL))) REPARSE [SETQ NEXTWORD (SETQ LASTADVERB (SETQ PARSED (SETQ CONJUNCTIONS (SETQ VAL (SETQ RESETS (SETQ LASTPARSED (SETQ SEEKING] (SETQ S SENTENCE) (GO PARSE]) (MSFIXUPTYPES [LAMBDA (PRSD FLG) (* ; "Edited 15-Aug-90 12:53 by jds") (for X in (REVERSE PRSD) do (SELECTQ (CAR (fetch (PARSED SOUGHT) of X)) (MSCOMMAND (SELECTQ (fetch (SENTENCE ID) of (fetch (PARSED ITEM) of X)) ((? EDIT SHOW) [MSSETSETTYPE (fetch (SENTENCE SUBJECT) of (fetch (PARSED ITEM) of X)) (OR (fetch (MSSETPHRASE TYPE) of (fetch (SENTENCE MSPRED) of (fetch (PARSED ITEM) of X))) (fetch (MSSETPHRASE DEFAULTTYPE) of (fetch (SENTENCE MSPRED) of (fetch (PARSED ITEM) of X] [MSSETSETTYPE (fetch (SENTENCE MSPRED) of (fetch (PARSED ITEM) of X)) (OR (fetch (MSSETPHRASE TYPE) of (fetch (SENTENCE SUBJECT) of (fetch (PARSED ITEM) of X))) (fetch (MSSETPHRASE DEFAULTTYPE) of (fetch (SENTENCE SUBJECT) of (fetch (PARSED ITEM) of X]) NIL)) ((MSPRED MSSETPHRASE MSDOES) [COND ((type? THAT (fetch (MSSETPHRASE REP) of (fetch (PARSED ITEM) of X))) (FIXVERBSETTYPE (fetch (PARSED ITEM) of X))) ((type? NOT (fetch (MSSETPHRASE REP) of (fetch (PARSED ITEM) of X))) (PROG [(NS (fetch (NOT NEGATED) of (fetch (MSSETPHRASE REP) of (fetch (PARSED ITEM) of X] (COND ((type? THAT (fetch (MSSETPHRASE REP) of NS)) (FIXVERBSETTYPE NS) (MSSETSETTYPE (fetch (PARSED ITEM) of X) (OR (fetch (MSSETPHRASE TYPE) of NS) (fetch (MSSETPHRASE DEFAULTTYPE) of NS))) (AND (fetch (MSSETPHRASE KNOWN) of NS) (MSKNOWN (fetch (PARSED ITEM) of X]) NIL]) (MSVERBTYPE [LAMBDA (MSVERB SUBJECT OBJECT) (* ; "Edited 15-Aug-90 12:49 by jds") (COND ((type? CVERB (fetch (MSVERB VPART) of MSVERB)) (MSVERBTYPE (fetch (CVERB VB1) of (fetch (MSVERB VPART) of MSVERB)) SUBJECT OBJECT) (MSVERBTYPE (fetch (CVERB VB2) of (fetch (MSVERB VPART) of MSVERB)) SUBJECT OBJECT)) (T (PROG (TYPE) [COND ((EQ (fetch (MSVERB TENSE) of MSVERB) 'ED) (SETQ OBJECT (PROG1 SUBJECT (SETQ SUBJECT OBJECT] (SETQ TYPE (OR (fetch (MSSETPHRASE TYPE) of OBJECT) (fetch (MSSETPHRASE DEFAULTTYPE) of OBJECT))) (SELECTQ (fetch (MSVERB ROOT) of MSVERB) (CONTAIN (MSSETSETTYPE SUBJECT 'FILES)) ((USE SET REFERENCE SMASH TEST) (SELECTQ (fetch (MSVERB MODIFIER) of MSVERB) (NIL (AND [EQMEMB (fetch (MSVERB ROOT) of MSVERB) (CDR (GETWORDTYPE TYPE 'AS] (replace (MSVERB MODIFIER) of MSVERB with TYPE))) ((FREELY LOCALLY) (MSSETSETTYPE OBJECT 'VARS)) (MSSETSETTYPE OBJECT (fetch (MSVERB MODIFIER) of MSVERB) )) (MSKNOWN SUBJECT)) (CALL (MSKNOWN SUBJECT) (MSSETSETTYPE OBJECT 'FNS)) (CREATE (MSKNOWN SUBJECT) (MSSETSETTYPE OBJECT 'RECORDS)) ((FETCH REPLACE) (MSKNOWN SUBJECT) (MSSETSETTYPE OBJECT 'FIELDS)) (PROGN (MSKNOWN SUBJECT) (MSSETSETTYPE OBJECT 'VARS]) (MSSETREP [LAMBDA (LISTOKFLG) (* ; "Edited 15-Aug-90 12:48 by jds") (PROG [(NEG (SEEKWORD NOT)) (VAL (COND ((NULL S) NIL) [(SEEKWORD IN) (OR (MSSEEK MSBLOCK) (create IN EXPRESSION _ (MSEAT] ((SEEKWORD %' QUOTE) (MSQUOTED)) [(SEEKWORD @) (create APPLY PRED _ (PROG ((X (MSEAT))) (RETURN (COND ((NLISTP X) X) ((EQ (CAR X) 'LAMBDA) X) (T (LIST 'LAMBDA '(X) X] [(SEEKWORD ONPATH) (create PATHS MSPATHOPTIONS _ (OR (MSSEEK MSPATHOPTIONS T) (MSCANT] [(MSSEEK MSVERB ING) (create THAT MSVERB _ LASTPARSED OTHERSET _ (OR (MSSEEK MSSETPHRASE) (MSCANT] ((MSSEEK MSVERBED)) [(AND (EQ SETTYPE 'FIELDS) (SEEKWORD OF)) (create FIELDS RECS _ (OR (MSSEEK MSSETPHRASE RECORDS) (MSCANT] [(SEEKWORD LIKE) (create APPLY PRED _ (PROG [(PAT (EDITFPAT (MSEAT] (SETQ EDITQUIETFLG T) (RETURN (LIST 'LAMBDA '(X) (LIST 'EDIT4E (KWOTE PAT) 'X] ((SEEKWORD THOSE) (create IN EXPRESSION _ 'MSTHOSE)) ((SEEKWORD KNOWN) (create THAT MSVERB _ (create MSVERB ROOT _ 'IS MODIFIER _ 'KNOWN) OTHERSET _ (create MSSETPHRASE))) ((AND LISTOKFLG (NOTANY S (FUNCTION MSWORD?))) (PROG1 (create QUOTE QUOTED _ S) (SETQ S))) ((MSSEEK MSBLOCK)) [(OR (SEEKWORD THAT) (AND (OR SETDET SETTYPE) (SEEKWORD WHO WHICH))) (fetch (MSSETPHRASE REP) of (OR (MSSEEK MSPRED) (MSCANT] ([COND ((EQ SETDET 'THE)) ((AND (NULL SETDET) (OR (NULL SETTYPE) (LISTP SETTYPE))) (COND ((MSWORD? (MSNEXTWORD)) (AND (LISTP SPELLING) (MSTRYSPELL (CONS (CAR S) (KWOTE (CAR S))) S)) NIL) (T T] (MSQUOTED] (RETURN (COND (NEG (create NOT NEGATED _ (create MSSETPHRASE REP _ VAL))) (T VAL]) (MSSEEKPHRASE [LAMBDA (SOUGHT FORCONJUNCTION) (* ; "Edited 15-Aug-90 12:47 by jds") (PROG ((OS S) (OLA LASTADVERB) (ORS RESETS) (OC CONJUNCTIONS) (OP PARSED) THIS (SEEKING (CONS (create PARSED SOUGHT _ SOUGHT) SEEKING))) (SETQ THIS (CAR SEEKING)) (SETQ LASTPARSED) LP [COND ((LISTP (MSNEXTWORD)) (COND ([PROG ((S (MSNEXTWORD)) (SEEKING)) (RETURN (AND [SETQ LASTPARSED (MSSEEKPHRASE (COND ((EQ (CAR SOUGHT) 'MSSETREP) (LIST 'MSSETREP T)) (T SOUGHT] (NOT (MSNEXTWORD] (SETQ S (CDR S)) (GO GOTIT] (OR (SETQ LASTPARSED (MSTRYPARSE (CAR SOUGHT) (CDR SOUGHT))) (GO MSFAIL)) GOTIT (replace (PARSED ITEM) of THIS with LASTPARSED) (SETQ PARSED (CONS THIS PARSED)) [COND ((AND (NOT FORCONJUNCTION) (FMEMB (CAR SOUGHT) CONJUNCTABLE)) (PROG (LASTPARSED OLDS TEM C (SK SEEKING) (MARKER (CONS))) LP (MSNEXTWORD) (* So that S won't be reset to  something before a adverb) (SETQ OLDS S) [COND ((SETQ C (MSSEEKTYPE 'C)) [COND ((EQ C 'AND) (AND (SEEKWORD NOT) (SETQQ C ANDNOT] (COND ((SETQ TEM (MSSEEKPHRASE (COND ((EQ (CAR SOUGHT) 'MSSETPHRASE) (* kludge. Implicit types should not  carry along) '(MSSETPHRASE)) (T SOUGHT)) T)) (SETQ CONJUNCTIONS (CONS (create CONJUNCTION C _ C PARSED _ (CAR PARSED) POSSIBLES _ SK START _ MARKER) CONJUNCTIONS)) (GO LP)) (T (SETQ S OLDS] (for X in CONJUNCTIONS when (EQ (fetch (CONJUNCTION START) of X) MARKER) do (replace (CONJUNCTION START) of X with S] (replace (PARSED ENDING) of THIS with S) (RETURN LASTPARSED) MSFAIL (SETQ S OS) (SETQ LASTADVERB OLA) (SETQ CONJUNCTIONS OC) (SETQ PARSED OP) (while (NEQ RESETS ORS) do (replace (MSVERB MODIFIER) of (CAR RESETS) with NIL) (SETQ RESETS (CDR RESETS]) (MSTYPEMATCHRATING [LAMBDA (X Y) (* ; "Edited 25-Nov-86 21:08 by lmm") (* Returns the NEGATIVE of a rating of how much two types agree;  the values will be sorted and the minimum taken) (COND ([OR (NULL X) (NULL Y) (EQ (COND ((LISTP X) (SETQ X (CAR X))) (T X)) (COND ((LISTP Y) (SETQ Y (CAR Y))) (T Y))) (AND (EQ X 'KNOWN) (EQ Y 'FNS)) (AND (EQ Y 'KNOWN) (EQ X 'FNS] -100) (T 0]) (MSTRYSPELL [LAMBDA (WORD TAIL) (* ; "Edited 25-Nov-86 21:08 by lmm") [AND TAIL (NLISTP (CAR TAIL)) (LISTP SPELLING) (PROG [(PTR (OR (FASSOC TAIL SPELLING) (CAR (SETQ SPELLING (CONS (LIST TAIL) SPELLING] LP (COND ((NULL (CDR PTR)) (FRPLACD PTR (LIST WORD))) ((NEQ (CAR (SETQ PTR (CDR PTR))) WORD) (GO LP] NIL]) (MSTRYPARSE [LAMBDA (FN ARGS) (* ; "Edited 25-Nov-86 21:08 by lmm") (* lmm%: 17-FEB-76 20 49) (* MSCANT does a RETFROM (MSTRYPARSE)%. The idea is that, no matter how deeply  embedded parser is in a particular SEEK, the MSCANT will back up to the current  att) (BLKAPPLY FN ARGS]) (MSCOMMAND [LAMBDA (TEM) (* ; "Edited 15-Aug-90 12:48 by jds") (COND ((SEEKWORD DESCRIBE) (CONS LASTPARSED (MSSEEK MSSETPHRASE FNS T))) ((SEEKWORD ANALYZE REANALYZE) (CONS LASTPARSED (MSSEEK MSSETPHRASE FNS))) ((SEEKWORD ERASE FORGET) (CONS 'ERASE (MSSEEK MSSETPHRASE FNS))) [(SEEKWORD SHOW) (COND ((SEEKWORD PATHS) (CONS 'PATHS (MSSEEK MSPATHOPTIONS))) [(MSSEEK MSVERB S) (* e.g. SHOW USE OF X) (create SENTENCE ID _ 'SHOW MSPRED _ (create MSSETPHRASE REP _ (create THAT MSVERB _ LASTPARSED OTHERSET _ (PROGN (OR (SEEKWORD OF) (MSCANT)) (OR (MSSEEK MSSETPHRASE) (MSCANT] (T (SEEKWORD WHERE) (create SENTENCE ID _ 'SHOW SUBJECT _ (OR (MSSEEK MSSETPHRASE) (MSCANT)) MSPRED _ (MSSEEK MSPRED] [(SEEKWORD EDIT) (SEEKWORD WHERE) (create SENTENCE ID _ 'EDIT SUBJECT _ (OR (MSSEEK MSSETPHRASE) (MSCANT)) MSPRED _ (MSSEEK MSPRED) OTHERSTUFF _ (COND ((SEEKWORD -) (PROG1 S (SETQ S] [(SEEKWORD FOR) (CONS 'FOR (CONS (MSEAT) (CONS 'IN (CONS (OR (MSSEEK MSSETPHRASE) (MSCANT)) (COND ((EQ (CAR (GETP (CAR S) 'CLISPWORD)) 'FORWORD) (PROG1 S (SETQ S NIL))) (T (MSCANT] ((SEEKWORD CHECK) (SEEKWORD BLOCKS) (SEEKWORD ON) (CONS 'CHECK (MSSEEK MSSETPHRASE FILES))) [(SEEKWORD ARE IS) (* IS FOO CALLED BY X) (create SENTENCE ID _ '? SUBJECT _ (OR (MSSEEK MSSETPHRASE) (MSCANT)) MSPRED _ (OR (MSSEEKPHRASE (LIST 'MSSETPHRASE (fetch (MSSETPHRASE TYPE) of LASTPARSED) (fetch (MSSETPHRASE KNOWN) of LASTPARSED ))) (MSCANT] ((PROGN (SETQ TEM (SEEKWORD DOES DO)) (MSSEEK MSSETPHRASE)) (create SENTENCE ID _ '? SUBJECT _ LASTPARSED MSPRED _ (PROG ((TYPE (fetch (MSSETPHRASE TYPE) of LASTPARSED)) (KNOWN (fetch (MSSETPHRASE KNOWN) of LASTPARSED)) SET) (SETQ SET (OR (MSSEEK MSPRED) (AND (NOT TEM) (MSSEEK MSDOES)) (MSCANT))) (COND (KNOWN (MSKNOWN SET)) (TYPE (MSSETSETTYPE SET TYPE))) (RETURN SET]) (MSSUBJTYPE [LAMBDA (MSVERB) (* ; "Edited 15-Aug-90 12:49 by jds") (* lmm%: 16-DEC-75 1 41) (COND [(type? CVERB (fetch (MSVERB VPART) of MSVERB)) (MSJOIN (fetch (CVERB C) of (fetch (MSVERB VPART) of MSVERB)) (MSSUBJTYPE (fetch (CVERB VB1) of (fetch (MSVERB VPART) of MSVERB))) (MSSUBJTYPE (fetch (CVERB VB2) of (fetch (MSVERB VPART) of MSVERB] ((EQ (fetch (MSVERB ROOT) of MSVERB) 'CONTAIN) 'FILES) (T 'KNOWN]) (MSOBJTYPE [LAMBDA (MSVERB) (* ; "Edited 15-Aug-90 12:49 by jds") (COND [(type? CVERB (fetch (MSVERB VPART) of MSVERB)) (MSJOIN (fetch (CVERB C) of (fetch (MSVERB VPART) of MSVERB)) (MSOBJTYPE (fetch (CVERB VB1) of (fetch (MSVERB VPART) of MSVERB))) (MSOBJTYPE (fetch (CVERB VB2) of (fetch (MSVERB VPART) of MSVERB] ((EQ (fetch (MSVERB ROOT) of MSVERB) 'CALL) '(FNS)) ((EQ (fetch (MSVERB ROOT) of MSVERB) 'CONTAIN) NIL) ((EQ (fetch (MSVERB ROOT) of MSVERB) 'USE) (SELECTQ (fetch (MSVERB MODIFIER) of MSVERB) ((FREELY LOCALLY NIL) '(VARS)) ((RECORDS FIELDS PROPNAMES I.S.OPRS) (LIST (fetch (MSVERB MODIFIER) of MSVERB))) (SHOULDNT))) (T '(VARS]) (MSVERB [LAMBDA (TENSE) (* ; "Edited 25-Nov-86 21:08 by lmm") (PROG ((ROOT (MSSEEKTYPE TENSE)) C) [COND ((NULL ROOT) (COND ((AND (EQ TENSE 'ED) (SEEKWORD ON)) (SETQ S (CONS 'BY S)) (SETQQ ROOT CONTAIN)) (T (RETURN] (RETURN (create MSVERB ROOT _ ROOT TENSE _ TENSE MODIFIER _ (COND ((AND LASTADVERB (FMEMB ROOT (CDR LASTADVERB))) (PROG1 (CAR LASTADVERB) (SETQ LASTADVERB NIL]) (MSSPLST [LAMBDA NIL (* ; "Edited 25-Nov-86 21:08 by lmm") (OR MSSPLST (PROGN (SETQ MSSPLST '(AS FOR)) [MAPHASH MSWORDS (FUNCTION (LAMBDA (MEANING WORD) (AND [find Y in MEANING suchthat (FMEMB (CAR Y) '(V PHRASE] (SETQ MSSPLST (CONS WORD MSSPLST] MSSPLST]) (MSWORD? [LAMBDA (X) (* ; "Edited 25-Nov-86 21:08 by lmm") (* lmm%: 24-JAN-76 6 14) (OR (NOT (LITATOM X)) (GETHASH X MSWORDS]) (MSSEEK-WORD [LAMBDA (LST) (* ; "Edited 25-Nov-86 21:08 by lmm") (LET (FND) (COND ((SETQ FND (CL:MEMBER (MSNEXTWORD) LST :TEST 'STRING.EQUAL)) (SETQ LASTPARSED (CAR FND)) (SETQ S (CDR S)) LASTPARSED) ([AND (LISTP SPELLING) (LISTP S) (NOT (MSWORD? (CAR S] (MAPC LST (FUNCTION (LAMBDA (WORD) (MSTRYSPELL WORD S]) (MSSEEKTYPE [LAMBDA (TYPE) (* ; "Edited 1-Apr-88 13:59 by jrb:") (* ;; "This was a garbage edit, since it didn't have anything to do with parsing") (* ;; "Check here to see if the current word could be an executable thingy.") (* ;; "(|if| (AND (EQ TYPE 'TYPE) (CL:SYMBOLP CURWORD)) |then| (LET ((CURATOM (|if| (EQ CURWORD 'QUOTE) |then| (CADR S) |else| CURWORD)) RESULT) ;; This should actually collect them all and ask you if there's more than one. (|for| FPTYPE |in| MSFNTYPES |when| (HASDEF CURATOM (|ffetch| (MSANALYZABLE FILEPKGNAME) |of| FPTYPE)) |do| (SETQ RESULT (|ffetch| (MSANALYZABLE SETNAME) |of| FPTYPE)) (RETURN)) ;; (COND ((HASDEF CURATOM 'METHOD-FNS) (SETQ RESULT 'METHODS)) ((HASDEF CURATOM 'CLASS) (SETQ RESULT 'CLASSES))) (|if| RESULT |then| ;; For some unintelligible reason, we DON'T remove quoted names... (|if| (NOT (EQ CURWORD 'QUOTE)) |then| (SETQ S (CDR S))) (RETURN RESULT))))") (COND ((SETQ LASTPARSED (GETWORDTYPE (MSNEXTWORD) TYPE)) (SETQ S (CDR S)) LASTPARSED) ((LISTP SPELLING) (MSTRYSPELLTYPE TYPE]) (MSRESPELL [LAMBDA (WORD TAIL SPLST) (* ; "Edited 25-Nov-86 21:08 by lmm") (* lmm%: 22-FEB-76 3 6) (AND (LITATOM WORD) WORD (SETQ SPLST (CHOOZ WORD 70 SPLST TAIL)) [COND [(LITATOM SPLST) (COND ((NEQ SPLST WORD) (SETQ SPLST (CONS NIL (FRPLACA TAIL SPLST] [(LISTP (CDR SPLST)) (* Alias) (SETQ SPLST (CONS NIL (FRPLACA TAIL (CAR (FLAST SPLST] ((CAR SPLST) (SETQ SPLST (FRPLNODE TAIL (CAR SPLST) (CONS (CDR SPLST) (CDR TAIL] SPLST]) (MSJOIN [LAMBDA (C X Y) (* ; "Edited 25-Nov-86 21:08 by lmm") (COND ((OR (EQ X Y) (NULL Y)) X) ((NULL X) Y) (T (UNION (MKLIST X) (MKLIST Y]) (MSSIMPLESET [LAMBDA (X) (* ; "Edited 15-Aug-90 12:52 by jds") (OR (NULL X) (AND (EQ (fetch (SENTENCE ID) of X) 'QUOTE) (OR (NLISTP (fetch 'QUOTED of X)) (NULL (CDR (fetch 'QUOTED of X]) (MSMATCHRATING [LAMBDA (X Y CONJ) (* ; "Edited 15-Aug-90 12:48 by jds") (IPLUS (COND ((EQUAL (fetch (PARSED SOUGHT) of X) (fetch (PARSED SOUGHT) of Y)) -200) (T 0)) (SELECTQ (CAR (fetch (PARSED SOUGHT) of X)) (MSVERB (COND [(EQUAL (CDR (fetch (PARSED SOUGHT) of X)) (CDR (fetch (PARSED SOUGHT) of Y))) (IPLUS (MSTYPEMATCHRATING (MSSUBJTYPE (fetch (PARSED ITEM) of X)) (MSSUBJTYPE (fetch (PARSED ITEM) of Y))) (MSTYPEMATCHRATING (MSOBJTYPE (fetch (PARSED ITEM) of X)) (MSOBJTYPE (fetch (PARSED ITEM) of Y] (T 100))) (MSSETPHRASE (IPLUS (COND ((EQUAL (fetch (MSSETPHRASE TYPE) of (fetch (PARSED ITEM) of X)) (fetch (MSSETPHRASE TYPE) of (fetch (PARSED ITEM) of Y))) -100) (T 0)) (COND ([OR (MSSIMPLESET (fetch (MSSETPHRASE REP) of (fetch (PARSED ITEM) of X))) (MSSIMPLESET (fetch (MSSETPHRASE REP) of (fetch (PARSED ITEM) of Y] (SELECTQ CONJ (OR 50) 600)) (T 0)))) T]) (MSVERBED [LAMBDA NIL (* ; "Edited 12-Jun-90 17:58 by teruuchi") (* Handled separately SOLELY for the  verb SET, which is both present and  past tense) (AND (MSSEEK MSVERB ED) (create THAT MSVERB _ LASTPARSED OTHERSET _ (COND ((SEEKWORD BY IN) (OR (MSSEEK MSSETPHRASE) (MSCANT))) ((EQUAL (MSNEXTWORD) 'OUTPUT) (* ; "Edited by TT (30-May-1990) This Modification is for parsing the command with %"OUTPUT %" [USAR#10196]") (create MSSETPHRASE DET _ 'ANY)) ((MSNEXTWORD) (MSCANT)) (T (* Setphrase of ANY) (create MSSETPHRASE DET _ 'ANY]) (MSCANT [LAMBDA NIL (* ; "Edited 25-Nov-86 21:08 by lmm") (RETFROM 'MSTRYPARSE]) (MSJOINDETS [LAMBDA (C X Y) (* ; "Edited 25-Nov-86 21:08 by lmm") (COND ((NULL X) Y) ((NULL Y) X) ((EQ X Y) X) ((OR (EQ X 'WHICH) (EQ Y 'WHICH)) 'WHICH) (T (SHOULDNT]) (MSNEGATESET [LAMBDA (X) (* ; "Edited 25-Nov-86 21:08 by lmm") (replace (MSSETPHRASE REP) of X with (create NOT NEGATED _ (create MSSETPHRASE using X REP _ (fetch (MSSETPHRASE REP) of X]) (MSNEXTWORD [LAMBDA NIL (* ; "Edited 25-Nov-86 21:08 by lmm") (* lmm%: 16-MAR-76 15 8) (PROG (TEM ADV) LPX [COND ((EQ NEXTWORD S) (RETURN (CAR NEXTWORD] (COND ((NULL (CAR S)) (* i.e. either at end of sentence or at a NIL) (RETURN NIL))) (COND ((NEQ S SENTENCE) (* No adverbs or AS words allowed at beginning of sentence) (COND ((SETQ TEM (GETWORDTYPE (CAR S) 'V)) (* V means ADVERB) (SETQ ADV (CAR TEM)) (GO ADV))) (SELECTQ (SETQ TEM (CAR S)) ((AS FOR) (SELECTQ (CAR (SETQ S (CDR S))) ((A AN) (* Skip over A and AN) (SETQ S (CDR S))) NIL) (CHECKSYNONYM) [SETQ TEM (OR (GETWORDTYPE (CAR S) TEM) (COND ((AND (EQ TEM 'AS) [SOME PARSED (FUNCTION (LAMBDA (X) (EQ (CAR (fetch (PARSED SOUGHT ) of X)) 'MSVERB) (EQ (fetch (MSVERB ROOT) of (fetch (PARSED ITEM) of X)) 'CONTAIN] (SETQ TEM (GETFILEPKGTYPE (CAR S) NIL T))) [MSSETWORDTYPE (CAR S) 'AS (SETQ TEM (CONS TEM '(CONTAIN] TEM) (T (MSFAIL T] (SETQ ADV (CAR TEM)) (GO ADV)) NIL))) (COND ((CHECKSYNONYM) (GO LPX))) (RETURN (CAR (SETQ NEXTWORD S))) ADV (SETQ TEM (CDR TEM)) (SETQ S (CDR S)) (for X in PARSED when (AND (EQ (CAR (fetch (PARSED SOUGHT) of X)) 'MSVERB) (NULL (fetch (MSVERB MODIFIER) of (fetch (PARSED ITEM) of X))) (FMEMB (fetch (MSVERB ROOT) of (fetch (PARSED ITEM) of X)) TEM)) do (replace (MSVERB MODIFIER) of (fetch (PARSED ITEM) of X) with ADV) (SETQ RESETS (CONS (fetch (PARSED ITEM) of X) RESETS)) (GO LPX)) [COND (LASTADVERB (MSFAIL T)) (T (SETQ LASTADVERB (CONS ADV TEM] (GO LPX]) (MSPRED [LAMBDA (FLG) (* ; "Edited 25-Nov-86 21:08 by lmm") (* FLG is used in calls from EDIT/SHOW where passive is not allowed) (AND (SEEKWORD DOES DO) (SETQ FLG T)) (COND [(SEEKWORD NOT) (create MSSETPHRASE REP _ (create NOT NEGATED _ (create MSSETPHRASE REP _ (create THAT MSVERB _ (OR (MSSEEK MSVERB S) (MSCANT)) OTHERSET _ (OR (MSSEEK MSSETPHRASE) (MSCANT] [(MSSEEK MSVERB S) (create MSSETPHRASE REP _ (create THAT MSVERB _ LASTPARSED OTHERSET _ (OR (MSSEEK MSSETPHRASE) (MSCANT] ((AND (NULL FLG) (SEEKWORD ARE IS)) (MSSEEK MSSETPHRASE]) (CHECKSYNONYM [LAMBDA NIL (* ; "Edited 25-Nov-86 21:08 by lmm") (* lmm%: 22-FEB-76 3 10) (* Returns T if a synonym is found. Resets S to be sentence with synonym  substituted) (PROG (KEYLST (STAIL S) NXT (CNT 0)) (COND ([NOT (SETQ KEYLST (GETWORDTYPE (CAR S) 'PHRASE] (RETURN))) (* See SETSYNONYM for def of synonym  format) PHLOOP (SETQ STAIL (CDR STAIL)) LPX (COND ((SETQ NXT (FASSOC (CAR STAIL) (CDR KEYLST))) (SETQ KEYLST (CDR NXT)) (GO PHLOOP)) [(CAR KEYLST) (RETURN (NOT (EQUAL S (SETQ S (APPEND (CAR KEYLST) STAIL] ((SETQ NXT (FASSOC '& (CDR KEYLST))) (* A & in a synonym will match any word;  the word will be substituted for N in the "new" phrase where N is the number of  &'s which have been matched -  e.g. SETSYNONYM ((FOO & &) (IN 1 OR ON 2)) will take FOO FIE FUM into IN FIE OR  ON FUM) (SETQ KEYLST (SUBST (CAR STAIL) (SETQ CNT (ADD1 CNT)) (CDR NXT))) (GO PHLOOP)) ((SETQ NXT (FASSOC '* (CDR KEYLST))) (* Just to make a lot of things easier, a * will match either  (NAME) (NAMES) or nothing) (SETQ KEYLST (CDR NXT)) [COND ((OR (EQ (CAR STAIL) 'NAME) (EQ (CAR STAIL) 'NAMES)) (SETQ STAIL (CDR STAIL] (GO LPX)) (T (* If some words match and others don't, try to correct on the rest) [AND (LISTP STAIL) (LISTP SPELLING) (NOT (MSWORD? (CAR STAIL))) (MAPC (CDR KEYLST) (FUNCTION (LAMBDA (X) (MSTRYSPELL X STAIL] (RETURN]) (MSSETWORDTYPE [LAMBDA (WORD TYPE SYN) (* ; "Edited 25-Nov-86 21:08 by lmm") (PUTHASH WORD (NCONC1 (GETHASH WORD MSWORDS) (CONS TYPE SYN)) MSWORDS]) (MSEAT [LAMBDA NIL (* ; "Edited 25-Nov-86 21:08 by lmm") (* lmm%: 5-DEC-75 11 24) (PROG1 (CAR S) (SETQ S (CDR S]) (MSTRYSPELLTYPE [LAMBDA (TYPE) (* ; "Edited 25-Nov-86 21:08 by lmm") (DECLARE (SPECVARS TYPE)) [AND (LISTP SPELLING) (LITATOM (CAR S)) (NOT (MSWORD? (CAR S))) (MAPHASH MSWORDS (FUNCTION (LAMBDA (INTERP WORD) (AND (FASSOC TYPE INTERP) (MSTRYSPELL WORD S] NIL]) (MSSETPHRASE [LAMBDA (TYPE KNOWN) (* ; "Edited 8-Apr-88 11:37 by jrb:") (PROG (SETDET REP NOTYP SETTYPE VAL (NEG (SEEKWORD NOT))) (SETQ VAL (MSSETSETTYPE (create MSSETPHRASE DET _ [SETQ SETDET (COND ((SETQ NOTYP (SEEKWORD WHO WHOM)) 'WHICH) ((SEEKWORD WHAT WHICH) 'WHICH) (T (SEEKWORD ANY THE A] TYPE _ [SETQ SETTYPE (AND (NOT NOTYP) (MSSEEKTYPE 'TYPE] REP _ (SETQ REP (MSSEEK MSSETREP)) KNOWN _ KNOWN) TYPE)) (OR SETDET SETTYPE REP (MSCANT)) (AND NEG (MSNEGATESET VAL)) (RETURN VAL]) (MSQUOTED [LAMBDA NIL (* ; "Edited 25-Nov-86 21:08 by lmm") (create QUOTE QUOTED _ (MKLIST (MSEAT]) (FIXVERBSETTYPE [LAMBDA (SETPHRSE) (* ; "Edited 15-Aug-90 12:51 by jds") (* lmm%: 16-MAR-76 15 31) (COND ((NULL (fetch (MSSETPHRASE TYPE) of SETPHRSE)) (MSVERBTYPE (fetch (THAT MSVERB) of (fetch (MSSETPHRASE REP) of SETPHRSE)) SETPHRSE (fetch (THAT OTHERSET) of (fetch (MSSETPHRASE REP) of SETPHRSE]) (SETSYNONYM [LAMBDA (OLDPHRASE NEWPHRASE FLG) (* ; "Edited 25-Nov-86 21:08 by lmm") (OR (LISTP OLDPHRASE) (SETQ OLDPHRASE (LIST OLDPHRASE))) [AND NEWPHRASE (OR (LISTP NEWPHRASE) (SETQ NEWPHRASE (LIST NEWPHRASE] [OR (ATOM (CAR OLDPHRASE)) (ERRORX (LIST 14 (CAR OLDPHRASE] (PROG ((KEYLST (GETWORDTYPE (CAR OLDPHRASE) 'PHRASE)) NXT) (* The keylist is of the form  (VALUE (WORD . KEYLST)  (WORD . KEYLST) ...)) [COND ((NULL KEYLST) (MSSETWORDTYPE (CAR OLDPHRASE) 'PHRASE (SETQ KEYLST (LIST NIL] LP (COND ((NLISTP KEYLST) (SHOULDNT)) ((NULL (SETQ OLDPHRASE (CDR OLDPHRASE))) (FRPLACA KEYLST NEWPHRASE) (RETURN)) ((SETQ NXT (FASSOC (CAR OLDPHRASE) KEYLST)) (SETQ KEYLST (CDR NXT))) (T (FRPLACD KEYLST (CONS (CONS (CAR OLDPHRASE) (SETQ NXT (LIST NIL))) (CDR KEYLST))) (SETQ KEYLST NXT))) (GO LP]) (MSSETUP [LAMBDA (V A AS F SYN TYPES OTHERS INITFLG) (* ; "Edited 25-Nov-86 21:08 by lmm") [OR (AND (NULL INITFLG) (HASHARRAYP MSWORDS)) (SETQ MSWORDS (HASHARRAY 150 NIL 'STRING-EQUAL-HASHBITS 'STRING.EQUAL] [MAPC V (FUNCTION (LAMBDA (X) (MSSETWORDTYPE (CAR X) 'S (CAR X)) (MSSETWORDTYPE (CADR X) 'S (CAR X)) (MSSETWORDTYPE (CADDR X) 'ING (CAR X)) (MSSETWORDTYPE (CADDDR X) 'ED (CAR X] [MAPC A (FUNCTION (LAMBDA (X P) (SETQ P (CONS (CAAR X) (CDR X))) (MAPC (CAR X) (FUNCTION (LAMBDA (Y) (MSSETWORDTYPE Y 'V P] [MAPC AS (FUNCTION (LAMBDA (X P) (SETQ P (CONS (CAAR X) (CDR X))) (MAPC (CAR X) (FUNCTION (LAMBDA (Y) (MSSETWORDTYPE Y 'AS P] [MAPC F (FUNCTION (LAMBDA (X P) (SETQ P (CONS (CAAR X) (CDR X))) (MAPC (CAR X) (FUNCTION (LAMBDA (Y) (MSSETWORDTYPE Y 'FOR P] [MAPC SYN (FUNCTION (LAMBDA (X) (SETSYNONYM (CAR X) (CADR X) T] [MAPC TYPES (FUNCTION (LAMBDA (L) (MAPC L (FUNCTION (LAMBDA (X) (MSSETWORDTYPE X 'TYPE (CAR L] [MAPC OTHERS (FUNCTION (LAMBDA (X) (MSSETWORDTYPE (CAR X) (CADR X) (OR (CADDR X) (CAR X] (* I.e. all the things that can occur almost anywhere -  synonyms, adverbs, and the word AS) NIL]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ PARSERRECORDS (SENTENCE CONJUNCTION PARSED MSSETPHRASE MSVERB VPART CVERB THAT QUOTE IN NOT PATHS APPLY CSET BLOCKS FIELDS)) (DECLARE%: EVAL@COMPILE (RECORD SENTENCE (ID SUBJECT MSPRED . OTHERSTUFF)) (RECORD CONJUNCTION (C START PARSED . POSSIBLES)) (RECORD PARSED (SOUGHT ITEM . ENDING)) (RECORD MSSETPHRASE (DET (TYPE KNOWN . DEFAULTTYPE) . REP) (* represents a set of things) (TYPE? (EQLENGTH (CADR DATUM) 2))) (RECORD MSVERB (TENSE . VPART) (SUBRECORD VPART)) (RECORD VPART (ROOT . MODIFIER)) (RECORD CVERB (C VB1 . VB2) [TYPE? (FMEMB (CAR DATUM) '(OR AND ANDNOT]) (RECORD THAT (ID MSVERB . OTHERSET) ID _ 'THAT (TYPE? (EQ (CAR DATUM) 'THAT))) (RECORD QUOTE (ID . QUOTED) ID _ 'QUOTE) (RECORD IN (ID . EXPRESSION) ID _ 'IN) (RECORD NOT (ID . NEGATED) ID _ 'NOT (TYPE? (EQ (CAR DATUM) 'NOT))) (RECORD PATHS (ID . MSPATHOPTIONS) ID _ 'PATHS) (RECORD APPLY (ID . PRED) ID _ 'APPLY) (RECORD CSET (ID SET1 . SET2)) (RECORD BLOCKS (ID TYPES FNS . FILES) ID _ 'BLOCKS (* e.g. ENTRIES ON FOO)) (RECORD FIELDS (ID . RECS) ID _ 'FIELDS) ) (DECLARE%: EVAL@COMPILE (PUTPROPS GETWORDTYPE MACRO [(WORD TYPE) (CDR (FASSOC TYPE (GETHASH WORD MSWORDS]) ) ) (RPAQQ CONJUNCTABLE (MSSETPHRASE MSPRED MSDOES MSVERB)) (RPAQQ MSSPLST NIL) (RPAQQ INITWORDLIST (((CONTAIN CONTAINS CONTAINING CONTAINED) (BIND BINDS BINDING BOUND) (CALL CALLS CALLING CALLED) (SET SETS SETTING SET) (SMASH SMASHES SMASHING SMASHED) (TEST TESTS TESTING TESTED) (USE USES USING USED) (REFERENCE REFERENCES REFERENCING REFERENCED) (CREATE CREATES CREATING CREATED) (FETCH FETCHES FETCHING FETCHED) (REPLACE REPLACES REPLACING REPLACED) (DECLARE DECLARES DECLARING DECLARED)) (((FREELY FREE) USE SET SMASH TEST) ((LOCALLY LOCAL) USE SET SMASH BIND DECLARE REFERENCE) ((SOMEHOW) CALL) ((DIRECTLY) CALL) ((INDIRECTLY) CALL USE)) (((LOCALVARS LOCALVAR) DECLARE) ((SPECVARS SPECVAR) DECLARE) ((RECORDS RECORD) USE) ((FIELDS FIELD) USE SET SMASH REFERENCE) ((PROPNAMES PROPERTIES PROPERTY PROP PROPS) USE) ((I.S.OPRS I.S.OPR CLISPWORD CLISPWORDS) USE) ((MSPRED) CALL USE) ((TYPE) USE)) (((VALUE) CALL USE) ((TESTING) CALL USE) ((EFFECT) CALL)) (((RECORD FIELD *) FIELD) ((RECORD FIELDS) FIELDS) ((FIELD *) FIELD) ((RECORD *) RECORD) ((CLISP WORD) CLISPWORD) ((CLISP WORDS) CLISPWORD) ((PROP *) PROPNAMES) ((PROPERTY *) PROPNAMES) ((ON PATH) ONPATH) ((ON THE PATH) ONPATH) ((ON A PATH) ONPATH) ((LOOK AT) ANALYZE) [(CHANGED ON &) (IN (PROGN (UPDATEFILES) (CDR (GETPROP '1 'FILE] (AMONG (AVOIDING NOT)) (DOESN'T (DOES NOT)) (DON'T (DO NOT)) (ISN'T (IS NOT)) (AREN'T (ARE NOT)) ((ALL PATHS) PATHS) (SOME ANY) (ALL ANY) (ANYONE ANY) ((ALL PATHS) PATHS) (UNDEFINED (FNS NOT @ GETD))) ((FNS FN FUNCTIONS FUNCTION) (VARS VAR VARIABLES VARIABLE) (RECORDS RECORD) (FILES FILE) (I.S.OPRS I.S.OPR CLISPWORD CLISPWORDS) (FIELDS FIELD) (PROPNAMES PROPERTIES PROPS PROP)) ((FROM PATH) (TO PATH) (AVOIDING PATH) (NOTRACE PATH) (MARKING PATH) (OUTPUT PATH) (LINELENGTH PATH) (DOES X DO) (DO X) (IS X) (ARE X IS) (AND C) (OR C) (SEPARATE PATH) (LOCALFREEVARS BLOCKS) (SPECVARS BLOCKS) (LOCALVARS BLOCKS) (GLOBALVARS BLOCKS) (BLOCKS BLOCKS BLKFNS) (BLOCK BLOCKS BLKFNS) (ENTRY BLOCKS ENTRIES) (ENTRIES BLOCKS) (BLKAPPLYFNS BLOCKS) (BLKLIBRARY BLOCKS) (BLKFNS BLOCKS)) T)) (APPLY 'MSSETUP INITWORDLIST) (DEFMACRO MSSEEK (&REST SOUGHT) `(MSSEEKPHRASE ',SOUGHT)) (DEFMACRO SEEKWORD (&REST SOUGHT) `(MSSEEK-WORD ',SOUGHT)) (DEFCOMMAND "." (&REST LINE) "Masterscope query" (MASTERSCOPE LINE)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: MSPARSEBLOCK MSKNOWN MSDOES MSSETSETTYPE MS-SMASH-PACKAGE MSFAIL MSJOINSET MSBLOCK MSPATHOPTIONS MSPARSE MSFIXUPTYPES MSVERBTYPE MSSETREP MSSEEKPHRASE MSTYPEMATCHRATING MSTRYSPELL MSTRYPARSE MSCOMMAND MSSUBJTYPE MSOBJTYPE MSVERB MSSPLST MSWORD? MSSEEKTYPE MSRESPELL MSJOIN MSSIMPLESET MSMATCHRATING MSVERBED MSCANT MSJOINDETS MSNEGATESET MSNEXTWORD MSPRED CHECKSYNONYM MSEAT MSTRYSPELLTYPE MSSETPHRASE MSQUOTED FIXVERBSETTYPE (ENTRIES MSPARSE MSJOINSET MSTRYSPELL SETSYNONYM MSSETUP) (RETFNS MSTRYPARSE) (SPECVARS SPELLING) (LOCALFREEVARS CONJUNCTIONS LASTADVERB LASTPARSED NEXTWORD PARSED S SEEKING SENTENCE RESETS) (BLKAPPLYFNS MSDOES MSVERBED MSBLOCK MSPATHOPTIONS MSSETREP MSCOMMAND MSVERB MSPRED MSSETPHRASE) (LOCALFREEVARS SETTYPE SETDET) (NOLINKFNS . T) (GLOBALVARS MSWORDS MSSPLST CONJUNCTABLE) MSSETUP MSSETWORDTYPE SETSYNONYM MSSEEK-WORD) (BLOCK%: NIL (LOCALVARS . T) (GLOBALVARS MSWORDS)) ) (PUTPROPS MSPARSE FILETYPE :COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS MSPARSE COPYRIGHT ("Venue & Xerox Corporation" 1984 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3128 68762 (MSKNOWN 3138 . 4007) (MSDOES 4009 . 4761) (MSSETSETTYPE 4763 . 7133) ( MS-SMASH-PACKAGE 7135 . 8022) (MSFAIL 8024 . 8610) (MSJOINSET 8612 . 12397) (MSBLOCK 12399 . 13281) ( MSPATHOPTIONS 13283 . 14245) (MSPARSE 14247 . 21910) (MSFIXUPTYPES 21912 . 26177) (MSVERBTYPE 26179 . 28427) (MSSETREP 28429 . 32562) (MSSEEKPHRASE 32564 . 36647) (MSTYPEMATCHRATING 36649 . 37366) ( MSTRYSPELL 37368 . 37943) (MSTRYPARSE 37945 . 38402) (MSCOMMAND 38404 . 42555) (MSSUBJTYPE 42557 . 43395) (MSOBJTYPE 43397 . 44576) (MSVERB 44578 . 45374) (MSSPLST 45376 . 46008) (MSWORD? 46010 . 46274 ) (MSSEEK-WORD 46276 . 46847) (MSSEEKTYPE 46849 . 48061) (MSRESPELL 48063 . 48853) (MSJOIN 48855 . 49122) (MSSIMPLESET 49124 . 49450) (MSMATCHRATING 49452 . 51867) (MSVERBED 51869 . 53178) (MSCANT 53180 . 53325) (MSJOINDETS 53327 . 53634) (MSNEGATESET 53636 . 54115) (MSNEXTWORD 54117 . 58267) ( MSPRED 58269 . 59469) (CHECKSYNONYM 59471 . 61961) (MSSETWORDTYPE 61963 . 62200) (MSEAT 62202 . 62456) (MSTRYSPELLTYPE 62458 . 62907) (MSSETPHRASE 62909 . 64121) (MSQUOTED 64123 . 64306) (FIXVERBSETTYPE 64308 . 64917) (SETSYNONYM 64919 . 66353) (MSSETUP 66355 . 68760))))) STOP \ No newline at end of file diff --git a/library/NSCHAT b/library/NSCHAT new file mode 100644 index 00000000..56a40b6e --- /dev/null +++ b/library/NSCHAT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "12-Sep-91 18:26:50" |{PELE:MV:ENVOS}LIBRARY>NSCHAT.;3| 33673 changes to%: (FNS NSCHAT.SERVICES NSCHAT.OPEN) previous date%: "12-Jun-90 10:26:34" |{PELE:MV:ENVOS}LIBRARY>NSCHAT.;2|) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1989, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT NSCHATCOMS) (RPAQQ NSCHATCOMS [(COURIERPROGRAMS GAP) (FNS NSCHAT.3270.HOST NSCHAT.ATTENTIONFN NSCHAT.ERRORHANDLER NSCHAT.HOST.FILTER NSCHAT.OPEN NSCHAT.OPEN.3270 NSCHAT.OPEN.DIALOUT NSCHAT.OPEN.TTYHOST NSCHAT.SERVICES SPP.INPUT.EVENT ) (INITVARS (NSCHAT.OPTIONS.MENU)) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) SPPDECLS) (RECORDS NSCHAT.SERVICE) (CONSTANTS (\NS.WKS.Courier 5) (GAP.RemoteSystemAdministration 1) (GAP.RemoteSystemExecutive 2) (GAP.InteractiveTerminalService 3)) (GLOBALVARS NSCHAT.OPTIONS.MENU)) (DECLARE%: DONTEVAL@LOAD DOCOPY (* ;; "Tell Chat we exist.") (ADDVARS (CHAT.PROTOCOLTYPES (NS . NSCHAT.HOST.FILTER)) (CHAT.PROTOCOL.ABBREVS (X . NS]) (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))) (DEFINEQ (NSCHAT.3270.HOST (LAMBDA (IBM.VIRTUAL.HOST) (* ejs%: " 3-May-86 18:24") (* ;;; "Retrieves the NSNAME of the physical host on which the virtual host lives") (COURIER.FETCH (GAP . IBM3270HostBack) path (CADR (CH.RETRIEVE.ITEM IBM.VIRTUAL.HOST (QUOTE IBM3270.HOST.BACK) (QUOTE (GAP . IBM3270HostBack)))))) ) (NSCHAT.ATTENTIONFN (LAMBDA (STREAM ATTNBYTE) (* bvm%: "11-Mar-85 13:00") (SELECTQ ATTNBYTE (208 -1) (209 (NOTIFY.EVENT (STREAMPROP STREAM (QUOTE MediumUpEvent)))) (COND ((OR XIPTRACEFLG NSWIZARDFLG) (printout PROMPTWINDOW T "Attention byte: " |.I1.8| ATTNBYTE)))) T) ) (NSCHAT.ERRORHANDLER (LAMBDA (STREAM ERRCODE) (* ejs%: "18-Dec-84 20:43") (SELECTQ ERRCODE (EOM (SPP.CLEAREOM STREAM)) (ATTENTION (SPP.CLEARATTENTION STREAM) (NSCHAT.ATTENTIONFN STREAM (BIN STREAM))) (END (ADD.CHAT.MESSAGE STREAM "[Connection closed by remote host]") -1) (COND ((SPP.OPENP STREAM) (* ; "non-fatal error?") (ADD.CHAT.MESSAGE STREAM (CONCAT "[SPP error " ERRCODE "]")) (BIN STREAM)) (T (\EOF.ACTION STREAM))))) ) (NSCHAT.HOST.FILTER (LAMBDA (NAME EXPLICIT) (* ; "Edited 15-Feb-90 12:50 by bvm") (* ;;; "Return NSCHAT.OPEN if NAME is an NS host with (potentially) a telnet server.") (* ;; "Unless we were explicitly invoked, we ignore hosts with no colon in name") (AND \NSFLG (OR EXPLICIT (STRPOS ":" NAME)) (SETQ NAME (CAR (LOOKUP.NS.SERVER NAME NIL T))) (LIST (MKATOM NAME) (FUNCTION NSCHAT.OPEN)))) ) (NSCHAT.OPEN [LAMBDA (HOST) (* ; "Edited 12-Sep-91 17:48 by jds") (* ;;; "Return a pair of SPP streams for a chat connection, or NIL. Add CHAT specific operations to the STREAM via STREAMPROP.") (PROG ((MediumUpEvent (CREATE.EVENT)) SERVICE.OPTIONS PORT SERVICE OUTSTREAM STREAM HANDLE FAILURE) LP (SETQ SERVICE.OPTIONS (NSCHAT.SERVICES HOST SERVICE)) [COND ([NOT (SETQ SERVICE (COND ((LITATOM SERVICE.OPTIONS) (* ;;  "The clearinghouse didn't respond, so return T to move to the (NULL SERVICE.OPTIONS) clause.") T) ((EQLENGTH SERVICE.OPTIONS 1) (printout PROMPTWINDOW T "Connecting to " (CAAR SERVICE.OPTIONS) " on " HOST T) (CADAR SERVICE.OPTIONS)) (T (PROG1 [MENU (create MENU ITEMS _ SERVICE.OPTIONS TITLE _ "Specific NS Service?" WHENSELECTEDFN _ (FUNCTION (LAMBDA (ITEM MENU MOUSE) (CADR ITEM] (CLRPROMPT] (COND (STREAM (CLOSEF? STREAM))) (RETURN NIL)) ((LITATOM SERVICE.OPTIONS) (SETQ FAILURE (CONCAT "Clearinghouse not responding - " SERVICE.OPTIONS))) ([NULL (SETQ PORT (LOOKUP.NS.SERVER (CL:FUNCALL (fetch (NSCHAT.SERVICE PhysicalHostFunction) of SERVICE) HOST] (SETQ FAILURE "Name not found")) ([NULL (SETQ STREAM (COURIER.OPEN PORT NIL T 'NSCHAT NIL '(EOM.ON.FORCEOUT T ERRORHANDLER NSCHAT.ERRORHANDLER ATTENTIONFN NSCHAT.ATTENTIONFN] (* ; "No response") ) (T (STREAMPROP STREAM 'MediumUpEvent MediumUpEvent) (* ;  "the EOFPFN is udf - (STREAMPROP STREAM 'EOFPFN (FUNCTION NSCHAT.EOFPFN))") (SPP.DSTYPE STREAM 192) (COND [(NLISTP (SETQ HANDLE (CL:FUNCALL (fetch (NSCHAT.SERVICE OpenFunction) of SERVICE) STREAM HOST (fetch (NSCHAT.SERVICE ServiceID) of SERVICE] [(EQ (CAR HANDLE) 'ERROR) (SETQ FAILURE (SELECTQ (CADR HANDLE) ((REJECT serviceNotFound) [PRINTOUT PROMPTWINDOW T HOST " does not support " (CAR (find S in SERVICE.OPTIONS suchthat (EQ SERVICE (CADR S] (GO LP)) (SUBSTRING (CDR HANDLE) 2 -2] (T (STREAMPROP STREAM 'SETDISPLAYTYPE (FUNCTION NILL)) (STREAMPROP STREAM 'LOGINFO (FUNCTION NILL)) (STREAMPROP STREAM 'FLUSH&WAIT (FUNCTION NILL)) (STREAMPROP STREAM 'SENDSCREENPARAMS (FUNCTION NILL)) (STREAMPROP STREAM 'READPEVENT (SPP.INPUT.EVENT STREAM)) (SETQ OUTSTREAM (SPPOUTPUTSTREAM STREAM)) (AWAIT.EVENT MediumUpEvent 15000) (COND ((NEQ SERVICE GAP.InteractiveTerminalService) (* ;;  "This is always true. Do you suppose he means (fetch ServiceID of service)? --bvm") (SPP.SENDATTENTION OUTSTREAM 209))) (RETURN (CONS STREAM OUTSTREAM] (CLOSEF? STREAM) (printout PROMPTWINDOW T "Could not chat to " HOST " because: " (OR FAILURE "No Response")) (RETURN NIL]) (NSCHAT.OPEN.3270 (LAMBDA (STREAM IBM3270.VIRTUAL.HOST) (* bvm%: " 7-Oct-86 21:24") (LET ((AUTHENTICATOR (CH.GETAUTHENTICATOR T)) (CONTROLLER (CAR (CADR (CH.RETRIEVE.ITEM IBM3270.VIRTUAL.HOST (QUOTE IBM3270HOSTDATA) (QUOTE (GAP . IBM3270HostData))))))) (COND ((AND CONTROLLER STREAM) (COURIER.CALL STREAM (QUOTE GAP) (QUOTE Create) (BQUOTE (ibm3270Host)) (SELECTQ (COURIER.FETCH (GAP . IBM3270Controller) linkType CONTROLLER) (sdlc (BQUOTE ((sdlcTerminal ((\, (CONCAT (fetch (NSNAME NSOBJECT) of (PARSE.NSNAME IBM3270.VIRTUAL.HOST)) "#" (OCTALSTRING (COURIER.FETCH (GAP . IBM3270Controller) controllerAddress CONTROLLER)) "B")) 1))))) (bsc (BQUOTE ((polledBSCTerminal ((\, (CONCAT (fetch (NSNAME NSOBJECT) of (PARSE.NSNAME IBM3270.VIRTUAL.HOST)) "#" (OCTALSTRING (COURIER.FETCH (GAP . IBM3270Controller) controllerAddress CONTROLLER)) "B")) 5))))) (ERROR "Unknown 3270 controller link type" (COURIER.FETCH (GAP . IBM3270Controller) linkType CONTROLLER))) 15000 (CAR AUTHENTICATOR) (CADR AUTHENTICATOR) (QUOTE RETURNERRORS)))))) ) (NSCHAT.OPEN.DIALOUT [LAMBDA (STREAM HOST) (* ; "Edited 2-Apr-90 16:38 by gadener") (* ;; "From {PHYLUM}MEDLEY>PATCHES>NSCHAT-DIALOUT-PATCH.;1") (DECLARE (GLOBALVARS CHAT.PHONE.NUMBERS)) (LET ([RS232CDATA (CADR (CH.RETRIEVE.ITEM HOST 'RS232CDATA '(GAP . RS232CData] (AUTHENTICATOR (CH.GETAUTHENTICATOR T)) PHONENUMBER) (COND ((NULL RS232CDATA) (printout PROMPTWINDOW T HOST " does not appear support dialout service" T) (CLOSEF STREAM) (ERROR!)) (T (RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (CSTREAM) (AND RESETSTATE (CLOSEF CSTREAM] STREAM)) (OR (EQ (COURIER.FETCH (GAP . RS232CData) dialingHardware of RS232CDATA) 'none) (SETQ PHONENUMBER (CHAT.CHOOSE.PHONE.NUMBER))) (COURIER.CALL STREAM 'GAP 'Create `[tty ,(LIST (COURIER.FETCH (GAP . RS232CData) charLength of RS232CDATA) (COURIER.FETCH (GAP . RS232CData) parity of RS232CDATA) (COURIER.FETCH (GAP . RS232CData) stopBits of RS232CDATA) 100 (COURIER.FETCH (GAP . RS232CData) flowControl of RS232CDATA] [COND [PHONENUMBER `([rs232c (((dialConn (full asynchronous ,(COURIER.FETCH (GAP . RS232CData) lineSpeed of RS232CDATA) auto ,(COURIER.FETCH (GAP . RS232CData) dialerNumber of RS232CDATA) 1))) preemptInactive preemptInactive ,PHONENUMBER (reserveNeeded (,(COURIER.FETCH (GAP . RS232CData) lineNumber of RS232CDATA] (teletype] (T `([rs232c ([(directConn (full asynchronous ,(COURIER.FETCH (GAP . RS232CData) lineSpeed of RS232CDATA] preemptInactive preemptInactive NIL (reserveNeeded (,(COURIER.FETCH (GAP . RS232CData) lineNumber of RS232CDATA] (teletype] 15000 (CAR AUTHENTICATOR) (CADR AUTHENTICATOR) 'RETURNERRORS))]) (NSCHAT.OPEN.TTYHOST (LAMBDA (STREAM HOST SERVICE) (* bvm%: " 7-Oct-86 21:12") (LET ((AUTHENTICATOR (CH.GETAUTHENTICATOR))) (COURIER.CALL STREAM (QUOTE GAP) (QUOTE Create) (QUOTE (ttyHost (seven even two 100 (none 0 0)))) (BQUOTE ((service ((\, SERVICE))) (teletype))) 15000 (CAR AUTHENTICATOR) (CADR AUTHENTICATOR) (QUOTE RETURNERRORS)))) ) (NSCHAT.SERVICES [LAMBDA (HOST ALLFLG) (* ; "Edited 12-Sep-91 17:43 by jds") (LET [(SERVICES (CONSTANT `((,(LIST (CH.PROPERTY 'FILE.SERVICE) (CH.PROPERTY 'PRINT.SERVICE) (CH.PROPERTY 'CLEARINGHOUSE.SERVICE) (CH.PROPERTY 'EXTERNAL.COMMUNICATION.SERVICE) (CH.PROPERTY 'GATEWAY.SERVICE) (CH.PROPERTY 'INTERNET.ROUTING.SERVICE) (CH.PROPERTY 'MAIL.SERVICE) (CH.PROPERTY 'REMOTE.BATCH.SERVICE) 10024) "Remote System Administration" ,(create NSCHAT.SERVICE ServiceID _ GAP.RemoteSystemAdministration PhysicalHostFunction _ (FUNCTION CL:IDENTITY) OpenFunction _ (FUNCTION NSCHAT.OPEN.TTYHOST)) "Connect to a server executive") (,(CH.PROPERTY 'WORKSTATION) "Remote System Executive" ,(create NSCHAT.SERVICE ServiceID _ GAP.RemoteSystemExecutive PhysicalHostFunction _ (FUNCTION CL:IDENTITY) OpenFunction _ (FUNCTION NSCHAT.OPEN.TTYHOST)) "Connect to a remote exec on another workstation") (,(CH.PROPERTY 'INTERACTIVE.TERMINAL.SERVICE) "Interactive Terminal Service" ,(create NSCHAT.SERVICE ServiceID _ GAP.InteractiveTerminalService PhysicalHostFunction _ (FUNCTION CL:IDENTITY) OpenFunction _ (FUNCTION NSCHAT.OPEN.TTYHOST)) "Connect to a terminal-based mail reader") (,(CH.PROPERTY 'RS232CDATA) "RS232 Dialout" ,(create NSCHAT.SERVICE ServiceID _ 'DIALOUT PhysicalHostFunction _ (FUNCTION CL:IDENTITY) OpenFunction _ (FUNCTION NSCHAT.OPEN.DIALOUT)) "Connect to a dialout facility") (,(CH.PROPERTY 'IBM3270.HOST) "IBM3270 Emulation Service" ,(create NSCHAT.SERVICE ServiceID _ 'IBM3270 PhysicalHostFunction _ (FUNCTION NSCHAT.3270.HOST) OpenFunction _ (FUNCTION NSCHAT.OPEN.3270)) "Connect to an IBM3270 Emulator Port"] (if [AND (NOT ALLFLG) (for S in SERVICES bind (PROPERTIES _ (CADR (CH.LIST.PROPERTIES HOST))) first (COND ((LITATOM PROPERTIES) (* ; "CH.LIST.PROPERTIES returned an atom, indicating a failure mode. Return NIL to indicate that we had trouble.") (RETFROM 'NSCHAT.SERVICES PROPERTIES))) collect (CDR S) when (for X inside (CAR S) thereis (FMEMB X PROPERTIES] else (if (NOT ALLFLG) then (printout PROMPTWINDOW T HOST " does not have any registered NSCHAT services.")) (printout PROMPTWINDOW T "Please choose a service from the menu.") (* ; "Return them all") (MAPCAR SERVICES (FUNCTION CDR]) (SPP.INPUT.EVENT (LAMBDA (STREAM) (* ejs%: " 2-Jul-85 13:38") (* ;;; "Returns the SPPINPUTEVENT of the associated connection for STREAM, if STREAM is open for INPUT") (COND ((EQ (fetch (STREAM ACCESS) of STREAM) (QUOTE INPUT)) (fetch (SPPCON SPPINPUTEVENT) of (fetch (SPPSTREAM SPP.CONNECTION) of STREAM))) (T (ERROR "FILE NOT OPEN" STREAM)))) ) ) (RPAQ? NSCHAT.OPTIONS.MENU ) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) SPPDECLS) (DECLARE%: EVAL@COMPILE (RECORD NSCHAT.SERVICE (ServiceID PhysicalHostFunction OpenFunction)) ) (DECLARE%: EVAL@COMPILE (RPAQQ \NS.WKS.Courier 5) (RPAQQ GAP.RemoteSystemAdministration 1) (RPAQQ GAP.RemoteSystemExecutive 2) (RPAQQ GAP.InteractiveTerminalService 3) (CONSTANTS (\NS.WKS.Courier 5) (GAP.RemoteSystemAdministration 1) (GAP.RemoteSystemExecutive 2) (GAP.InteractiveTerminalService 3)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS NSCHAT.OPTIONS.MENU) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDTOVAR CHAT.PROTOCOLTYPES (NS . NSCHAT.HOST.FILTER)) (ADDTOVAR CHAT.PROTOCOL.ABBREVS (X . NS)) ) (PUTPROPS NSCHAT COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1989 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (17206 32785 (NSCHAT.3270.HOST 17216 . 17525) (NSCHAT.ATTENTIONFN 17527 . 17800) ( NSCHAT.ERRORHANDLER 17802 . 18233) (NSCHAT.HOST.FILTER 18235 . 18629) (NSCHAT.OPEN 18631 . 23259) ( NSCHAT.OPEN.3270 23261 . 24294) (NSCHAT.OPEN.DIALOUT 24296 . 27727) (NSCHAT.OPEN.TTYHOST 27729 . 28074 ) (NSCHAT.SERVICES 28076 . 32432) (SPP.INPUT.EVENT 32434 . 32783))))) STOP \ No newline at end of file diff --git a/library/NSMAINTAIN b/library/NSMAINTAIN new file mode 100644 index 00000000..f5b94cd8 --- /dev/null +++ b/library/NSMAINTAIN @@ -0,0 +1,366 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED " 8-Jan-92 10:57:28" "{piglet/n}vanmelle>lispusers>NSMAINTAIN.;32" 69479 + + changes to%: (FNS \NSMT.DESCRIBE.OBJECT) (VARS NSMAINTAINCOMS) + + previous date%: "17-Sep-91 14:31:41" "{piglet/n}vanmelle>lispusers>NSMAINTAIN.;30") + + +(* ; " +Copyright (c) 1985, 1986, 1987, 1989, 1990, 1991, 1992 by Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT NSMAINTAINCOMS) + +(RPAQQ NSMAINTAINCOMS ((COMS (* ; "Main entry and utility fns") (FNS NSMAINTAIN \NSMT.INITIAL.LOGIN \NSMT.HELP \NSMT.READFNAME \NSMT.LOOKUP \NSMT.LOOKUP1 \NSMT.CHECK.DOMAIN \NSMT.DOMAIN.MAY.EXIST \NSMT.FOREIGN.DOMAINP \NSMT.COLLECT.NAMES \NSMT.GET.REMARK \NSMT.GET.PASSWORD \NSMT.LOGIN \NSMT.GETAUTHENTICATOR \NSMT.CHANGE.DOMAIN \NSMT.PRINT.LIST \NSMT.PRINT.OBJECTS \NSMT.PROCESS.LIST \NSMT.READ.COMMA.LIST \NSMT.SHOW.RESULT \NSMT.CHOOSE \NSMT.COURIER.OPEN \NSMT.CLEAR.CACHE EQUAL.NSADDRESS)) (COMS (* ; "Ordinary user commands") (FNS \NSMT.CHANGE.PASSWORD \NSMT.DESCRIBE.ACL \NSMT.DESCRIBE.OBJECT \NSMT.DESCRIPTIVE.PROPS \NSMT.DESCRIBE.PROPERTY \NSMT.PRETTY.PROPERTY \NSMT.LIST.OBJECTS \NSMT.LIST.CLEARINGHOUSES \NSMT.LIST.SERVERS \NSMT.SHOW.DETAILS \NSMT.GROUP.FILTER \NSMT.LIST.ADMINISTRATORS \NSMT.FETCH.ADMINISTRATORS \NSMT.FETCH.ADMINISTRATORS1 \NSMT.LIST.DOMAINS \NSMT.TYPE.ENTRY \NSMT.TYPE.MEMBERS \NSMT.UNCACHE \NSMT.CLEAR.NAME.CACHE)) (COMS (* ; "Administrator commands") (FNS \NSMT.ADD.ALIAS \NSMT.ADD.GROUP \NSMT.SET.INITIAL.ACL \NSMT.ADD.USER \NSMT.ADD.OBJECT \NSMT.CREATE.OBJECT \NSMT.ADD.OBJECT.GENERIC \NSMT.CHANGE.ADDRESS \NSMT.CHANGE.ADMINISTRATORS \NSMT.CHANGE.FORWARDING \NSMT.CHANGE.GROUP.COMPONENT \NSMT.CHANGE.REMARK \NSMT.GET.OBJECT.TYPE \NSMT.REMOVE.ALIAS \NSMT.REMOVE.OBJECT \NSMT.REMOVE.USER)) (FILES (SYSLOAD) DES AUTHENTICATION) (COMS (* ; "Patch to clearinghouse") (FNS CH.FINDSERVER)) (VARS *NSMAINTAIN-COMMANDS* *NSMAINTAIN-ABORT-ITEM*) (ADDVARS (CH.PROPERTIES (ALIAS 1) (BOOT.SERVICE 10026)) (*NSMAINTAIN-DESCRIPTIVE-PROPERTIES* 10000 10001 10002 10003 10004 10005 10006 10007 10008 10009 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10022 10023 10024 10026) (*NSMAINTAIN-IGNORE-PROPERTIES* 6 7 10027 20003 20002 20101) (*NSMAINTAIN-PROPERTY-FORMATS* (4 CLEARINGHOUSE . NETWORK.ADDRESS.LIST) (8 RECORD (SIMPLE BOOLEAN) (STRONG BOOLEAN)) (30 . NSNAME) (31 CLEARINGHOUSE . MAILBOX.VALUES) (10000 . STRING) (10001 . STRING) (10002 . STRING) (10003 . STRING) (10004 . STRING) (10005 . STRING) (10006 . STRING) (10007 . STRING) (10008 . STRING) (10009 . STRING) (10010 . STRING) (10011 . STRING) (10012 . STRING) (10013 . STRING) (10014 . STRING) (10015 . STRING) (10016 . STRING) (10017 . STRING) (10018 . STRING) (10019 . STRING) (10020 . STRING) (10021 . STRING) (10022 . STRING) (10023 . STRING) (10024 . STRING) (10026 . STRING) (10029 . STRING) (10030 . STRING) (10032 . STRING) (10034 . STRING) (10035 . STRING) (15002 . STRING) (20000 CLEARINGHOUSE . USERDATA.VALUE) (20001 GAP . RS232CData) (20006 SEQUENCE NSNAME) (20007 . NSNAME) (20102 GAP . RS232CBack) (29965 . STRING) (30005 . NSNAME)) (*NSMAINTAIN-MEMBER-PROPERTIES* 3 20006)) (INITVARS (*NSMAINTAIN-MEMBER-THRESHOLD* 3) (*NSMAINTAIN-SHOW-GROUP-ACCESS*)) (DECLARE%: EVAL@COMPILE (P (CL:PROCLAIM (QUOTE (CL:SPECIAL *NSMAINTAIN-MEMBER-THRESHOLD* *NSMAINTAIN-SHOW-GROUP-ACCESS*))) (CL:PROCLAIM (QUOTE (GLOBAL *NSMAINTAIN-MEMBER-PROPERTIES* *NSMAINTAIN-PROPERTY-FORMATS* *NSMAINTAIN-IGNORE-PROPERTIES* *NSMAINTAIN-DESCRIPTIVE-PROPERTIES*)))) DONTCOPY (FUNCTIONS WITH-CHS) (FILES (LOADCOMP) CLEARINGHOUSE) (* ; "Get optimizer for CH.PROPERTY") (CONSTANTS \CH.BROADCAST.SOCKET) (GLOBALVARS *NSMAINTAIN-COMMANDS* *NSMAINTAIN-ABORT-ITEM* CH.PROPERTIES) (P (CL:PROCLAIM (QUOTE (CL:SPECIAL *USER* *LASTDOMAIN* *LASTNAME* *LASTGROUP* *LASTLIST* *LASTSTRING* *LAST-MEMBERSHIP* *SERVERTYPES* *ALLTYPES* *OBJECTTYPES* *DEFAULTDOMAIN* *REAL-NAME-CACHE* *DOMAIN*)))) (LOCALVARS . T) (* ;; "For masterscope") (VARS (*NSMT-MENU-FNS* (CL:REMOVE-DUPLICATES (FOR ENTRY IN *NSMAINTAIN-COMMANDS* WHEN (LISTP (SETQ ENTRY (CADR (MEMB (QUOTE RETURN) ENTRY)))) COLLECT (IF (EQ (CAR ENTRY) (QUOTE FUNCTION)) THEN (CADR ENTRY) ELSEIF (EQ (CAR ENTRY) (QUOTE QUOTE)) THEN (CAR (LISTP (CADR ENTRY))))))))))) + + + +(* ; "Main entry and utility fns") + +(DEFINEQ + +(NSMAINTAIN +(LAMBDA NIL (* ; "Edited 21-Nov-90 12:38 by bvm") (PROG ((*STANDARD-OUTPUT* (PROGN (* ; "Make sure T for FORMAT and PRINTOUT are the same (yecch).") (\GETSTREAM T (QUOTE OUTPUT)))) (*REAL-NAME-CACHE* (HASHARRAY 10 NIL (FUNCTION (LAMBDA (OBJECT) (* ; "Use first part of name to produce hash bits") (STRING-EQUAL-HASHBITS (fetch NSOBJECT of OBJECT)))) (FUNCTION EQUAL.CH.NAMES))) *USER* *LASTNAME* *DEFAULTDOMAIN* *LASTDOMAIN* *LASTGROUP* *LASTSTRING* *LASTLIST* *LAST-MEMBERSHIP* *SERVERTYPES* *ALLTYPES* *OBJECTTYPES* ORIG-USER PASS) (* ;; "*REAL-NAME-CACHE* entries are of several possible forms:") (* ;; "1) Ordinary ns name. Value is distinguished name, or :NONE if no such object.") (* ;; "2) org:*:*. Value :OK => org is legal. :NONE => no such org") (* ;; "3) domain:org:*. Same as 2, plus value :FOREIGN => domain:org is a known gatewayed domain.") (* ;; "4) *:domain:org. Value is list of domain administrators.") (\NSMT.INITIAL.LOGIN) (SETQ ORIG-USER *USER*) (do (TERPRI T) repeatwhile (NULL (ERSETQ (bind CMD while (SETQ CMD (ASKUSER NIL NIL "CH: " *NSMAINTAIN-COMMANDS* T NIL (QUOTE (AUTOCOMPLETEFLG T)))) do (COND ((LISTP CMD) (APPLY (CAR CMD) (CDR CMD))) (T (CL:FUNCALL CMD))) (TERPRI T))))) (if (AND (NOT (EQUAL.CH.NAMES *USER* ORIG-USER)) (CL:Y-OR-N-P "Note: ~A is currently logged in. Restore login to ~A? " *USER* ORIG-USER)) then (SETPASSWORD (QUOTE |NS::|) (NSNAME.TO.STRING ORIG-USER T) (PROMPTFORWORD "Password: " NIL NIL T (QUOTE *)))))) +) + +(\NSMT.INITIAL.LOGIN +(LAMBDA NIL (* ; "Edited 14-Nov-90 17:12 by bvm") (* ;; "Get user to log in if necessary, and set *USER*, *LASTNAME*, *LASTDOMAIN*, *DEFAULTDOMAIN* appropriately") (LET* ((CREDS (\INTERNAL/GETPASSWORD (QUOTE |NS::|))) (FULLNAME (\NSMT.LOOKUP1 (SETQ *USER* (PARSE.NSNAME (CAR CREDS))))) (BADP (CASE FULLNAME (:NONE (SETQ FULLNAME NIL) "not a valid name") ((NIL) "no verification from Clearinghouse") (T NIL)))) (CL:FORMAT T "[Default login: ~A~@[ (~A)~];~%% Default domain: ~A]~%%" (NSNAME.TO.STRING (OR FULLNAME *USER*) T) BADP (NSNAME.TO.STRING (SETQ *LASTDOMAIN* (SETQ *DEFAULTDOMAIN* (create NSNAME NSDOMAIN _ CH.DEFAULT.DOMAIN NSORGANIZATION _ CH.DEFAULT.ORGANIZATION))) T)) (if (AND (SETQ *LASTNAME* FULLNAME) (NOT (EQUAL.CH.NAMES *USER* FULLNAME))) then (* ; "Canonical name different from current login, so be helpful and canonize") (RPLACA CREDS (NSNAME.TO.STRING (SETQ *LASTNAME* (SETQ *USER* FULLNAME)) T))))) +) + +(\NSMT.HELP +(LAMBDA NIL (* ; "Edited 21-Aug-89 18:14 by bvm") (* ;; "Give more compact help than ASKUSER's default") (PRINTOUT T T T " You need type only the initial letters of most command words. + Use Control-E to abort a command." T T) (LET ((LINELEN (LINELENGTH NIL T)) *LASTSTRING* LASTN EXPLAINSTRING UNPRINTED CMD LEN TAB) (for ITEM in *NSMAINTAIN-COMMANDS* unless (EQ (CHCON1 (SETQ CMD (CAR ITEM))) (CHARCODE ?)) do (* ; "Handle all commands but ?") (if (AND (NOT (SETQ EXPLAINSTRING (LISTGET ITEM (QUOTE EXPLAINSTRING)))) *LASTSTRING* (> (SETQ LEN (NCHARS CMD)) LASTN) (STRING-EQUAL *LASTSTRING* CMD :END1 LASTN :END2 LASTN)) then (* ; "This command has same prefix as previous one") (if UNPRINTED then (PRINTOUT T (SUBSTRING *LASTSTRING* 1 LASTN) "{" (SUBSTRING *LASTSTRING* (ADD1 LASTN))) (SETQ UNPRINTED NIL) (SETQ TAB (ADD1 (POSITION T))) (* ; "An aesthetically pleasing tab stop puts command directly under next command")) (PRIN1 "," T) (if (> (+ (POSITION T) (- LEN LASTN) 3) LINELEN) then (* ; "No room left on this line, so tab to reasonable place.") (TERPRI T) (TAB TAB NIL T)) (PRIN1 (SUBSTRING CMD LASTN) T) else (* ; "New prefix.") (if *LASTSTRING* then (* ; "Clean up previous command") (PRINTOUT T (if UNPRINTED then *LASTSTRING* else "}") T)) (if EXPLAINSTRING then (* ; "Explicit thing here for ?") (PRINTOUT T EXPLAINSTRING T) (SETQ *LASTSTRING* NIL) elseif (SETQ LASTN (STRPOS " " CMD)) then (SETQ *LASTSTRING* CMD) (SETQ UNPRINTED T) else (PRINTOUT T CMD T) (SETQ *LASTSTRING* NIL)))) (if *LASTSTRING* then (* ; "Take care of the last line") (PRINTOUT T (if UNPRINTED then *LASTSTRING* else "}") T)))) +) + +(\NSMT.READFNAME +(LAMBDA (PROMPT DEFAULT DOMAINFLG ...FLG CHECK *OK) (* ; "Edited 14-Nov-90 17:09 by bvm") (* ;; "Prompt for a name with PROMPT, offering DEFAULT. If DOMAINFLG is true, we expect a domain (2-part name), else a 3-part name. If ...FLG is true, print ... after successfully reading name.") (* ;; "CHECK controls whether we verify the name: NIL=don't; :OK=do, but happily accept anything; :CONFIRM=require confirmation if bad name; :FOREIGN=accept names in foreign domains, otherwise like :CONFIRM; T=must be valid name.") (* ;; "*OK controls whether * is ok in any component: NIL=no; T=ok in first component only; :ANY=yes.") (PROG ((COLON ":") NAME COLPOS FULLNAME REALNAME) RETRY (if (NULL (SETQ NAME (PROMPTFORWORD PROMPT (COND ((AND DEFAULT (TYPENAMEP DEFAULT (QUOTE NSNAME))) (* ; "Make it fully qualified") (NSNAME.TO.STRING DEFAULT T)) (T DEFAULT)) NIL T NIL NIL (CHARCODE (EOL))))) then (printout T " xxx" T) (* ; "aborted") (RETURN NIL)) (SETQ FULLNAME (if (AND (SETQ COLPOS (STRPOS COLON NAME)) (NEQ COLPOS (NCHARS NAME))) then (SETQ COLPOS (STRPOS COLON NAME (ADD1 COLPOS))) (* ; "Find second colon") (if DOMAINFLG then (* ; "Wants domain name--a 2-part name") (if COLPOS then (* ; "too many colons") (PRINTOUT T " Invalid domain" T) (RETURN NIL) else (PARSE.NSNAME NAME 2 *DEFAULTDOMAIN*)) else (if (NOT COLPOS) then (* ; "Org defaulted") (printout T COLON (fetch NSORGANIZATION of *DEFAULTDOMAIN*)) elseif (EQ COLPOS (NCHARS NAME)) then (* ; "Trailing colon after domain") (printout T (fetch NSORGANIZATION of *DEFAULTDOMAIN*))) (PARSE.NSNAME NAME 3 *DEFAULTDOMAIN*)) else (* ; "Completely unqualified (or only a trailing colon)") (if COLPOS then (* ; "User typed, e.g., %"Fred:%"") (SETQ NAME (SUBSTRING NAME 1 -2)) else (PRIN1 COLON T)) (if DOMAINFLG then (printout T (fetch NSORGANIZATION of *DEFAULTDOMAIN*)) (create NSNAME using *DEFAULTDOMAIN* NSDOMAIN _ NAME) else (printout T (fetch NSDOMAIN of *DEFAULTDOMAIN*) COLON (fetch NSORGANIZATION of *DEFAULTDOMAIN*)) (create NSNAME using *DEFAULTDOMAIN* NSOBJECT _ NAME)))) (if (STRPOS "*" NAME) then (if (CASE *OK (:ANY (* ; "Any old * is ok") NIL) ((NIL) (* ; "No * is ok") T) (T (* ; "* permitted in first part only") (OR (STRPOS "*" (fetch NSORGANIZATION of FULLNAME)) (AND (NOT DOMAINFLG) (STRPOS "*" (fetch NSDOMAIN of FULLNAME)))))) then (PRINTOUT T " ... Invalid use of *" T) (SETQ DEFAULT FULLNAME) (GO RETRY)) elseif CHECK then (* ; "Canonicalize the name") (SETQ REALNAME (\NSMT.LOOKUP FULLNAME (EQ CHECK :FOREIGN))) (if (NULL REALNAME) then (if (NOT (CASE CHECK (:OK (* ; "Accept it regardless") T) ((:FOREIGN :CONFIRM) (* ; "Accept with confirmation") (CL:Y-OR-N-P " Use it anyway? ")) (T (* ; "Must be valid name") (TERPRI T) NIL))) then (SETQ DEFAULT FULLNAME) (GO RETRY)) else (SETQ FULLNAME REALNAME))) (COND (...FLG (PRIN1 " ... " T))) (RETURN FULLNAME))) +) + +(\NSMT.LOOKUP +(LAMBDA (NAME FOREIGNOK) (* ; "Edited 14-Nov-90 17:20 by bvm") (* ;; "Like CH.LOOKUP.OBJECT but caches results (well, at least the positive ones). Also prints out message if it couldn't find name or name was an alias") (OR (TYPEP NAME (QUOTE NSNAME)) (SETQ NAME (PARSE.NSNAME NAME))) (PROG ((CACHE (GETHASH NAME *REAL-NAME-CACHE*)) FULLNAME) (if CACHE then (SETQ FULLNAME CACHE) else (CASE (\NSMT.CHECK.DOMAIN NAME) ((:OK NIL) (if (SETQ FULLNAME (\NSMT.LOOKUP1 NAME)) then (PUTHASH NAME FULLNAME *REAL-NAME-CACHE*))) (:NONE (RETURN NIL)) (:FOREIGN (RETURN (AND FOREIGNOK NAME))))) (if (NULL FULLNAME) then (PRINTOUT T " (couldn't verify name)") elseif (EQ FULLNAME :NONE) then (PRINTOUT T " (non-existent name)") (SETQ FULLNAME NIL) elseif (NOT (EQUAL.CH.NAMES FULLNAME NAME)) then (printout T " = " (NSNAME.TO.STRING FULLNAME T))) (RETURN FULLNAME))) +) + +(\NSMT.LOOKUP1 +(LAMBDA (NAME) (* ; "Edited 14-Nov-90 16:34 by bvm") (* ;;; "Returns the canonical name of the specified object, :none if it doesn't exist, nil if we couldn't figure it out (because of chs problem)") (LET ((ADDRESS (CH.FINDSERVER NAME T)) RESULT) (if (NOT ADDRESS) then NIL elseif (NLISTP (SETQ RESULT (COURIER.EXPEDITED.CALL ADDRESS \CH.BROADCAST.SOCKET (QUOTE CLEARINGHOUSE) (QUOTE LOOKUP.OBJECT) NAME (CH.GETAUTHENTICATOR) (QUOTE RETURNERRORS)))) then RESULT elseif (EQ (CADDR (LISTP RESULT)) (QUOTE NoSuchObject)) then :NONE else NIL))) +) + +(\NSMT.CHECK.DOMAIN +(LAMBDA (NAME) (* ; "Edited 14-Nov-90 17:44 by bvm") (* ;; "See whether name is in a valid domain. Returns :ok, :none, :foreign, or nil if it can't figure out right now. We do all this because the Lisp chs interface doesn't let us find out in any detail why an operation failed. Also, it's silly to keep getting prompt messages about a non-existent domain, when we can certainly cache the answers.") (PROG* ((ORG (fetch NSORGANIZATION of NAME)) (TEST (create NSNAME NSOBJECT _ ORG NSDOMAIN _ "*" NSORGANIZATION _ "*")) (RESULT (GETHASH TEST *REAL-NAME-CACHE*)) ORGCACHE) (if (NOT RESULT) then (* ;; "See if the org exists. First check the chs cache, which is faster than asking a chs.") (CASE (OR (SETQ ORGCACHE (\CH.FIND.ORG.SERVER ORG T T)) (SETQ RESULT (\NSMT.LOOKUP1 (create NSNAME using TEST NSDOMAIN _ "CHServers" NSORGANIZATION _ "CHServers")))) (:NONE) ((NIL) (* ; "punt") (RETURN NIL)) (T (SETQ RESULT :OK))) (* ; "And cache the result, copying the test object (which is ordinarily smashed further below)") (PUTHASH (create NSNAME using TEST) RESULT *REAL-NAME-CACHE*)) (if (NEQ RESULT :OK) then (printout T " (no such organization)") (RETURN RESULT)) (* ;; "Ok, the org exists, shift right one") (replace NSDOMAIN of TEST with (fetch NSOBJECT of TEST)) (replace NSOBJECT of TEST with (fetch NSDOMAIN of NAME)) (SETQ RESULT (GETHASH TEST *REAL-NAME-CACHE*)) (if (NOT RESULT) then (* ;; "See if the domain exists") (CASE (OR (AND (OR ORGCACHE (\CH.FIND.ORG.SERVER ORG T T)) (CL:ASSOC (fetch NSDOMAIN of NAME) (CDDR ORGCACHE) :TEST (QUOTE STRING-EQUAL))) (SETQ RESULT (\NSMT.LOOKUP1 (create NSNAME using TEST NSORGANIZATION _ "CHServers")))) (:NONE (if (NOT (SETQ RESULT (\NSMT.FOREIGN.DOMAINP NAME))) then (* ; "punt") (RETURN NIL))) ((NIL) (* ; "punt") (RETURN NIL)) (T (SETQ RESULT :OK))) (* ; "And cache the result") (PUTHASH TEST RESULT *REAL-NAME-CACHE*)) (if (NEQ RESULT :OK) then (printout T " (" (if (EQ RESULT :FOREIGN) then "foreign" else "no such") " domain)")) (RETURN RESULT))) +) + +(\NSMT.DOMAIN.MAY.EXIST +(LAMBDA (DOMAIN) (* ; "Edited 14-Nov-90 18:03 by bvm") (CASE (\NSMT.CHECK.DOMAIN DOMAIN) ((NIL :OK) T))) +) + +(\NSMT.FOREIGN.DOMAINP +(LAMBDA (NAME) (* ; "Edited 14-Nov-90 16:51 by bvm") (* ;; "Returns :foreign, :none, nil depending on whether name specifies a foreign domain, simply nonexistent domain, or we couldn't find out") (LET* ((OBJ (create NSNAME NSOBJECT _ (CONCAT (fetch NSDOMAIN of NAME) (fetch NSORGANIZATION of NAME)) NSDOMAIN _ "..." NSORGANIZATION _ "...")) (RESULT (\NSMT.LOOKUP1 OBJ))) (CASE RESULT ((:NONE NIL) RESULT) (T (* ;; "The object domainorganization:...:... exists. Now retrieve the property that verifies that it's this domain and org, rather than some other concatenation.") (LET ((ADDRESS (CH.FINDSERVER RESULT T)) VALUE) (if (AND ADDRESS (LISTP (SETQ VALUE (COURIER.EXPEDITED.CALL ADDRESS \CH.BROADCAST.SOCKET (QUOTE CLEARINGHOUSE) (QUOTE RETRIEVE.ITEM) RESULT (CH.PROPERTY (QUOTE FOREIGNMAILSYSTEMNAME)) (CH.GETAUTHENTICATOR) (QUOTE RETURNERRORS))))) then (if (NEQ (CAR VALUE) (QUOTE ERROR)) then (SETQ VALUE (COURIER.READ.REP (CADR VALUE) (QUOTE CLEARINGHOUSE) (QUOTE NSNAME))) (if (AND (STRING-EQUAL (fetch NSDOMAIN of NAME) (fetch NSDOMAIN of VALUE)) (STRING-EQUAL (fetch NSORGANIZATION of NAME) (fetch NSORGANIZATION of VALUE))) then :FOREIGN else :NONE) elseif (EQ (CADDR VALUE) (QUOTE Missing)) then :NONE))))))) +) + +(\NSMT.COLLECT.NAMES +(LAMBDA (PROMPT CHECK *OK) (* ; "Edited 14-Aug-87 15:14 by bvm:") (* ;; "Prompt for an arbitrary number of names. CHECK and *OK are the corresponding args to \nsmt.readfname.") (bind NAME while (SETQ NAME (PROGN (TERPRI T) (\NSMT.READFNAME PROMPT NIL NIL NIL CHECK *OK))) collect NAME)) +) + +(\NSMT.GET.REMARK +(LAMBDA (DEFAULT) (* ; "Edited 11-Aug-87 12:24 by bvm:") (* ;; "Prompt for a remark (an arbitrary string used to describe an object). DEFAULT if any is usually the previous remark.") (PROMPTFORWORD "Remark (terminate with CR):" DEFAULT NIL T NIL NIL (CHARCODE (CR)))) +) + +(\NSMT.GET.PASSWORD +(LAMBDA (PROMPT) (* ; "Edited 11-Aug-87 13:39 by bvm:") (* ;; "Read a password, prompting with PROMPT. Ask user to retry password to verify that it was typed correctly. Loop if the retype mismatches the original. Return NIL if user declines to enter a password in the first place.") (PROG (PASS) LP (COND ((NULL (SETQ PASS (PROMPTFORWORD PROMPT NIL NIL T (QUOTE *)))) (RETURN NIL)) ((STREQUAL PASS (PROMPTFORWORD " (retype password)" NIL NIL T (QUOTE *))) (RETURN PASS)) (T (PRINTOUT T T "Mismatch. Try again." T) (SETQ PROMPT "Password:") (GO LP))))) +) + +(\NSMT.LOGIN +(LAMBDA NIL (* ; "Edited 14-Nov-90 17:13 by bvm") (bind LOGINFO FULLNAME until (OR (NULL (SETQ LOGINFO (\INTERNAL/GETPASSWORD (QUOTE |NS::|) T))) (COND ((AND (SETQ FULLNAME (\NSMT.LOOKUP1 (SETQ *USER* (PARSE.NSNAME (CAR LOGINFO) 3 *DEFAULTDOMAIN*)))) (NEQ FULLNAME :NONE)) (RPLACA LOGINFO (NSNAME.TO.STRING (SETQ *USER* FULLNAME) T)) (* ; "Make login canonical") (\NSMT.SHOW.RESULT (NS.AUTHENTICATE (NS.MAKE.SIMPLE.CREDENTIALS LOGINFO)))) (T (CL:FORMAT T " Invalid name ~A~%%" (NSNAME.TO.STRING *USER* T)) NIL))))) +) + +(\NSMT.GETAUTHENTICATOR +(LAMBDA NIL (* ; "Edited 14-Nov-90 11:57 by bvm") (LET ((INFO (\INTERNAL/GETPASSWORD (QUOTE |NS::|)))) (COND (INFO (* ; "Make sure we use the canonical user name here, not an alias") (COURIER.CREATE (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS _ (COURIER.CREATE (AUTHENTICATION . CREDENTIALS) TYPE _ (QUOTE SIMPLE) VALUE _ (COURIER.WRITE.REP *USER* (QUOTE AUTHENTICATION) (QUOTE SIMPLE.CREDENTIALS))) VERIFIER _ (COURIER.WRITE.REP (HASH.PASSWORD (CDR INFO)) (QUOTE AUTHENTICATION) (QUOTE SIMPLE.VERIFIER)))) (T (ERROR!))))) +) + +(\NSMT.CHANGE.DOMAIN +(LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET ((DOMAIN (\NSMT.READFNAME " (for name entry) to be:" *DEFAULTDOMAIN* T))) (COND (DOMAIN (TERPRI T) (COND ((CL:Y-OR-N-P "Set this default globally as well (i.e. for use outside Maintain)? ") (SETQ CH.DEFAULT.DOMAIN (fetch NSDOMAIN of DOMAIN)) (SETQ CH.DEFAULT.ORGANIZATION (fetch NSORGANIZATION of DOMAIN)))) (SETQ *LASTDOMAIN* (SETQ *DEFAULTDOMAIN* DOMAIN)))))) +) + +(\NSMT.PRINT.LIST +(LAMBDA (LST PREFIX) (* ; "Edited 21-Nov-90 12:38 by bvm") (if PREFIX then (PRINTOUT T .FONT BOLDFONT PREFIX .FONT DEFAULTFONT)) (if (EQ (CAR LST) (QUOTE ERROR)) then (\NSMT.SHOW.RESULT LST) else (if (NULL LST) then (PRINTOUT T "(none)") else (MAPRINT LST T NIL NIL ", ")) (TERPRI T))) +) + +(\NSMT.PRINT.OBJECTS +(LAMBDA (OBJECTS) (* ; "Edited 15-Nov-90 18:04 by bvm") (for OBJ in OBJECTS bind LASTDOMAIN LASTORG do (COND ((AND LASTDOMAIN (STRING-EQUAL (fetch NSDOMAIN of OBJ) LASTDOMAIN) (STRING-EQUAL (fetch NSORGANIZATION of OBJ) LASTORG)) (PRINTOUT T ", ")) (T (PRINTOUT T T "[In " .FONT BOLDFONT (SETQ LASTDOMAIN (fetch NSDOMAIN of OBJ)) ":" (SETQ LASTORG (fetch NSORGANIZATION of OBJ)) .FONT DEFAULTFONT "] "))) (PRIN1 (fetch NSOBJECT of OBJ) T)) (TERPRI T)) +) + +(\NSMT.PROCESS.LIST +(LAMBDA (ITEMS *DOMAIN* LISTFN) (* ; "Edited 26-Sep-90 17:26 by bvm") (DECLARE (SPECVARS *DOMAIN*)) (* ; "Usable by LISTFN") (* ;; "Display a list of Clearinghouse objects. OBJECTS is the result of some sort of listing call. If the result is a list of strings, DOMAIN is supplied so that future %"Show Details%" commands can use it. LISTFN is a function to call to print the list; it returns a possibly new list of objects to be saved for later.") (COND ((EQ (CAR ITEMS) (QUOTE ERROR)) (\NSMT.SHOW.RESULT ITEMS)) (T (COND (LISTFN (SETQ ITEMS (CL:FUNCALL LISTFN ITEMS))) (T (\NSMT.PRINT.LIST ITEMS))) (COND (ITEMS (* ; "Save list for Show Details command.") (SETQ *LASTLIST* (CONS (AND *DOMAIN* (SETQ *LASTDOMAIN* (create NSNAME using *DOMAIN* NSOBJECT _ NIL))) ITEMS))))))) +) + +(\NSMT.READ.COMMA.LIST +(LAMBDA (PROMPT DEFAULT) (* ; "Edited 19-Nov-90 15:17 by bvm") (* ;; "Read a list of strings separated by commas. Return a list (or NIL) of the stuff between commas, with white space trimmed. DEFAULT is the old list, offered as initial type in") (LET ((VALUE (TTYIN PROMPT NIL NIL (QUOTE (STRING NORAISE)) NIL NIL (AND DEFAULT (if (CDR DEFAULT) then (CONCATLIST (CDR (for PIECE in DEFAULT join (LIST ", " (MKSTRING PIECE))))) else (MKSTRING (CAR DEFAULT))))))) (AND VALUE (bind (START _ 1) COMMA PIECE when (> (NCHARS (SETQ PIECE (CL:STRING-TRIM (QUOTE (#\Space #\Tab)) (SUBSTRING VALUE START (AND (SETQ COMMA (STRPOS "," VALUE START)) (SUB1 COMMA)))))) 0) collect (* ; "Parse stuff out from between the commas") PIECE repeatwhile (AND COMMA (SETQ START (ADD1 COMMA))))))) +) + +(\NSMT.SHOW.RESULT +(LAMBDA (RESULT PART FIRST SECOND) (* ; "Edited 21-Aug-89 17:14 by bvm") (* ;; "Used to show the outcome of a typical clearinghouse operation. If RESULT is T or NIL, it succeeded, otherwise we print an error code. FIRST and SECOND, if non-NIL, are the actual names we used in the call, in case error has a FIRST or SECOND identification.") (COND ((OR (EQ RESULT T) (NULL RESULT)) (printout T " done" T) (* ; "Return T for success") T) (T (COND (PART (PRINTOUT T " " PART))) (PRINTOUT T " failed: ") (if (EQ (CAR (LISTP RESULT)) (QUOTE ERROR)) then (PRINTOUT T (CADDR RESULT)) (LET ((CULPRIT (CASE (CADDDR RESULT) (FIRST FIRST) (SECOND SECOND)))) (if CULPRIT then (PRINTOUT T " " CULPRIT))) else (PRINTOUT T RESULT)) (TERPRI T) NIL))) +) + +(\NSMT.CHOOSE +(LAMBDA (PROMPT ALTERNATIVES) (* ; "Edited 19-Nov-90 14:50 by bvm") (* ;; "Prompt for one of alternatives. aborts.") (ASKUSER NIL NIL PROMPT (CONS *NSMAINTAIN-ABORT-ITEM* ALTERNATIVES) T)) +) + +(\NSMT.COURIER.OPEN +(LAMBDA (DOMAIN) (* ; "Edited 14-Nov-90 19:11 by bvm") (* ;; "Open a courier connection to a server for this domain. Caller is responsible for closing it.") (PROG (SERVER STREAM LOOPED) (if (NOT (TYPENAMEP DOMAIN (QUOTE NSNAME))) then (SETQ DOMAIN (PARSE.NSNAME DOMAIN 2))) (if (AND (CL:HASH-TABLE-P *REAL-NAME-CACHE*) (NOT (\NSMT.DOMAIN.MAY.EXIST DOMAIN))) then (* ;; "Check up front whether domain is ok, rather than letting Lisp chs stuff go wild") (RETURN NIL)) TOP (if (SETQ SERVER (CH.FINDSERVER DOMAIN T)) then (if (SETQ STREAM (COURIER.OPEN SERVER NIL T)) then (* ; "Ah, success") (RETURN STREAM)) (if (NOT LOOPED) then (* ; "Maybe time to refresh the cache") (\NSMT.CLEAR.CACHE DOMAIN) (SETQ LOOPED T) (GO TOP))) (PRINTOUT T "[Couldn't " (if SERVER then "contact" else "locate") " server for " (fetch NSDOMAIN of DOMAIN) ":" (fetch NSORGANIZATION of DOMAIN) "] ") (RETURN NIL))) +) + +(\NSMT.CLEAR.CACHE +(LAMBDA (DOMAIN) (* ; "Edited 2-Nov-90 14:51 by bvm") (* ;; "Clear the clearinghouse cache of servers for this domain. NIL means everyone. Domain can be *:org to clear all servers for a given org. Returns T if it did anything.") (if (NULL DOMAIN) then (SETQ \CH.CACHE (SETQ LOCAL.CLEARINGHOUSE NIL)) (GETCLEARINGHOUSE) T else (SETQ DOMAIN (PARSE.NSNAME DOMAIN 2)) (LET* ((ORG (fetch NSORGANIZATION of DOMAIN)) (ORGINFO (CL:ASSOC ORG \CH.CACHE :TEST (QUOTE STRING-EQUAL))) DOM DOMINFO) (if (NULL ORGINFO) then NIL elseif (OR (STRING-EQUAL (SETQ DOM (fetch NSDOMAIN of DOMAIN)) "*") (STRING-EQUAL ORG "...") (STRING-EQUAL ORG "CHServers")) then (SETQ \CH.CACHE (DREMOVE ORGINFO \CH.CACHE)) (* ; "Get rid of them all") (if (AND LOCAL.CLEARINGHOUSE (EQUAL.NSADDRESS LOCAL.CLEARINGHOUSE (CAAADR ORGINFO))) then (* ; "It was our primary server, so go get another.") (SETQ LOCAL.CLEARINGHOUSE NIL) (GETCLEARINGHOUSE)) T elseif (SETQ DOMINFO (CL:ASSOC DOM (CDDR ORGINFO) :TEST (QUOTE STRING-EQUAL))) then (if (NULL (RPLACD (CDR ORGINFO) (DREMOVE DOMINFO (CDDR ORGINFO)))) then (* ; "Get rid of org altogether if this was the only server cached") (SETQ \CH.CACHE (DREMOVE ORGINFO \CH.CACHE))) T)))) +) + +(EQUAL.NSADDRESS +(LAMBDA (A1 A2) (* ; "Edited 2-Nov-90 14:50 by bvm") (AND (EQ (ffetch NSHNM2 of (\DTEST A1 (QUOTE NSADDRESS))) (ffetch NSHNM2 of (\DTEST A2 (QUOTE NSADDRESS)))) (EQ (ffetch NSHNM1 of A1) (ffetch NSHNM1 of A2)) (EQ (ffetch NSHNM0 of A1) (ffetch NSHNM0 of A2)) (EQ (ffetch NSNETLO of A1) (ffetch NSNETLO of A2)) (EQ (ffetch NSNETHI of A1) (ffetch NSNETHI of A2)) (EQ (ffetch NSSOCKET of A1) (ffetch NSSOCKET of A2)))) +) +) + + + +(* ; "Ordinary user commands") + +(DEFINEQ + +(\NSMT.CHANGE.PASSWORD +(LAMBDA NIL (* ; "Edited 14-Nov-90 17:16 by bvm") (LET ((NAME (\NSMT.READFNAME " for user:" (NSNAME.TO.STRING *USER* T) NIL NIL T)) PASS) (COND ((NULL NAME) NIL) ((NULL (SETQ PASS (\NSMT.GET.PASSWORD " to be:"))) (printout T " xxx" T)) (T (PRIN1 "..." T) (COND ((AND NAME (EQUAL.CH.NAMES *USER* (SETQ *LASTNAME* (SETQ *LASTSTRING* NAME)))) (* ; "Changing own password") (COND ((\NSMT.SHOW.RESULT (AS.CHANGE.OWN.PASSWORDS (\ENCRYPT.PWD (CONCAT PASS)))) (\INTERNAL/SETPASSWORD (QUOTE |NS::|) (CONS (NSNAME.TO.STRING NAME T) PASS))))) (T (* ; "Changing someone else's password. Only way to do this is to delete the old keys and create new ones.") (\NSMT.SHOW.RESULT (AS.REPLACE.PASSWORDS NAME (\ENCRYPT.PWD (CONCAT PASS)))))))))) +) + +(\NSMT.DESCRIBE.ACL +(LAMBDA (NAME WHICH.LIST AUTH S PROPERTY) (* ; "Edited 21-Nov-90 12:01 by bvm") (* ;; "Fetch and display the access control list WHICH.LIST for NAME. PROPERTY is the property under control, defaulting to MEMBERS") (LET ((MEMBERS (COURIER.CALL S (QUOTE CHACCESSCONTROL) (QUOTE RETRIEVE.PROPERTY.ACL) NAME (OR PROPERTY (CH.PROPERTY (QUOTE MEMBERS))) WHICH.LIST (QUOTE (CHACCESSCONTROL . ELEMENT.NAME)) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS of AUTH) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) VERIFIER of AUTH) (QUOTE RETURNERRORS))) ADMIN) (PRINTOUT T .FONT BOLDFONT (CASE WHICH.LIST (Administrators "Owners: ") (selfControllers "Friends: ")) .FONT DEFAULTFONT) (if (AND (CDDDDR (LISTP MEMBERS)) (SETQ ADMIN (\NSMT.FETCH.ADMINISTRATORS NAME T S)) (EQ (LENGTH MEMBERS) (LENGTH ADMIN)) (CL:EVERY (FUNCTION EQUAL.CH.NAMES) MEMBERS ADMIN)) then (* ;; "It's equal to the list of domain administrators, so guess that that's what it is. It's really stupid that this interface doesn't let us tell the difference between the acl being defaulted or not.") (CL:FORMAT T "(Administrators of ~A:~A)~%%" (fetch NSDOMAIN of NAME) (fetch NSORGANIZATION of NAME)) else (\NSMT.PRINT.LIST MEMBERS)))) +) + +(\NSMT.DESCRIBE.OBJECT +(LAMBDA (NAME BRIEFLY) (* ; "Edited 8-Jan-92 10:57 by bvm") (* ;; "Identify name by type and show its interesting properties. Return distinguished name if it exists, else NIL.") (WITH-CHS (S NAME) (PROG* ((SIMPLE.AUTH (CH.GETAUTHENTICATOR)) (NAME&PROPS (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE LIST.PROPERTIES) NAME SIMPLE.AUTH (QUOTE RETURNERRORS))) (PROP.MEMBERS (CH.PROPERTY (QUOTE MEMBERS))) MAINPROPS PROPS ALIASES DESCR GOTSOME FORWARD GROUPP USERP USERGROUPP) (if (EQ (CAR NAME&PROPS) (QUOTE ERROR)) then (RETURN (\NSMT.SHOW.RESULT NAME&PROPS)) else (* ; "Pull out distinguished name") (SETQ NAME (CAR NAME&PROPS))) (FRESHLINE T) (printout T T .FONT BOLDFONT (NSNAME.TO.STRING NAME T) .FONT DEFAULTFONT) (SETQ PROPS (CL:NSET-DIFFERENCE (CADR NAME&PROPS) *NSMAINTAIN-IGNORE-PROPERTIES*)) (SETQ MAINPROPS (\NSMT.DESCRIPTIVE.PROPS PROPS)) (SETQ GROUPP (CL:MEMBER PROP.MEMBERS PROPS)) (for P in MAINPROPS do (if (EQ P (CH.PROPERTY (QUOTE USER))) then (* ; "Note this for subsequent kludge") (SETQ USERP T)) (if (AND (EQ P (CH.PROPERTY (QUOTE USERGROUP))) (PROGN (SETQ USERGROUPP T) USERP) GROUPP) then (* ;; "Both USER and group? This is kludge to get NS mail forwarding, so don't mention USERGROUP (the prop %"describes%" the forwarding, but is pretty uninteresting). We depend on server returning props in order, which means we got to USER before USERGROUP.") else (CL:FORMAT T " ~A a ~A~@[ (~A)~]" (if GOTSOME then (* ; "Multiple identities") (TERPRI T) " and" else (* ; "First prop") (SETQ GOTSOME T) "is") (\NSMT.PRETTY.PROPERTY P) (LET ((DESCR (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE RETRIEVE.ITEM) NAME P SIMPLE.AUTH (QUOTE NOERROR)))) (* ;; "Description of object is stored as string on this descriptive property. Sometimes the value is null, which is why we are careful about trying to interpret the result.") (AND DESCR (COURIER.READ.REP (CADR DESCR) NIL (QUOTE STRING)))))) (SETQ PROPS (CL:DELETE P PROPS))) (if GROUPP then (if USERP then (SETQ FORWARD T) (SETQ GROUPP NIL) else (if (NOT USERGROUPP) then (COND (GOTSOME (PRINTOUT T T " and")) (T (PRINTOUT T " is"))) (PRINTOUT T " a group")) (SETQ PROPS (CL:DELETE PROP.MEMBERS PROPS)))) (SETQ *LASTSTRING* (if GROUPP then (SETQ *LASTGROUP* NAME) else (SETQ *LASTNAME* NAME))) (if (NOT BRIEFLY) then (TERPRI T) (if (SETQ ALIASES (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE LIST.ALIASES.OF) NAME (QUOTE (CLEARINGHOUSE . OBJECT.NAME)) SIMPLE.AUTH (QUOTE NOERROR))) then (\NSMT.PRINT.LIST ALIASES "Aliases: ")) (for P in PROPS do (\NSMT.DESCRIBE.PROPERTY NAME P S (AND FORWARD (EQ P PROP.MEMBERS) "Forwarding"))) (if (OR GROUPP (AND FORWARD (EQ *NSMAINTAIN-SHOW-GROUP-ACCESS* :ALWAYS))) then (* ; "Show owners and friends") (\NSMT.DESCRIBE.ACL NAME (QUOTE Administrators) SIMPLE.AUTH S) (\NSMT.DESCRIBE.ACL NAME (QUOTE selfControllers) SIMPLE.AUTH S) (if (AND GROUPP (> *NSMAINTAIN-MEMBER-THRESHOLD* 0)) then (* ; "Look at membership") (PRINTOUT T .FONT BOLDFONT "Members: " .FONT DEFAULTFONT) (LET ((MEMBERS (LISTP (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE RETRIEVE.MEMBERS) NAME PROP.MEMBERS (QUOTE (CLEARINGHOUSE . OBJECT.NAME)) SIMPLE.AUTH (QUOTE RETURNERRORS)))) (*PRINT-CASE* 10) N) (if (EQ (CAR MEMBERS) (QUOTE ERROR)) then (\NSMT.SHOW.RESULT MEMBERS) else (if MEMBERS then (* ; "Save for Type Members") (SETQ *LAST-MEMBERSHIP* (CONS NAME MEMBERS))) (if (< (SETQ N (LENGTH MEMBERS)) *NSMAINTAIN-MEMBER-THRESHOLD*) then (* ; "If there are few enough members, just show them") (\NSMT.PRINT.LIST MEMBERS) else (PRINT N T))))))) (RETURN NAME)))) +) + +(\NSMT.DESCRIPTIVE.PROPS +(LAMBDA (PROPS) (* ; "Edited 20-Nov-90 13:01 by bvm") (* ;; "PROPS is a list of property numbers. Return the subset that are %"descriptive%" properties, i.e., whose value is a remark string.") (* ;; "If we fail on the documented props, see if any props are in the 10000 range, which is conventionally allocated for descriptions") (OR (CL:INTERSECTION PROPS *NSMAINTAIN-DESCRIPTIVE-PROPERTIES*) (for P in PROPS collect P when (AND (>= P 10000) (<= P 20000))))) +) + +(\NSMT.DESCRIBE.PROPERTY +(LAMBDA (FNAME CHP S PROPNAME) (* ; "Edited 20-Nov-90 14:47 by bvm") (* ;; "Called by \NSMT.TYPE.ENTRY to show one particular property.") (LET* ((GROUPP (MEMB CHP *NSMAINTAIN-MEMBER-PROPERTIES*)) (VAL (COND (GROUPP (* ; "This is a group property, so get its value differently") (CH.RETRIEVE.MEMBERS FNAME CHP S)) (T (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE RETRIEVE.ITEM) FNAME CHP (CH.GETAUTHENTICATOR) (QUOTE RETURNERRORS)))))) (PRINTOUT T .FONT BOLDFONT (OR PROPNAME (\NSMT.PRETTY.PROPERTY CHP T)) ": " .FONT DEFAULTFONT) (if (EQ (CAR VAL) (QUOTE ERROR)) then (\NSMT.SHOW.RESULT VAL) elseif GROUPP then (* ; "Group property, print members as list") (\NSMT.PRINT.LIST VAL) elseif (NULL (SETQ VAL (CADR VAL))) then (* ; "note that RETRIEVE.ITEM produced (name value)") (PRINTOUT T "(null)" T) elseif (IGNORE-ERRORS (LET ((HOW (CDR (ASSOC CHP *NSMAINTAIN-PROPERTY-FORMATS*))) PGM) (while (AND (LISTP HOW) (LITATOM (CDR HOW)) (CDR HOW)) do (* ; "Reduce to a less qualified name, to see if it gets down to a record decl") (SETQ HOW (\GET.COURIER.TYPE (SETQ PGM (CAR HOW)) (CDR HOW)))) (* ;; "Ok, now try to interpret the value") (SETQ VAL (COURIER.READ.REP VAL PGM HOW)) (if (EQ (CAR (LISTP HOW)) (QUOTE RECORD)) then (* ; "make records humanly intelligible") (for PAIR in (CDR HOW) as V in VAL bind (PREFIX _ "[") do (PRIN1 PREFIX T) (PRINTOUT T (CL:STRING-CAPITALIZE (STRING (CAR PAIR))) ": " (SELECTQ (CADR PAIR) (BOOLEAN (CL:IF V "true" "false")) (TIME (GDATE V)) V)) (SETQ PREFIX "; ") finally (PRINTOUT T "]" T)) T))) else (* ; "just print what we've got") (PRINTOUT T VAL T)))) +) + +(\NSMT.PRETTY.PROPERTY +(LAMBDA (P VERBOSE) (* ; "Edited 20-Nov-90 14:27 by bvm") (LET ((NAME (CH.NUMBER.TO.PROPERTY P))) (if NAME then (CL:STRING-CAPITALIZE NAME) else (CL:FORMAT NIL "#~D" P)))) +) + +(\NSMT.LIST.OBJECTS +(LAMBDA (PROP LISTFN) (* ; "Edited 14-Nov-90 18:04 by bvm") (* ;;; "given a clearinghouse property, lookup all objects with a user-specified pattern that have that property. Default pattern is * in recent domain.") (LET (PATTERN) (COND ((AND (OR PROP (SETQ PROP (ASKUSER NIL NIL " having property " (OR *ALLTYPES* (SETQ *ALLTYPES* (CONS (QUOTE ("" "any" EXPLAINSTRING " - list ALL objects" RETURN (QUOTE ALL))) (CONS (QUOTE (* "" EXPLAINSTRING "* - list ALL objects" CONFIRMFLG T RETURN (QUOTE ALL))) (SORT (DREMOVE (QUOTE ALL) (MAPCAR CH.PROPERTIES (FUNCTION CAR)))))))) T))) (SETQ PATTERN (\NSMT.READFNAME " by pattern:" (AND *LASTNAME* (create NSNAME using *LASTNAME* NSOBJECT _ "*")) NIL T NIL T))) (AND (\NSMT.DOMAIN.MAY.EXIST PATTERN) (\NSMT.PROCESS.LIST (CH.LIST.OBJECTS PATTERN PROP) PATTERN LISTFN)))))) +) + +(\NSMT.LIST.CLEARINGHOUSES +(LAMBDA NIL (* ; "Edited 21-Aug-89 17:10 by bvm") (DECLARE (USEDFREE *LASTDOMAIN*)) (LET ((DOMAIN (\NSMT.READFNAME " serving domain:" *LASTDOMAIN* T)) (CHSPART "CHServers") SERVERS) (COND (DOMAIN (SETQ *LASTDOMAIN* DOMAIN) (TERPRI T) (SETQ SERVERS (LISTP (CH.RETRIEVE.MEMBERS (create NSNAME NSOBJECT _ (fetch NSDOMAIN of DOMAIN) NSDOMAIN _ (fetch NSORGANIZATION of DOMAIN) NSORGANIZATION _ CHSPART)))) (COND ((EQ (CAR SERVERS) (QUOTE ERROR)) (\NSMT.SHOW.RESULT (COND ((EQ (CADDR SERVERS) (QUOTE NoSuchObject)) (* ; "translate this error") "No Such Domain") (T SERVERS)))) ((SETQ SERVERS (for S in SERVERS collect (COND ((AND (STRING-EQUAL (fetch NSDOMAIN of S) CHSPART) (STRING-EQUAL (fetch NSORGANIZATION of S) CHSPART)) (* ;; "Clearinghouse names are usually of the form server:CHServers:CHServers. The domain here is thus junk--print the name only. Hope for not too much confusion if user tries to type name by hand, rather than using Show Details command.") (fetch NSOBJECT of S)) (T (* ; "An aberrant name--punt by printing all full names") (\NSMT.PROCESS.LIST SERVERS) (RETURN NIL))))) (* ; "Show short names, preserve domain for Show Details") (\NSMT.PROCESS.LIST SERVERS (create NSNAME NSDOMAIN _ CHSPART NSORGANIZATION _ CHSPART)))))))) +) + +(\NSMT.LIST.SERVERS +(LAMBDA NIL (* ; "Edited 19-Nov-90 14:53 by bvm") (* ;; "List Objects specialized to servers. We offer as choices those properties with SERVICE in their name, plus the oddly generic %"SERVER%". CLEARINGHOUSE.SERVICE is excluded because its name space doesn't work as you'd expect.") (LET ((PROP (\NSMT.CHOOSE " of type " (OR *SERVERTYPES* (SETQ *SERVERTYPES* (SORT (CONS (QUOTE ("Server" "" RETURN (QUOTE SERVER))) (for P in CH.PROPERTIES when (AND (STRPOS "SERVICE" (CAR P) -7) (NEQ (CAR P) (QUOTE CLEARINGHOUSE.SERVICE))) collect (BQUOTE ((\, (CL:STRING-CAPITALIZE (SUBSTRING (CAR P) 1 -9))) "" RETURN (QUOTE (\, (CAR P))))))) T)))))) (AND PROP (\NSMT.LIST.OBJECTS PROP)))) +) + +(\NSMT.SHOW.DETAILS +(LAMBDA NIL (* ; "Edited 20-Nov-90 17:19 by bvm") (COND ((NULL *LASTLIST*) (PRINTOUT T " (no previous list)" T)) (T (DESTRUCTURING-BIND (DOMAIN . OBJECTS) *LASTLIST* (COND ((NULL (CDR OBJECTS)) (* ; "only one, describe it straight away") (TERPRI T) (\NSMT.DESCRIBE.OBJECT (COND (DOMAIN (create NSNAME using DOMAIN NSOBJECT _ (CAR OBJECTS))) (T (PARSE.NSNAME (CAR OBJECTS)))))) (T (COND ((NOT (STRINGP (CAR OBJECTS))) (* ; "Turn ns names into strings") (RPLACD *LASTLIST* (SETQ OBJECTS (for N in OBJECTS collect (NSNAME.TO.STRING N T)))))) (bind (CMDS _ (CONS *NSMAINTAIN-ABORT-ITEM* OBJECTS)) NAME while (SETQ NAME (PROGN (TERPRI T) (ASKUSER NIL NIL " name: " CMDS T))) do (\NSMT.DESCRIBE.OBJECT (COND (DOMAIN (create NSNAME using DOMAIN NSOBJECT _ NAME)) (T (PARSE.NSNAME NAME))))))))))) +) + +(\NSMT.GROUP.FILTER +(LAMBDA (NAMES) (* ; "Edited 26-Sep-90 17:47 by bvm") (DECLARE (USEDFREE *DOMAIN*)) (* ;; "List function for List Objects -- NAMES is a list of objects that have a members prop. Filter out those that also have a USER prop, assuming that these %"groups%" are merely for forwarding, and print the rest.") (* ;; "We could ask for each object whether it's a user, but it's much faster to just ask the server to enumerate the users and take the difference.") (LET ((USERS (CH.LIST.OBJECTS *DOMAIN* (QUOTE USER)))) (\NSMT.PRINT.LIST (CL:SET-DIFFERENCE NAMES USERS :TEST (QUOTE STRING-EQUAL))))) +) + +(\NSMT.LIST.ADMINISTRATORS +(LAMBDA NIL (* ; "Edited 20-Nov-90 16:12 by bvm") (LET ((DOMAIN (\NSMT.READFNAME " of domain:" *LASTDOMAIN* T T))) (if (AND DOMAIN (\NSMT.DOMAIN.MAY.EXIST DOMAIN)) then (\NSMT.PROCESS.LIST (\NSMT.FETCH.ADMINISTRATORS (SETQ *LASTDOMAIN* DOMAIN)))))) +) + +(\NSMT.FETCH.ADMINISTRATORS +(LAMBDA (DOMAIN CACHEOK S) (* ; "Edited 20-Nov-90 16:05 by bvm") (* ;; "Return the list of administrators for domain. If CACHEOK is true, we're allowed to find the answer in the cache. S is appropriate courier stream, or NIL.") (SETQ DOMAIN (create NSNAME using DOMAIN NSOBJECT _ "*")) (* ; "Copy just in case") (OR (AND CACHEOK (GETHASH DOMAIN *REAL-NAME-CACHE*)) (LET ((ADMIN (if S then (\NSMT.FETCH.ADMINISTRATORS1 S DOMAIN) else (WITH-CHS (S DOMAIN) (\NSMT.FETCH.ADMINISTRATORS1 S DOMAIN))))) (if (AND ADMIN (NEQ (CAR (LISTP ADMIN)) (QUOTE ERROR))) then (PUTHASH DOMAIN ADMIN *REAL-NAME-CACHE*) (* ; "Cache the results") ADMIN)))) +) + +(\NSMT.FETCH.ADMINISTRATORS1 +(LAMBDA (S DOMAIN) (* ; "Edited 20-Nov-90 16:03 by bvm") (COURIER.CALL S (QUOTE CHACCESSCONTROL) (QUOTE RETRIEVE.DOMAIN.ACL) DOMAIN (QUOTE Administrators) (QUOTE (CHACCESSCONTROL . ELEMENT.NAME)) (QUOTE (SIMPLE NIL)) (QUOTE (0)) (QUOTE RETURNERRORS))) +) + +(\NSMT.LIST.DOMAINS +(LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET ((DOMAIN (\NSMT.READFNAME " by pattern:" (create NSNAME using *LASTDOMAIN* NSDOMAIN _ "*") T T NIL T))) (COND (DOMAIN (\NSMT.PRINT.LIST (CH.LIST.DOMAINS DOMAIN)))))) +) + +(\NSMT.TYPE.ENTRY +(LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET (NAME) (COND ((SETQ NAME (\NSMT.READFNAME " name:" *LASTSTRING* NIL T NIL T)) (\NSMT.DESCRIBE.OBJECT NAME))))) +) + +(\NSMT.TYPE.MEMBERS +(LAMBDA NIL (* ; "Edited 21-Nov-90 12:53 by bvm") (DECLARE (USEDFREE *LASTGROUP* *LASTSTRING*)) (PROG ((NAME (\NSMT.READFNAME " of group:" *LASTGROUP* NIL T)) ITEMS) (if (NOT NAME) then (RETURN)) (SETQ *LASTSTRING* NAME) (if (AND *LAST-MEMBERSHIP* (EQUAL.CH.NAMES NAME (CAR *LAST-MEMBERSHIP*))) then (SETQ ITEMS (CDR *LAST-MEMBERSHIP*)) elseif (NOT (\NSMT.DOMAIN.MAY.EXIST NAME)) then (RETURN) elseif (EQ (CAR (SETQ ITEMS (LISTP (CH.RETRIEVE.MEMBERS NAME (QUOTE MEMBERS))))) (QUOTE ERROR)) then (* ; "Failure. Translate the %"Missing%" error into English") (RETURN (\NSMT.SHOW.RESULT (if (EQ (CADDR ITEMS) (QUOTE Missing)) then "Not A Group" else ITEMS)))) (SETQ *LASTGROUP* NAME) (if (NULL ITEMS) then (PRIN1 "(No members)" T) else (if (CDR ITEMS) then (CL:FORMAT T "~2%%(~D members)~%%" (LENGTH ITEMS)) (\NSMT.PRINT.OBJECTS ITEMS) else (* ; "Just one") (PRINTOUT T (CAR ITEMS) T)) (* ; "Save list for Show Details command.") (SETQ *LASTLIST* (CONS NIL ITEMS))))) +) + +(\NSMT.UNCACHE +(LAMBDA (ALLP) (* ; "Edited 14-Nov-90 18:09 by bvm") (LET (DOMAIN) (if (OR ALLP (SETQ DOMAIN (\NSMT.READFNAME ":" *LASTDOMAIN* T T))) then (if (NOT ALLP) then (SETQ *LASTDOMAIN* DOMAIN)) (PRINTOUT T (if (\NSMT.CLEAR.CACHE (AND (NOT ALLP) DOMAIN)) then "done" else "nothing cached") T)))) +) + +(\NSMT.CLEAR.NAME.CACHE +(LAMBDA NIL (* ; "Edited 21-Nov-90 13:06 by bvm") (LET ((CNT (CL:HASH-TABLE-COUNT *REAL-NAME-CACHE*))) (TERPRI T) (if *LAST-MEMBERSHIP* then (* ; "This is another cache") (add CNT 1)) (if (EQ CNT 0) then (PRINTOUT T "nothing cached" T) else (CLRHASH *REAL-NAME-CACHE*) (SETQ *LAST-MEMBERSHIP* NIL) (CL:FORMAT T "Ok, ~D cache entries cleared.~%%" CNT)))) +) +) + + + +(* ; "Administrator commands") + +(DEFINEQ + +(\NSMT.ADD.ALIAS +(LAMBDA NIL (* ; "Edited 14-Nov-90 12:13 by bvm") (LET (OBJECT ALIAS) (COND ((AND (SETQ OBJECT (\NSMT.READFNAME " for object:" *LASTSTRING*)) (LET ((*DEFAULTDOMAIN* (create NSNAME using OBJECT NSOBJECT _ NIL))) (DECLARE (CL:SPECIAL *DEFAULTDOMAIN*)) (* ; "Read the alias by default in the same domain as object") (TERPRI T) (SETQ ALIAS (\NSMT.READFNAME " Alias:" NIL NIL T)))) (OR (\NSMT.SHOW.RESULT (LISTP (SETQ *LASTSTRING* (WITH-CHS (S OBJECT) (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE CREATE.ALIAS) ALIAS OBJECT (\NSMT.GETAUTHENTICATOR) (QUOTE RETURNERRORS)))))) (SETQ *LASTSTRING* OBJECT)))))) +) + +(\NSMT.ADD.GROUP +(LAMBDA NIL (* ; "Edited 15-Nov-90 18:01 by bvm") (* ;; "Create a new group") (LET ((GROUP (\NSMT.READFNAME " New group name:" NIL NIL T)) AUTH REMARK RESULT MEMBERS OWNERS FRIENDS) (if (NULL GROUP) elseif (LISTP (SETQ RESULT (WITH-CHS (S GROUP) (* ;; "Note: two calls on with-chs, because we want to create the object first, to assure it can be done, but then user can take arbitrarily long supplying the group components") (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE CREATE.OBJECT) GROUP (SETQ AUTH (\NSMT.GETAUTHENTICATOR)) (QUOTE RETURNERRORS))))) then (* ; "Failed to create object") (\NSMT.SHOW.RESULT RESULT) else (SETQ *LASTSTRING* (SETQ *LASTGROUP* GROUP)) (* ;; "Assume if user had access rights to create the object, then calls below don't fail. Gather all the info before taking the time to call the Clearinghouse, since sometimes these update calls are very slow.") (TERPRI T) (SETQ REMARK (\NSMT.GET.REMARK)) (CL:FORMAT T "~%%~%%Enter names of members, owners and friends, one per line, terminated with a blank line.~%%") (SETQ MEMBERS (\NSMT.COLLECT.NAMES "Member:" :FOREIGN :ANY)) (CL:FORMAT T "~%%(If you enter no owners, the group will be owned by the administrators of ~A.)~%%" (create NSNAME using GROUP NSOBJECT _ NIL)) (SETQ OWNERS (\NSMT.COLLECT.NAMES "Owner:" T :ANY)) (SETQ FRIENDS (\NSMT.COLLECT.NAMES "Friend:" T :ANY)) (TERPRI T) (* ;; "Ok, we're ready to roll...") (WITH-CHS (S GROUP) (LET ((USERADMIN (create NSNAME using GROUP NSOBJECT _ "UserAdministration"))) (if (AND (NOT (CL:MEMBER USERADMIN OWNERS)) (SETQ USERADMIN (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE LOOKUP.OBJECT) USERADMIN AUTH (QUOTE NOERROR))) (CL:Y-OR-N-P "Do you want to include, as is conventional, ~A as an owner? " USERADMIN)) then (push OWNERS USERADMIN)) (LET* ((SELF *USER*) (FOUNDSELF (CL:MEMBER SELF OWNERS :TEST (QUOTE EQUAL.CH.NAMES)))) (* ;; "Have to make user be first owner, because as soon as we add one administrator, we override the default administrators, which means user is no longer empowered to add the rest of the owners! Stupid @#&#!!@ Clearinghouse design.") (if FOUNDSELF then (if (NEQ FOUNDSELF OWNERS) then (SETQ OWNERS (CONS SELF (CL:REMOVE (CAR FOUNDSELF) OWNERS)))) elseif (CL:Y-OR-N-P "Do you want to include yourself as an owner? ") then (SETQ OWNERS (CONS SELF OWNERS)))) (PRINTOUT T "Setting remark...") (\NSMT.SHOW.RESULT (LISTP (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE ADD.ITEM.PROPERTY) GROUP (CH.PROPERTY (QUOTE USERGROUP)) (COURIER.WRITE.REP REMARK (QUOTE CLEARINGHOUSE) (QUOTE STRING)) AUTH (QUOTE RETURNERRORS)))) (if MEMBERS then (PRINTOUT T "Adding members...") (\NSMT.SHOW.RESULT (LISTP (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE ADD.GROUP.PROPERTY) GROUP (CH.PROPERTY (QUOTE MEMBERS)) (FUNCTION (LAMBDA (DATASTREAM) (* ; "Function to write the membership onto the bulk data stream") (COURIER.WRITE.BULKDATA DATASTREAM MEMBERS NIL (QUOTE NSNAME)))) AUTH (QUOTE RETURNERRORS))))) (if OWNERS then (\NSMT.SET.INITIAL.ACL GROUP OWNERS (QUOTE Administrators) AUTH S)) (if FRIENDS then (\NSMT.SET.INITIAL.ACL GROUP FRIENDS (QUOTE selfControllers) AUTH S))))))) +) + +(\NSMT.SET.INITIAL.ACL +(LAMBDA (GROUP MEMBERS WHICH.LIST AUTH S) (* ; "Edited 31-Oct-90 16:59 by bvm") (* ;; "Set the initial access control list WHICH.LIST for GROUP to be MEMBERS") (PRINTOUT T "Adding " (CASE WHICH.LIST (Administrators "owners") (selfControllers "friends") (T WHICH.LIST)) "...") (\NSMT.SHOW.RESULT (for NAME in MEMBERS thereis (SETQ $$VAL (LISTP (COURIER.CALL S (QUOTE CHACCESSCONTROL) (QUOTE ADD.MEMBER.TO.PROPERTY.ACL) GROUP (CH.PROPERTY (QUOTE MEMBERS)) WHICH.LIST NAME (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS of AUTH) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) VERIFIER of AUTH) (QUOTE RETURNERRORS))))))) +) + +(\NSMT.ADD.USER +(LAMBDA NIL (* ; "Edited 19-Nov-90 15:48 by bvm") (* ;; "Create new user") (PROG (AUTH NAME PASS ERROR) (DECLARE (USEDFREE *LASTNAME* *LASTSTRING*)) (TERPRI T) (if (NOT (SETQ NAME (\NSMT.READFNAME "Name for new object:" *LASTNAME* NIL T))) then (RETURN)) (SETQ *LASTSTRING* (SETQ *LASTNAME* NAME)) (if (LISTP (SETQ ERROR (\NSMT.CREATE.OBJECT NAME (SETQ AUTH (\NSMT.GETAUTHENTICATOR))))) then (* ; "Error") (RETURN (\NSMT.SHOW.RESULT ERROR))) (* ;; "Having created the object, get all the other parts. We assume that if the creation succeeded, we'll be able to do the rest, so gather all the info first, then do the calls.") (TERPRI T) (if (NULL (SETQ PASS (\NSMT.GET.PASSWORD "Initial password:"))) then (printout T " (no password stored; use Change Password to create one)" T)) (\NSMT.ADD.OBJECT.GENERIC NAME AUTH (CH.PROPERTY (QUOTE USER))) (* ;; "Unfortunately, can't use the same Clearinghouse stream to do the passwords, since that requires an Authentication service. The two are usually the same, but we can't assume so.") (if PASS then (PRINTOUT T "Setting password...") (\NSMT.SHOW.RESULT (AS.CREATE.PASSWORDS NAME (\ENCRYPT.PWD PASS)))))) +) + +(\NSMT.ADD.OBJECT +(LAMBDA NIL (* ; "Edited 19-Nov-90 15:04 by bvm") (* ;; "Create new object of arbitrary type") (PROG (TYPE AUTH NAME PASS ERROR) (DECLARE (USEDFREE *LASTNAME* *LASTSTRING*)) (if (NOT (AND (SETQ TYPE (\NSMT.GET.OBJECT.TYPE " of type: ")) (SETQ NAME (\NSMT.READFNAME "Name for new object:" *LASTNAME* NIL T)))) then (RETURN)) (SETQ *LASTSTRING* (SETQ *LASTNAME* NAME)) (if (LISTP (SETQ ERROR (\NSMT.CREATE.OBJECT NAME (SETQ AUTH (\NSMT.GETAUTHENTICATOR))))) then (* ; "Error") (RETURN (\NSMT.SHOW.RESULT ERROR))) (* ;; "Having created the object, get all the other parts. We assume that if the creation succeeded, we'll be able to do the rest, so gather all the info first, then do the calls.") (TERPRI T) (\NSMT.ADD.OBJECT.GENERIC NAME AUTH (CH.PROPERTY TYPE)))) +) + +(\NSMT.CREATE.OBJECT +(LAMBDA (NAME AUTH) (* ; "Edited 19-Nov-90 14:17 by bvm") (* ;; "Create object and return its name or error") (WITH-CHS (S NAME) (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE CREATE.OBJECT) NAME AUTH (QUOTE RETURNERRORS)))) +) + +(\NSMT.ADD.OBJECT.GENERIC +(LAMBDA (NAME AUTH TYPE) (* ; "Edited 19-Nov-90 15:00 by bvm") (* ;; "Add the %"generic%" parts of a new object -- remark, aliases.") (LET ((DESC (\NSMT.GET.REMARK)) (ALIASES (LET ((*DEFAULTDOMAIN* (create NSNAME using NAME NSOBJECT _ NIL))) (DECLARE (CL:SPECIAL *DEFAULTDOMAIN*)) (* ; "Read the aliases by default in the same domain as object") (\NSMT.COLLECT.NAMES "Alias:")))) (PRIN1 "... " T) (WITH-CHS (S NAME) (LET (ERROR) (PRINTOUT T "Setting remark...") (\NSMT.SHOW.RESULT (LISTP (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE ADD.ITEM.PROPERTY) NAME TYPE (AND DESC (COURIER.WRITE.REP DESC (QUOTE CLEARINGHOUSE) (QUOTE STRING))) AUTH (QUOTE RETURNERRORS)))) (if ALIASES then (PRINTOUT T "Setting aliases...") (\NSMT.SHOW.RESULT (AND (for A in ALIASES thereis (SETQ ERROR (LISTP (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE CREATE.ALIAS) A NAME AUTH (QUOTE RETURNERRORS))))) ERROR))))))) +) + +(\NSMT.CHANGE.ADDRESS +(LAMBDA NIL (* ; "Edited 19-Nov-90 15:45 by bvm") (* ;; "Change the Address.list property of a machine.") (PROG ((ADDRESS.PROPERTY (CONSTANT (CH.PROPERTY (QUOTE ADDRESS.LIST)))) PROPS NAME INPUT OLDADDRESSES NEWADDRESSES HADADDRESS) (DECLARE (USEDFREE *LASTSTRING* *LASTNAME*)) (if (NOT (SETQ NAME (\NSMT.READFNAME " of machine:" *LASTNAME*))) then (RETURN)) (TERPRI T) (SETQ PROPS (CH.LIST.PROPERTIES NAME)) (* ; "returns (realname props)") (if (EQ (SETQ NAME (CAR PROPS)) (QUOTE ERROR)) then (* ; "Object does not exist, probably") (RETURN (\NSMT.SHOW.RESULT PROPS))) (if (AND (SETQ HADADDRESS (MEMB ADDRESS.PROPERTY PROPS)) (SETQ OLDADDRESSES (CH.RETRIEVE.ITEM NAME ADDRESS.PROPERTY))) then (SETQ OLDADDRESSES (COURIER.READ.REP OLDADDRESSES (QUOTE CLEARINGHOUSE) (QUOTE NETWORK.ADDRESS.LIST))) else (PRINTOUT T NAME " does not yet have an address." T)) (SETQ *LASTSTRING* (SETQ *LASTNAME* NAME)) RETRY (PRINTOUT T "Type one or more NS addresses, separated by commas." T "Octal format: oo#o...o#oo or Decimal: n-nnn#nnn-...-nnn#nnn" T) (if (NULL (SETQ INPUT (for X in (\NSMT.READ.COMMA.LIST "Address(es): " (OR INPUT OLDADDRESSES)) collect (PARSE-NSADDRESS X 0)))) then (* ; "No new address...delete old?") (if (NOT HADADDRESS) then (RETURN (PRINTOUT T " (not changed)" T)) elseif (CL:Y-OR-N-P "Remove address list for ~A? " NAME) then (\NSMT.SHOW.RESULT (LISTP (CH.DELETE.PROPERTY ADDRESS.PROPERTY)))) elseif (MEMB NIL (SETQ NEWADDRESSES (for X in INPUT collect (PARSE-NSADDRESS X 0)))) then (PRINTOUT T "Illegal address:") (for I in INPUT as A in NEWADDRESSES unless A bind (SEPR _ " ") do (PRINTOUT T SEPR I) (SETQ SEPR ",")) (TERPRI T) elseif (AND (EQ (LENGTH OLDADDRESSES) (LENGTH NEWADDRESSES)) (for O in OLDADDRESSES as N in NEWADDRESSES always (EQUAL.NSADDRESS O N))) then (RETURN (PRINTOUT T " (not changed)" T)) else (\NSMT.SHOW.RESULT (LISTP (CL:FUNCALL (if HADADDRESS then (FUNCTION CH.CHANGE.ITEM) else (FUNCTION CH.ADD.ITEM.PROPERTY)) NAME ADDRESS.PROPERTY NEWADDRESSES (QUOTE (CLEARINGHOUSE . NETWORK.ADDRESS.LIST)))))))) +) + +(\NSMT.CHANGE.ADMINISTRATORS +(LAMBDA (CHACCESSFN OPERATION) (* ; "Edited 20-Nov-90 16:15 by bvm") (* ;; "Add/remove a domain administrator") (LET (DOMAIN INDIVIDUAL) (DECLARE (USEDFREE *LASTNAME* *LASTDOMAIN* *LASTSTRING*)) (COND ((AND (SETQ INDIVIDUAL (\NSMT.READFNAME " name:" *LASTNAME*)) (SETQ DOMAIN (\NSMT.READFNAME (SELECTQ OPERATION (ADD " to domain:") (REMOVE " from domain:") (SHOULDNT)) *LASTDOMAIN* T T))) (REMHASH (create NSNAME using DOMAIN NSOBJECT _ "*") *REAL-NAME-CACHE*) (* ; "We're about to invalidate this cache entry") (\NSMT.SHOW.RESULT (CL:FUNCALL CHACCESSFN DOMAIN (QUOTE Administrators) INDIVIDUAL)) (SETQ *LASTSTRING* (SETQ *LASTNAME* INDIVIDUAL)) (SETQ *LASTDOMAIN* DOMAIN))))) +) + +(\NSMT.CHANGE.FORWARDING +(LAMBDA NIL (* ; "Edited 20-Nov-90 13:00 by bvm") (* ;; "Change the %"Forwarding%" list for a user. Since NS doesn't really have forwarding, it is faked by giving an object a MEMBERS property--the mail system, finding no mailbox, looks at the members and sends the message to all of them.") (PROG (PROPS GOODPROPS NAME REALNAME OLDFORWARDING NEWFORWARDING HADFORWARDING HADUSERGROUP) (DECLARE (USEDFREE *LASTSTRING* *LASTNAME* *LASTGROUP*)) (if (NOT (SETQ NAME (\NSMT.READFNAME " for user:" *LASTNAME*))) then (RETURN)) (TERPRI T) (SETQ PROPS (CH.LIST.PROPERTIES NAME)) (* ; "returns (realname props)") (if (EQ (SETQ REALNAME (CAR PROPS)) (QUOTE ERROR)) then (* ; "Object does not exist, probably") (RETURN (\NSMT.SHOW.RESULT PROPS))) (if (MEMB (CH.PROPERTY (QUOTE USER)) (SETQ PROPS (CADR PROPS))) then (* ; "Ok, it's a user") else (PRINTOUT T T REALNAME " is not a User") (if (NULL (SETQ GOODPROPS (\NSMT.DESCRIPTIVE.PROPS PROPS))) then (RETURN (PRINTOUT T ", or any other type I know about." T))) (PRINTOUT T ", but a " (\NSMT.PRETTY.PROPERTY (CAR GOODPROPS))) (if (CDR GOODPROPS) then (PRINTOUT T " (also " (CONCATLIST (CDR (for P in (CDR GOODPROPS) join (LIST ", " (\NSMT.PRETTY.PROPERTY P))))) ")")) (if (EQ (CAR GOODPROPS) (CH.PROPERTY (QUOTE USERGROUP))) then (RETURN (PRINTOUT T " Groups %"forward%" to their members." T)) elseif (NOT (CL:Y-OR-N-P "Are you sure you want to change the Forwarding? ")) then (RETURN))) (if (SETQ HADFORWARDING (MEMB (CH.PROPERTY (QUOTE MEMBERS)) PROPS)) then (* ; "There's already forwarding, so fetch it") (SETQ OLDFORWARDING (CH.RETRIEVE.MEMBERS REALNAME)) else (PRINTOUT T REALNAME " does not yet have Forwarding." T)) (SETQ HADUSERGROUP (MEMB (CH.PROPERTY (QUOTE USERGROUP)) PROPS)) (SETQ *LASTSTRING* (SETQ *LASTNAME* REALNAME)) (PRINTOUT T "Type one or more NS names, separated by commas." T) (if (NULL (SETQ NEWFORWARDING (MAPCAR (\NSMT.READ.COMMA.LIST "Forward to: " (for NAME in OLDFORWARDING collect (NSNAME.TO.STRING NAME T))) (FUNCTION PARSE.NSNAME)))) then (* ; "No new forwarding...delete old?") (if (NOT HADFORWARDING) then (RETURN (PRINTOUT T " (not changed)" T)) elseif (NOT (CL:Y-OR-N-P "Remove forwarding for ~A? " REALNAME)) then (RETURN)) elseif (AND (EQ (LENGTH OLDFORWARDING) (LENGTH NEWFORWARDING)) (for O in OLDFORWARDING as N in NEWFORWARDING always (* ; "See if the lists are the same. Could use EQUAL.CH.NAMES, but want to be able to recognize case differences") (AND (CL:STRING= (fetch NSOBJECT of O) (fetch NSOBJECT of N)) (CL:STRING= (fetch NSDOMAIN of O) (fetch NSDOMAIN of N)) (CL:STRING= (fetch NSORGANIZATION of O) (fetch NSORGANIZATION of N))))) then (RETURN (PRINTOUT T " (not changed)"))) (WITH-CHS (S REALNAME) (* ;; "Ok, ready to either delete old forwarding or change it. Since there is no command to replace group membership, the easiest thing when prop already existed is to delete the old one and add the new one") (PROG ((AUTH (\NSMT.GETAUTHENTICATOR)) RESULT) (if HADFORWARDING then (* ;; "In either case, we want to delete the old members prop.") (SETQ RESULT (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE DELETE.PROPERTY) REALNAME (CH.PROPERTY (QUOTE MEMBERS)) AUTH (QUOTE RETURNERRORS))) (if (EQ (CAR RESULT) (QUOTE ERROR)) then (RETURN (\NSMT.SHOW.RESULT RESULT)))) (if (NOT NEWFORWARDING) then (PRINTOUT T "Forwarding removed") (if (AND HADUSERGROUP (EQ (CAR (SETQ RESULT (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE DELETE.PROPERTY) REALNAME (CH.PROPERTY (QUOTE USERGROUP)) AUTH (QUOTE RETURNERRORS)))) (QUOTE ERROR))) then (* ; "Failed to delete the %"group%" comment") (PRINTOUT T ", but failed to remove the forwarding comment because: " (CADDR RESULT) T) else (PRINTOUT T "." T)) else (* ;; "Create new membership ") (SETQ RESULT (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE ADD.GROUP.PROPERTY) REALNAME (CH.PROPERTY (QUOTE MEMBERS)) (FUNCTION (LAMBDA (DATASTREAM) (* ; "Function to write the membership onto the bulk data stream") (COURIER.WRITE.BULKDATA DATASTREAM NEWFORWARDING NIL (QUOTE NSNAME)))) AUTH (QUOTE RETURNERRORS))) (if (EQ (CAR RESULT) (QUOTE ERROR)) then (\NSMT.SHOW.RESULT RESULT) else (if (NOT HADUSERGROUP) then (SETQ RESULT (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE ADD.ITEM.PROPERTY) REALNAME (CH.PROPERTY (QUOTE USERGROUP)) (COURIER.WRITE.REP (CONCAT "Forwarding for " (fetch NSOBJECT of REALNAME)) (QUOTE CLEARINGHOUSE) (QUOTE STRING)) AUTH (QUOTE RETURNERRORS))) (* ; "This isn't strictly necessary, but I think some tools expect it to be there") (if (EQ (CAR RESULT) (QUOTE ERROR)) then (PRINTOUT T "(Failed to set usergroup comment)" T))) (PRINTOUT T "Done, forwarding set to ") (\NSMT.PRINT.LIST NEWFORWARDING) (TERPRI T))))))) +) + +(\NSMT.CHANGE.GROUP.COMPONENT +(LAMBDA (CHFN OPERATION SELF/LIST) (* ; "Edited 21-Nov-90 13:06 by bvm") (* ;; "Add or remove a member from to/from a group. CHACCESSFN is the CH function that will make the change, OPERATION is ADD or REMOVE, and SELF/LIST is one of T (self), NIL (general member) or the name of an access list property.") (LET (GROUP INDIVIDUAL ORIGINAL) (if (AND (OR (EQ SELF/LIST T) (SETQ INDIVIDUAL (\NSMT.READFNAME " name:" *LASTNAME* NIL NIL (COND ((EQ OPERATION (QUOTE REMOVE)) (* ; "Want to be able to remove bogus names if they got on there somehow, so let's do the processing ourselves") NIL) (SELF/LIST (* ; "must be valid ns name") T) (T (* ; "use canonical name, but foreign names ok") :FOREIGN)) :ANY))) (PROGN (if (AND (EQ OPERATION (QUOTE REMOVE)) (NEQ SELF/LIST T) (NOT (STRPOS "*" (NSNAME.TO.STRING INDIVIDUAL)))) then (* ; "Do name fixing ourselves so we can keep track of the original (below)") (SETQ INDIVIDUAL (OR (\NSMT.LOOKUP (SETQ ORIGINAL INDIVIDUAL)) INDIVIDUAL))) (SETQ GROUP (\NSMT.READFNAME (SELECTQ OPERATION (ADD " to group:") (REMOVE " from group:") (SHOULDNT)) *LASTGROUP* NIL T)))) then (* ;; "Ok, here's a name and a group, try the desired operation") (CASE SELF/LIST ((T NIL) (* ; "We're about to spoil the cache") (SETQ *LAST-MEMBERSHIP* NIL))) (WITH-CHS (S GROUP) (PROG ((AUTH (\NSMT.GETAUTHENTICATOR)) (MEMBER INDIVIDUAL) RESULT) RETRY (SETQ RESULT (CASE SELF/LIST ((T) (* ; "adding/removing self") (COURIER.CALL S (QUOTE CLEARINGHOUSE) CHFN GROUP (CH.PROPERTY (QUOTE MEMBERS)) AUTH (QUOTE RETURNERRORS))) ((NIL) (* ; "adding/removing member") (COURIER.CALL S (QUOTE CLEARINGHOUSE) CHFN GROUP (CH.PROPERTY (QUOTE MEMBERS)) MEMBER AUTH (QUOTE RETURNERRORS))) (T (* ; "Adding/removing from access list") (COURIER.CALL S (QUOTE CHACCESSCONTROL) CHFN GROUP (CH.PROPERTY (QUOTE MEMBERS)) SELF/LIST MEMBER (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS of AUTH) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) VERIFIER of AUTH) (QUOTE RETURNERRORS))))) (if (AND (LISTP RESULT) (EQ (CADDR RESULT) (QUOTE NoChange)) ORIGINAL (EQ MEMBER INDIVIDUAL) (NOT (EQUAL.CH.NAMES INDIVIDUAL ORIGINAL))) then (* ;; "Command was to remove something. We first tried the full name, but CH said nothing happened. So try original name, just in case someone got an alias on the list by mistake.") (SETQ MEMBER ORIGINAL) (GO RETRY)) (if (\NSMT.SHOW.RESULT (LISTP RESULT) NIL GROUP MEMBER) then (* ; "Success") (if (NEQ MEMBER INDIVIDUAL) then (PRINTOUT T "(removed " (NSNAME.TO.STRING ORIGINAL T) ")" T)) (SETQ *LASTSTRING* (SETQ *LASTGROUP* RESULT))))) (if INDIVIDUAL then (SETQ *LASTNAME* INDIVIDUAL))))) +) + +(\NSMT.CHANGE.REMARK +(LAMBDA NIL (* ; "Edited 20-Nov-90 12:58 by bvm") (PROG (PROPS GOODPROPS MAINPROP NAME REALNAME RESULT REMARK OLDREMARK) (DECLARE (USEDFREE *LASTSTRING* *LASTNAME* *LASTGROUP*)) (if (NOT (SETQ NAME (\NSMT.READFNAME " for object:" *LASTSTRING*))) then (RETURN)) (SETQ PROPS (CH.LIST.PROPERTIES NAME)) (* ; "returns (realname props)") (if (EQ (SETQ REALNAME (CAR PROPS)) (QUOTE ERROR)) then (* ; "Object does not exist, probably") (RETURN (\NSMT.SHOW.RESULT PROPS))) (if (NULL (SETQ GOODPROPS (\NSMT.DESCRIPTIVE.PROPS (CADR PROPS)))) then (printout T T (SETQ *LASTSTRING* REALNAME) " has no remarkable properties." T) (if (NULL (SETQ MAINPROP (\NSMT.GET.OBJECT.TYPE "Add remark of type ( to abort): "))) then (RETURN)) else (if (OR (NULL (CDR GOODPROPS)) (AND (EQ (CAR GOODPROPS) (CH.PROPERTY (QUOTE USER))) (EQ (CADR GOODPROPS) (CH.PROPERTY (QUOTE USERGROUP))) (NULL (CDDR GOODPROPS)))) then (* ; "only one, the normal case (or both user & usergroup, in which case we ignore the boring forwarding remark)") (CL:FORMAT T " (~@[~A -- ~]a ~A)" (AND (NOT (EQUAL.CH.NAMES REALNAME NAME)) (NSNAME.TO.STRING REALNAME)) (\NSMT.PRETTY.PROPERTY (SETQ MAINPROP (CAR GOODPROPS)))) else (PRINTOUT T T (NSNAME.TO.STRING REALNAME) " has the descriptive properties ") (\NSMT.PRINT.LIST (SETQ GOODPROPS (for P in GOODPROPS collect (OR (CH.NUMBER.TO.PROPERTY P) P)))) (if (NULL (SETQ MAINPROP (\NSMT.CHOOSE "Specify property to modify: " GOODPROPS))) then (RETURN))) (TERPRI T) (if (SETQ OLDREMARK (CADR (CH.RETRIEVE.ITEM REALNAME MAINPROP))) then (* ; "Retrieve carefully in case the prop is null") (SETQ OLDREMARK (COURIER.READ.REP OLDREMARK NIL (QUOTE STRING))))) (if (NOT (FIXP MAINPROP)) then (* ; "Convert prop we got from interaction back to number") (SETQ MAINPROP (CH.PROPERTY MAINPROP))) (if (SETQ REMARK (\NSMT.GET.REMARK OLDREMARK)) then (PRIN1 "..." T) (\NSMT.SHOW.RESULT (LISTP (if GOODPROPS then (CH.CHANGE.ITEM REALNAME MAINPROP REMARK (QUOTE STRING)) else (CH.ADD.ITEM.PROPERTY REALNAME MAINPROP REMARK (QUOTE STRING))))) else (PRINTOUT T " xxx" T)) (SETQ *LASTSTRING* (if (EQ MAINPROP (CH.PROPERTY (QUOTE USERGROUP))) then (SETQ *LASTGROUP* REALNAME) else (SETQ *LASTNAME* REALNAME))))) +) + +(\NSMT.GET.OBJECT.TYPE +(LAMBDA (PROMPT) (* ; "Edited 19-Nov-90 14:50 by bvm") (\NSMT.CHOOSE PROMPT (OR *OBJECTTYPES* (SETQ *OBJECTTYPES* (SORT (for P in *NSMAINTAIN-DESCRIPTIVE-PROPERTIES* collect (OR (CH.NUMBER.TO.PROPERTY P) P))))))) +) + +(\NSMT.REMOVE.ALIAS +(LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET (ALIAS) (COND ((NULL (SETQ ALIAS (\NSMT.READFNAME " alias:" NIL NIL T)))) ((NLISTP (SETQ ALIAS (CH.DELETE.ALIAS ALIAS))) (* ; "Success, returned canonical name") (CL:FORMAT T "done, alias was removed from ~S~%%" (SETQ *LASTSTRING* ALIAS))) (T (\NSMT.SHOW.RESULT ALIAS))))) +) + +(\NSMT.REMOVE.OBJECT +(LAMBDA (NAME) (* ; "Edited 18-Aug-89 17:12 by bvm") (COND ((AND (OR NAME (SETQ NAME (\NSMT.READFNAME ":" *LASTSTRING* NIL T))) (SETQ NAME (\NSMT.DESCRIBE.OBJECT NAME T)) (CL:Y-OR-N-P " Confirm deletion (y or n): ")) (\NSMT.SHOW.RESULT (LISTP (CH.DELETE.OBJECT NAME)))))) +) + +(\NSMT.REMOVE.USER +(LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET (USER INFO) (COND ((NULL (SETQ USER (\NSMT.READFNAME ":" *LASTNAME* NIL T)))) ((NULL (SETQ INFO (CH.RETRIEVE.ITEM USER (QUOTE USER)))) (PRINTOUT T " not a user." T)) (T (PRINTOUT T T (NSNAME.TO.STRING (CAR INFO) T)) (COND ((CADR INFO) (CL:FORMAT T " (~A)" (COURIER.READ.REP (CADR INFO) NIL (QUOTE STRING))))) (COND ((CL:Y-OR-N-P " Confirm deletion (y or n): ") (\NSMT.SHOW.RESULT (LISTP (CH.DELETE.OBJECT USER))))))))) +) +) + +(FILESLOAD (SYSLOAD) DES AUTHENTICATION) + + + +(* ; "Patch to clearinghouse") + +(DEFINEQ + +(CH.FINDSERVER +(LAMBDA (DOMAINPATTERN NOERRORFLG DONTPROBEFLG) (* ; "Edited 20-Feb-91 16:16 by bvm") (* ;; "Find a Clearinghouse which serves the specified domain and return its NS address. If DONTPROBEFLG is T, just search the cache.") (OR (type? NSNAME DOMAINPATTERN) (SETQ DOMAINPATTERN (PARSE.NSNAME DOMAINPATTERN 2))) (LET ((ORGANIZATION (fetch NSORGANIZATION of DOMAINPATTERN)) (DOMAIN (fetch NSDOMAIN of DOMAINPATTERN)) (GLUE "CHServers") ORGANIZATION.INFO) (if (STRING-EQUAL ORGANIZATION GLUE) then (* ; "Shift right") (if (STRING-EQUAL DOMAIN GLUE) then (* ; "Everyone handles this") (GETCLEARINGHOUSE) else (CAR (CAR (fetch OCALLSERVERS of (\CH.FIND.ORG.SERVER DOMAIN NOERRORFLG DONTPROBEFLG))))) else (SETQ ORGANIZATION.INFO (\CH.FIND.ORG.SERVER ORGANIZATION NOERRORFLG DONTPROBEFLG)) (if (STRING-EQUAL DOMAIN "*") then (* ; "Any server in the org will do.") (CAR (CAR (fetch OCALLSERVERS of ORGANIZATION.INFO))) elseif (for DOMAIN.INFO in (fetch OCDOMAINS of ORGANIZATION.INFO) when (STRING-EQUAL (fetch DCDOMAIN of DOMAIN.INFO) DOMAIN) do (RETURN (CAR (CAR (fetch DCKNOWNSERVERS of DOMAIN.INFO))))) elseif DONTPROBEFLG then (AND (NOT NOERRORFLG) (ERROR "Couldn't find Clearinghouse server for domain" DOMAINPATTERN T)) else (* ;; "Ask a clearinghouse in ORGANIZATION to find servers for this domain. For simplicity, assume the first one will tell us. This should be 'Local Clearinghouse' if it serves ORGANIZATION") (\CH.LOCATE.SERVERS (CAR (CAR (fetch OCALLSERVERS of ORGANIZATION.INFO))) (create NSNAME NSOBJECT _ DOMAIN NSDOMAIN _ ORGANIZATION NSORGANIZATION _ GLUE) NOERRORFLG ORGANIZATION DOMAIN) (CH.FINDSERVER DOMAINPATTERN NOERRORFLG T))))) +) +) + +(RPAQQ *NSMAINTAIN-COMMANDS* (("?" "" RETURN (FUNCTION \NSMT.HELP)) ("Add Alias" "" RETURN (FUNCTION \NSMT.ADD.ALIAS)) ("Add Domain Administrator" "" RETURN (QUOTE (\NSMT.CHANGE.ADMINISTRATORS CH.ADD.MEMBER.TO.DOMAIN.ACL ADD))) ("Add Friend" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT ADD.MEMBER.TO.PROPERTY.ACL ADD selfControllers))) ("Add Group" "" RETURN (FUNCTION \NSMT.ADD.GROUP)) ("Add Member" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT ADD.MEMBER ADD))) ("Add Owner" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT ADD.MEMBER.TO.PROPERTY.ACL ADD Administrators))) ("Add Registered Object" "" RETURN (FUNCTION \NSMT.ADD.OBJECT)) ("Add Self" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT ADD.SELF ADD T))) ("Add User" "" RETURN (FUNCTION \NSMT.ADD.USER)) ("Remove Alias" "" RETURN (FUNCTION \NSMT.REMOVE.ALIAS)) ("Remove Domain Administrator" "" RETURN (QUOTE (\NSMT.CHANGE.ADMINISTRATORS CH.DELETE.MEMBER.FROM.DOMAIN.ACL REMOVE))) ("Remove Friend" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT DELETE.MEMBER.FROM.PROPERTY.ACL REMOVE selfControllers))) ("Remove Member" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT DELETE.MEMBER REMOVE))) ("Remove Owner" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT DELETE.MEMBER.FROM.PROPERTY.ACL REMOVE Administrators))) ("Remove Registered Object" "" RETURN (FUNCTION \NSMT.REMOVE.OBJECT)) ("Remove Self" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT DELETE.SELF REMOVE T))) ("Remove User" "" RETURN (FUNCTION \NSMT.REMOVE.USER)) ("Change Address" "" RETURN (FUNCTION \NSMT.CHANGE.ADDRESS)) ("Change Default Domain" "" RETURN (FUNCTION \NSMT.CHANGE.DOMAIN)) ("Change Forwarding" "" RETURN (FUNCTION \NSMT.CHANGE.FORWARDING)) ("Change Login" "" RETURN (FUNCTION \NSMT.LOGIN)) ("Change Password" "" RETURN (FUNCTION \NSMT.CHANGE.PASSWORD)) ("Change Remark" "" RETURN (FUNCTION \NSMT.CHANGE.REMARK)) ("Describe" "" RETURN (FUNCTION \NSMT.TYPE.ENTRY)) ("List Aliases" "" RETURN (QUOTE (\NSMT.LIST.OBJECTS ALIAS))) ("List Administrators" "" RETURN (FUNCTION \NSMT.LIST.ADMINISTRATORS)) ("List Clearinghouses" "" RETURN (FUNCTION \NSMT.LIST.CLEARINGHOUSES)) ("List Domains" "" RETURN (FUNCTION \NSMT.LIST.DOMAINS)) ("List Groups" "" RETURN (QUOTE (\NSMT.LIST.OBJECTS MEMBERS))) ("List Members" "" RETURN (FUNCTION \NSMT.TYPE.MEMBERS)) ("List Objects" "" RETURN (FUNCTION \NSMT.LIST.OBJECTS)) ("List Servers" "" RETURN (FUNCTION \NSMT.LIST.SERVERS)) ("List True Groups" "" RETURN (QUOTE (\NSMT.LIST.OBJECTS MEMBERS \NSMT.GROUP.FILTER))) ("List Users" "" RETURN (QUOTE (\NSMT.LIST.OBJECTS USER))) ("Show Details of previously listed names" "" RETURN (FUNCTION \NSMT.SHOW.DETAILS)) ("Type Entry" "" RETURN (FUNCTION \NSMT.TYPE.ENTRY) EXPLAINSTRING "Type Entry -- same as Describe") ("Type Members" "" RETURN (FUNCTION \NSMT.TYPE.MEMBERS) EXPLAINSTRING "Type Members -- same as List Members") ("Uncache All Clearinghouses" " [confirm]" CONFIRMFLG T RETURN (QUOTE (\NSMT.UNCACHE T))) ("Uncache Clearinghouse for domain" "" RETURN (FUNCTION \NSMT.UNCACHE)) ("Uncache Local (force Maintain to refetch some info)" " [confirm]" CONFIRMFLG T RETURN (FUNCTION \NSMT.CLEAR.NAME.CACHE)) ("Quit" " [confirm]" CONFIRMFLG T RETURN NIL))) + +(RPAQQ *NSMAINTAIN-ABORT-ITEM* ("" "" EXPLAINSTRING " - abort" RETURN NIL)) + +(ADDTOVAR CH.PROPERTIES (ALIAS 1) (BOOT.SERVICE 10026)) + +(ADDTOVAR *NSMAINTAIN-DESCRIPTIVE-PROPERTIES* 10000 10001 10002 10003 10004 10005 10006 10007 10008 10009 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10022 10023 10024 10026) + +(ADDTOVAR *NSMAINTAIN-IGNORE-PROPERTIES* 6 7 10027 20003 20002 20101) + +(ADDTOVAR *NSMAINTAIN-PROPERTY-FORMATS* (4 CLEARINGHOUSE . NETWORK.ADDRESS.LIST) (8 RECORD (SIMPLE BOOLEAN) (STRONG BOOLEAN)) (30 . NSNAME) (31 CLEARINGHOUSE . MAILBOX.VALUES) (10000 . STRING) (10001 . STRING) (10002 . STRING) (10003 . STRING) (10004 . STRING) (10005 . STRING) (10006 . STRING) (10007 . STRING) (10008 . STRING) (10009 . STRING) (10010 . STRING) (10011 . STRING) (10012 . STRING) (10013 . STRING) (10014 . STRING) (10015 . STRING) (10016 . STRING) (10017 . STRING) (10018 . STRING) (10019 . STRING) (10020 . STRING) (10021 . STRING) (10022 . STRING) (10023 . STRING) (10024 . STRING) (10026 . STRING) (10029 . STRING) (10030 . STRING) (10032 . STRING) (10034 . STRING) (10035 . STRING) (15002 . STRING) (20000 CLEARINGHOUSE . USERDATA.VALUE) (20001 GAP . RS232CData) (20006 SEQUENCE NSNAME) (20007 . NSNAME) (20102 GAP . RS232CBack) (29965 . STRING) (30005 . NSNAME)) + +(ADDTOVAR *NSMAINTAIN-MEMBER-PROPERTIES* 3 20006) + +(RPAQ? *NSMAINTAIN-MEMBER-THRESHOLD* 3) + +(RPAQ? *NSMAINTAIN-SHOW-GROUP-ACCESS*) +(DECLARE%: EVAL@COMPILE + +(CL:PROCLAIM (QUOTE (CL:SPECIAL *NSMAINTAIN-MEMBER-THRESHOLD* *NSMAINTAIN-SHOW-GROUP-ACCESS*))) + +(CL:PROCLAIM (QUOTE (GLOBAL *NSMAINTAIN-MEMBER-PROPERTIES* *NSMAINTAIN-PROPERTY-FORMATS* *NSMAINTAIN-IGNORE-PROPERTIES* *NSMAINTAIN-DESCRIPTIVE-PROPERTIES*))) +DONTCOPY + +(DEFMACRO WITH-CHS ((STREAMVAR DOMAIN) &BODY BODY) (BQUOTE (LET (((\, STREAMVAR) (\NSMT.COURIER.OPEN (\, DOMAIN)))) (AND (\, STREAMVAR) (CL:UNWIND-PROTECT (PROGN (\,@ BODY)) (CLOSEF? (\, STREAMVAR))))))) + + +(FILESLOAD (LOADCOMP) CLEARINGHOUSE) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ \CH.BROADCAST.SOCKET 20) + + +(CONSTANTS \CH.BROADCAST.SOCKET) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS *NSMAINTAIN-COMMANDS* *NSMAINTAIN-ABORT-ITEM* CH.PROPERTIES) +) + + +(CL:PROCLAIM (QUOTE (CL:SPECIAL *USER* *LASTDOMAIN* *LASTNAME* *LASTGROUP* *LASTLIST* *LASTSTRING* *LAST-MEMBERSHIP* *SERVERTYPES* *ALLTYPES* *OBJECTTYPES* *DEFAULTDOMAIN* *REAL-NAME-CACHE* *DOMAIN*))) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) + + +(RPAQ *NSMT-MENU-FNS* (CL:REMOVE-DUPLICATES (FOR ENTRY IN *NSMAINTAIN-COMMANDS* WHEN (LISTP (SETQ ENTRY (CADR (MEMB (QUOTE RETURN) ENTRY)))) COLLECT (IF (EQ (CAR ENTRY) (QUOTE FUNCTION)) THEN (CADR ENTRY) ELSEIF (EQ (CAR ENTRY) (QUOTE QUOTE)) THEN (CAR (LISTP (CADR ENTRY))))))) +) +(PUTPROPS NSMAINTAIN COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1989 1990 1991 1992)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (4329 24808 (NSMAINTAIN 4339 . 5822) (\NSMT.INITIAL.LOGIN 5824 . 6771) (\NSMT.HELP 6773 + . 8409) (\NSMT.READFNAME 8411 . 11270) (\NSMT.LOOKUP 11272 . 12144) (\NSMT.LOOKUP1 12146 . 12707) ( +\NSMT.CHECK.DOMAIN 12709 . 14737) (\NSMT.DOMAIN.MAY.EXIST 14739 . 14873) (\NSMT.FOREIGN.DOMAINP 14875 + . 16123) (\NSMT.COLLECT.NAMES 16125 . 16439) (\NSMT.GET.REMARK 16441 . 16733) (\NSMT.GET.PASSWORD +16735 . 17316) (\NSMT.LOGIN 17318 . 17852) (\NSMT.GETAUTHENTICATOR 17854 . 18406) (\NSMT.CHANGE.DOMAIN + 18408 . 18851) (\NSMT.PRINT.LIST 18853 . 19162) (\NSMT.PRINT.OBJECTS 19164 . 19642) ( +\NSMT.PROCESS.LIST 19644 . 20446) (\NSMT.READ.COMMA.LIST 20448 . 21251) (\NSMT.SHOW.RESULT 21253 . +22013) (\NSMT.CHOOSE 22015 . 22229) (\NSMT.COURIER.OPEN 22231 . 23145) (\NSMT.CLEAR.CACHE 23147 . +24365) (EQUAL.NSADDRESS 24367 . 24806)) (24848 40360 (\NSMT.CHANGE.PASSWORD 24858 . 25614) ( +\NSMT.DESCRIBE.ACL 25616 . 26848) (\NSMT.DESCRIBE.OBJECT 26850 . 30408) (\NSMT.DESCRIPTIVE.PROPS 30410 + . 30901) (\NSMT.DESCRIBE.PROPERTY 30903 . 32520) (\NSMT.PRETTY.PROPERTY 32522 . 32722) ( +\NSMT.LIST.OBJECTS 32724 . 33567) (\NSMT.LIST.CLEARINGHOUSES 33569 . 34849) (\NSMT.LIST.SERVERS 34851 + . 35554) (\NSMT.SHOW.DETAILS 35556 . 36371) (\NSMT.GROUP.FILTER 36373 . 36988) ( +\NSMT.LIST.ADMINISTRATORS 36990 . 37271) (\NSMT.FETCH.ADMINISTRATORS 37273 . 37943) ( +\NSMT.FETCH.ADMINISTRATORS1 37945 . 38231) (\NSMT.LIST.DOMAINS 38233 . 38479) (\NSMT.TYPE.ENTRY 38481 + . 38670) (\NSMT.TYPE.MEMBERS 38672 . 39663) (\NSMT.UNCACHE 39665 . 39973) (\NSMT.CLEAR.NAME.CACHE +39975 . 40358)) (40400 61713 (\NSMT.ADD.ALIAS 40410 . 41034) (\NSMT.ADD.GROUP 41036 . 44171) ( +\NSMT.SET.INITIAL.ACL 44173 . 44831) (\NSMT.ADD.USER 44833 . 46004) (\NSMT.ADD.OBJECT 46006 . 46792) ( +\NSMT.CREATE.OBJECT 46794 . 47043) (\NSMT.ADD.OBJECT.GENERIC 47045 . 47969) (\NSMT.CHANGE.ADDRESS +47971 . 50037) (\NSMT.CHANGE.ADMINISTRATORS 50039 . 50750) (\NSMT.CHANGE.FORWARDING 50752 . 55440) ( +\NSMT.CHANGE.GROUP.COMPONENT 55442 . 58095) (\NSMT.CHANGE.REMARK 58097 . 60313) (\NSMT.GET.OBJECT.TYPE + 60315 . 60556) (\NSMT.REMOVE.ALIAS 60558 . 60911) (\NSMT.REMOVE.OBJECT 60913 . 61211) ( +\NSMT.REMOVE.USER 61213 . 61711)) (61795 63477 (CH.FINDSERVER 61805 . 63475))))) +STOP diff --git a/library/PCTREE b/library/PCTREE new file mode 100644 index 00000000..19b52cbb --- /dev/null +++ b/library/PCTREE @@ -0,0 +1,251 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Apr-2018 12:19:49" {DSK}kaplan>Local>medley3.5>lispcore>library>PCTREE.;4 28288 changes to%: (VARS PCTREECOMS) previous date%: "29-Jan-99 17:33:18" {DSK}kaplan>Local>medley3.5>lispcore>library>PCTREE.;3) (* ; " Copyright (c) 1990, 1991, 1993, 1994, 1995, 1999, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PCTREECOMS) (RPAQQ PCTREECOMS [ (* ;; "Balanced tree PIECE TABLE supporting functions") (FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (* ;; "\WORDSINBTREEMAIN = # of words in the child-pointers & offsets section of the node -- everything before SPARE5 (the overflow place).") (* ;;  "\BTREEMAXCOUNT = number of children in a full node = maximum value for a node's COUNT field.") (* ;; "\BTREELASTREALOFFSET = offset of last real space for a child entry in the node ( = \WORDSINBTREEMAIN - 4)") (CONSTANTS (\BTREEMAXENTRIES 8) (\BTREEMAXCOUNT 8) (\BTREEWORDSPERENTRY 4) (\WORDSINBTREEMAIN (UNFOLD \BTREEMAXENTRIES 4)) (\BTREELASTREALOFFSET (UNFOLD (SUB1 \BTREEMAXENTRIES) 4)) (\BTREETOPHALFOFFSET (UNFOLD (LRSH \BTREEMAXENTRIES 1) 4))) (FILES (LOADCOMP) TEDITDCL)) (FNS UPDATEPCNODES FINDPCNODE \FIRSTNODE \DELETETREE \INSERTTREE \LASTNODE \MATCHPCS \SPLITTREE \TEDIT.UPDATETREE \TEDIT.PIECE-CHNO \TEDIT.SET-TOTLEN) (FNS DISPTREE TREEGRAPHNODE) (RECORDS BTREENODE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ;; "Balanced tree PIECE TABLE supporting functions") (FILESLOAD TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \BTREEMAXENTRIES 8) (RPAQQ \BTREEMAXCOUNT 8) (RPAQQ \BTREEWORDSPERENTRY 4) (RPAQ \WORDSINBTREEMAIN (UNFOLD \BTREEMAXENTRIES 4)) (RPAQ \BTREELASTREALOFFSET (UNFOLD (SUB1 \BTREEMAXENTRIES) 4)) (RPAQ \BTREETOPHALFOFFSET (UNFOLD (LRSH \BTREEMAXENTRIES 1) 4)) (CONSTANTS (\BTREEMAXENTRIES 8) (\BTREEMAXCOUNT 8) (\BTREEWORDSPERENTRY 4) (\WORDSINBTREEMAIN (UNFOLD \BTREEMAXENTRIES 4)) (\BTREELASTREALOFFSET (UNFOLD (SUB1 \BTREEMAXENTRIES) 4)) (\BTREETOPHALFOFFSET (UNFOLD (LRSH \BTREEMAXENTRIES 1) 4))) ) (FILESLOAD (LOADCOMP) TEDITDCL) ) (DEFINEQ (UPDATEPCNODES + [LAMBDA (PC DELTA) (* ; "Edited 21-Apr-93 16:09 by jds") + + (* ;; "ADD DELTA TO CHNUM IN NEXTALL NODES OF TOPNODE.") + + (LET ((UPWARD (fetch (PIECE PTREENODE) of PC))) + (while UPWARD do (for I from 0 by 4 as ITEM from 1 + to (fetch (BTREENODE COUNT) of UPWARD) + when (EQ PC (\GETBASEPTR UPWARD I)) + do [\PUTBASEFIXP UPWARD (IPLUS I 2) + (IPLUS DELTA (\GETBASEFIXP UPWARD (IPLUS I 2] + (add (fetch (BTREENODE TOTLEN) of UPWARD) + DELTA) + (SETQ PC UPWARD) + (SETQ UPWARD (fetch (BTREENODE UPWARD) of PC)) + (RETURN) finally (HELP "Piece not in its TREENODE"]) (FINDPCNODE + [LAMBDA (PC PCTB) (* ; "Edited 13-Apr-93 15:00 by jds") + + (* ;; "Given a piece and the pctb it's in, return pcnode") + + (fetch (PIECE PTREENODE) of PC]) (\FIRSTNODE + [LAMBDA (TREE) (* ; "Edited 14-Apr-93 02:06 by jds") + (LET ((COUNT (fetch (BTREENODE COUNT) of TREE)) + CHILD) + (SETQ CHILD (\GETBASEPTR TREE 0)) + (COND + ((type? BTREENODE CHILD) + (\FIRSTNODE CHILD)) + (T TREE]) (\DELETETREE [LAMBDA (OLD PCNODE) (* ;  "Edited 21-Mar-95 15:29 by sybalsky:mv:envos") (* ;; "Removes OLD from PCNODE. OLD is either a piece or tree node.") (UNINTERRUPTABLY (LET* ((OLDLEN (ffetch (BTREENODE TOTLEN) of PCNODE)) NEWLEN INCHNO AFTERFLG NODE-COUNT ITEM# BB) (* ;; "NEW CODE") (SETQ NODE-COUNT (fetch (BTREENODE COUNT) of PCNODE)) (* ;; "Find OLD, .") (for old ITEM# from 0 to (LLSH (SUB1 NODE-COUNT) 2) by 4 when (EQ OLD (\GETBASEPTR PCNODE ITEM#)) do (RETURN) finally (HELP "Piece/node not in PCNODE")) (* ;; "Update the previous piece's length, if appropriate:") (SETQ BB (\ADDBASE PCNODE ITEM#)) (\RPLPTR BB 0 NIL) [for I from 0 to (IDIFFERENCE \BTREELASTREALOFFSET ITEM#) by 4 do (\PUTBASEPTR BB I (\GETBASEPTR BB (IPLUS I 4))) (\PUTBASEFIXP BB (IPLUS I 2) (\GETBASEFIXP BB (IPLUS I 6] (\PUTBASEPTR PCNODE \BTREELASTREALOFFSET NIL) (* ;  "Because it's been copied, clear the old value before the refcnt-er gets to it.") (* ;; " If adding this piece EMPTIES the tree node, DELETE it.") (* ;; "FIXMI -- This should coalesce adjacent nodes that are too empty!") [COND ((IEQP NODE-COUNT 1) (\DELETETREE PCNODE (fetch (BTREENODE UPWARD) of PCNODE))) (T (* ;  "No split, so update upper nodes with delta-length.") [SETQ NEWLEN (replace (BTREENODE TOTLEN) of PCNODE with (for I from 2 to NODE-COUNT as ITEM# from 2 by 4 sum (\GETBASEFIXP PCNODE ITEM#] (replace (BTREENODE COUNT) of PCNODE with (SUB1 NODE-COUNT)) (\TEDIT.UPDATETREE PCNODE (IDIFFERENCE NEWLEN OLDLEN] (* ;; "END NEW CODE") 1))]) (\INSERTTREE [LAMBDA (NEW OLD PCNODE NEW-PREVLEN NEW-OLDLEN PREV) (* ;  "Edited 21-Mar-95 15:29 by sybalsky:mv:envos") (* ;; "inserts NEW in front of OLD in PCNODE. NEW/OLD are either pieces or tree nodes.") (* ;; "If NEWE-PREVLEN is non-NIL, it's a DELTA for updating parents of THE PIECE BEFORE OLD. This is used by \SPLITPIECE to pass down the new shortened length for the original piece.") (UNINTERRUPTABLY (LET* ((OLDLEN (ffetch (BTREENODE TOTLEN) of PCNODE)) NEWLEN INCHNO AFTERFLG NODE-COUNT ITEM# BB) (* ;; "NEW CODE") (SETQ NODE-COUNT (fetch (BTREENODE COUNT) of PCNODE)) (* ;; "Find OLD, and insert the NEW piece (and length) in front of it.") (for old ITEM# from 0 to (LLSH (SUB1 NODE-COUNT) 2) by 4 when (EQ OLD (\GETBASEPTR PCNODE ITEM#)) do (RETURN) FINALLY (HELP "Old piece not in this PCNODE.")) (OR NEW (HELP "Inserting empty item")) (* ;; "Update the previous piece's length, if appropriate:") [AND NEW-PREVLEN (COND ((ZEROP ITEM#) (* ;; "The hard way -- the previous piece is in a prior btree node, so we have to go there to update it.") (LET* ((NODE (fetch (PIECE PTREENODE) of PREV))) (UPDATEPCNODES PREV NEW-PREVLEN))) (T (* ;; "Easy way -- it's in this node. Update it in place.") (\PUTBASEFIXP PCNODE (IDIFFERENCE ITEM# 2) (IPLUS NEW-PREVLEN (\GETBASEFIXP PCNODE (IDIFFERENCE ITEM# 2] (COND (NEW-OLDLEN (\PUTBASEFIXP PCNODE (IPLUS ITEM# 2) NEW-OLDLEN))) (SETQ BB (\ADDBASE PCNODE ITEM#)) (\RPLPTR PCNODE \WORDSINBTREEMAIN NIL) (* ;  "Clean out the slot that's about to be copied over.") (\BLT (\ADDBASE BB 4) BB (IDIFFERENCE \WORDSINBTREEMAIN ITEM#)) (\PUTBASEPTR PCNODE ITEM# NIL) (* ;  "Because it's been copied, clear the old value before the refcnt-er gets to it.") (\RPLPTR PCNODE ITEM# NEW) (COND ((type? PIECE NEW) (\PUTBASEFIXP PCNODE (IPLUS ITEM# 2) (fetch (PIECE PLEN) of NEW)) (replace (PIECE PTREENODE) of NEW with PCNODE)) ((type? BTREENODE NEW) (* ; "Inserting a NODE") (\PUTBASEFIXP PCNODE (IPLUS ITEM# 2) (fetch (BTREENODE TOTLEN) of NEW)) (replace (BTREENODE UPWARD) of NEW with PCNODE)) (T (\ILLEGAL.ARG NEW))) [SETQ NEWLEN (replace (BTREENODE TOTLEN) of PCNODE with (for I from 0 to NODE-COUNT as ITEM# from 2 by 4 sum (\GETBASEFIXP PCNODE ITEM#] (* ;; " If adding this piece overflows the tree node, split it.") [COND ((IEQP NODE-COUNT \BTREEMAXCOUNT) (* ;  "Tree node is full, so have to split.") (\SPLITTREE PCNODE OLD NEW)) (T (* ;  "No split, so update upper nodes with delta-length.") (replace (BTREENODE COUNT) of PCNODE with (ADD1 NODE-COUNT)) (\TEDIT.UPDATETREE PCNODE (IDIFFERENCE NEWLEN OLDLEN] (* ;; "END NEW CODE") 1))]) (\LASTNODE + [LAMBDA (TREE) (* ; "Edited 14-Apr-93 16:29 by jds") + (LET ((COUNT (fetch (BTREENODE COUNT) of TREE)) + CHILD) + (for ITEM# from (LLSH (IDIFFERENCE COUNT 1) + 2) to 0 by -4 when (SETQ CHILD (\GETBASEPTR TREE + ITEM#)) + do (RETURN (COND + ((type? BTREENODE CHILD) + (\LASTNODE CHILD)) + (T TREE]) (\MATCHPCS + [LAMBDA (PCNODE) (* ; "Edited 5-May-93 17:57 by jds") + + (* ;; "Make sure that any pieces pointed to this node point back to this node.") + + (bind PC for OFFSET from 0 to \WORDSINBTREEMAIN by 4 as I from 1 + to (fetch (BTREENODE COUNT) of PCNODE) do (SETQ PC (\GETBASEPTR PCNODE OFFSET) + ) + (COND + ((type? PIECE PC) + (replace (PIECE PTREENODE) + of PC with PCNODE)) + ((type? BTREENODE PC) + (replace (BTREENODE UPWARD) + of PC with PCNODE]) (\SPLITTREE + [LAMBDA (PCNODE) (* ; + "Edited 21-Mar-95 15:26 by sybalsky:mv:envos") + + (* ;; "We're adding piece NEW in front of OLD. OLD is represented in the B-tree node PCNODE, which is full.") + + (* ;; "Split PCNODE in two and propogate any changes upward.") + + (UNINTERRUPTABLY + [LET ((UPWARD (fetch (BTREENODE UPWARD) of PCNODE)) + COUNT ITEM# NEW1 NEW2) + (COND + (UPWARD + + (* ;; + "Easy case: This is not the root node, so split the node and propogate up.") + + (SETQ NEW1 (create BTREENODE using PCNODE)) + + (* ;; "Clean out upper 3 child entries, leaving only the lower 2. Have to tell GC about actual child slots being set to NIL (hence \RPLPTRs):") + + (for OFST from \BTREETOPHALFOFFSET to \WORDSINBTREEMAIN + by 4 do (\RPLPTR NEW1 OFST NIL) + (\PUTBASEFIXP NEW1 (IPLUS OFST 2) + 0)) + (replace (BTREENODE COUNT) of NEW1 with (LRSH \BTREEMAXENTRIES 1)) + (\TEDIT.SET-TOTLEN NEW1) + (\MATCHPCS NEW1) + + (* ;; + "Now clean up the old piece, to contain only the upper 3 original children:") + + (for OFST from 0 to (SUB1 \BTREETOPHALFOFFSET) by 4 + do (* ; + "For GC, have to tell it we've dropped pointers to first N/2 pieces") + (\RPLPTR PCNODE OFST NIL)) + + (* ;; "Move upper N/2+1 down") + + [for OFST from 0 to \BTREETOPHALFOFFSET by 4 as UPPEROFST + from \BTREETOPHALFOFFSET by 4 + do (\PUTBASEPTR PCNODE OFST (\GETBASEPTR PCNODE UPPEROFST)) + (\PUTBASEFIXP PCNODE (IPLUS 2 OFST) + (\GETBASEFIXP PCNODE (IPLUS 2 UPPEROFST] + + (* ;; "And clean out upper 2 slots, without the GC seeing it:") + + (for OFST from (IPLUS \BTREEWORDSPERENTRY \BTREETOPHALFOFFSET) + to \WORDSINBTREEMAIN by \BTREEWORDSPERENTRY + do (\PUTBASEPTR PCNODE OFST NIL) + (\PUTBASEFIXP PCNODE (IPLUS OFST 2) + 0)) + (replace (BTREENODE COUNT) of PCNODE with (ADD1 (LRSH + \BTREEMAXENTRIES + 1))) + (\TEDIT.SET-TOTLEN PCNODE) + (SETQ COUNT (fetch (BTREENODE COUNT) of UPWARD)) + (\INSERTTREE NEW1 PCNODE UPWARD NIL (fetch (BTREENODE TOTLEN) + of PCNODE))) + (T + (* ;; "Hard case: This is the root node. We need to create 2 new nodes, put the split parts there, and re-use this node as the root.") + + (SETQ NEW1 (create BTREENODE using PCNODE)) + (for OFST from \BTREETOPHALFOFFSET to \WORDSINBTREEMAIN by 4 + do (\RPLPTR NEW1 OFST NIL) + (\PUTBASEFIXP NEW1 (IPLUS OFST 2) + 0)) + (replace (BTREENODE UPWARD) of NEW1 with PCNODE) + (replace (BTREENODE COUNT) of NEW1 with (LRSH \BTREEMAXENTRIES 1)) + (\TEDIT.SET-TOTLEN NEW1) + (\MATCHPCS NEW1) + + (* ;; "--") + + (SETQ NEW2 (create BTREENODE using PCNODE)) + (for OFST from 0 to (SUB1 \BTREETOPHALFOFFSET) by 4 + do (* ; + "For GC, have to tell it we've dropped pointers to first N/2 pieces") + (\RPLPTR NEW2 OFST NIL)) + [for OFST from 0 to \BTREETOPHALFOFFSET by 4 as UPPEROFST + from \BTREETOPHALFOFFSET by 4 + do (\PUTBASEPTR NEW2 OFST (\GETBASEPTR NEW2 UPPEROFST)) + (\PUTBASEFIXP NEW2 (IPLUS 2 OFST) + (\GETBASEFIXP NEW2 (IPLUS 2 UPPEROFST] + (for OFST from (IPLUS \BTREEWORDSPERENTRY \BTREETOPHALFOFFSET) + to \WORDSINBTREEMAIN by \BTREEWORDSPERENTRY + do (\PUTBASEPTR NEW2 OFST NIL) + (\PUTBASEFIXP NEW2 (IPLUS OFST 2) + 0)) + (replace (BTREENODE UPWARD) of NEW2 with PCNODE) + (replace (BTREENODE COUNT) of NEW2 with (ADD1 (LRSH \BTREEMAXENTRIES 1 + ))) + (\TEDIT.SET-TOTLEN NEW2) + (\MATCHPCS NEW2) + + (* ;; "Now clean out the top-level node, and fill it in with its new children.") + + (for OFST from 0 to \WORDSINBTREEMAIN by \BTREEWORDSPERENTRY + do + + (* ;; "Clean out the entries in the node, so we don't over-write them by mistake, thus losing refcount sync.") + + (\RPLPTR PCNODE OFST NIL) + (\PUTBASEFIXP PCNODE (IPLUS 2 OFST) + 0)) + (\RPLPTR PCNODE 0 NEW1) (* ; "Add first new node") + (\PUTBASEFIXP PCNODE 2 (ffetch (BTREENODE TOTLEN) of NEW1)) + (\RPLPTR PCNODE 4 NEW2) (* ; "And the second....") + (\PUTBASEFIXP PCNODE 6 (ffetch (BTREENODE TOTLEN) of NEW2)) + (freplace (BTREENODE COUNT) of PCNODE with 2) + (freplace (BTREENODE TOTLEN) of PCNODE with (IPLUS (ffetch + (BTREENODE TOTLEN) + of NEW1) + (ffetch + (BTREENODE TOTLEN) + of NEW2])]) (\TEDIT.UPDATETREE + [LAMBDA (PCNODE DELTA) (* ; + "Edited 21-Mar-95 14:40 by sybalsky:mv:envos") + + (* ;; "The size of the text represented by PCNODE has grown by DELTA. Update all of PCNODE's parents to reflect the change in length.") + + (LET ((UPWARD (fetch (BTREENODE UPWARD) of PCNODE))) + (while UPWARD do + + (* ;; "Keep going up in the tree til we hit the top.") + + (for old ITEM# from 0 by 4 as I from 1 + to (ffetch (BTREENODE COUNT) of UPWARD) + when (EQ (\GETBASEPTR UPWARD ITEM#) + PCNODE) + do (\PUTBASEFIXP UPWARD (IPLUS ITEM# 2) + (IPLUS (\GETBASEFIXP UPWARD (IPLUS ITEM# 2)) + DELTA)) + (add (fetch (BTREENODE TOTLEN) of UPWARD) + DELTA) + (RETURN) FINALLY (HELP "PCNODE not in upward node.")) + (SETQ PCNODE UPWARD) + (SETQ UPWARD (fetch (BTREENODE UPWARD) of PCNODE]) (\TEDIT.PIECE-CHNO + [LAMBDA (PC) + (LET ((PCNODE (fetch (PIECE PTREENODE) of PC)) + (CHARCOUNT 0)) + (while PCNODE do [add CHARCOUNT (for OFST from 0 by 4 + while (NEQ PC (\GETBASEPTR PCNODE OFST)) + sum (\GETBASEFIXP PCNODE (IPLUS OFST 2] + (SETQ PC PCNODE) + (SETQ PCNODE (fetch (BTREENODE UPWARD) of PCNODE))) + (ADD1 CHARCOUNT]) (\TEDIT.SET-TOTLEN + [LAMBDA (PCNODE) (* ; "Edited 9-May-93 15:40 by jds") + + (* ;; "Fix the TOTLEN field of a node to match the sum of its childrens' lengths") + + (replace (BTREENODE TOTLEN) of PCNODE with (for I from 1 + to (fetch (BTREENODE COUNT) + of PCNODE) as ITEM# + from 2 by 4 + sum (\GETBASEFIXP PCNODE ITEM#]) ) (DEFINEQ (DISPTREE + [LAMBDA (TREE DEPTH) (* ; "Edited 13-Apr-90 15:00 by ON") + (LET [(G (TREEGRAPHNODE TREE NIL (OR (NUMBERP DEPTH) + T] + (SHOWGRAPH (LAYOUTGRAPH (CADR G) + (LIST (CAR G)) + '(VERTICAL)) + NIL + #'(LAMBDA (X) + (INSPECT (fetch NODEID of X]) (TREEGRAPHNODE + [LAMBDA (TREE PARENT DEPTH) (* ; "Edited 12-Jun-90 10:33 by mitani") + (LET (THISNODE NEWDEPTH NODEID LONODES HINODES BFNODE BFNODEID RANKNODE RANKNODEID) + (COND + ((ATOM TREE) + (LIST [fetch NODEID of (SETQ THISNODE (NODECREATE (CONS) + TREE NIL NIL (LIST PARENT] + (LIST THISNODE))) + ((OR (EQ DEPTH T) + (AND (NUMBERP DEPTH) + (>= DEPTH 0))) + (SETQ NEWDEPTH (COND + ((NUMBERP DEPTH) + (SUB1 DEPTH)) + (T DEPTH))) + (SETQ NODEID (fetch (PCTNODE PCE) of TREE)) + (SETQ LONODES (TREEGRAPHNODE (fetch (PCTNODE LO) of TREE) + NODEID NEWDEPTH)) + (SETQ HINODES (TREEGRAPHNODE (fetch (PCTNODE HI) of TREE) + NODEID NEWDEPTH)) + (SETQ BFNODE (NODECREATE (SETQ BFNODEID (CONS)) + (fetch (PCTNODE BF) of TREE) + NIL NIL (LIST NODEID))) + (SETQ RANKNODE (NODECREATE (SETQ RANKNODEID (CONS)) + (fetch (PCTNODE RANK) of TREE) + NIL NIL (LIST NODEID))) + [SETQ THISNODE (NODECREATE NODEID (fetch (PCTNODE CHNUM) of TREE) + NIL + (LIST (CAR LONODES) + BFNODEID RANKNODEID (CAR HINODES)) + (AND PARENT (LIST PARENT] + (LIST (fetch NODEID of THISNODE) + (APPEND (LIST THISNODE BFNODE RANKNODE) + (CADR LONODES) + (CADR HINODES]) ) (DECLARE%: EVAL@COMPILE (DATATYPE BTREENODE ( (* ;; "An order-4 BTREE node for representing the piece table for TEdit.") DOWN1 (DLEN1 FIXP) DOWN2 (DLEN2 FIXP) DOWN3 (DLEN3 FIXP) DOWN4 (DLEN4 FIXP) DOWN5 (DLEN5 FIXP) DOWN6 (DLEN6 FIXP) DOWN7 (DLEN7 FIXP) DOWN8 (DLEN8 FIXP) SPARE5 (* ;  "Used only to hold the extra piece when we're overflowing") (SPARELEN FIXP) (* ; "So the code is easy and fast.") (COUNT BITS 4) (* ; "# of children of this node") (UPWARD XPOINTER) (* ; "Parent of this node, if any.") (TOTLEN FIXP) (* ;  "Total length of this tree and subtrees") )) ) (/DECLAREDATATYPE 'BTREENODE '(POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP (BITS 4) XPOINTER FIXP) '((BTREENODE 0 POINTER) (BTREENODE 2 FIXP) (BTREENODE 4 POINTER) (BTREENODE 6 FIXP) (BTREENODE 8 POINTER) (BTREENODE 10 FIXP) (BTREENODE 12 POINTER) (BTREENODE 14 FIXP) (BTREENODE 16 POINTER) (BTREENODE 18 FIXP) (BTREENODE 20 POINTER) (BTREENODE 22 FIXP) (BTREENODE 24 POINTER) (BTREENODE 26 FIXP) (BTREENODE 28 POINTER) (BTREENODE 30 FIXP) (BTREENODE 32 POINTER) (BTREENODE 34 FIXP) (BTREENODE 32 (BITS . 3)) (BTREENODE 36 XPOINTER) (BTREENODE 38 FIXP)) '40) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS PCTREE COPYRIGHT ("Venue & Xerox Corporation" 1990 1991 1993 1994 1995 1999 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3043 23338 (UPDATEPCNODES 3053 . 4140) (FINDPCNODE 4142 . 4374) (\FIRSTNODE 4376 . 4733 ) (\DELETETREE 4735 . 7216) (\INSERTTREE 7218 . 11647) (\LASTNODE 11649 . 12292) (\MATCHPCS 12294 . 13418) (\SPLITTREE 13420 . 20596) (\TEDIT.UPDATETREE 20598 . 22075) (\TEDIT.PIECE-CHNO 22077 . 22656) (\TEDIT.SET-TOTLEN 22658 . 23336)) (23339 25779 (DISPTREE 23349 . 23805) (TREEGRAPHNODE 23807 . 25777) )))) STOP \ No newline at end of file diff --git a/library/POSTSCRIPTSTREAM b/library/POSTSCRIPTSTREAM new file mode 100644 index 00000000..1d57934f --- /dev/null +++ b/library/POSTSCRIPTSTREAM @@ -0,0 +1,2523 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP") (FILECREATED "14-May-2018 10:52:48"  {DSK}Kaplan>Local>medley3.5>lispcore>library>POSTSCRIPTSTREAM.;7 267706 changes to%: (FNS POSTSCRIPT.INIT) previous date%: " 8-May-2018 19:34:01" {DSK}Kaplan>Local>medley3.5>lispcore>library>POSTSCRIPTSTREAM.;5) (* ; " Copyright (c) 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998, 2018 by Venue This program or documentation contains confidential information and trade secrets of Venue. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Venue. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets. All rights reserved. ") (PRETTYCOMPRINT POSTSCRIPTSTREAMCOMS) (RPAQQ POSTSCRIPTSTREAMCOMS [ (* ;; "PostScript printer support for Medley") (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS FONTID PSCFONT \POSTSCRIPTDATA POSTSCRIPTXFORM)) (INITRECORDS \POSTSCRIPTDATA) (FNS POSTSCRIPT.INIT) (ADDVARS (DEFAULTFILETYPELIST (PS . TEXT) (PSC . TEXT) (PSF . BINARY) (PSCFONT . BINARY) (POSTSCRIPT . TEXT)) (*DISPLAY-FONT-NAME-MAP* (AVANTGARDE-BOOK . AB) (AVANTGARDE-DEMI . AD) (BECKMAN . BM) (BOOKMAN-LIGHT . BL) (BOOKMAN-DEMI . BD) (COURIER . CO) (HELVETICA-NARROW . HN) (NEWCENTURYSCHLBK . NC) (PALATINO . PA) (TIMES . TS) (ZAPFCHANCERY-MEDIUM . ZM) (ZAPFCHANCERY . ZC) (ZAPFDINGBATS . ZD))) (* ;; "Font-reading code") (FNS PSCFONT.READFONT PSCFONT.SPELLFILE PSCFONT.COERCEFILE PSCFONTFROMCACHE.SPELLFILE PSCFONTFROMCACHE.COERCEFILE PSCFONT.WRITEFONT READ-AFM-FILE CONVERT-AFM-FILES POSTSCRIPT.GETFONTID POSTSCRIPT.FONTCREATE \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS POSTSCRIPT.FONTSAVAILABLE) (COMS (* ;; "Until macro in FONT is exported") (MACROS \FSETCHARWIDTH)) (FNS OPENPOSTSCRIPTSTREAM CLOSEPOSTSCRIPTSTREAM) (INITVARS (*POSTSCRIPT-FILE-TYPE* 'BINARY)) (FNS POSTSCRIPT.HARDCOPYW POSTSCRIPT.TEDIT POSTSCRIPT.TEXT POSTSCRIPTFILEP MAKEEPSFILE) (FNS POSTSCRIPT.BITMAPSCALE POSTSCRIPT.CLOSESTRING POSTSCRIPT.ENDPAGE POSTSCRIPT.OUTSTR POSTSCRIPT.PUTBITMAPBYTES POSTSCRIPT.PUTCOMMAND POSTSCRIPT.SET-FAKE-LANDSCAPE POSTSCRIPT.SHOWACCUM POSTSCRIPT.STARTPAGE \POSTSCRIPTTAB \PS.BOUTFIXP \PS.SCALEHACK \PS.SCALEREGION \SCALEDBITBLT.PSC \SETPOS.PSC \SETXFORM.PSC \STRINGWIDTH.PSC \SWITCHFONTS.PSC \TERPRI.PSC) (* ;; "DIG operations: ") (FNS \BITBLT.PSC \BLTSHADE.PSC \CHARWIDTH.PSC \CREATECHARSET.PSC \DRAWARC.PSC \DRAWCIRCLE.PSC \DRAWCURVE.PSC \DRAWELLIPSE.PSC \DRAWLINE.PSC \DRAWPOINT.PSC \DRAWPOLYGON.PSC \DSPBOTTOMMARGIN.PSC \DSPCLIPPINGREGION.PSC \DSPCOLOR.PSC \DSPFONT.PSC \DSPLEFTMARGIN.PSC \DSPLINEFEED.PSC \DSPPUSHSTATE.PSC \DSPPOPSTATE.PSC \DSPRESET.PSC \DSPRIGHTMARGIN.PSC \DSPROTATE.PSC \DSPSCALE.PSC \DSPSCALE2.PSC \DSPSPACEFACTOR.PSC \DSPTOPMARGIN.PSC \DSPTRANSLATE.PSC \DSPXPOSITION.PSC \DSPYPOSITION.PSC \FILLCIRCLE.PSC \FILLPOLYGON.PSC \FIXLINELENGTH.PSC \MOVETO.PSC \NEWPAGE.PSC) (COMS (* ;; "Character-output, plus special-cases:") (FNS \POSTSCRIPT.CHANGECHARSET \POSTSCRIPT.OUTCHARFN \POSTSCRIPT.PRINTSLUG \POSTSCRIPT.SPECIALOUTCHARFN \UPDATE.PSC \POSTSCRIPT.ACCENTFN \POSTSCRIPT.ACCENTPAIR) (* ;;  "Spacing-character (M-quad, etc.) and ballot-box-check &c special-case functions") (FNS \PSC.SPACEDISP \PSC.SPACEWID \PSC.SYMBOLS) (* ;;  "The mapping of NS characters to Postscript renderings, both as an AList and as a hashtable") (FNS \POSTSCRIPT.NSHASH) (VARS (*POSTSCRIPT-UNACCENTED-FONTS* '(Dancer ZapfDingbats "Dancer" "ZapfDingbats")) *POSTSCRIPT-NS-TRANSLATIONS*) (GLOBALVARS *POSTSCRIPT-NS-HASH*)) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \POSTSCRIPT.FRACTION)) (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 (COND ((EQ (MACHINETYPE) 'MAIKO) "{dsk}/USR/LOCAL/LDE/FONTS/POSTSCRIPT/") (T "{DSK}POSTSCRIPT>"] (\POSTSCRIPT.MAX.WILD.FONTSIZE 72)) [COMS (FNS POSTSCRIPTSEND) (ADDVARS (PRINTERTYPES ((POSTSCRIPT) (CANPRINT (POSTSCRIPT)) (STATUS TRUE) (PROPERTIES NILL) (SEND POSTSCRIPTSEND) (BITMAPSCALE POSTSCRIPT.BITMAPSCALE) (BITMAPFILE (POSTSCRIPT.HARDCOPYW FILE BITMAP SCALEFACTOR REGION ROTATION TITLE] [ADDVARS (POSTSCRIPT.FONT.ALIST (HELVETICA . HELVETICA) (HELVETICAD . HELVETICA) (TIMESROMAN . TIMES) (TIMESROMAND . TIMES) (COURIER . COURIER) (GACHA . COURIER) (CLASSIC . NEWCENTURYSCHLBK) (MODERN . HELVETICA) (CREAM . HELVETICA) (TERMINAL . COURIER) (LOGO . HELVETICA) (OPTIMA . PALATINO) (TITAN . COURIER)) [PRINTFILETYPES (POSTSCRIPT (TEST POSTSCRIPTFILEP) (EXTENSION (PS PSC PSF)) (CONVERSION (TEXT POSTSCRIPT.TEXT TEDIT POSTSCRIPT.TEDIT] (IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM) (FONTCREATE POSTSCRIPT.FONTCREATE) (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE) (CREATECHARSET \CREATECHARSET.PSC] (INITVARS (POSTSCRIPT.PAGETYPE 'LETTER)) (* ;; "NIL means initial clipping is same as paper size. Don't know why the other regions were specified--rmk") [APPENDVARS (POSTSCRIPT.PAGEREGIONS (LETTER (0 0 8.5 11) NIL (-0.1 -0.1 8.7 11.2)) (LEGAL (0 0 8.5 14) NIL (-0.1 -0.1 8.7 14.2)) (NOTE (0 0 8.5 11) NIL (-0.1 -0.1 8.7 11.2] (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 ]) (* ;; "PostScript printer support for Medley") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD FONTID (FONTIDNAME FONTXFACTOR FONTOBLIQUEFACTOR)) (RECORD PSCFONT (FID IL-FONTID FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTHS)) (DATATYPE \POSTSCRIPTDATA ((POSTSCRIPTACCENTED FLAG) (* ;  "T if we're to do NS-to-PS translations on characters in the current font.") 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 (* ;  "Color (or grey shade) in effect; 0.0=black, 1.0=white.") 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") POSTSCRIPTXFORMSTACK (* ; "The stack of transformations. DSPPUSHSTATE pushes one onto this, DSPPOPSTATE uses it to reset values.") POSTSCRIPTROTATION (* ;  "Rotation value currently in effect.") POSTSCRIPTPENDINGROTATION (* ;  "Rotation to take effect at next SETXFORM.") POSTSCRIPTFONTSUSED (* ; "List of FONTIDs of the fonts that've been used before. This is used to control the re-encoding of fonts for accented-character rendering.") (POSTSCRIPTNSCHARSET BYTE) (* ;  "Current NSCHARSET--widths are in POSTSCRIPTWIDTHS") (POSTSCRIPTNATURALSPACEWIDTH WORD) (* ;  "Width of the space in the current font, used to compute the scaled space width.") ) POSTSCRIPTX _ 0 POSTSCRIPTY _ 0 POSTSCRIPTTRANSX _ 0 POSTSCRIPTTRANSY _ 0 POSTSCRIPTSPACEFACTOR _ 1 POSTSCRIPTPAGENUM _ 0 POSTSCRIPTSCALEHACK _ 1 POSTSCRIPTTEMPARRAY _ (ARRAY \PS.TEMPARRAYLEN 'BYTE 0 0) POSTSCRIPTROTATION _ 0 POSTSCRIPTCOLOR _ 0.0) (RECORD POSTSCRIPTXFORM ( (* ;; "Holds the transformation state as saved by DSPPUSHSTATE. Used by DSPPOPSTATE to restore the tranformation state.") PSXCLIP (* ; "Clipping region") PSXPAGE (* ; "Page region") PSXX (* ; "X position?") PSXY (* ; "Y position?") PSXLEFT (* ; "Left margin") PSXRIGHT (* ; "Right margin") PSXTOP (* ; "Top margin") PSXBOTTOM (* ; "Bottom Margin") PSXTRANX (* ; "X-translation in effect") PSXTRANY (* ; "Y-translation in effect") PSXLAND (* ; "Landscape?") PSXXFORMPEND (* ; "Are there transforms pending? ") )) ) (/DECLAREDATATYPE '\POSTSCRIPTDATA '(FLAG 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 POINTER POINTER POINTER POINTER BYTE WORD) '((\POSTSCRIPTDATA 0 (FLAGBITS . 0)) (\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) (\POSTSCRIPTDATA 58 POINTER) (\POSTSCRIPTDATA 60 POINTER) (\POSTSCRIPTDATA 62 POINTER) (\POSTSCRIPTDATA 64 POINTER) (\POSTSCRIPTDATA 66 (BITS . 7)) (\POSTSCRIPTDATA 67 (BITS . 15))) '68) ) (/DECLAREDATATYPE '\POSTSCRIPTDATA '(FLAG 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 POINTER POINTER POINTER POINTER BYTE WORD) '((\POSTSCRIPTDATA 0 (FLAGBITS . 0)) (\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) (\POSTSCRIPTDATA 58 POINTER) (\POSTSCRIPTDATA 60 POINTER) (\POSTSCRIPTDATA 62 POINTER) (\POSTSCRIPTDATA 64 POINTER) (\POSTSCRIPTDATA 66 (BITS . 7)) (\POSTSCRIPTDATA 67 (BITS . 15))) '68) (DEFINEQ (POSTSCRIPT.INIT [LAMBDA NIL (* ; "Edited 14-May-2018 10:48 by rmk:") (* ; "Edited 4-Feb-93 21:08 by jds") (DECLARE (GLOBALVARS \POSTSCRIPT.CHARTYPE)) (* ;; "Add POSTSCRIPT font descriptions to the active font profile.") [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 INTERPRESSFD) of CLASS) (fetch (FONTCLASS PRESSFD) 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] [FOR FD IN FONTDEFS DO (FOR FP IN (CDR (ASSOC 'FONTPROFILE (CDR FD))) DO (COND ((ASSOC 'POSTSCRIPT (CL:NTHCDR 5 FP)) (* ;; "There's already a postscript spec, so leave it be.") ) (T (NCONC1 FP `(POSTSCRIPT ,(OR (CL:FIFTH FP) (CL:FOURTH FP) (CL:THIRD FP] (* ;; "Eliminate any existing postscript fonts, to start with a clean slate if reinitializing.") (FOR FD IN (FONTSAVAILABLE '* '* '* '* 'POSTSCRIPT) DO (APPLY (FUNCTION SETFONTDESCRIPTOR) FD)) (SETQ POSTSCRIPTFONTCACHE NIL) (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)) (* ;; "RMK: Maybe the following is equivalent to alot of the stuff above??") (FONTPROFILE.ADDDEVICE 'POSTSCRIPT 'INTERPRESS) (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) IMSCALE2 _ (FUNCTION \DSPSCALE2.PSC) IMCOLOR _ (FUNCTION \DSPCOLOR.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) IMPUSHSTATE _ (FUNCTION \DSPPUSHSTATE.PSC) IMPOPSTATE _ (FUNCTION \DSPPOPSTATE.PSC))) (SETQ *POSTSCRIPT-NS-HASH* (HARRAY 255)) (\POSTSCRIPT.NSHASH *POSTSCRIPT-NS-TRANSLATIONS*]) ) (ADDTOVAR DEFAULTFILETYPELIST (PS . TEXT) (PSC . TEXT) (PSF . BINARY) (PSCFONT . BINARY) (POSTSCRIPT . TEXT)) (ADDTOVAR *DISPLAY-FONT-NAME-MAP* (AVANTGARDE-BOOK . AB) (AVANTGARDE-DEMI . AD) (BECKMAN . BM) (BOOKMAN-LIGHT . BL) (BOOKMAN-DEMI . BD) (COURIER . CO) (HELVETICA-NARROW . HN) (NEWCENTURYSCHLBK . NC) (PALATINO . PA) (TIMES . TS) (ZAPFCHANCERY-MEDIUM . ZM) (ZAPFCHANCERY . ZC) (ZAPFDINGBATS . ZD)) (* ;; "Font-reading code") (DEFINEQ (PSCFONT.READFONT + [LAMBDA (FONTFILENAME) (* ; "Edited 5-Oct-93 17:19 by rmk:") + (* ; "Edited 1-Sep-89 10:55 by jds") + + (* ;; "Read one of Matt Heffron's .PSC files, to get postscript font metrics. First check to see if incore cache as information indexed under the file's name.") + + (LET (FID W [S (OPENSTREAM FONTFILENAME 'INPUT NIL '((SEQUENTIAL T] + (PF (create PSCFONT))) + [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))) + (PUSH POSTSCRIPTFONTCACHE (CONS (L-CASE (FILENAMEFIELD FONTFILENAME 'NAME)) + (CREATE PSCFONT USING PF))) + PF]) (PSCFONT.SPELLFILE + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 5-Oct-93 22:15 by rmk:") + (* ; "Edited 5-Oct-92 15:23 by jds") + + (* ;; + "Find the font file for a postscript font. Does the display-name conversion as well, for DOS.") + + (CL:WHEN POSTSCRIPTFONTDIRECTORIES + (\FINDFONTFILE (OR (CDR (FASSOC FAMILY POSTSCRIPT.FONT.ALIST)) + FAMILY) + SIZE FACE 0 DEVICE 0 POSTSCRIPTFONTDIRECTORIES '(PSCFONT PF PSC)))]) (PSCFONT.COERCEFILE + [LAMBDA (FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION DEVICE) + (* ; "Edited 5-Oct-93 16:28 by rmk:") + + (* ;; +"This coerces the WEIGHT and SLOPE incrementally back to REGULAR in order to find a matching file.") + + (COND + ((AND (NEQ EXPANSION 'REGULAR) + (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT SLOPE 'REGULAR) + ROTATION DEVICE))) + ((AND (EQ SLOPE 'ITALIC) + (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR EXPANSION) + ROTATION DEVICE))) + ((AND (NEQ EXPANSION 'REGULAR) + (EQ SLOPE 'ITALIC) + (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR 'REGULAR) + ROTATION DEVICE))) + ((AND (NEQ WEIGHT 'MEDIUM) + (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE EXPANSION) + ROTATION DEVICE))) + ((AND (NEQ WEIGHT 'MEDIUM) + (NEQ EXPANSION 'REGULAR) + (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE 'REGULAR) + ROTATION DEVICE))) + ((AND (NEQ WEIGHT 'MEDIUM) + (EQ SLOPE 'ITALIC) + (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR EXPANSION) + ROTATION DEVICE))) + ((AND (NEQ WEIGHT 'MEDIUM) + (NEQ EXPANSION 'REGULAR) + (EQ SLOPE 'ITALIC) + (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR 'REGULAR) + ROTATION DEVICE]) (PSCFONTFROMCACHE.SPELLFILE + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 5-Oct-93 17:54 by rmk:") + (* ; "Edited 5-Oct-92 15:23 by jds") + + (* ;; "Tries to find postscript font information in the cache, indexed by the name-field of the fontfile. ") + + (LET [(CACHE (CDR (ASSOC (L-CASE (FILENAMEFIELD (\FONTFILENAME (OR (CDR (FASSOC FAMILY + POSTSCRIPT.FONT.ALIST + )) + FAMILY) + SIZE FACE 'PSCFONT 0) + 'NAME)) + POSTSCRIPTFONTCACHE] + (IF CACHE + THEN (CREATE PSCFONT USING CACHE]) (PSCFONTFROMCACHE.COERCEFILE + [LAMBDA (FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION DEVICE) + (* ; "Edited 5-Oct-93 17:00 by rmk:") + + (* ;; "This coerces the WEIGHT and SLOPE incrementally back to REGULAR in order to find a matching font in the cache.") + + (COND + ((AND (NEQ EXPANSION 'REGULAR) + (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST WEIGHT SLOPE 'REGULAR) + ROTATION DEVICE))) + ((AND (EQ SLOPE 'ITALIC) + (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR EXPANSION) + ROTATION DEVICE))) + ((AND (NEQ EXPANSION 'REGULAR) + (EQ SLOPE 'ITALIC) + (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR 'REGULAR) + ROTATION DEVICE))) + ((AND (NEQ WEIGHT 'MEDIUM) + (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE EXPANSION) + ROTATION DEVICE))) + ((AND (NEQ WEIGHT 'MEDIUM) + (NEQ EXPANSION 'REGULAR) + (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE 'REGULAR) + ROTATION DEVICE))) + ((AND (NEQ WEIGHT 'MEDIUM) + (EQ SLOPE 'ITALIC) + (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR EXPANSION) + ROTATION DEVICE))) + ((AND (NEQ WEIGHT 'MEDIUM) + (NEQ EXPANSION 'REGULAR) + (EQ SLOPE 'ITALIC) + (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR 'REGULAR) + ROTATION DEVICE]) (PSCFONT.WRITEFONT + [LAMBDA (FONTFILENAME PF) (* ; + "Edited 5-Aug-93 16:28 by sybalskY:MV:ENVOS") + + (* ;; "Given a PSCFONT data structure, write it out as a properly-named xxx.PSCFONT file, for later reading.") + + NIL + (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 BOLDNESS ITALICNESS) (* ; + "Edited 5-Aug-93 16:37 by sybalskY:MV:ENVOS") + + (* ;; + "Read an Adobe-version-3 AFM file, and extract the metrics from it for making a PSCFONT file.") + + (LET ((IFILE (OPENSTREAM FILE 'INPUT)) + (PSCFONT (create PSCFONT)) + (FCHAR 1000) + (LCHAR 0) + (W (ARRAY 256 'SMALLPOSP 0 0)) + TOKEN WEIGHT SLOPE HEIGHT CMCOUNT FBBOX) + (with PSCFONT PSCFONT (repeatuntil (STRING-EQUAL "FontName" (RSTRING IFILE)) + do (READCCODE IFILE)) + (repeatwhile (STRING-EQUAL "" (SETQ TOKEN (RSTRING IFILE))) + do (READCCODE IFILE)) + [COND + ((NOT (AND (BOUNDP 'WeightMenu) + (type? MENU WeightMenu))) + (SETQ WeightMenu (create MENU + ITEMS _ WeightMenuItems + MENUFONT _ (FONTCREATE 'HELVETICA 12] + [COND + ((NOT (AND (BOUNDP 'SlopeMenu) + (type? MENU SlopeMenu))) + (SETQ SlopeMenu (create MENU + ITEMS _ SlopeMenuItems + MENUFONT _ (FONTCREATE 'HELVETICA 12] + (OR (SETQ WEIGHT BOLDNESS) + (printout T T "Font WEIGHT for " PSCFONT ": " (SETQ WEIGHT (MENU WeightMenu)) + T)) + (OR (SETQ SLOPE ITALICNESS) + (printout T T "Font SLOPE for " PSCFONT ": " (SETQ SLOPE (MENU SlopeMenu)) + T)) + (SETQ FID (LIST TOKEN WEIGHT SLOPE 'REGULAR)) + [SETQ IL-FONTID (COND + ((AND (EQ SLOPE 'REGULAR) + (EQ WEIGHT 'MEDIUM)) + TOKEN) + (T (POSTSCRIPT.GETFONTID FID WEIGHT SLOPE 'REGULAR] + [repeatuntil (STRING-EQUAL "StartCharMetrics" TOKEN) + do (SETQ TOKEN (RSTRING IFILE)) + (COND + [(STRING-EQUAL "FontBBox" TOKEN) + (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, SCALED to the height of the font.") + + (SETQ DESCENT (IABS (CADR FBBOX))) + (SETQ ASCENT (CADDDR FBBOX)) + (SETQ HEIGHT (IPLUS ASCENT DESCENT)) + [SETQ DESCENT (FIXR (FTIMES DESCENT (/ 1000 HEIGHT] + (SETQ ASCENT (FIXR (FTIMES ASCENT (/ 1000 HEIGHT] + (T (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)) + (RATOMS 'WX IFILE) + (SETQ CWIDTH (READ IFILE)) + [COND + ((CL:PLUSP CCODE) (* ; + "This character appears in the standard encoding, so just use the charcode.") + (COND + ((ILESSP CCODE FCHAR) + (SETQ FCHAR CCODE))) + (COND + ((IGREATERP CCODE LCHAR) + (SETQ LCHAR CCODE))) + (SETA W CCODE CWIDTH)) + (T (* ; "A character not in the standard encoding; look it up to see if it's one we need (eth & thorn are brought into the CS-0 codespace for UToronto's work).") + (repeatuntil (EQ 'N (RATOM IFILE)) do + + (* ;; + "Skip to the N entry, which gives the Adobe-standard name.") +) + (SETQ CNAME (RATOM IFILE)) + (* ; "GET THE NAME") + (SETQ CCODE (LISTGET *POSTSCRIPT-EXTRA-CHARACTERS* CNAME)) + (COND + (CCODE (COND + ((ILESSP CCODE FCHAR) + (SETQ FCHAR CCODE))) + (COND + ((IGREATERP CCODE LCHAR) + (SETQ LCHAR CCODE))) + (SETA W CCODE CWIDTH] + (repeatuntil (EQ (CHARCODE EOL) + (READCCODE IFILE)) do))) + (SETQ FIRSTCHAR FCHAR) + (SETQ LASTCHAR LCHAR)) + (CLOSEF IFILE) + PSCFONT]) (CONVERT-AFM-FILES + [LAMBDA (FILE-LIST) (* ; + "Edited 5-Aug-93 16:47 by sybalskY:MV:ENVOS") + (for FL in FILE-LIST do (LET ((FNAME (pop FL)) + FONT FILENAME) + (for AFM-FILE in FL as WEIGHT + in '(MEDIUM MEDIUM BOLD BOLD) as SLOPE + in '(REGULAR ITALIC REGULAR ITALIC) + do (SETQ FONT (READ-AFM-FILE AFM-FILE WEIGHT + SLOPE)) + (SETQ FILENAME (\FONTFILENAME + FNAME 1 (LIST WEIGHT SLOPE + 'REGULAR) + 'PSCFONT 0)) + (PSCFONT.WRITEFONT FILENAME FONT]) (POSTSCRIPT.GETFONTID + [LAMBDA (FID WEIGHT SLOPE EXPANSION) (* ; + "Edited 20-Nov-92 15:04 by sybalsky:mv:envos") + (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 (FONTID FONTOBLIQUEFACTOR) of FONTID + with (CONSTANT (TAN 7.0] + (if (AND (NEQ (CADR FID) + WEIGHT) + (EQ WEIGHT 'BOLD)) + then (* ; "Fake bold by slight expansion.") + (replace (FONTID FONTXFACTOR) of FONTID with 1.1)) + [if (NEQ EXPANSION 'REGULAR) + then (replace (FONTID FONTXFACTOR) of FONTID + with (TIMES (fetch (FONTID FONTXFACTOR) of FONTID) + (if (EQ EXPANSION 'COMPRESSED) + then (CONSTANT (QUOTIENT 1.0 GOLDEN.RATIO)) + else GOLDEN.RATIO] + FONTID]) (POSTSCRIPT.FONTCREATE + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 29-Oct-93 16:39 by rmk:") + (* ; "Edited 3-Feb-93 17:22 by jds") + (LET (UNITFONT FULLNAME SCALEFONTP PSCFD ASCENT DESCENT FIXPWIDTHS PSCWIDTHSBLOCK 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 ridiculously 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 PSCFD (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) + + (* ;; "Check in-core cache for exact match first") + + (SETQ FACECHANGED NIL)) + ((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) + + (* ;; "Check file for exact match next") + + (SETQ PSCFD (PSCFONT.READFONT FULLNAME)) + (SETQ FACECHANGED NIL)) + ((SETQ PSCFD (PSCFONTFROMCACHE.COERCEFILE FAMILY SIZE WEIGHT SLOPE EXPANSION + ROTATION DEVICE)) + + (* ;; "Then check cache for coerced match") + + (SETQ FACECHANGED T)) + ((SETQ FULLNAME (PSCFONT.COERCEFILE FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION + DEVICE)) + + (* ;; "Check file for coerced match") + + (SETQ PSCFD (PSCFONT.READFONT FULLNAME)) + (SETQ FACECHANGED T))) + (COND + (PSCFD (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 PSCFD (COND + ((PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) + ((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION + DEVICE)) + (PSCFONT.READFONT FULLNAME] + (SETQ ASCENT (fetch (PSCFONT ASCENT) of PSCFD)) + (SETQ DESCENT (fetch (PSCFONT DESCENT) of PSCFD)) + (SETQ SCALEFONTP NIL] + (COND + (PSCFD + (* ;; "Set up the Charset descriptions and Widths vectors for character set 0:") + + (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)) + (SETQ WIDTHSBLOCK (fetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO 0 FD))) + (SETQ FIXPWIDTHS (fetch (PSCFONT WIDTHS) of PSCFD)) + [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] + (SETQ PSCWIDTHSBLOCK (\CREATECSINFOELEMENT)) + + (* ;; "PSCWIDTHSBLOCK preserves the scaled widths from the original postscript metrics, not the NS mapping of them, which goes into WIDTHSBLOCK.") + + (for CH from 0 to 255 do (\FSETWIDTH PSCWIDTHSBLOCK CH + (\FGETWIDTH WIDTHSBLOCK 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] + [LET ((SYMWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'SYMBOL FD ROTATION + DEVICE)) + (DINGWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'ZAPFDINGBATS FD + ROTATION DEVICE))) + + (* ;; + "Now run thru the mapping table, filling in the new font from whatever source is specified:") + + [MAPHASH *POSTSCRIPT-NS-HASH* + (FUNCTION (LAMBDA (MAPPING CODE) + (DESTRUCTURING-BIND + (KIND CODE2 BASECHAR) + MAPPING + + (* ;; + "Depending on what kind of item it is, process it:") + + (SELECTQ KIND + (NIL + (* ;; + "Translating an NS character to a PSC char in CS 0.") + + (\FSETCHARWIDTH FD CODE (\FGETWIDTH + PSCWIDTHSBLOCK + (\CHAR8CODE + CODE2)))) + (SYMBOL [AND SYMWIDTHS (\FSETCHARWIDTH + FD CODE (ELT SYMWIDTHS + (\CHAR8CODE + CODE2]) + (DINGBAT [AND DINGWIDTHS (\FSETCHARWIDTH + FD CODE (ELT DINGWIDTHS + (\CHAR8CODE + CODE2]) + (FUNCTION + (* ;; + "This is fake and only works for the fractions. Need a better case.") + + [\FSETCHARWIDTH + FD CODE + (IPLUS (\FGETWIDTH PSCWIDTHSBLOCK 164) + (FIXR (FTIMES 1.3 + (\FGETWIDTH + PSCWIDTHSBLOCK + (CHARCODE 1]) + (ACCENT (* ; + "CODE2 is the rendering character but width comes from width of basechar") + (\FSETCHARWIDTH FD CODE (\FGETWIDTH + PSCWIDTHSBLOCK + BASECHAR))) + (ACCENTPAIR + + (* ;; "CODE2 and BASECHAR are overprinted, width is taken from CODE2 (the real character), basechar is the accent") + + (\FSETCHARWIDTH FD CODE (\FGETWIDTH + PSCWIDTHSBLOCK + CODE2))) + (PROGN + + (* ;; "Skip APPLY*'s on this pass, waiting until normal characters get set up, so that widths of other NS characters are available. Also skip anything else") + + NIL] + + (* ;; "Now do APPLY*'s. MAPPING is of the form ('APPLY* DATA PRINTFN WIDTHFN). WIDTHFN gets applied to FD and DATA (coerced by INITFN)") + + (MAPHASH *POSTSCRIPT-NS-HASH* (FUNCTION (LAMBDA (MAPPING CODE) + (CL:WHEN (EQ (CAR MAPPING) + 'APPLY*) + (\FSETCHARWIDTH + FD CODE (APPLY* (CADDDR + MAPPING + ) + FD + (CADR MAPPING)) + ))] + FD) + (T NIL]) (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS + [LAMBDA (TYPE FD ROTATION DEVICE) (* ; "Edited 5-Oct-93 18:21 by rmk:") + + (* ;; "Returns the scaled widths for a unit font of type TYPE (SYMBOL or ZAPFDINGBATS) compatible with FD. A separate function so that the unit widths can be easily cached.") + + (LET [TYPEFONT WIDTHS NEWWIDTHS (SIZE (FETCH FONTSIZE OF FD)) + (FONTFILE (OR (PSCFONT.SPELLFILE TYPE 1 (FETCH (FONTDESCRIPTOR FONTFACE) + OF FD) + ROTATION DEVICE) + (PSCFONT.SPELLFILE 'SYMBOL 1 '(MEDIUM REGULAR REGULAR) + ROTATION DEVICE] + [SETQ TYPEFONT (COND + ((PSCFONTFROMCACHE.SPELLFILE TYPE 1 (FETCH (FONTDESCRIPTOR + FONTFACE) + OF FD) + ROTATION DEVICE)) + ((SETQ FONTFILE (PSCFONT.SPELLFILE TYPE 1 (FETCH (FONTDESCRIPTOR + FONTFACE) + OF FD) + ROTATION DEVICE)) + (PSCFONT.READFONT FONTFILE)) + ((PSCFONTFROMCACHE.SPELLFILE 'SYMBOL 1 '(MEDIUM REGULAR REGULAR) + ROTATION DEVICE)) + ((SETQ FONTFILE (PSCFONT.SPELLFILE 'SYMBOL 1 '(MEDIUM REGULAR REGULAR) + ROTATION DEVICE)) + (PSCFONT.READFONT FONTFILE] + (CL:WHEN (AND TYPEFONT (SETQ WIDTHS (FETCH (PSCFONT WIDTHS) OF TYPEFONT))) + (SETQ NEWWIDTHS (ARRAY 256 'SMALLPOSP 0 0)) + + (* ;; "Have to copy because of scaling") + + [FOR CH FROM 0 TO 255 DO (SETA NEWWIDTHS CH + (FIXR (TIMES SIZE (ELT WIDTHS CH) + 0.1] + NEWWIDTHS)]) (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]) ) (* ;; "Until macro in FONT is exported") (DECLARE%: EVAL@COMPILE (PUTPROPS \FSETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE WIDTH) (\FSETWIDTH (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE) FONTDESC)) (\CHAR8CODE CHARCODE) WIDTH))) ) (DEFINEQ (OPENPOSTSCRIPTSTREAM [LAMBDA (FILE OPTIONS) (* ; "Edited 17-Jun-97 21:15 by rmk:") (* ;  "Edited 31-May-93 12:42 by sybalsky:mv:envos") (* ; "Edited 23-Dec-92 01:17 by jds") (LET [[FP (OPENSTREAM FILE 'OUTPUT NIL `((TYPE ,*POSTSCRIPT-FILE-TYPE*) (SEQUENTIAL T] (IMAGEDATA (create \POSTSCRIPTDATA)) PAPER IMAGESIZEFACTOR CLIP REG (BBOX (LISTGET OPTIONS 'BOUNDINGBOX] (replace (STREAM OUTCHARFN) of FP with '\FILEOUTCHARFN) (replace (STREAM IMAGEDATA) of FP with IMAGEDATA) (replace (STREAM IMAGEOPS) of FP with \POSTSCRIPTIMAGEOPS) (* ;; "Bounding box is for encapsulated postscript. The bounding box is in Medley's postscript-coordinate system, so we have to scale it back to default postscript since it will be interpreted outside of the operators specified below. CEIL and FLOOR to make sure that we don't leave anything out. We may also want to change the header to have the EPSF qualifier") (printout FP "%%!PS-Adobe-2.0" T %# (CL:WHEN BBOX (PRINTOUT FP "%%%%BoundingBox: " (CL:FLOOR (CAR BBOX) \PS.SCALE0) " " (CL:FLOOR (CADR BBOX) \PS.SCALE0) " " (CL:CEILING (CADDR BBOX) \PS.SCALE0) " " (CL:CEILING (CADDDR BBOX) \PS.SCALE0) T)) "%%%%Title: " (MKSTRING (OR (LISTGET OPTIONS 'DOCUMENT.NAME) FILE)) T "%%%%Creator: PostScript Driver Copyright (C) 1988-1992 Venue and others" T "%%%%CreationDate: " (DATE) T %# (COND ((EQ 'LPT (FILENAMEFIELD FP 'HOST)) (* ;; "Put current user's name on break page only if going to LPT for immediate printing. Presumably the print-spooler itself should know what the user's system login-name is, but that may not be the case for all printers in all environments.") (PRINTOUT NIL "%%%%For: " (MKSTRING USERNAME) T))) "%%%%EndComments" T) (for X in \POSTSCRIPT.JOB.SETUP do (POSTSCRIPT.OUTSTR FP X) (\FILEOUTCHARFN FP (CHARCODE EOL))) (SETQ PAPER (OR (CDR (CL:ASSOC (SETQ PAPER (OR (LISTGET OPTIONS 'PAGETYPE) (LISTGET OPTIONS 'PAPERTYPE) POSTSCRIPT.PAGETYPE)) POSTSCRIPT.PAGEREGIONS :TEST #'STRING-EQUAL)) (ERROR "Unknown PostScript page type" PAPER))) (* ;; "Set the paper size:") (PRINTOUT FP (L-CASE (OR (LISTGET OPTIONS 'PAGETYPE) (LISTGET OPTIONS 'PAPERTYPE) POSTSCRIPT.PAGETYPE)) T) (COND ((NOT (AND [SETQ IMAGESIZEFACTOR (NUMBERP (LISTGET OPTIONS 'IMAGESIZEFACTOR] (CL:PLUSP IMAGESIZEFACTOR))) (SETQ IMAGESIZEFACTOR 1))) [COND ((AND (NUMBERP POSTSCRIPT.IMAGESIZEFACTOR) (CL:PLUSP POSTSCRIPT.IMAGESIZEFACTOR)) (SETQ IMAGESIZEFACTOR (TIMES IMAGESIZEFACTOR POSTSCRIPT.IMAGESIZEFACTOR] (printout FP "/imagesizefactor " IMAGESIZEFACTOR " def" T) (printout FP "%%%%EndSetup" T) (replace (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA with \PS.SCALE0) (replace (STREAM OUTCHARFN) of FP with '\POSTSCRIPT.OUTCHARFN) (replace (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of IMAGEDATA with (\PS.SCALEREGION (/ (TIMES 72 \PS.SCALE0) IMAGESIZEFACTOR) (CAR PAPER))) (* ;;  "Initial clipping region can be specified separately from the page size, default is to page size.") [replace (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA with (SETQ CLIP (\PS.SCALEREGION (/ (TIMES 72 \PS.SCALE0) IMAGESIZEFACTOR) (OR (CADR PAPER) (CAR PAPER] (* ;; "If a REGION parameter was supplied, it establishes the initial margins.") (SETQ REG (OR (AND (SETQ REG (LISTGET OPTIONS 'REGION)) (INTERSECTREGIONS REG CLIP)) (CREATEREGION 3600 3600 54000 72000))) (replace (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA with (fetch (REGION LEFT) of REG)) (replace (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA with (fetch (REGION BOTTOM) of REG)) (replace (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA with (PLUS (fetch (REGION BOTTOM) of REG) (fetch (REGION HEIGHT) of REG) -1)) (replace (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA with (PLUS (fetch (REGION LEFT) of REG) (fetch (REGION WIDTH) of REG) -1)) (\DSPFONT.PSC FP (FONTCREATE (OR [CAR (MKLIST (LISTGET OPTIONS 'FONTS] DEFAULTFONT) NIL NIL NIL FP)) (\SWITCHFONTS.PSC FP IMAGEDATA) [COND ((replace (\POSTSCRIPTDATA POSTSCRIPTHEADING) of IMAGEDATA with (LISTGET OPTIONS 'HEADING)) (replace (\POSTSCRIPTDATA POSTSCRIPTHEADINGFONT) of IMAGEDATA with (COND ((LISTGET OPTIONS 'HEADINGFONT) (FONTCREATE (LISTGET OPTIONS 'HEADINGFONT) NIL NIL NIL FP)) (T (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA] (* ;; "Decide if it's landscape: if (LANDSCAPE T) appears in OPTIONS, it is. IF ROTATION isn't DEFAULT, it is.") (COND ([COND ((CL:GETF OPTIONS 'LANDSCAPE NIL)) ((EQL (CL:GETF OPTIONS 'ROTATION 'DEFAULT) 'DEFAULT) (COND ((EQL POSTSCRIPT.PREFER.LANDSCAPE 'ASK) (MENU \POSTSCRIPT.ORIENTATION.MENU)) (T POSTSCRIPT.PREFER.LANDSCAPE))) (T (CL:GETF OPTIONS 'ROTATION] (POSTSCRIPT.SET-FAKE-LANDSCAPE FP 90))) (POSTSCRIPT.STARTPAGE FP) FP]) (CLOSEPOSTSCRIPTSTREAM + [LAMBDA (STREAM) (* ; "Edited 8-Mar-93 10:31 by jds") + (POSTSCRIPT.ENDPAGE STREAM) + (POSTSCRIPT.PUTCOMMAND STREAM :EOL "%%%%Trailer" :EOL) + (* BOUT STREAM (CHARCODE ^D)) + ]) ) (RPAQ? *POSTSCRIPT-FILE-TYPE* 'BINARY) (DEFINEQ (POSTSCRIPT.HARDCOPYW + [LAMBDA (FILE BITMAP SCALEFACTOR REGION Landscape? TITLE) + (* ; + "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") + (ALLOW.BUTTON.EVENTS) + (LET* ((STREAM (OPENPOSTSCRIPTSTREAM FILE (LIST 'DOCUMENT.NAME TITLE 'ROTATION Landscape? + 'IMAGESIZEFACTOR SCALEFACTOR))) + (IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + (SCLIP (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA)) + SCALE) + [COND + [REGION (SETQ REGION (COPY REGION)) (* ; "In case we need to change it.") + [COND + ((< (fetch BITMAPWIDTH of BITMAP) + (+ (fetch (REGION LEFT) of REGION) + (fetch (REGION WIDTH) of REGION))) + (replace (REGION WIDTH) of REGION with (- (fetch BITMAPWIDTH + of BITMAP) + (fetch (REGION + LEFT) + of REGION] + (COND + ((< (fetch BITMAPHEIGHT of BITMAP) + (+ (fetch (REGION BOTTOM) of REGION) + (fetch (REGION HEIGHT) of REGION))) + (replace (REGION HEIGHT) of REGION + with (- (fetch BITMAPHEIGHT of BITMAP) + (fetch (REGION BOTTOM) of REGION] + (T (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 (\POSTSCRIPTDATA POSTSCRIPTSCALE) + of IMAGEDATA))) + (BITBLT BITMAP (fetch (REGION LEFT) of REGION) + (fetch (REGION BOTTOM) of REGION) + STREAM + (PLUS (fetch (REGION LEFT) of SCLIP) + (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of SCLIP) + (TIMES SCALE (fetch (REGION WIDTH) of REGION))) + 2)) + (PLUS (fetch (REGION BOTTOM) of SCLIP) + (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of SCLIP) + (TIMES SCALE (fetch (REGION HEIGHT) of REGION))) + 2)) + (fetch (REGION WIDTH) of REGION) + (fetch (REGION HEIGHT) of REGION) + 'INPUT + 'REPLACE) + (CLOSEF STREAM) + (FULLNAME STREAM]) (POSTSCRIPT.TEDIT + [LAMBDA (FILE PFILE) (* ; "Edited 18-Sep-91 18:16 by jds") + + (* ;; "Make a PS file from a TEdit document. If FILE is a string, make it into a symbol for the file-name. If it's a STREAM, use that stream.") + + [COND + ((STRINGP FILE) + (SETQ FILE (MKATOM FILE] + (SETQ FILE (OPENTEXTSTREAM 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 5-Mar-93 21:40 by rmk:") + (* ; "Edited 14-Jan-93 10:56 by jds") + (OR (CL:MEMBER (UNPACKFILENAME.STRING FILE 'EXTENSION) + '("PS" "PSC" "PSF") + :TEST + (FUNCTION STRING-EQUAL)) + (PROGN (SETFILEPTR FILE 0) + (PROG1 (AND (EQ (BIN FILE) + (CHARCODE %%)) + (EQ (BIN FILE) + (CHARCODE !))) + (SETFILEPTR FILE 0]) (MAKEEPSFILE + [LAMBDA (IMAGEOBJ FILENAME) (* ; "Edited 7-Apr-94 14:48 by rmk:") + + (* ;; "Puts IMAGEOBJ on a 1-page encapsulated postscript file. The lower-left corner of the image box will be at 0,0 on the page.") + + (LET* [(STREAM (OPENIMAGESTREAM `{NODIRCORE}SCRATCH 'POSTSCRIPT)) + (IMAGEBOX (APPLY* (IMAGEOBJPROP IMAGEOBJ 'IMAGEBOXFN) + IMAGEOBJ STREAM)) + (BOUNDINGBOX (LIST 0 0 (FETCH XSIZE OF IMAGEBOX) + (FETCH YSIZE OF IMAGEBOX] + [SETQ STREAM (OPENIMAGESTREAM FILENAME 'POSTSCRIPT + `(BOUNDINGBOX (0 0 ,(FETCH XSIZE OF IMAGEBOX) + ,(FETCH YSIZE OF IMAGEBOX] + (MOVETO (FETCH XKERN OF IMAGEBOX) + (FETCH YDESC OF IMAGEBOX) + STREAM) + (APPLY* (IMAGEOBJPROP IMAGEOBJ 'DISPLAYFN) + IMAGEOBJ STREAM) + (CLOSEF STREAM]) ) (DEFINEQ (POSTSCRIPT.BITMAPSCALE [LAMBDA (WIDTH HEIGHT) (* ; "Edited 29-Apr-98 08:46 by rmk:") (* ;  "Edited 20-Nov-92 14:52 by sybalsky:mv:envos") (LET* ([PAGEREGION (\PS.SCALEREGION (/ 72 POSTSCRIPT.BITMAP.SCALE) (CADR (FASSOC POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS] (LONGEDGE (MAX (fetch (REGION WIDTH) of PAGEREGION) (fetch (REGION HEIGHT) of PAGEREGION))) (SHORTEDGE (MIN (fetch (REGION WIDTH) of PAGEREGION) (fetch (REGION 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 20-Nov-92 15:11 by sybalsky:mv:envos") + (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) + (COND + ((fetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA) + (POSTSCRIPT.OUTSTR STREAM ") ") + (replace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA with NIL) + T) + (T NIL]) (POSTSCRIPT.ENDPAGE + [LAMBDA (STREAM) (* ; + "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") + (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) + (POSTSCRIPT.SHOWACCUM STREAM) + (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with NIL) + (COND + ((NOT (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGEBLANK) of IMAGEDATA) + (POSTSCRIPT.PUTCOMMAND STREAM "grestore savepage restore "))) + (POSTSCRIPT.PUTCOMMAND STREAM "showpage" :EOL))) + + (* ;; +"Force re-encoding of fonts, because the restore wipes out any you encoded while writing this page.") + + (replace (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) of IMAGEDATA with NIL]) (POSTSCRIPT.OUTSTR + [LAMBDA (STREAM X) (* ; "Edited 14-Jul-89 14:05 by Matt Heffron") + (DECLARE (LOCALVARS . T)) + (COND + ((FIXP X) (* ; "Common case, speed helps") + (\PS.BOUTFIXP STREAM X)) + [(STRINGP X) (* ; "Other common case") + (COND + [(ffetch (STRINGP FATSTRINGP) of X) + (for c infatstring X do (BOUT STREAM (\CHAR8CODE c] + (T (\BOUTS STREAM (ffetch (STRINGP BASE) of X) + (ffetch (STRINGP OFFST) of X) + (ffetch (STRINGP LENGTH) of X] + [(LITATOM X) + (for c inatom X do (BOUT STREAM (\CHAR8CODE c] + ((ZEROP X) + (BOUT STREAM (CHARCODE 0))) + (T [COND + ((TYPEP X 'RATIO) + (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))) + (COND + [DELIMFLG (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 (COND + ((IGEQ POS 254) + (\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] + (T + (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)) + (COND + [(IGEQ REPC 3) + (SETQ B (IPLUS B REPC)) + (SETQ BYTEOFFSET (IPLUS BYTEOFFSET REPC)) + (SETQ PRVO (IPLUS PRVO REPC)) + (while (CL:PLUSP (SETQ REPC (IDIFFERENCE REPC 1))) + do (COND + ((IGEQ POS 251) + (\FILEOUTCHARFN STREAM (CHARCODE EOL)) + (SETQ POS 0))) + (BOUT STREAM (CHARCODE B)) + (BOUT STREAM (CHARCODE 3)) + [COND + ((IGEQ REPC 256) + (BOUT STREAM (CHARCODE F)) + (BOUT STREAM (CHARCODE F))) + (T [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] + (T (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)) + (COND + [(IGEQ REPC 3) + (SETQ B (IPLUS B REPC)) + (SETQ BYTEOFFSET (IPLUS BYTEOFFSET REPC)) + (SETQ PRVO (IPLUS PRVO REPC)) + (while (CL:PLUSP (SETQ REPC (IDIFFERENCE REPC 1))) + do (COND + ((IGEQ POS 249) + (\FILEOUTCHARFN STREAM (CHARCODE EOL)) + (SETQ POS 0))) + (BOUT STREAM (CHARCODE B)) + (BOUT STREAM (CHARCODE 2)) + [COND + ((IGEQ REPC 256) + (BOUT STREAM (CHARCODE F)) + (BOUT STREAM (CHARCODE F))) + (T [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] + (T (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET)) + (COND + ((IGEQ POS 251) + (\FILEOUTCHARFN STREAM (CHARCODE EOL)) + (SETQ POS 0))) + [COND + ((FMEMB BYTE '(178 179 180)) + + (* ;; "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 20-Nov-92 15:11 by sybalsky:mv:envos") + (LET* ((STREAM (ARG S.STRS 1)) + (IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + S#S) + (freplace (\POSTSCRIPTDATA POSTSCRIPTPAGEBLANK) of IMAGEDATA with NIL) + (COND + ((ffetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA) + (POSTSCRIPT.SHOWACCUM STREAM))) + (COND + ((ffetch (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA) + (\SETXFORM.PSC STREAM IMAGEDATA))) + (for STR# from 2 to S.STRS do (COND + ((EQ (SETQ S#S (ARG S.STRS STR#)) + :EOL) + (\FILEOUTCHARFN STREAM (CHARCODE EOL))) + (T (POSTSCRIPT.OUTSTR STREAM S#S]) (POSTSCRIPT.SET-FAKE-LANDSCAPE + [LAMBDA (STREAM ROTATION) (* ; + "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") + + (* ;; "Set up for (or disable) fake landscaping") + + (* ;; + "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 (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA) + 90) + (T 0))) + LAND C0 P0 C P ML MB MR MT) + (COND + ((AND ROTATION (NEQ (SETQ LAND (NOT (ZEROP ROTATION))) + (fetch (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA))) + (POSTSCRIPT.SHOWACCUM STREAM) + (\DSPTRANSLATE.PSC STREAM 0 0) + (SETQ C0 (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA)) + (SETQ P0 (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of IMAGEDATA)) + (SETQ C (create REGION + WIDTH _ (fetch (REGION HEIGHT) of C0) + HEIGHT _ (fetch (REGION WIDTH) of C0))) + (SETQ P (create REGION + LEFT _ 0 + BOTTOM _ 0 + WIDTH _ (fetch (REGION HEIGHT) of P0) + HEIGHT _ (fetch (REGION WIDTH) of P0))) + [COND + (LAND (replace (REGION LEFT) of C with (fetch (REGION BOTTOM) + of C0)) + [replace (REGION BOTTOM) of C with + (- (fetch (REGION WIDTH) + of P0) + (+ (fetch (REGION LEFT) + of C0) + (fetch (REGION WIDTH) + of C0] + (SETQ ML (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA) + ) + (SETQ MB (- (fetch (REGION WIDTH) of P0) + (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of + IMAGEDATA + ) + 1)) + (SETQ MR (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA)) + (SETQ MT (- (fetch (REGION WIDTH) of P0) + (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA + ) + 1))) + (T [replace (REGION LEFT) of C with (- (fetch (REGION HEIGHT) + of P0) + (+ (fetch (REGION BOTTOM) + of C0) + (fetch (REGION HEIGHT) + of C0] + (replace (REGION BOTTOM) of C with (fetch (REGION LEFT) + of C0)) + (SETQ ML (- (fetch (REGION HEIGHT) of P0) + (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA) + 1)) + (SETQ MB (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA)) + (SETQ MR (- (fetch (REGION HEIGHT) of P0) + (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA) + 1)) + (SETQ MT (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA] + (replace (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA with + C) + (replace (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of IMAGEDATA with P) + (replace (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA with ML) + (replace (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA with MB) + (replace (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA with MR) + (replace (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA with MT) + (replace (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA with LAND) + (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with T) + (\DSPRESET.PSC STREAM))) + OLAND]) (POSTSCRIPT.SHOWACCUM + [LAMBDA (STREAM) (* ; "Edited 23-May-93 11:52 by rmk:") + + (* ;; + "Send commands to SHOW the accumulated characters. Uses S (= SHOW) for regular characters.") + + (* ;; "Uses WIDTHSHOW if the space-factor isn't 1") + + (* ;; "Uses ASHOW if a KERN value is on STREAM's properties") + + (* ;; "USES AWIDTHSHOW if both space-factor != 1 and there's a KERN value.") + + (LET ((IMAGEDATA (ffetch (STREAM IMAGEDATA) of STREAM)) + KERN) + (COND + ((fetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA) + (SETQ KERN (STREAMPROP STREAM 'KERN)) + [COND + [(EQP (ffetch (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) of IMAGEDATA) + 1) + (COND + (KERN (POSTSCRIPT.OUTSTR STREAM (CONCAT ") " KERN " 0 3 -1 roll ashow"))) + (T (POSTSCRIPT.OUTSTR STREAM ") S"] + (T (POSTSCRIPT.OUTSTR STREAM ") ") + (POSTSCRIPT.OUTSTR STREAM (DIFFERENCE (ffetch (\POSTSCRIPTDATA + POSTSCRIPTSPACEWIDTH) + of IMAGEDATA) + (ffetch (\POSTSCRIPTDATA + POSTSCRIPTNATURALSPACEWIDTH + ) of IMAGEDATA))) + (COND + (KERN (POSTSCRIPT.OUTSTR STREAM (CONCAT " 0 " (CHARCODE SPACE) + " " KERN " 0 " + " 6 -1 roll awidthshow"))) + (T (POSTSCRIPT.OUTSTR STREAM (CONSTANT (CONCAT " 0 " (CHARCODE SPACE) + " 4 -1 roll widthshow"] + (\FILEOUTCHARFN STREAM (CHARCODE EOL)) + (freplace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA with NIL]) (POSTSCRIPT.STARTPAGE +(LAMBDA (STREAM) (* ; "Edited 28-Dec-94 17:41 by jds") (* ;; "Start up a new page in a Postscript document.") (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) NEW-PAGE) (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with NIL) (* ; "shouldnt need this") (SETQ NEW-PAGE (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGENUM) of IMAGEDATA))) (* ; "Page number goes up by 1") (* ;; "Print the %"Document structuring%" info for the page, then the initial page setup") (POSTSCRIPT.PUTCOMMAND STREAM :EOL "%%%%Page: " NEW-PAGE " " NEW-PAGE :EOL "%%%%BeginPageSetup" :EOL "/savepage save def" :EOL (FQUOTIENT 1 \PS.SCALE0) " imagesizefactor mul dup scale" :EOL "%%%%EndPageSetup" :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 (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of IMAGEDATA with T) (replace (\POSTSCRIPTDATA POSTSCRIPTPAGEBLANK) of IMAGEDATA with T) (* ; "nothing printed yet...") (COND ((fetch (\POSTSCRIPTDATA POSTSCRIPTHEADING) of IMAGEDATA) (* ;; "Here we handle headings.") (LET ((FONT (\DSPFONT.PSC STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTHEADINGFONT) of IMAGEDATA)))) (\DSPRESET.PSC STREAM) (PRIN3 (fetch (\POSTSCRIPTDATA POSTSCRIPTHEADING) of IMAGEDATA) STREAM) (RELMOVETO (CONSTANT (TIMES 72 \PS.SCALE0)) 0 STREAM) (* ; "Skip an inch before page number") (PRIN3 "Page " STREAM) (PRIN3 NEW-PAGE STREAM) (\TERPRI.PSC STREAM) (* ; "Skip 2 lines") (\TERPRI.PSC STREAM) (\DSPFONT.PSC STREAM FONT))) (T (\DSPRESET.PSC STREAM))))) +) (\POSTSCRIPTTAB + [LAMBDA (POSTSCRIPTDATA) (* ; + "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") + (LET [(TABSPACE (TIMES 8 (ffetch FONTAVGCHARWIDTH of (ffetch (\POSTSCRIPTDATA + POSTSCRIPTFONT) + of POSTSCRIPTDATA] + (IDIFFERENCE TABSPACE (IREMAINDER (IDIFFERENCE (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) + of POSTSCRIPTDATA) + (ffetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) + of POSTSCRIPTDATA)) + TABSPACE]) (\PS.BOUTFIXP + [LAMBDA (STREAM N) (* ; + "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") + + (* ;; "BOUT the decimal representation of N to STREAM using temp storage from the imagedata. Done this way for speed.") + + (DECLARE (LOCALVARS . T)) + [COND + ((MINUSP N) + (BOUT STREAM (CHARCODE -)) + (SETQ N (IMINUS N] + (COND + [(LESSP N 10) + (BOUT STREAM (IPLUS N (CHARCODE 0] + [(LESSP N 1000000000) + (LET ([BASE (fetch (ARRAYP BASE) of (fetch (\POSTSCRIPTDATA 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] + (T (* ; "Just in case we get a bignum") + (for c in (CHCON N) do (BOUT STREAM (\CHAR8CODE c]) (\PS.SCALEHACK + [LAMBDA (STREAM SCALEFACTOR) (* ; + "Edited 20-Nov-92 15:11 by sybalsky:mv:envos") + (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + (OLDSCALE (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of IMAGEDATA)) + FACTOR) + (COND + ((AND (NUMBERP SCALEFACTOR) + (NOT (EQP OLDSCALE SCALEFACTOR))) + (POSTSCRIPT.SHOWACCUM STREAM) + (SETQ FACTOR (/ OLDSCALE SCALEFACTOR)) + [for REG in (LIST (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) + of IMAGEDATA) + (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) + of IMAGEDATA)) + do (change (fetch (REGION LEFT) of REG) + (FIXR (CL:* DATUM FACTOR))) + (change (fetch (REGION BOTTOM) of REG) + (FIXR (CL:* DATUM FACTOR))) + (change (fetch (REGION WIDTH) of REG) + (FIXR (CL:* DATUM FACTOR))) + (change (fetch (REGION HEIGHT) of REG) + (FIXR (CL:* DATUM FACTOR] + (change (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) + (FIXR (CL:* DATUM FACTOR))) + (change (fetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA) + (FIXR (CL:* DATUM FACTOR))) + (change (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA) + (FIXR (CL:* DATUM FACTOR))) + (change (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA) + (FIXR (CL:* DATUM FACTOR))) + (change (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA) + (FIXR (CL:* DATUM FACTOR))) + (change (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA) + (FIXR (CL:* DATUM FACTOR))) + (change (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA) + (FIXR (CL:* DATUM FACTOR))) + (change (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA) + (FIXR (CL:* DATUM FACTOR))) + (replace (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of IMAGEDATA with + SCALEFACTOR) + (replace (\POSTSCRIPTDATA 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 8-May-2018 19:33 by rmk:") (* ; "Edited 8-May-2018 15:05 by rmk:") (* ;  "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") (* ;; "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 (STREAM IMAGEDATA) of STREAM)) (SCALE1 (TIMES SCALE (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA))) (SCALE2 (TIMES SCALE1 (OR (NUMBERP POSTSCRIPT.BITMAP.SCALE) 1))) DESTREGION (BITMAPWIDTH (fetch BITMAPWIDTH of SOURCEBITMAP)) (BITMAPHEIGHT (fetch BITMAPHEIGHT of SOURCEBITMAP)) TEMPBM) [COND ((NULL DESTINATIONLEFT) (SETQ DESTINATIONLEFT (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA] [COND ((NULL DESTINATIONBOTTOM) (SETQ DESTINATIONBOTTOM (fetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA] (COND ((OR (NULL WIDTH) (NULL HEIGHT)) (SETQ WIDTH BITMAPWIDTH) (SETQ HEIGHT BITMAPHEIGHT))) (COND ((GREATERP WIDTH BITMAPWIDTH) (SETQ WIDTH BITMAPWIDTH))) (COND ((GREATERP HEIGHT BITMAPHEIGHT) (SETQ HEIGHT BITMAPHEIGHT))) [SETQ DESTREGION (INTERSECTREGIONS (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA) (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM (TIMES SCALE1 WIDTH ) (TIMES SCALE1 HEIGHT] (COND ((AND DESTREGION (OR (NULL CLIPPINGREGION) (REGIONSINTERSECTP DESTREGION CLIPPINGREGION))) [COND ((AND (EQ SOURCELEFT 0) (EQ SOURCEBOTTOM 0) (EQP WIDTH BITMAPWIDTH) (EQP HEIGHT BITMAPHEIGHT)) (* ;  "Avoid copy if sending entire bitmap") (SETQ TEMPBM SOURCEBITMAP)) (T (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 (COND ((EQ OPERATION 'PAINT) " true") (T (* ;;  "RMK: For REPLACE, was %"false%", but then white was black.") " true")) " thebitimage" :EOL) (POSTSCRIPT.PUTBITMAPBYTES STREAM TEMPBM NIL) (POSTSCRIPT.PUTCOMMAND STREAM :EOL "bitbltsave restore" :EOL) (\MOVETO.PSC STREAM DESTINATIONLEFT DESTINATIONBOTTOM) T) (T NIL]) (\SETPOS.PSC + [LAMBDA (STREAM IMAGEDATA) (* ; + "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") + (POSTSCRIPT.PUTCOMMAND STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) + " " + (ffetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA) + " M ") + (freplace (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of IMAGEDATA with NIL]) (\SETXFORM.PSC +(LAMBDA (STREAM IMAGEDATA NORESTORE) (* ; "Edited 28-Dec-94 17:59 by jds") (* ;; "Write transforms into the PS file to make what it prints match what we think it should print.") (LET ((CLIP (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA))) (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with NIL) (COND ((NOT NORESTORE) (POSTSCRIPT.OUTSTR STREAM "grestore "))) (POSTSCRIPT.PUTCOMMAND STREAM "gsave" :EOL) (* ;; "Scaling") (COND ((NOT (EQP (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of IMAGEDATA) 1)) (POSTSCRIPT.PUTCOMMAND STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of IMAGEDATA) " dup scale" :EOL))) (* ;; "Landscape mode (as in POSTSCRIPT.PREFER.LANDSCAPE, not as in TEdit doing landscaping)") (COND ((fetch (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA) (POSTSCRIPT.OUTSTR STREAM " 90 rotate 0 -61200 imagesizefactor div translate "))) (* ;; "Any rotation that is in effect.") (POSTSCRIPT.PUTCOMMAND STREAM " " (fetch (\POSTSCRIPTDATA POSTSCRIPTROTATION) of IMAGEDATA) " rotate " :EOL) (* ;; "Any translations that are in effect.") (COND ((NOT (AND (ZEROP (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA)) (ZEROP (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA)))) (POSTSCRIPT.PUTCOMMAND STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA) " " (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA) " translate" :EOL))) (* ;; "Clipping region:") (POSTSCRIPT.PUTCOMMAND STREAM " " (fetch (REGION HEIGHT) of CLIP) " " (fetch (REGION WIDTH) of CLIP) " " (fetch (REGION LEFT) of CLIP) " " (fetch (REGION BOTTOM) of CLIP) " CLP" :EOL) (* ;; "And force recaching of location and font.") (replace (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of IMAGEDATA with T) (replace (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of IMAGEDATA with T))) +) (\STRINGWIDTH.PSC + [LAMBDA (STREAM STR RDTBL) (* ; + "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") + (LET ((IMAGEDATA (ffetch (STREAM IMAGEDATA) of STREAM))) + (\STRINGWIDTH.GENERIC STR (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA) + RDTBL + (ffetch (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of IMAGEDATA]) (\SWITCHFONTS.PSC + [LAMBDA (STREAM POSTSCRIPTDATA) (* ; "Edited 23-May-93 12:04 by rmk:") + (* ; "Edited 11-May-93 02:11 by jds") + + (* ;; "Actually emit the PS commands to change the font. If the new font hasn't been used (on this page) before, re-encode it to support accented characters.") + + (LET* [(FONT (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of POSTSCRIPTDATA)) + (FONTID (fetch (PSCFONT IL-FONTID) of (LISTGET (fetch (FONTDESCRIPTOR + OTHERDEVICEFONTPROPS + ) of FONT) + 'PSCFONT] + [COND + [(LISTP FONTID) + [COND + ((MEMB (fetch (FONTID FONTIDNAME) of FONTID) + (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) of POSTSCRIPTDATA))) + ((MEMB (fetch (FONTID FONTIDNAME) of FONTID) + *POSTSCRIPT-UNACCENTED-FONTS*)) + (T + (* ;; + "This font hasn't been used on this page yet. Re-encode it to include accented characters.") + + (POSTSCRIPT.PUTCOMMAND STREAM "/" (fetch (FONTID FONTIDNAME) of + FONTID) + " /" + (CONCAT (fetch (FONTID FONTIDNAME) of FONTID) + "-Acnt") + " encodefont" :EOL) + (CL:PUSH (fetch (FONTID FONTIDNAME) of FONTID) + (FFETCH (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) OF POSTSCRIPTDATA] + (COND + ((MEMB (fetch (FONTID FONTIDNAME) of FONTID) + *POSTSCRIPT-UNACCENTED-FONTS*) + (FREPLACE (\POSTSCRIPTDATA POSTSCRIPTACCENTED) OF POSTSCRIPTDATA + WITH NIL) + (POSTSCRIPT.PUTCOMMAND STREAM "/" (fetch (FONTID FONTIDNAME) of FONTID) + " findfont [" + (TIMES (fetch (FONTID FONTXFACTOR) of FONTID) + (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) + 100) + " 0 " + (TIMES (fetch (FONTID FONTOBLIQUEFACTOR) of FONTID) + (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) + 100) + " " + (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) + 100) + " 0 0] makefont setfont" :EOL)) + (T (FREPLACE (\POSTSCRIPTDATA POSTSCRIPTACCENTED) OF POSTSCRIPTDATA + WITH T) + (POSTSCRIPT.PUTCOMMAND STREAM "/" (CONCAT (fetch (FONTID FONTIDNAME) + of FONTID) + "-Acnt") + " findfont [" + (TIMES (fetch (FONTID FONTXFACTOR) of FONTID) + (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) + 100) + " 0 " + (TIMES (fetch (FONTID FONTOBLIQUEFACTOR) of FONTID) + (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) + 100) + " " + (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) + 100) + " 0 0] makefont setfont" :EOL] + (T [COND + ((MEMB FONTID (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) of + POSTSCRIPTDATA + ))) + ((MEMB FONTID *POSTSCRIPT-UNACCENTED-FONTS*)) + (T + (* ;; + "This font hasn't been used on this page yet. Re-encode it to include accented characters.") + + (POSTSCRIPT.PUTCOMMAND STREAM "/" FONTID " /" (CONCAT FONTID "-Acnt") + " encodefont" :EOL) + (CL:PUSH FONTID (FFETCH (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) OF + POSTSCRIPTDATA + ] + (COND + ((MEMB FONTID *POSTSCRIPT-UNACCENTED-FONTS*) + (freplace (\POSTSCRIPTDATA POSTSCRIPTACCENTED) of POSTSCRIPTDATA + with NIL) + (POSTSCRIPT.PUTCOMMAND STREAM (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) + of FONT) + 100) + " /" FONTID " F" :EOL)) + (T (freplace (\POSTSCRIPTDATA POSTSCRIPTACCENTED) of POSTSCRIPTDATA + with T) + (POSTSCRIPT.PUTCOMMAND STREAM (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) + of FONT) + 100) + " /" + (CONCAT FONTID "-Acnt") + " F" :EOL] + (replace (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of POSTSCRIPTDATA with + NIL]) (\TERPRI.PSC + [LAMBDA (STREAM) (* ; + "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") + (LET* [(IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + (NEWY (PLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA) + (ffetch (\POSTSCRIPTDATA POSTSCRIPTLINESPACING) of IMAGEDATA] + (COND + ([LESSP NEWY (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of + IMAGEDATA + ) + (fetch (FONTDESCRIPTOR \SFDescent) of (ffetch + (\POSTSCRIPTDATA + POSTSCRIPTFONT) + of IMAGEDATA] + (DSPNEWPAGE STREAM)) + (T (replace (STREAM CHARPOSITION) of STREAM with 0) + (\MOVETO.PSC STREAM (ffetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) + of IMAGEDATA) + NEWY))) + NIL]) ) (* ;; "DIG operations: ") (DEFINEQ (\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 20-Nov-92 15:12 by sybalsky:mv:envos") + + (* ;; "Maybe we should do something with OPERATION") + + (LET ((RGN (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT)) + (IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + TEXTUREBM TEXTUREWIDTH LEFT BOTTOM WIDTH HEIGHT) + [COND + [CLIPPINGREGION (SETQ RGN (INTERSECTREGIONS RGN CLIPPINGREGION (fetch ( + \POSTSCRIPTDATA + + POSTSCRIPTCLIPPINGREGION + ) of + IMAGEDATA] + (T (SETQ RGN (INTERSECTREGIONS RGN (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) + of IMAGEDATA] + (COND + (RGN (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))) + [COND + ((FIXP TEXTURE) + (SETQ TEXTURE (SELECT TEXTURE ((BLACKSHADE -1) + 0.0) + (WHITESHADE 1.0) + TEXTURE] + [COND + ((AND (FLOATP TEXTURE) + (<= 0.0 TEXTURE 1.0)) + (POSTSCRIPT.PUTCOMMAND STREAM HEIGHT " " WIDTH " " LEFT " " BOTTOM " " + TEXTURE " R" :EOL)) + ((OR (TEXTUREP TEXTURE) + (NULL TEXTURE)) + (SETQ TEXTUREBM (BITMAPCREATE 16 16 1)) + (SETQ TEXTUREWIDTH 16) + (BLTSHADE TEXTURE TEXTUREBM)) + ((BITMAPP TEXTURE) + (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] + (COND + (TEXTUREBM (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) + (T NIL]) (\CHARWIDTH.PSC + [LAMBDA (STREAM CHARCODE) (* ; "Edited 8-May-93 11:19 by rmk:") + (COND + ((EQ CHARCODE (CHARCODE SPACE)) + (fetch (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of (ffetch (STREAM IMAGEDATA) + of STREAM))) + ((\FGETCHARWIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of (ffetch (STREAM + IMAGEDATA + ) + of STREAM)) + CHARCODE]) (\CREATECHARSET.PSC + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) + (* ; "Edited 8-May-93 22:55 by rmk:") + (LET* ((CSINFO (CREATE CHARSETINFO + OFFSETS _ NIL)) + (WIDTHS (FETCH (CHARSETINFO WIDTHS) OF CSINFO))) + (REPLACE (CHARSETINFO IMAGEWIDTHS) OF CSINFO WITH WIDTHS) + + (* ;; "Make imagewidths point to widths. Shouldn't matter to anyone, since imagewidths really has to do with bitmaps etc. But...") + + (CL:UNLESS (EQ CHARSET 0) + + (* ;; "For all charsets other than 0, initialize widths with width of black box=average char width. We know that the AVGCHARWIDTH field of the FONTDESC will eventually be the width of A, but that might not be filled in when this is executed inside POSTSCRIPT.FONTCREATE--it's only after the return to FONTCREATE itself that this gets filled in. However, we do know that charset 0 is all set up before any other characters are dealt with.") + + (FOR I (AVGCHARWIDTH _ (CHARWIDTH (CHARCODE A) + FONTDESC)) FROM 0 TO 255 + FIRST (CL:WHEN (EQ 0 AVGCHARWIDTH) + + (* ;; + "This is what \AVGCHARWIDTH in FONT does, but we don't have it here. Just to be extremely safe.") + + [SETQ AVGCHARWIDTH (MAX 1 (FIXR (FTIMES 0.6 (FONTPROP FONTDESC + 'HEIGHT]) + DO (\FSETWIDTH WIDTHS I AVGCHARWIDTH))) + CSINFO]) (\DRAWARC.PSC + [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) + (* ; + "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") + (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + WIDTH COLOR) + [COND + ((NUMBERP BRUSH) + (SETQ WIDTH BRUSH)) + ((LISTP BRUSH) + (COND + ((NEQ (fetch BRUSHSHAPE of BRUSH) + 'ROUND) + (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))) + (T (* ; + "If FUNCTIONAL BRUSH big trouble!") + (printout T T + "[In \DRAWARC.PSC: Functional BRUSH not supported.] +[Using ROUND 1 point BRUSH]" T) + (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA] + (COND + ((NOT (ZEROP WIDTH)) + (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") + (COND + ((FLOATP COLOR) + (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") + (* ; + "COLOR is specified in POSTSCRIPT setgray notation.") + )) + (COND + ((LISTP DASHING) + (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 20-Nov-92 15:12 by sybalsky:mv:envos") + (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + WIDTH COLOR) + [COND + ((NUMBERP BRUSH) + (SETQ WIDTH BRUSH)) + ((LISTP BRUSH) + (COND + ((NEQ (fetch BRUSHSHAPE of BRUSH) + 'ROUND) + (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))) + (T (* ; + "If FUNCTIONAL BRUSH big trouble!") + (printout T T + "[In \DRAWCIRCLE.PSC: Functional BRUSH not supported.] +[Using (ROUND 1) BRUSH]" T) + (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA] + (COND + ((NOT (ZEROP WIDTH)) + (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") + (COND + ((FLOATP COLOR) + (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") + (* ; + "COLOR is specified in POSTSCRIPT setgray notation.") + )) + (COND + ((LISTP DASHING) + (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 20-Nov-92 15:12 by sybalsky:mv:envos") + (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + WIDTH SHAPE COLOR PSPLINE XA YA DXA DYA N PREVX PREVY PREV-DX3 PREV-DY3) + [COND + ((NUMBERP BRUSH) + (SETQ WIDTH BRUSH) + (SETQ SHAPE 'ROUND)) + ((LISTP BRUSH) + (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) + (SETQ SHAPE (fetch BRUSHSHAPE of BRUSH)) + (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))) + (T + (* ;; "If FUNCTIONAL BRUSH then BIG trouble!") + + (printout T T + "[In \DRAWCURVE.PSC: Functional BRUSH not supported.] +[Using (ROUND 1) BRUSH]" T) + (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA)) + (SETQ SHAPE 'ROUND] + (COND + ((NOT (ZEROP WIDTH)) + (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") + (COND + ((FLOATP COLOR) + (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") + + (* ;; "COLOR is specified in POSTSCRIPT setgray notation.") + + )) + (COND + ((LISTP DASHING) + (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 20-Nov-92 15:12 by sybalsky:mv:envos") + (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + WIDTH COLOR) + [COND + ((NUMBERP BRUSH) + (SETQ WIDTH BRUSH)) + ((LISTP BRUSH) + (COND + ((NEQ (fetch BRUSHSHAPE of BRUSH) + 'ROUND) + (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))) + (T (* ; + "If FUNCTIONAL BRUSH, big trouble!") + (printout T T + "[In \DRAWELLIPSE.PSC: Functional BRUSH not supported.] +[Using (ROUND 1) BRUSH]" T) + (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA] + (COND + ((NOT (ZEROP WIDTH)) + (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") + (COND + ((FLOATP COLOR) + (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") + (* ; + "COLOR is specified in POSTSCRIPT setgray notation.") + )) + (COND + ((LISTP DASHING) + (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 20-Nov-92 15:12 by sybalsky:mv:envos") + + (* ;; "DRAWLINE method for postscript streams.") + + (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) + [COND + ((NOT (NUMBERP WIDTH)) + + (* ;; "The WIDTH = NIL should have been handled before here, but just in case!") + + (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA] + [COND + ((NOT (ZEROP WIDTH)) + (COND + ((LESSP X2 X1) + + (* ;; "For Syntelligence, make all lines move from left to right, to defeat a bug in SPARCPrinter PS decoder.") + + (\DRAWLINE.PSC STREAM X2 Y2 X1 Y1 WIDTH OPERATION COLOR DASHING)) + ((NOT (OR (FLOATP COLOR) + (LISTP DASHING))) (* ; "Simple case, no dash or gray") + (POSTSCRIPT.PUTCOMMAND STREAM X2 " " Y2 " " X1 " " Y1 " " WIDTH " L" :EOL)) + (T (* ; + "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 (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA with X2) + (freplace (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA with Y2) + (freplace (\POSTSCRIPTDATA 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 20-Nov-92 15:17 by sybalsky:mv:envos") + (LET ((LASTPOINT (CAR (LAST POINTS))) + (IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + WIDTH SHAPE COLOR) + [COND + ((NUMBERP BRUSH) + (SETQ WIDTH BRUSH) + (SETQ SHAPE 'ROUND)) + ((LISTP BRUSH) + (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) + (SETQ SHAPE (fetch BRUSHSHAPE of BRUSH)) + (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))) + (T + (* ;; "If FUNCTIONAL BRUSH then BIG trouble!") + + (printout T T + "[In \DRAWPOLYGON.PSC: Functional BRUSH not supported.] +[Using (ROUND 1) BRUSH]" T) + (SETQ WIDTH (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA)) + (SETQ SHAPE 'ROUND] + (COND + ((NOT (ZEROP WIDTH)) + (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ") + (COND + ((FLOATP COLOR) + (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") + + (* ;; "COLOR is specified in POSTSCRIPT setgray notation.") + + )) + (COND + ((LISTP DASHING) + (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 (POSITION XCOORD) of (CAR POINTS)) + " " + (fetch (POSITION YCOORD) of (CAR POINTS)) + " M" :EOL) + (for P in (CDR POINTS) do (POSTSCRIPT.PUTCOMMAND STREAM + (fetch (POSITION XCOORD) of P) + " " + (fetch (POSITION YCOORD) of P) + " lineto" :EOL)) + (COND + (CLOSED (POSTSCRIPT.PUTCOMMAND STREAM " closepath"))) + (POSTSCRIPT.PUTCOMMAND STREAM " stroke" :EOL "grestore" :EOL))) + (\MOVETO.PSC STREAM (fetch (POSITION XCOORD) of LASTPOINT) + (fetch (POSITION YCOORD) of LASTPOINT]) (\DSPBOTTOMMARGIN.PSC + [LAMBDA (STREAM YPOSITION) (* ; + "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") + (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of (fetch (STREAM IMAGEDATA) + of STREAM)) + (COND + (YPOSITION (replace (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) + of (fetch (STREAM IMAGEDATA) of STREAM) with YPOSITION))))]) (\DSPCLIPPINGREGION.PSC + [LAMBDA (STREAM REGION) (* ; + "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") + (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + (OLDCLIP (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA))) + (COND + ([AND REGION (NOT (AND (EQP (fetch (REGION LEFT) of OLDCLIP) + (fetch (REGION LEFT) of REGION)) + (EQP (fetch (REGION BOTTOM) of OLDCLIP) + (fetch (REGION BOTTOM) of REGION)) + (EQP (fetch (REGION WIDTH) of OLDCLIP) + (fetch (REGION WIDTH) of REGION)) + (EQP (fetch (REGION HEIGHT) of OLDCLIP) + (fetch (REGION HEIGHT) of REGION] + (POSTSCRIPT.SHOWACCUM STREAM) + (replace (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA with + REGION) + (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with T) + (\FIXLINELENGTH.PSC STREAM IMAGEDATA))) + OLDCLIP]) (\DSPCOLOR.PSC + [LAMBDA (STREAM COLOR) (* ; "Edited 14-Jan-93 17:14 by jds") + + (* ;; + "Postscript %"color%" setter -- really sets gray shade for now. 0.0 = black, 1.0 = white.") + + (POSTSCRIPT.SHOWACCUM STREAM) + (PROG1 (FETCH (\POSTSCRIPTDATA POSTSCRIPTCOLOR) OF (FETCH (STREAM IMAGEDATA) + OF STREAM)) + (COND + ((AND (NUMBERP COLOR) + (<= 0 COLOR 1)) + (REPLACE (\POSTSCRIPTDATA POSTSCRIPTCOLOR) OF (FETCH (STREAM IMAGEDATA) + OF STREAM) WITH COLOR) + (POSTSCRIPT.PUTCOMMAND STREAM :EOL COLOR " setgray ")) + (COLOR (\ILLEGAL.ARG COLOR))))]) (\DSPFONT.PSC + [LAMBDA (STREAM FONT) (* ; + "Edited 26-May-93 01:06 by sybalsky:mv:envos") + (* ; "Edited 11-May-93 02:11 by jds") + (* ; "Edited 19-Jan-93 17:17 by jds") + + (* ;; "Change fonts on the PostScript stream STREAM to be FONT.") + + (* ;; "Doesn't actually write the font-change command to the stream (it saves doing that until the font is actually needed, so that multiple font changes don't yield larger PS files).") + + (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + (OLDFONT (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA)) + NEWFONT FONTID) + (COND + ((AND FONT (SETQ NEWFONT (OR (\COERCEFONTDESC FONT STREAM) + (FONTCOPY OLDFONT FONT))) + (type? FONTDESCRIPTOR NEWFONT) + (NEQ NEWFONT OLDFONT)) + + (* ;; "OK, it's a good font.") + + (POSTSCRIPT.SHOWACCUM STREAM) (* ; + " Write out any accumulated characters.") + + (* ;; "Change the font in the Lisp stream:") + + (replace (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA with NEWFONT) + + (* ;; "and now update all font-dependent fields in the imagedata, EXCEPT POSTSCRIPTSPACEWIDTH and POSTSCRIPTNATURALSPACEWIDTH. These latter 2 must stay as-is up thru the actual writing of characters by SHOWACCUM, so") + + (\POSTSCRIPT.CHANGECHARSET IMAGEDATA 0) + (\DSPLINEFEED.PSC STREAM (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) of + NEWFONT))) + [replace (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of IMAGEDATA + with (FIXR (TIMES (fetch (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) + of IMAGEDATA) + (replace (\POSTSCRIPTDATA POSTSCRIPTNATURALSPACEWIDTH) + of IMAGEDATA with (\FGETWIDTH (fetch + (\POSTSCRIPTDATA + POSTSCRIPTWIDTHS) + of IMAGEDATA) + (CHARCODE SPACE] + (\FIXLINELENGTH.PSC STREAM IMAGEDATA) + [SETQ FONTID (fetch (PSCFONT IL-FONTID) of (LISTGET (fetch (FONTDESCRIPTOR + + OTHERDEVICEFONTPROPS + ) of + NEWFONT + ) + 'PSCFONT] + (COND + ((MEMB (fetch (FONTID FONTIDNAME) of FONTID) + *POSTSCRIPT-UNACCENTED-FONTS*) + (FREPLACE (\POSTSCRIPTDATA POSTSCRIPTACCENTED) OF IMAGEDATA WITH NIL)) + (T (freplace (\POSTSCRIPTDATA POSTSCRIPTACCENTED) of IMAGEDATA with + T))) + + (* ;; "Remember to actually write a change command") + + (replace (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of IMAGEDATA with + T))) + OLDFONT]) (\DSPLEFTMARGIN.PSC + [LAMBDA (STREAM XPOSITION) (* ; + "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") + (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) + (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA) + (COND + (XPOSITION (replace (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA + with XPOSITION) + (\FIXLINELENGTH.PSC STREAM IMAGEDATA))))]) (\DSPLINEFEED.PSC + [LAMBDA (STREAM LINELEADING) (* ; + "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") + (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTLINESPACING) of (fetch (STREAM IMAGEDATA) + of STREAM)) + (COND + (LINELEADING (replace (\POSTSCRIPTDATA POSTSCRIPTLINESPACING) + of (fetch (STREAM IMAGEDATA) of STREAM) with LINELEADING)) + ))]) (\DSPPUSHSTATE.PSC + [LAMBDA (STREAM) (* ; + "Edited 20-Nov-92 15:12 by sybalsky:mv:envos") + (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) + (push (fetch (\POSTSCRIPTDATA POSTSCRIPTXFORMSTACK) of IMAGEDATA) + (create POSTSCRIPTXFORM + PSXCLIP _ (COPY (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) + of IMAGEDATA)) + PSXPAGE _ (COPY (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of + IMAGEDATA)) + PSXLEFT _ (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA) + PSXRIGHT _ (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA + ) + PSXTOP _ (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA) + PSXBOTTOM _ (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of + IMAGEDATA + ) + PSXTRANX _ (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA) + PSXTRANY _ (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA) + PSXLAND _ (fetch (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA) + PSXXFORMPEND _ (fetch (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) + of IMAGEDATA]) (\DSPPOPSTATE.PSC + [LAMBDA (STREAM) (* ; + "Edited 20-Nov-92 15:15 by sybalsky:mv:envos") + (LET* [(IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + (XFORM (pop (fetch (\POSTSCRIPTDATA POSTSCRIPTXFORMSTACK) of IMAGEDATA] + (replace (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of IMAGEDATA + with (fetch (POSTSCRIPTXFORM PSXCLIP) of XFORM)) + (replace (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of IMAGEDATA + with (fetch (POSTSCRIPTXFORM PSXPAGE) of XFORM)) + (replace (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA + with (fetch (POSTSCRIPTXFORM PSXBOTTOM) of XFORM)) + (replace (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA + with (fetch (POSTSCRIPTXFORM PSXTOP) of XFORM)) + (replace (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA + with (fetch (POSTSCRIPTXFORM PSXLEFT) of XFORM)) + (replace (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA + with (fetch (POSTSCRIPTXFORM PSXRIGHT) of XFORM)) + (replace (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of IMAGEDATA + with (fetch (POSTSCRIPTXFORM PSXLAND) of XFORM)) + (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA + with (fetch (POSTSCRIPTXFORM PSXXFORMPEND) of XFORM)) + (replace (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA with + (fetch ( + POSTSCRIPTXFORM + PSXTRANX) + of XFORM)) + (replace (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA with + (fetch ( + POSTSCRIPTXFORM + PSXTRANY) + of XFORM]) (\DSPRESET.PSC + [LAMBDA (STREAM) (* ; + "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") + (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) + (replace (STREAM CHARPOSITION) of STREAM with 0) + (\MOVETO.PSC STREAM (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA) + (DIFFERENCE (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA) + (FONTPROP (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA) + 'ASCENT]) (\DSPRIGHTMARGIN.PSC + [LAMBDA (STREAM XPOSITION) (* ; + "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") + (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) + (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA) + (COND + (XPOSITION (replace (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA + with XPOSITION) + (\FIXLINELENGTH.PSC STREAM IMAGEDATA))))]) (\DSPROTATE.PSC + [LAMBDA (STREAM ROTATION) (* ; + "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") + + (* ;; "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)) + (OROT (fetch (\POSTSCRIPTDATA POSTSCRIPTROTATION) of IMAGEDATA)) + LAND C0 P0 C P ML MB MR MT) + (COND + ((AND ROTATION (NEQ ROTATION (fetch (\POSTSCRIPTDATA POSTSCRIPTROTATION) + of IMAGEDATA))) + (POSTSCRIPT.SHOWACCUM STREAM) + (replace (\POSTSCRIPTDATA POSTSCRIPTROTATION) of IMAGEDATA with ROTATION) + (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with T) + (\DSPRESET.PSC STREAM))) + OROT]) (\DSPSCALE.PSC + [LAMBDA (STREAM SCALE) (* ; + "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") + (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + (OSCALE (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA)) + NSCALE) + (COND + ((AND NIL + + (* ;; "Changing SCALE is not implemented. According to IRM.") + + (NUMBERP SCALE) + (CL:PLUSP SCALE)) + (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 (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA with SCALE))) + OSCALE]) (\DSPSCALE2.PSC + [LAMBDA (STREAM X-SCALE Y-SCALE) (* ; + "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") + + (* ;; "SETS X AND Y SCALE ") + + (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + (OSCALE (fetch (\POSTSCRIPTDATA POSTSCRIPTSCALE) of IMAGEDATA)) + NSCALE) + (COND + ((AND X-SCALE (NUMBERP X-SCALE) + (CL:PLUSP X-SCALE)) + (POSTSCRIPT.SHOWACCUM STREAM) + (\UPDATE.PSC STREAM IMAGEDATA) + + (* ;; + "NSCALE is the adjustment for the fact that the scale operator takes RELATIVE scale changes.") + + (POSTSCRIPT.PUTCOMMAND STREAM " " X-SCALE " " Y-SCALE " scale" :EOL))) + T]) (\DSPSPACEFACTOR.PSC + [LAMBDA (STREAM FACTOR) (* ; + "Edited 26-May-93 01:18 by sybalsky:mv:envos") + (DECLARE (LOCALVARS . T)) + (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + (OLDFACTOR (fetch (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) of IMAGEDATA))) + [COND + ((AND (NUMBERP FACTOR) + (NOT (EQUAL FACTOR OLDFACTOR))) + (POSTSCRIPT.SHOWACCUM STREAM) + (replace (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) of IMAGEDATA with FACTOR) + (replace (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of IMAGEDATA + with (FIXR (TIMES FACTOR (ffetch (\POSTSCRIPTDATA + POSTSCRIPTNATURALSPACEWIDTH) + of IMAGEDATA] + OLDFACTOR]) (\DSPTOPMARGIN.PSC + [LAMBDA (STREAM YPOSITION) (* ; + "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") + (PROG1 (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of (fetch (STREAM IMAGEDATA) + of STREAM)) + (COND + (YPOSITION (replace (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of (fetch + (STREAM IMAGEDATA) + of STREAM) + with YPOSITION))))]) (\DSPTRANSLATE.PSC + [LAMBDA (STREAM TX TY) (* ; + "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") + (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + (MDX (DIFFERENCE (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA) + TX)) + (MDY (DIFFERENCE (fetch (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA) + TY))) + (COND + ((NOT (AND (ZEROP MDX) + (ZEROP MDY))) + (POSTSCRIPT.SHOWACCUM STREAM) + (for REG in (LIST (fetch (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) + of IMAGEDATA) + (fetch (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) + of IMAGEDATA)) do (CL:INCF (fetch (REGION + LEFT) + of REG) + MDX) + (CL:INCF (fetch (REGION + BOTTOM) + of REG) + MDY)) + (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) + MDX) + (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA) + MDY) + (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of IMAGEDATA) + MDX) + (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA) + MDX) + (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of IMAGEDATA) + MDY) + (CL:INCF (fetch (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of IMAGEDATA) + MDY) + (replace (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of IMAGEDATA with TX) + (replace (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of IMAGEDATA with TY) + (replace (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA with T]) (\DSPXPOSITION.PSC + [LAMBDA (STREAM XPOSITION) (* ; + "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") + (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + OLDX) + (PROG1 (SETQ OLDX (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA)) + [COND + ((AND XPOSITION (NOT (EQUAL XPOSITION OLDX))) + (\MOVETO.PSC STREAM XPOSITION (fetch (\POSTSCRIPTDATA POSTSCRIPTY) + of IMAGEDATA])]) (\DSPYPOSITION.PSC + [LAMBDA (STREAM YPOSITION) (* ; + "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") + (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + OLDY) + (PROG1 (SETQ OLDY (fetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA)) + (COND + ((AND YPOSITION (NOT (EQUAL YPOSITION OLDY))) + (\MOVETO.PSC STREAM (fetch (\POSTSCRIPTDATA 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 20-Nov-92 15:17 by sybalsky:mv:envos") + (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 (POSITION XCOORD) of (CAR KNOTS)) + " " + (fetch (POSITION YCOORD) of (CAR KNOTS)) + " M" :EOL) + (for K in (CDR KNOTS) do (POSTSCRIPT.PUTCOMMAND STREAM (fetch + (POSITION XCOORD) + of K) + " " + (fetch (POSITION 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 (POSITION XCOORD) of LASTPOINT) + (fetch (POSITION YCOORD) of LASTPOINT]) (\FIXLINELENGTH.PSC + [LAMBDA (STREAM IMAGEDATA) (* ; + "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") + + (* ;; "Called by margin, font or rotation change to update the LINELENGTH field in the stream.") + + (LET [(TMP (MIN MAX.SMALLP (FIX (QUOTIENT (DIFFERENCE (fetch (\POSTSCRIPTDATA + POSTSCRIPTRIGHTMARGIN) + of IMAGEDATA) + (ffetch (\POSTSCRIPTDATA + POSTSCRIPTLEFTMARGIN) + of IMAGEDATA)) + (fetch FONTAVGCHARWIDTH of (ffetch + (\POSTSCRIPTDATA + POSTSCRIPTFONT) + of IMAGEDATA] + (replace (STREAM LINELENGTH) of STREAM with (COND + ((GREATERP TMP 1) + TMP) + (T 10]) (\MOVETO.PSC + [LAMBDA (STREAM X Y) (* ; + "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") + (LET ((IMAGEDATA (ffetch (STREAM IMAGEDATA) of STREAM))) + (COND + ([NOT (AND (EQP X (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA)) + (EQP Y (ffetch (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA] + (POSTSCRIPT.SHOWACCUM STREAM) + (freplace (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA with X) + (freplace (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA with Y) + (freplace (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of IMAGEDATA with T]) (\NEWPAGE.PSC + [LAMBDA (STREAM) (* ; "Edited 5-Apr-89 17:31 by TAL") + (POSTSCRIPT.ENDPAGE STREAM) + (POSTSCRIPT.STARTPAGE STREAM]) ) (* ;; "Character-output, plus special-cases:") (DEFINEQ (\POSTSCRIPT.CHANGECHARSET + [LAMBDA (PSDATA CHARSET) (* ; "Edited 29-Apr-93 13:51 by rmk:") + + (* ;; +"Called when the character set information cached in a display stream doesn't correspond to CHARSET") + + (PROG* ((FONT (ffetch POSTSCRIPTFONT of PSDATA)) + (CSINFO (\GETCHARSETINFO CHARSET FONT))) + + (* ;; "since the call to \getcharsetinfo has NOSLUG? = NIL, we know that we will get a reasonable character set back") + + (UNINTERRUPTABLY + (freplace POSTSCRIPTWIDTHS of PSDATA with (ffetch (CHARSETINFO WIDTHS) + of CSINFO)) + (freplace POSTSCRIPTNSCHARSET of PSDATA with CHARSET))]) (\POSTSCRIPT.OUTCHARFN + [LAMBDA (STREAM CHAR) (* ; "Edited 23-May-93 12:00 by rmk:") + (* ; "Edited 4-May-93 02:20 by jds") + (* ; "Edited 3-Feb-93 00:45 by jds") + +(* ;;; "Output a character to be printed.") + +(* ;;; "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 efficiency.") + + (DECLARE (GLOBALVARS \POSTSCRIPT.CHARTYPE) + (LOCALVARS . T)) + (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + (XPOS (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA)) + (FONT (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA)) + CHARWID NEWXPOS MAPPING) + (CL:UNLESS (EQ (\CHARSET CHAR) + (ffetch POSTSCRIPTNSCHARSET of IMAGEDATA)) + + (* ;; "Switch character set so that we get the right char width.") + + (\POSTSCRIPT.CHANGECHARSET IMAGEDATA (\CHARSET CHAR))) + [SETQ CHARWID (SELCHARQ CHAR + (SPACE (ffetch (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of + IMAGEDATA + )) + (\FGETWIDTH (ffetch (\POSTSCRIPTDATA POSTSCRIPTWIDTHS) of + IMAGEDATA + ) + (\CHAR8CODE CHAR] + + (* ;; "POSTSCRIPTACCENTED true if font has accented rendering characters in it; otherwise, a c-set 0 special font (SYMBOL, ZAPFDINGBATS...)") + + [COND + [[OR (NOT (ffetch (\POSTSCRIPTDATA POSTSCRIPTACCENTED) of IMAGEDATA)) + (AND (ILEQ CHAR 254) + (NOT (CL:AREF \POSTSCRIPT.CHARTYPE CHAR] + + (* ;; "OR is NIL if char is special in any way: Either font isn't supposed to be treated as an NS font (e.g. ZapfDingbats, which uses all the legal char positions for its own), or char itself is in cset 0 and ordinary") + + [COND + ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) + (ffetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA)) + (\TERPRI.PSC STREAM) + (SETQ NEWXPOS (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) + CHARWID] + (CL:UNLESS (ffetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA) + (\UPDATE.PSC STREAM IMAGEDATA) + (BOUT STREAM (CHARCODE %()) + (freplace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA with + T)) + (COND + [(ILESSP CHAR (CHARCODE " ")) + (BOUT STREAM (CHARCODE \)) + [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] + [(IGEQ CHAR 127) + (BOUT STREAM (CHARCODE \)) + [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] + (T (SELCHARQ CHAR + ((%( %) \) + (BOUT STREAM (CHARCODE \)) + (BOUT STREAM CHAR)) + (BOUT STREAM CHAR] + [(SETQ MAPPING (GETHASH CHAR *POSTSCRIPT-NS-HASH*)) + (* ; + "Special character that's taken care of by the NS mapping.") + [COND + ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) + (ffetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of IMAGEDATA)) + (\TERPRI.PSC STREAM) + (SETQ NEWXPOS (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA) + CHARWID] + (SELECTQ (CAR MAPPING) + (NIL + (* ;; "just a remap within the lower 256. But the code in (CDR MAPPING) is in charset 2 to prevent recursion") + + (\POSTSCRIPT.SPECIALOUTCHARFN STREAM (CADR MAPPING))) + (SYMBOL + (* ;; "Its in the SYMBOL font. Symbol is specified as %"2,xxx%" rather than %"0,xxx%" to defeat translations to symbol that go to matching character codes.") + + (\POSTSCRIPT.SPECIALOUTCHARFN STREAM (CADR MAPPING) + 'SYMBOL)) + (ACCENT (* ; "Special accent mapping we did") + (\POSTSCRIPT.ACCENTFN STREAM (CADR MAPPING))) + (ACCENTPAIR (* ; + "Given base char & accent, overlap them.") + (\POSTSCRIPT.ACCENTPAIR STREAM (CADR MAPPING) + (CADDR MAPPING) + (CADDDR MAPPING))) + (DINGBAT (* ; "A Zapf dingbat") + (\POSTSCRIPT.SPECIALOUTCHARFN STREAM (CADR MAPPING) + 'ZAPFDINGBATS)) + (APPLY* (POSTSCRIPT.SHOWACCUM STREAM) + (\UPDATE.PSC STREAM IMAGEDATA) + + (* ;; "User function can call any stream operations it wants. At the end, we guarantee that baseline hasn't changed and that xpos is where the widthset it would be.") + + [freplace (\POSTSCRIPTDATA POSTSCRIPTY) of IMAGEDATA + with (PROG1 (ffetch (\POSTSCRIPTDATA POSTSCRIPTY) OF + IMAGEDATA + ) + (APPLY* (CADDR MAPPING) + STREAM + (CADR MAPPING)))]) + (FUNCTION (* ; "Done as special PS code.") + (POSTSCRIPT.SHOWACCUM STREAM) + (\UPDATE.PSC STREAM IMAGEDATA) + (POSTSCRIPT.OUTSTR STREAM (CADR MAPPING))) + (\ILLEGAL.ARG (CAR MAPPING] + (T (* ; "Special char") + (SELCHARQ CHAR + ((EOL LF) + (\TERPRI.PSC STREAM) + + (* ;; + "Set NEWXPOS to current value here and in FF to preserve value after external resetting.") + + (SETQ NEWXPOS (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA))) + (FF (DSPNEWPAGE STREAM) + (SETQ NEWXPOS (fetch (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA))) + (TAB (SETQ NEWXPOS (IPLUS XPOS (\POSTSCRIPTTAB IMAGEDATA))) + [COND + ((IGREATERP NEWXPOS (ffetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) + of IMAGEDATA)) + (\TERPRI.PSC STREAM) + (SETQ NEWXPOS (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) + of IMAGEDATA) + (\POSTSCRIPTTAB IMAGEDATA] + (\MOVETO.PSC STREAM NEWXPOS (ffetch (\POSTSCRIPTDATA POSTSCRIPTY) + of IMAGEDATA))) + ("357,140" (* ; " Ballot box, checked") + [COND + ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) + (ffetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) + of IMAGEDATA)) + (\TERPRI.PSC STREAM) + (SETQ NEWXPOS (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) + of IMAGEDATA) + CHARWID] + (LET ((OLDFONT (\DSPFONT.PSC STREAM))) + (POSTSCRIPT.SHOWACCUM STREAM) + (\DSPFONT.PSC STREAM (LIST 'ZAPFDINGBATS (fetch + (FONTDESCRIPTOR + FONTSIZE) + of OLDFONT) + (fetch (FONTDESCRIPTOR + FONTFACE) + of OLDFONT))) + (\UPDATE.PSC STREAM IMAGEDATA) + (POSTSCRIPT.OUTSTR STREAM " bboxchk ") + (\DSPFONT.PSC STREAM OLDFONT))) + (PROGN [COND + ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID)) + (ffetch (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) + of IMAGEDATA)) + (\TERPRI.PSC STREAM) + (SETQ NEWXPOS (IPLUS (ffetch (\POSTSCRIPTDATA POSTSCRIPTX) + of IMAGEDATA) + CHARWID] + (COND + ((IGEQ CHAR 255) + + (* ;; "If it's 255 or above and we don't know anything about it, print the black box. Width vector will determine width of box, to maintain consistency.") + + (\POSTSCRIPT.PRINTSLUG STREAM CHAR)) + (T (SETQ CHAR (\CHAR8CODE CHAR)) + (COND + ((NOT (ffetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) + of IMAGEDATA)) + (\UPDATE.PSC STREAM IMAGEDATA) + (BOUT STREAM (CHARCODE %()) + (freplace (\POSTSCRIPTDATA 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 (\POSTSCRIPTDATA POSTSCRIPTX) of IMAGEDATA with NEWXPOS) + CHAR]) (\POSTSCRIPT.PRINTSLUG + [LAMBDA (STREAM CHAR) (* ; "Edited 9-May-93 21:55 by rmk:") + (* ; "Edited 4-May-93 02:20 by jds") + (* ; "Edited 3-Feb-93 00:45 by jds") + +(* ;;; "Internal function to display a black box for a missing character. Width is taken from widths vector, so that box and charwidth are always consistent. Caller (\POSTSCRIPT.OUTCHARFN) is responsible for guaranteeing proper caching of widths vector and for measurement and position updating, although \DRAWLINE.PSC also updates position.") + + (DECLARE (LOCALVARS . T)) + (LET ((IMAGEDATA (FETCH (STREAM IMAGEDATA) OF STREAM))) + (\BLTSHADE.PSC BLACKSHADE STREAM (FETCH (\POSTSCRIPTDATA POSTSCRIPTX) OF + IMAGEDATA + ) + (FETCH (\POSTSCRIPTDATA POSTSCRIPTY) OF IMAGEDATA) + (\FGETWIDTH (FFETCH (\POSTSCRIPTDATA POSTSCRIPTWIDTHS) OF IMAGEDATA) + (\CHAR8CODE CHAR)) + (FETCH (FONTDESCRIPTOR \SFAscent) OF (FETCH (\POSTSCRIPTDATA + POSTSCRIPTFONT) + OF IMAGEDATA)) + 'PAINT) + (\MOVETO.PSC STREAM (IPLUS (FETCH (\POSTSCRIPTDATA POSTSCRIPTX) OF IMAGEDATA) + (\FGETWIDTH (FFETCH (\POSTSCRIPTDATA POSTSCRIPTWIDTHS) + OF IMAGEDATA) + (\CHAR8CODE CHAR))) + (FETCH (\POSTSCRIPTDATA POSTSCRIPTY) OF IMAGEDATA]) (\POSTSCRIPT.SPECIALOUTCHARFN + [LAMBDA (STREAM CHAR FAMILY) (* ; "Edited 23-May-93 13:31 by rmk:") + (* ; "Edited 4-May-93 02:20 by jds") + (* ; "Edited 3-Feb-93 00:45 by jds") + +(* ;;; "Internal function to output a special character to be printed, changing font if necessary. Width processing is carried out at higher level. If FAMILY is given, switches to that font (SYMBOL, ZAPFDINGBATS) before printing, then switches back.") + + (DECLARE (LOCALVARS . T)) + (LET* [(IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + (OLDFONT (AND FAMILY (\DSPFONT.PSC STREAM] + (CL:WHEN OLDFONT + (\DSPFONT.PSC STREAM (LIST FAMILY (fetch (FONTDESCRIPTOR FONTSIZE) of + OLDFONT) + (fetch (FONTDESCRIPTOR FONTFACE) of OLDFONT)))) + (CL:UNLESS (ffetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA) + (\UPDATE.PSC STREAM IMAGEDATA) + (BOUT STREAM (CHARCODE %()) + (freplace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA with T)) + [COND + [(ILESSP CHAR (CHARCODE " ")) + (BOUT STREAM (CHARCODE \)) + [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] + [(IGEQ CHAR 127) + (BOUT STREAM (CHARCODE \)) + [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] + (T (SELCHARQ CHAR + ((%( %) \) + (BOUT STREAM (CHARCODE \)) + (BOUT STREAM CHAR)) + (BOUT STREAM CHAR] + (CL:WHEN OLDFONT (\DSPFONT.PSC STREAM OLDFONT)) + CHAR]) (\UPDATE.PSC + [LAMBDA (STREAM IMAGEDATA) (* ; + "Edited 20-Nov-92 15:13 by sybalsky:mv:envos") + + (* ;; "Make any outstanding font, scale, location updates, prepatory to something that might depend heavily on it. (e.g. before starting to output characters, or making a scale change)") + (* ; + "This code was originally in \POSTSCRIPT.OUTCHAR &c, and is here for commonality.") + (COND + ((ffetch (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of IMAGEDATA) + (\SETXFORM.PSC STREAM IMAGEDATA))) + (COND + ((ffetch (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of IMAGEDATA) + (* ; + "If font was changed then switch before printing") + (\SWITCHFONTS.PSC STREAM IMAGEDATA))) + (COND + ((ffetch (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of IMAGEDATA) + (* ; "likewise for position") + (\SETPOS.PSC STREAM IMAGEDATA]) (\POSTSCRIPT.ACCENTFN + [LAMBDA (STREAM CHAR) (* ; "Edited 28-Apr-93 16:35 by rmk:") + (* ; "Edited 3-Feb-93 01:05 by jds") + +(* ;;; "Output an accented character to be printed. .") + +(* ;;;; "Need to inc CHARPOSITION of STREAM") + + (DECLARE (LOCALVARS . T)) + (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) + (COND + ((NOT (ffetch (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA)) + (\UPDATE.PSC STREAM IMAGEDATA) + (BOUT STREAM (CHARCODE %()) + (freplace (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of IMAGEDATA with T))) + (BOUT STREAM (CHARCODE "\")) + (for CH instring (SUBSTRING (CONCAT "000" (OCTALSTRING CHAR)) + -3) do (BOUT STREAM CH)) + CHAR]) (\POSTSCRIPT.ACCENTPAIR + [LAMBDA (STREAM CHAR ACCENTS UNDER-ACCENTS) (* ; + "Edited 17-Aug-93 17:02 by sybalskY:MV:ENVOS") + (* ; "Edited 3-Feb-93 01:29 by jds") + +(* ;;; "Output an accented character to be printed. .") + +(* ;;;; "Prints the character as \xxx, with 3 octal digits, to avoid tripping up on EOLs and other postscript-special characters.") + + (DECLARE (LOCALVARS . T)) + (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + (FONT (ffetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA))) + (POSTSCRIPT.SHOWACCUM STREAM) + (\UPDATE.PSC STREAM IMAGEDATA) + (BOUT STREAM (CHARCODE %()) + (BOUT STREAM (CHARCODE "\")) + (for CH instring (SUBSTRING (CONCAT "000" (OCTALSTRING CHAR)) + -3) do (BOUT STREAM CH)) + (BOUT STREAM (CHARCODE %))) + (BOUT STREAM (CHARCODE %()) + (for ACCENT inside ACCENTS do (BOUT STREAM (CHARCODE "\")) + (for CH + instring (SUBSTRING (CONCAT "000" + (OCTALSTRING + ACCENT)) + -3) + do (BOUT STREAM CH))) + (POSTSCRIPT.PUTCOMMAND STREAM ") (") + (for ACCENT inside UNDER-ACCENTS + do (BOUT STREAM (CHARCODE "\")) + (for CH instring (SUBSTRING (CONCAT "000" (OCTALSTRING ACCENT)) + -3) do (BOUT STREAM CH))) + (BOUT STREAM (CHARCODE %))) + (COND + (NIL (OR (IEQP ACCENT (CHARCODE "0,313")) + (IEQP ACCENT (CHARCODE "0,316"))) (* ; + "Cedilla and ogonek are under-accents, so don't raise them for capital letters.") + (POSTSCRIPT.PUTCOMMAND STREAM " 0 ")) + ((ILESSP CHAR (CHARCODE a)) (* ; + "upper case, so adjust offset for accent") + (POSTSCRIPT.PUTCOMMAND STREAM " " (/ (fetch \SFAscent of FONT) + 3.0) + " ")) + (T (POSTSCRIPT.PUTCOMMAND STREAM " 0 "))) + (POSTSCRIPT.PUTCOMMAND STREAM " " (FONTPROP FONT 'SIZE) + " ") + (POSTSCRIPT.PUTCOMMAND STREAM " accentor ") + CHAR]) ) (* ;; "Spacing-character (M-quad, etc.) and ballot-box-check &c special-case functions") (DEFINEQ (\PSC.SPACEDISP + [LAMBDA (STREAM WIDTH) (* ; "Edited 28-Sep-93 13:50 by jds") + (POSTSCRIPT.PUTCOMMAND STREAM (\PSC.SPACEWID (DSPFONT NIL STREAM) + WIDTH) + " 0 rmoveto "]) (\PSC.SPACEWID + [LAMBDA (FONTDESC CHAR) (* ; "Edited 28-Sep-93 13:41 by jds") + + (* ;; "Spacing character with a special width (e.g. M space, thin (1/5-M) space...") + + (* ;; "If CHAR is a list, it's (CHARCODE FACTOR), and we return a width of FACTOR * (CHARWIDTH CHARCODE). Otherwise, we just return the width of CHARCODE.") + + (COND + [(LISTP CHAR) + (FIXR (FTIMES (CADR CHAR) + (CHARWIDTH (CHARCODE.DECODE (CAR CHAR)) + FONTDESC] + (T (CHARWIDTH (CHARCODE.DECODE CHAR) + FONTDESC]) (\PSC.SYMBOLS + [LAMBDA (STREAM CHAR) (* ; "Edited 2-Nov-94 17:01 by jds") + (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) + (OLDFONT (\DSPFONT.PSC STREAM))) + (\DSPFONT.PSC STREAM (LIST 'ZAPFDINGBATS (fetch (FONTDESCRIPTOR FONTSIZE) + of OLDFONT) + (fetch (FONTDESCRIPTOR FONTFACE) of OLDFONT))) + (POSTSCRIPT.SHOWACCUM STREAM) + (\UPDATE.PSC STREAM IMAGEDATA) + (COND + ((EQUAL CHAR "0,161") + (POSTSCRIPT.OUTSTR STREAM " bboxchk "))) + (\DSPFONT.PSC STREAM OLDFONT]) ) (* ;; "The mapping of NS characters to Postscript renderings, both as an AList and as a hashtable") (DEFINEQ (\POSTSCRIPT.NSHASH + [LAMBDA (MAPPING-LIST) (* ; + "Edited 30-Jul-93 14:46 by sybalskY:MV:ENVOS") + (* ; "Edited 4-May-93 02:21 by jds") + (* ; "Edited 3-Feb-93 00:33 by jds") + (for MAPPING in MAPPING-LIST unless (EQ (CAR MAPPING) + '*) + do (* ; + "Skip comments in the mapping list.") + (LET [(CHARCODE (CHARCODE.DECODE (CAR MAPPING] + + (* ;; "Fill in the translation entry for this character:") + + (PUTHASH CHARCODE + [DESTRUCTURING-BIND + (KIND CODE2 BASECHAR UNDERACCENTS) + (SETQ MAPPING (CDR MAPPING)) + (CONS KIND (SELECTQ KIND + ((SYMBOL NIL DINGBAT) + (CONS (CHARCODE.DECODE CODE2))) + (FUNCTION (CONS CODE2)) + ((ACCENT ACCENTPAIR) + (LIST (CHARCODE.DECODE CODE2) + (CHARCODE.DECODE BASECHAR) + (AND UNDERACCENTS (CHARCODE.DECODE UNDERACCENTS)) + )) + (APPLY* (* ; + "Apply setup function to coerce argument data") + + (* ;; "MAPPING is of the form ('APPLY* DATA PRINTFN WIDTHFN SETUPFN) PRINTFN gets applied to stream and result of applying SETUPFN to DATA. WIDTHFN gets applied to coerced data and fontdescriptor") + + (LIST (APPLY* (OR (CAR (CDDDDR MAPPING)) + (FUNCTION CL:IDENTITY)) + (CADR MAPPING)) + (CADDR MAPPING) + (CADDDR MAPPING))) + (ERROR "UNRECOGNIZED POSTSCRIPT CHARACTER TYPE" MAPPING] + *POSTSCRIPT-NS-HASH*) + + (* ;; "If this character is in the lower 127, we need to mark it for special handling in \POSTSCRIPT.CHARTYPE, by putting a T in the array at the charcode's position:") + + (CL:WHEN (<= CHARCODE 254) + (CL:SETF (CL:AREF \POSTSCRIPT.CHARTYPE CHARCODE) + T))]) ) (RPAQQ *POSTSCRIPT-UNACCENTED-FONTS* (Dancer ZapfDingbats "Dancer" "ZapfDingbats")) (RPAQQ *POSTSCRIPT-NS-TRANSLATIONS* ( (* ;; "Mapping of NS characters to Postscript renderings.") (* ;; "First few are for control-codes in old Press fonts (Timesroman, etc.); not strictly NS, but undefined therein so should be OK.") ("^S" NIL "2,320") (* ; "pressfont em dash") ("^V" NIL "2,261") (* ; "pressfont en dash") ("^G" NIL "0,140") ("0,244" NIL "2,250") (* ; "generic currency symbol") ("0,251" NIL "2,140") (* ; "left single quote") ("0,254" SYMBOL "2,254") (* ; "left arrow") ("0,255" SYMBOL "2,255") (* ; "uparrow") ("0,256" SYMBOL "2,256") (* ; "right arrow") ("0,257" SYMBOL "2,257") (* ; "down arrow") ("0,260" SYMBOL "2,260") (* ; "degree") ("0,261" SYMBOL "2,261") (* ; "+/-") ("0,264" SYMBOL "2,264") (* ; "times") ("0,267" NIL "2,264") (* ; "Center-dot") ("0,270" SYMBOL "2,270") (* ; "divide") ("0,271" NIL "2,047") (* ; "right single quote") ("0,274" FUNCTION " f14 ") (* ; "1/4") ("0,275" FUNCTION " f12 ") (* ; "1/2") ("0,276" FUNCTION " f34 ") (* ; "3/4") ("0,322" SYMBOL "2,342") (* ; "registered") ("0,323" SYMBOL "2,343") (* ; "copyright") ("0,324" SYMBOL "2,344") (* ; "tm") ("0,334" FUNCTION " f18 ") (* ; "1/8") ("0,335" FUNCTION " f38 ") (* ; "3/8") ("0,336" FUNCTION " f58 ") (* ; "5/8") ("0,337" FUNCTION " f78 ") (* ; "7/8") ("0,342" NIL "2,235") (* ; "Eth (slashed D?)") ("0,354" NIL "2,237") (* ; "Thorn") ("0,363" NIL "2,236") (* ; "eth") ("0,374" NIL "2,240") (* ; "thorn") ("41,172" DINGBAT "0,110") (* ; "filled star") ("42,42" DINGBAT "0,161") (* ; "ballot-box") ("42,61" APPLY* "0,161" \PSC.SYMBOLS \PSC.SPACEWID NIL) (* ; "Checked ballot-box") ("357,44" NIL "2,261") (* ; "n dash") ("357,45" NIL "2,320") (* ; "m dash") ("357,55" APPLY* "M" \PSC.SPACEDISP \PSC.SPACEWID NIL) (* ; "M quad") ("357,54" APPLY* "N" \PSC.SPACEDISP \PSC.SPACEWID NIL) (* ; "N quad") ("357,56" APPLY* "1" \PSC.SPACEDISP \PSC.SPACEWID NIL) (* ; "FIGURE quad") ("357,57" APPLY* ("M" 0.2) \PSC.SPACEDISP \PSC.SPACEWID NIL) (* ; "This space (1/5M)") ("357,60" NIL "2,262") (* ; "dagger") ("357,61" NIL "2,263") (* ; "double dagger") ("357,062" SYMBOL "2,361") (* ; "angleright") ("357,063" SYMBOL "2,341") (* ; "angleleft") ("357,70" SYMBOL "2,315") (* ; "perpendicular") ("357,101" NIL "2,275") (* ; "per mil o/oo") ("357,104" ACCENTPAIR "<" NIL "/") (* ; "not less than") ("357,105" ACCENTPAIR ">" "/") (* ; "not greater than") ("357,110" SYMBOL "2,312") (* ; "parallel") ("357,111" SYMBOL "2,315") (* ; "not parallel") ("357,112" SYMBOL "2,316") (* ; "element") ("357,113" SYMBOL "2,317") (* ; "notelement") ("357,114" SYMBOL "2,047") (* ; "suchthat") ("357,115" SYMBOL "2,334") (* ; "implied by, double arrow left") ("357,116" SYMBOL "2,333") (* ; "iff, double arrow") ("357,117" SYMBOL "2,336") (* ; "implies, double arrow right") ("357,120" SYMBOL "2,253") (* ; "double arrow") ("357,121" SYMBOL "2,333") (* ; "double arrow") ("357,122" SYMBOL "2,333") (* ; "l/r arrow") ("357,126" SYMBOL "2,307") (* ; "intersection") ("357,127" SYMBOL "2,310") (* ; "union") ("357,130" SYMBOL "2,312") (* ; "reflexsuperset") ("357,131" SYMBOL "2,315") (* ; "reflexsubset") ("357,132" SYMBOL "2,311") (* ; "propersuperset") ("357,133" SYMBOL "2,314") (* ; "propersubset") ("357,137" SYMBOL "2,313") (* ; "notsubset") ("357,141" SYMBOL "2,306") (* ; "emptyset") ("357,142" SYMBOL "2,305") (* ; "circleplus") ("357,144" SYMBOL "2,304") (* ; "circlemultiply") ("357,146" NIL "2,267") (* ; "bullet") ("357,147" SYMBOL "2,260") (* ;  "center circle (composition), lowered degree") ("357,152" SYMBOL "2,330") (* ; "logicalnot") ("357,154" SYMBOL "2,320") (* ; "angle") ("357,160" SYMBOL "2,136") (* ; "perpendicular") ("357,161" SYMBOL "2,265") (* ; "proportional") ("357,162" SYMBOL "2,272") (* ; "equivalence") ("357,165" SYMBOL "2,362") (* ; "integral") ("357,167" SYMBOL "2,273") (* ; "approxequal") ("357,170" SYMBOL "2,100") (* ; "congruent") ("357,172" SYMBOL "2,345") (* ; "summation") ("357,173" SYMBOL "2,325") (* ; "product") ("357,174" SYMBOL "2,326") (* ; "radical") ("357,242" SYMBOL "2,246") (* ; "florin") ("357,260" SYMBOL "2,351") (* ; "Ceiling, left ") ("357,261" SYMBOL "2,371") (* ; "Ceiling, right") ("357,262" SYMBOL "2,353") (* ; "Floor, left ") ("357,263" SYMBOL "2,373") (* ; "Floor, right") ("357,264" SYMBOL "2,44") (* ; "exists") ("357,265" SYMBOL "2,42") (* ; "forall") ("357,266" SYMBOL "2,331") (* ; "logicaland") ("357,267" SYMBOL "2,332") (* ; "logicalor") ("357,271" SYMBOL "2,321") (* ; "gradient") ("357,272" SYMBOL "2,266") (* ; "partialdiff") ("357,313" SYMBOL "2,252") (* ; "spade") ("357,317" DINGBAT "0,63") (* ; "check") ("357,375" FUNCTION " f13 ") (* ; "1/3") ("357,376" FUNCTION " f23 ") (* ; "2/3") ("361,041" ACCENT "0,4" A) ("361,042" ACCENT "0,1" A) ("361,043" ACCENT "0,2" A) ("361,044" ACCENT "0,6" A) ("361,045" ACCENTPAIR A "0,305") (* ; "A-macron") ("361,046" ACCENTPAIR A "0,306") (* ; "A-breve") ("361,047" ACCENT "0,3" A) ("361,050" ACCENT "0,5" A) ("361,055" ACCENT "0,7" C) ("361,060" ACCENT "0,13" E) ("361,061" ACCENT "0,10" E) ("361,062" ACCENT "0,11" E) ("361,063" ACCENTPAIR E "0,305") (* ; "E-macron") ("361,065" ACCENT "0,12" E) ("361,066" ACCENTPAIR E NIL "0,316") (* ; "E-ogonek") ("361,076" ACCENT "0,17" I) ("361,077" ACCENT "0,14" I) ("361,100" ACCENT "0,15" I) ("361,102" ACCENTPAIR I "0,305") (* ; "I-macron") ("361,104" ACCENT "0,16" I) ("361,114" ACCENT "0,20" N) ("361,117" ACCENT "0,24" O) ("361,120" ACCENT "0,21" O) ("361,121" ACCENT "0,22" O) ("361,122" ACCENT "0,25" O) ("361,123" ACCENTPAIR O "0,305") (* ; "O-macron") ("361,124" ACCENT "0,23" O) ("361,134" ACCENT "0,26" S) ("361,137" ACCENT "0,32" U) ("361,140" ACCENT "0,27" U) ("361,141" ACCENT "0,30" U) ("361,143" ACCENTPAIR U "0,305") (* ; "U-macron") ("361,145" ACCENT "0,31" U) ("361,155" ACCENT "0,33" Y) ("361,160" ACCENT "0,34" Z) ("361,165" ACCENTPAIR Y "0,305") (* ; "Y-macron") ("361,166" ACCENTPAIR "0,341" "0,305") (* ; "AE-macron") ("361,167" ACCENTPAIR "0,352" "0,305") (* ; "OE-macron") ("361,241" ACCENT "0,204" a) ("361,242" ACCENT "0,201" a) ("361,243" ACCENT "0,202" a) ("361,244" ACCENT "0,206" a) ("361,245" ACCENTPAIR a "0,305") (* ; "a-macron") ("361,246" ACCENTPAIR a "0,306") (* ; "a-breve") ("361,247" ACCENT "0,203" a) ("361,250" ACCENT "0,205" a) ("361,255" ACCENT "0,207" c) ("361,260" ACCENT "0,213" e) ("361,261" ACCENT "0,210" e) ("361,262" ACCENT "0,211" e) ("361,263" ACCENTPAIR e "0,305") (* ; "e-macron") ("361,265" ACCENT "0,212" e) ("361,266" ACCENTPAIR e NIL "0,316") (* ; "e-ogonek") ("361,267" ACCENTPAIR e "0,317") (* ; "e-caron") ("361,276" ACCENT "0,217" i) ("361,277" ACCENT "0,214" i) ("361,300" ACCENT "0,215" i) ("361,302" ACCENTPAIR "0,365" "0,305") (* ; "i-macron") ("361,304" ACCENT "0,216" i) ("361,314" ACCENT "0,220" n) ("361,317" ACCENT "0,224" o) ("361,320" ACCENT "0,221" o) ("361,321" ACCENT "0,222" o) ("361,322" ACCENT "0,225" o) ("361,323" ACCENTPAIR o "0,305") (* ; "o-macron") ("361,324" ACCENT "0,223" o) ("361,334" ACCENT "0,226" s) ("361,337" ACCENT "0,232" u) ("361,340" ACCENT "0,227" u) ("361,341" ACCENT "0,230" u) ("361,343" ACCENTPAIR u "0,305") (* ; "u-macron") ("361,344" ACCENTPAIR u "0,306") (* ; "u-breve") ("361,345" ACCENT "0,231" u) ("361,355" ACCENT "0,233" y) ("361,360" ACCENT "0,234" z) ("361,365" ACCENTPAIR y "0,305") (* ; "y-macron") ("361,366" ACCENTPAIR "0,361" "0,305") (* ; "ae-macron") ("361,367" ACCENTPAIR "0,372" "0,305") (* ; "oe-macron") ("361,371" ACCENTPAIR a "0,317") (* ; "a-caron") ("361,375" ACCENTPAIR g "0,317") (* ; "g-caron") (* ;;  "Special code assignments for Dictionary of Old English, UToronto:") ("361,370" ACCENTPAIR a ("0,305" "0,306")) (* ; "a - breve-macron") ("361,372" ACCENTPAIR e "0,306") (* ; "e-breve") ("361,373" ACCENTPAIR e "0,305" "0,56") (* ; "e macron underdot") ("361,374" ACCENTPAIR e ("0,305" "0,306")) (* ; "e - breve-macron") ("361,376" ACCENTPAIR "0,365" "0,306") (* ; "i-breve") ("362,242" ACCENTPAIR "0,365" "0,317") (* ; "i-caron") ("362,241" ACCENTPAIR "0,365" ("0,305" "0,306")) (* ; " i - breve-macron") ("362,243" ACCENTPAIR n "0,305") (* ; "n-macron") ("362,244" ACCENTPAIR m "0,305") (* ; "m-macron") ("362,245" ACCENTPAIR o "0,317") (* ; "o-caron") ("362,246" ACCENTPAIR o "0,306") (* ; "o-breve") ("362,247" ACCENTPAIR o ("0,305" "0,306")) (* ; "o - breve-macron") ("362,250" ACCENTPAIR o "0,305" "0,56") (* ; "o-macron underdot") ("362,251" ACCENTPAIR o "0,316") (* ; "o-ogonek") ("362,252" ACCENTPAIR u "0,317") (* ; "u-caron") ("362,253" ACCENTPAIR u ("0,305" "0,306")) (* ; "u - breve-macron") ("362,254" ACCENTPAIR y "0,306") (* ; "y-breve") ("362,256" ACCENTPAIR y "0,317") (* ; "y-caron") ("362,255" ACCENTPAIR y ("0,305" "0,306")) (* ; "y - breve-macron") (* ; "235 = Eth") (* ; "236 = eth") (* ; "237 = Thorn") (* ; "240 = thorn") (* ;; "NS Greek characters") ("46,101" SYMBOL "2,101") (* ; "Alpha") ("46,102" SYMBOL "2,102") (* ; "Beta") ("46,103" SYMBOL 0) (* ; "--empty--") ("46,104" SYMBOL "2,107") (* ; "Gamma") ("46,105" SYMBOL "2,104") (* ; "Delta") ("46,106" SYMBOL "2,105") (* ; "Epsilon") ("46,107" SYMBOL 0) (* ; "Stigma") ("46,110" SYMBOL 0) (* ; "Digamma") ("46,111" SYMBOL "2,132") (* ; "Zeta") ("46,112" SYMBOL "2,110") (* ; "Eta") ("46,113" SYMBOL "2,121") (* ; "Theta") ("46,114" SYMBOL "2,111") (* ; "Iota") ("46,115" SYMBOL "2,113") (* ; "Kappa") ("46,116" SYMBOL "2,114") (* ; "Lambda") ("46,117" SYMBOL "2,115") (* ; "Mu") ("46,120" SYMBOL "2,116") (* ; "Nu") ("46,121" SYMBOL "2,130") (* ; "Xi") ("46,122" SYMBOL "2,117") (* ; "Omicron") ("46,123" SYMBOL "2,120") (* ; "Pi") ("46,124" SYMBOL 0) (* ; "Koppa") ("46,125" SYMBOL "2,122") (* ; "Rho") ("46,126" SYMBOL "2,123") (* ; "Sigma") ("46,127" SYMBOL 0) (* ; "--empty--") ("46,130" SYMBOL "2,124") (* ; "Tau") ("46,131" SYMBOL "2,125") (* ; "Upsilon") ("46,132" SYMBOL "2,106") (* ; "Phi") ("46,133" SYMBOL "2,103") (* ; "Chi") ("46,134" SYMBOL "2,131") (* ; "Psi") ("46,135" SYMBOL "2,132") (* ; "Omega") ("46,141" SYMBOL "2,141") (* ; "alpha") ("46,142" SYMBOL "2,142") (* ; "beta") ("46,143" SYMBOL 0) (* ; "(md beta)") ("46,144" SYMBOL "2,147") (* ; "gamma") ("46,145" SYMBOL "2,144") (* ; "delta") ("46,146" SYMBOL "2,145") (* ; "epsilon") ("46,147" SYMBOL "2,126") (* ; "stigma") ("46,150" SYMBOL 0) (* ; "digamma") ("46,151" SYMBOL "2,172") (* ; "zeta") ("46,152" SYMBOL "2,150") (* ; "eta") ("46,153" SYMBOL "2,161") (* ; "theta") ("46,154" SYMBOL "2,151") (* ; "iota") ("46,155" SYMBOL "2,153") (* ; "kappa") ("46,156" SYMBOL "2,154") (* ; "lambda") ("46,157" SYMBOL "2,155") (* ; "mu") ("46,160" SYMBOL "2,156") (* ; "nu") ("46,161" SYMBOL "2,170") (* ; "xi") ("46,162" SYMBOL "2,157") (* ; "omicron") ("46,163" SYMBOL "2,160") (* ; "pi") ("46,164" SYMBOL 0) (* ; "(koppa)") ("46,165" SYMBOL "2,162") (* ; "rho") ("46,166" SYMBOL "2,163") (* ; "sigma") ("46,167" SYMBOL "2,126") (* ; "(fl sigma)") ("46,170" SYMBOL "2,164") (* ; "tau") ("46,171" SYMBOL "2.165") (* ; "upsilon") ("46,172" SYMBOL "2,146") (* ; "phi") ("46,173" SYMBOL "2,143") (* ; "chi") ("46,174" SYMBOL "2,171") (* ; "psi") ("46,175" SYMBOL "2,167") (* ; "omega") (* ;; "NS Miscellaneous symbols") ("041,142" SYMBOL "2,271") (* ; "notequal") ("041,145" SYMBOL "2,243") (* ; "lessequal") ("041,146" SYMBOL "2,263") (* ; "greaterequal") ("041,147" SYMBOL "2,245") (* ; "infinity") ("041,150" SYMBOL "2,134") (* ; "therefore") ("041,155" SYMBOL "2,262") (* ; "second") ("356,055" SYMBOL "2,055") (* ; "minus") ("356,106" SYMBOL "2,340") (* ; "lozenge") ("356,163" SYMBOL "2,351") (* ; "topleftbracket") ("356,164" SYMBOL "2,353") (* ; "bottomleftbracket") ("356,165" SYMBOL "2,352") (* ; "centerbracket") ("356,166" SYMBOL "2,371") (* ; "toprightbracket") ("356,167" SYMBOL "2,373") (* ; "bottomrightbracket") ("356,176" SYMBOL "2,176") (* ; "similar") ("356,314" SYMBOL "2,251") (* ; "heart") ("356,340" SYMBOL "2,374") (* ; "toprightbracce") ("356,341" SYMBOL "2,357") (* ; "braceextend") ("356,342" SYMBOL "2,375") (* ; "centerrightbracce") ("356,343" SYMBOL "2,376") (* ; "bottomrightbracce") ("356,344" SYMBOL "2,354") (* ; "topleftbracce") ("356,345" SYMBOL "2,356") (* ; "bottomleftbracce") ("356,346" SYMBOL "2,355") (* ; "centerleftbracce") ("356,355" SYMBOL "2,363") (* ; "integraltop") ("356,356" SYMBOL "2,365") (* ; "integralbottom") ("356,357" SYMBOL "2,364") (* ; "integralcenter"))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *POSTSCRIPT-NS-HASH*) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS \POSTSCRIPT.FRACTION MACRO ((STREAM STRING) (* ;; "Handle printing of a fraction, given a string that's the name of the PS function (defined in \POSTSCRIPT.JOB.SETUP) that prints it. You must put spaces around the name.") (POSTSCRIPT.SHOWACCUM STREAM) [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] (POSTSCRIPT.OUTSTR STREAM STRING))) ) ) (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 1 sub cvi def" " /yindex y 1 add 2 div bpside mul 1 sub 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" "%% - - - - - Fraction-setting code, to support NS fonts better - - - - -" "/fractiondict 20 dict def" "/fractionshow " "{ fractiondict begin" "/denom exch def " "/num exch def " "/regfont currentfont def" "/fractfont currentfont [.65 0 0 .6 0 0] makefont def " "gsave newpath 0 0 moveto " "(1) true charpath flattenpath pathbbox " "/height exch def pop pop pop" " grestore" "0 .4 height mul rmoveto" "fractfont setfont num show" "0 .4 height mul neg rmoveto regfont setfont (\244) show" "fractfont setfont denom show regfont setfont end } bdef" "/f14 { (1) (4) fractionshow } bdef" "/f12 { (1) (2) fractionshow } bdef" "/f34 { (3) (4) fractionshow } bdef" "/f18 { (1) (8) fractionshow } bdef" "/f38 { (3) (8) fractionshow } bdef" "/f58 { (5) (8) fractionshow } bdef" "/f78 { (7) (8) fractionshow } bdef" "/f13 { (1) (3) fractionshow } bdef" "/f23 { (2) (3) fractionshow } bdef" "/bboxdict 20 dict def" "/bboxchk { bboxdict begin" "/regfont currentfont def" "/chkfont currentfont [1.25 0 0 1.25 0 0] makefont def " "gsave newpath 0 0 moveto " "(\161) true charpath flattenpath pathbbox " "/height exch def pop pop pop " " grestore " " currentpoint " " .2 height mul .3 height mul rmoveto" "chkfont setfont (\063) show" " moveto" " regfont setfont" "(\161) show end } bdef" "/rencdict 15 dict def" "/encodefont { rencdict begin" "/newname exch def" "/oldfont exch def" "/newcodes [" "8#001 /Aacute" "8#002 /Acircumflex" "8#003 /Adieresis" "8#004 /Agrave" "8#005 /Aring" "8#006 /Atilde" "8#007 /Ccedilla" "8#010 /Eacute" "8#011 /Ecircumflex" "8#012 /Edieresis" "8#013 /Egrave" "8#014 /Iacute" "8#015 /Icircumflex" "8#016 /Idieresis" "8#017 /Igrave" "8#020 /Ntilde" "8#021 /Oacute" "8#022 /Ocircumflex" "8#023 /Odieresis" "8#024 /Ograve" "8#025 /Otilde" "8#026 /Scaron" "8#027 /Uacute" "8#030 /Ucircumflex" "8#031 /Udieresis" "8#032 /Ugrave" "8#033 /Ydieresis" "8#034 /Zcaron" "8#177 /periodinferior" "8#201 /aacute" "8#202 /acircumflex" "8#203 /adieresis" "8#204 /agrave" "8#205 /aring" "8#206 /atilde" "8#207 /ccedilla" "8#210 /eacute" "8#211 /ecircumflex" "8#212 /edieresis" "8#213 /egrave" "8#214 /iacute" "8#215 /icircumflex" "8#216 /idieresis" "8#217 /igrave" "8#220 /ntilde" "8#221 /oacute" "8#222 /ocircumflex" "8#223 /odieresis" "8#224 /ograve" "8#225 /otilde" "8#226 /scaron" "8#227 /uacute" "8#230 /ucircumflex" "8#231 /udieresis" "8#232 /ugrave" "8#233 /ydieresis" "8#234 /zcaron" "8#235 /Eth" "8#236 /eth" "8#237 /Thorn" "8#240 /thorn" " ] def" "/olddict oldfont findfont def /newfont olddict maxlength dict def" "olddict { exch dup /FID ne { dup /Encoding eq" "{ exch dup length array copy newfont 3 1 roll put }" "{ exch newfont 3 1 roll put } ifelse }" " { pop pop } ifelse } forall" "newfont /FontName newname put" "newcodes aload pop" "newcodes length 2 idiv { newfont /Encoding get 3 1 roll put } repeat " "newname newfont definefont pop end } def" " /accentdict 10 dict def " " /accentor { accentdict begin /scaler exch def /delta exch def " "/unders exch def /accents exch def /mainch exch def /scrt (X) def" " /w1 mainch stringwidth pop def " " currentpoint mainch show currentpoint 4 2 roll " "accents { /ch exch def 2 copy moveto " " scrt 0 ch put " " /w2 scrt stringwidth pop def " " w1 w2 sub 2 div delta rmoveto scrt show " " /delta delta 150 scaler mul 9 div add def" " } forall " "unders { /ch exch def 2 copy moveto " " scrt 0 ch put " " /w2 scrt stringwidth pop def " " ch 46 eq { w1 w2 sub 2 div -175 scaler mul 9 div rmoveto scrt show 0 175 rmoveto }" " { w1 w2 sub 2 div 0 rmoveto scrt show } ifelse " " } forall " " pop pop moveto end } def " "%%%%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 (COND ((EQ (MACHINETYPE) 'MAIKO) "{dsk}/USR/LOCAL/LDE/FONTS/POSTSCRIPT/") (T "{DSK}POSTSCRIPT>")))) (RPAQ? \POSTSCRIPT.MAX.WILD.FONTSIZE 72) (DEFINEQ (POSTSCRIPTSEND + [LAMBDA (HOST FILE PRINTOPTIONS) (* ; "Edited 20-Nov-95 11:29 by ") + (* ; "Edited 20-Nov-95 11:26 by ") + + (* ;; "This is the send function for generic POSTSCRIPT printers. It branches on the architecture-specific function. The theory is that the send method is really a property of the operating system, not a property of specific postscript printers. These functions are contained in separate library files (or defined by user).") + + (SELECTQ (MKATOM (UNIX-GETPARM "ARCH")) + (dos (DOSPRINT HOST FILE PRINTOPTIONS)) + (UnixPrint HOST FILE PRINTOPTIONS]) ) (ADDTOVAR PRINTERTYPES ((POSTSCRIPT) (CANPRINT (POSTSCRIPT)) (STATUS TRUE) (PROPERTIES NILL) (SEND POSTSCRIPTSEND) (BITMAPSCALE POSTSCRIPT.BITMAPSCALE) (BITMAPFILE (POSTSCRIPT.HARDCOPYW FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)))) (ADDTOVAR POSTSCRIPT.FONT.ALIST (HELVETICA . HELVETICA) (HELVETICAD . HELVETICA) (TIMESROMAN . TIMES) (TIMESROMAND . TIMES) (COURIER . COURIER) (GACHA . COURIER) (CLASSIC . NEWCENTURYSCHLBK) (MODERN . HELVETICA) (CREAM . HELVETICA) (TERMINAL . COURIER) (LOGO . HELVETICA) (OPTIMA . PALATINO) (TITAN . COURIER)) (ADDTOVAR PRINTFILETYPES (POSTSCRIPT (TEST POSTSCRIPTFILEP) (EXTENSION (PS PSC PSF)) (CONVERSION (TEXT POSTSCRIPT.TEXT TEDIT POSTSCRIPT.TEDIT)))) (ADDTOVAR IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM) (FONTCREATE POSTSCRIPT.FONTCREATE) (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE) (CREATECHARSET \CREATECHARSET.PSC))) (RPAQ? POSTSCRIPT.PAGETYPE 'LETTER) (* ;; "NIL means initial clipping is same as paper size. Don't know why the other regions were specified--rmk" ) (APPENDTOVAR POSTSCRIPT.PAGEREGIONS (LETTER (0 0 8.5 11) NIL (-0.1 -0.1 8.7 11.2)) (LEGAL (0 0 8.5 14) NIL (-0.1 -0.1 8.7 14.2)) (NOTE (0 0 8.5 11) NIL (-0.1 -0.1 8.7 11.2))) (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 ( "Venue This program or documentation contains confidential information and trade secrets of Venue. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Venue. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets" 1989 1990 1991 1992 1993 1994 1995 1997 1998 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (22715 29819 (POSTSCRIPT.INIT 22725 . 29817)) (30863 65647 (PSCFONT.READFONT 30873 . 32781) (PSCFONT.SPELLFILE 32783 . 33361) (PSCFONT.COERCEFILE 33363 . 34935) ( PSCFONTFROMCACHE.SPELLFILE 34937 . 35922) (PSCFONTFROMCACHE.COERCEFILE 35924 . 37576) ( PSCFONT.WRITEFONT 37578 . 38593) (READ-AFM-FILE 38595 . 44466) (CONVERT-AFM-FILES 44468 . 45680) ( POSTSCRIPT.GETFONTID 45682 . 47077) (POSTSCRIPT.FONTCREATE 47079 . 59478) ( \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 59480 . 61877) (POSTSCRIPT.FONTSAVAILABLE 61879 . 65645)) (66148 74313 (OPENPOSTSCRIPTSTREAM 66158 . 73979) (CLOSEPOSTSCRIPTSTREAM 73981 . 74311)) (74358 80179 ( POSTSCRIPT.HARDCOPYW 74368 . 77717) (POSTSCRIPT.TEDIT 77719 . 78199) (POSTSCRIPT.TEXT 78201 . 78492) ( POSTSCRIPTFILEP 78494 . 79130) (MAKEEPSFILE 79132 . 80177)) (80180 124442 (POSTSCRIPT.BITMAPSCALE 80190 . 82646) (POSTSCRIPT.CLOSESTRING 82648 . 83182) (POSTSCRIPT.ENDPAGE 83184 . 84055) ( POSTSCRIPT.OUTSTR 84057 . 85078) (POSTSCRIPT.PUTBITMAPBYTES 85080 . 93756) (POSTSCRIPT.PUTCOMMAND 93758 . 94882) (POSTSCRIPT.SET-FAKE-LANDSCAPE 94884 . 100332) (POSTSCRIPT.SHOWACCUM 100334 . 102592) ( POSTSCRIPT.STARTPAGE 102594 . 104249) (\POSTSCRIPTTAB 104251 . 105122) (\PS.BOUTFIXP 105124 . 106474) (\PS.SCALEHACK 106476 . 109305) (\PS.SCALEREGION 109307 . 109867) (\SCALEDBITBLT.PSC 109869 . 114169) (\SETPOS.PSC 114171 . 114633) (\SETXFORM.PSC 114635 . 116454) (\STRINGWIDTH.PSC 116456 . 116910) ( \SWITCHFONTS.PSC 116912 . 123069) (\TERPRI.PSC 123071 . 124440)) (124477 180197 (\BITBLT.PSC 124487 . 125040) (\BLTSHADE.PSC 125042 . 129324) (\CHARWIDTH.PSC 129326 . 130093) (\CREATECHARSET.PSC 130095 . 131793) (\DRAWARC.PSC 131795 . 134275) (\DRAWCIRCLE.PSC 134277 . 136686) (\DRAWCURVE.PSC 136688 . 140709) (\DRAWELLIPSE.PSC 140711 . 143188) (\DRAWLINE.PSC 143190 . 145540) (\DRAWPOINT.PSC 145542 . 146130) (\DRAWPOLYGON.PSC 146132 . 149246) (\DSPBOTTOMMARGIN.PSC 149248 . 149813) ( \DSPCLIPPINGREGION.PSC 149815 . 151258) (\DSPCOLOR.PSC 151260 . 152101) (\DSPFONT.PSC 152103 . 156313) (\DSPLEFTMARGIN.PSC 156315 . 156884) (\DSPLINEFEED.PSC 156886 . 157462) (\DSPPUSHSTATE.PSC 157464 . 159227) (\DSPPOPSTATE.PSC 159229 . 161738) (\DSPRESET.PSC 161740 . 162386) (\DSPRIGHTMARGIN.PSC 162388 . 162960) (\DSPROTATE.PSC 162962 . 163985) (\DSPSCALE.PSC 163987 . 164918) (\DSPSCALE2.PSC 164920 . 165739) (\DSPSPACEFACTOR.PSC 165741 . 166713) (\DSPTOPMARGIN.PSC 166715 . 167432) (\DSPTRANSLATE.PSC 167434 . 170008) (\DSPXPOSITION.PSC 170010 . 170609) (\DSPYPOSITION.PSC 170611 . 171183) ( \FILLCIRCLE.PSC 171185 . 173831) (\FILLPOLYGON.PSC 173833 . 177749) (\FIXLINELENGTH.PSC 177751 . 179245) (\MOVETO.PSC 179247 . 179998) (\NEWPAGE.PSC 180000 . 180195)) (180253 203405 ( \POSTSCRIPT.CHANGECHARSET 180263 . 181067) (\POSTSCRIPT.OUTCHARFN 181069 . 193926) ( \POSTSCRIPT.PRINTSLUG 193928 . 195895) (\POSTSCRIPT.SPECIALOUTCHARFN 195897 . 198329) (\UPDATE.PSC 198331 . 199554) (\POSTSCRIPT.ACCENTFN 199556 . 200498) (\POSTSCRIPT.ACCENTPAIR 200500 . 203403)) ( 203503 205148 (\PSC.SPACEDISP 203513 . 203792) (\PSC.SPACEWID 203794 . 204413) (\PSC.SYMBOLS 204415 . 205146)) (205257 208248 (\POSTSCRIPT.NSHASH 205267 . 208246)) (263291 264005 (POSTSCRIPTSEND 263301 . 264003))))) STOP \ No newline at end of file diff --git a/library/POSTSCRIPTSTREAM.DATABASE b/library/POSTSCRIPTSTREAM.DATABASE new file mode 100644 index 00000000..9d2249ed --- /dev/null +++ b/library/POSTSCRIPTSTREAM.DATABASE @@ -0,0 +1 @@ +(PROGN (PRIN1 "Use LOADDB to load database files! " T) (ERROR!)) (" 8-May-2018 19:34:01" . {DSK}kaplan>Local>medley3.5>lispcore>library>POSTSCRIPTSTREAM.;5) FNS (POSTSCRIPT.INIT PSCFONT.READFONT PSCFONT.SPELLFILE PSCFONT.COERCEFILE PSCFONTFROMCACHE.SPELLFILE PSCFONTFROMCACHE.COERCEFILE PSCFONT.WRITEFONT READ-AFM-FILE CONVERT-AFM-FILES POSTSCRIPT.GETFONTID POSTSCRIPT.FONTCREATE \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS POSTSCRIPT.FONTSAVAILABLE OPENPOSTSCRIPTSTREAM CLOSEPOSTSCRIPTSTREAM POSTSCRIPT.HARDCOPYW POSTSCRIPT.TEDIT POSTSCRIPT.TEXT POSTSCRIPTFILEP MAKEEPSFILE POSTSCRIPT.BITMAPSCALE POSTSCRIPT.CLOSESTRING POSTSCRIPT.ENDPAGE POSTSCRIPT.OUTSTR POSTSCRIPT.PUTBITMAPBYTES POSTSCRIPT.PUTCOMMAND POSTSCRIPT.SET-FAKE-LANDSCAPE POSTSCRIPT.SHOWACCUM POSTSCRIPT.STARTPAGE \POSTSCRIPTTAB \PS.BOUTFIXP \PS.SCALEHACK \PS.SCALEREGION \SCALEDBITBLT.PSC \SETPOS.PSC \SETXFORM.PSC \STRINGWIDTH.PSC \SWITCHFONTS.PSC \TERPRI.PSC \BITBLT.PSC \BLTSHADE.PSC \CHARWIDTH.PSC \CREATECHARSET.PSC \DRAWARC.PSC \DRAWCIRCLE.PSC \DRAWCURVE.PSC \DRAWELLIPSE.PSC \DRAWLINE.PSC \DRAWPOINT.PSC \DRAWPOLYGON.PSC \DSPBOTTOMMARGIN.PSC \DSPCLIPPINGREGION.PSC \DSPCOLOR.PSC \DSPFONT.PSC \DSPLEFTMARGIN.PSC \DSPLINEFEED.PSC \DSPPUSHSTATE.PSC \DSPPOPSTATE.PSC \DSPRESET.PSC \DSPRIGHTMARGIN.PSC \DSPROTATE.PSC \DSPSCALE.PSC \DSPSCALE2.PSC \DSPSPACEFACTOR.PSC \DSPTOPMARGIN.PSC \DSPTRANSLATE.PSC \DSPXPOSITION.PSC \DSPYPOSITION.PSC \FILLCIRCLE.PSC \FILLPOLYGON.PSC \FIXLINELENGTH.PSC \MOVETO.PSC \NEWPAGE.PSC \POSTSCRIPT.CHANGECHARSET \POSTSCRIPT.OUTCHARFN \POSTSCRIPT.PRINTSLUG \POSTSCRIPT.SPECIALOUTCHARFN \UPDATE.PSC \POSTSCRIPT.ACCENTFN \POSTSCRIPT.ACCENTPAIR \PSC.SPACEDISP \PSC.SPACEWID \PSC.SYMBOLS \POSTSCRIPT.NSHASH POSTSCRIPTSEND) (READATABASE) ( CALL POSTSCRIPT.INIT (CL:REMOVE-DUPLICATES NCONC MAPCONC MAPCAR ASSOC EVALV RPLACD FONTUNPARSE REPLACEFIELD CONS FETCHFIELD MAPC CL:NTHCDR NCONC1 BQUOTE LIST CL:FIFTH CL:FOURTH CL:THIRD FONTSAVAILABLE APPLY CL:MAKE-ARRAY CL:AREF PLUS FUNCTION HARRAY \POSTSCRIPT.NSHASH) PSCFONT.READFONT ( OPENSTREAM READ FIND-READTABLE BIN \WIN IPLUS LLSH \BIN ARRAY PLUS - CONS L-CASE FILENAMEFIELD) PSCFONT.SPELLFILE (CL:WHEN \FINDFONTFILE FASSOC) PSCFONT.COERCEFILE (PSCFONT.SPELLFILE LIST) PSCFONTFROMCACHE.SPELLFILE (ASSOC L-CASE FILENAMEFIELD \FONTFILENAME FASSOC) PSCFONTFROMCACHE.COERCEFILE (PSCFONTFROMCACHE.SPELLFILE LIST) PSCFONT.WRITEFONT (OPENSTREAM FIND-READTABLE \BOUT ELT PLUS) READ-AFM-FILE (OPENSTREAM ARRAY RSTRING FONTCREATE printout MENU TERPRI LIST POSTSCRIPT.GETFONTID READ IABS IMINUS IPLUS FIXR FTIMES / RATOM READCCODE LISTGET PLUS) CONVERT-AFM-FILES (MAPC READ-AFM-FILE \FONTFILENAME LIST) POSTSCRIPT.GETFONTID (CONSTANT TAN TIMES QUOTIENT) POSTSCRIPT.FONTCREATE (PSCFONTFROMCACHE.SPELLFILE PSCFONT.SPELLFILE PSCFONT.READFONT PSCFONTFROMCACHE.COERCEFILE PSCFONT.COERCEFILE FIXR TIMES POSTSCRIPT.GETFONTID FONTCREATE LISTGET LIST IPLUS \GETCHARSETINFO \GETBASEPTR UNFOLD LLSH \CREATECHARSET \PUTBASE ELT PLUS \CREATECSINFOELEMENT \ALLOCBLOCK FOLDHI LRSH \FGETWIDTH \GETBASE \FONTINFOFROMFILENAME COPY \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS (PSCFONT.SPELLFILE PSCFONTFROMCACHE.SPELLFILE PSCFONT.READFONT CL:WHEN ARRAY FIXR TIMES ELT PLUS) POSTSCRIPT.FONTSAVAILABLE (\FONTFILENAME ASSOC MAPCAR CONS MAPCONC DIRECTORY CONCAT \FONTINFOFROMFILENAME RPLACA LIST COPY PLUS) OPENPOSTSCRIPTSTREAM (OPENSTREAM BQUOTE CONS LIST LISTGET OUTPUT CL:MULTIPLE-VALUE-PROG1 .UNWIND.PROTECT. FUNCTION PRINTOUT CL:FLOOR CL:CEILING TERPRI MKSTRING DATE FILENAMEFIELD \FILEOUTCHARFN CL:ASSOC CL:FUNCTION ERROR L-CASE NUMBERP TIMES \PS.SCALEREGION / INTERSECTREGIONS CREATEREGION PLUS FONTCREATE MKLIST CL:GETF) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW (OPENPOSTSCRIPTSTREAM LIST COPY + - TIMES PLUS QUOTIENT DIFFERENCE FULLNAME) POSTSCRIPT.TEDIT (MKATOM OPENTEXTSTREAM) POSTSCRIPT.TEXT (TEXTTOIMAGEFILE BQUOTE LIST) POSTSCRIPTFILEP (CL:MEMBER UNPACKFILENAME.STRING FUNCTION BIN) MAKEEPSFILE (OPENIMAGESTREAM BQUOTE APPLY* IMAGEOBJPROP LIST CLOSEF) POSTSCRIPT.BITMAPSCALE (\PS.SCALEREGION / FASSOC MAX MIN FQUOTIENT TIMES MENU CONS) POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR (\PS.BOUTFIXP SUB1 IPLUS ADD1 \GETBASEFAT \GETBASE \CHAR8CODE LOGAND \BOUTS \GETBASETHIN \GETBASEBYTE BOUT FLOAT MAPC CHCON) POSTSCRIPT.PUTBITMAPBYTES (LRSH IPLUS LSH SUB1 ITIMES \GETBASEBYTE LOGAND PLUS IMINUS \FILEOUTCHARFN BITMAPCREATE ADD1 IDIFFERENCE) POSTSCRIPT.PUTCOMMAND (ARG PLUS) POSTSCRIPT.SET-FAKE-LANDSCAPE (- +) POSTSCRIPT.SHOWACCUM (STREAMPROP CONCAT DIFFERENCE CONSTANT) POSTSCRIPT.STARTPAGE (FQUOTIENT \DSPFONT.PSC CONSTANT TIMES \DSPRESET.PSC) \POSTSCRIPTTAB (TIMES IDIFFERENCE IREMAINDER) \PS.BOUTFIXP (IMINUS BOUT IPLUS SUB1 IREMAINDER IQUOTIENT PLUS \BOUTS IDIFFERENCE MAPC CHCON \CHAR8CODE LOGAND) \PS.SCALEHACK (/ LIST RPLACA FIXR CL:* FETCHFIELD) \PS.SCALEREGION (FIXR TIMES) \SCALEDBITBLT.PSC (NUMBERP TIMES INTERSECTREGIONS CREATEREGION BITMAPCREATE) \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC (\STRINGWIDTH.GENERIC) \SWITCHFONTS.PSC (LISTGET MEMB CONCAT TIMES) \TERPRI.PSC (PLUS IPLUS) \BITBLT.PSC (\SCALEDBITBLT.PSC) \BLTSHADE.PSC (CREATEREGION INTERSECTREGIONS CL:1- SELECT BITMAPCREATE MIN QUOTIENT MINUS LSH TIMES DSPSCALE) \CHARWIDTH.PSC (\FGETCHARWIDTH \FGETWIDTH \GETBASE \GETCHARSETINFO \GETBASEPTR UNFOLD LLSH \CHARSET LRSH \CREATECHARSET \CHAR8CODE LOGAND) \CREATECHARSET.PSC (CHARWIDTH MAX FIXR FTIMES FONTPROP \PUTBASE PLUS) \DRAWARC.PSC (TERPRI POSTSCRIPT.PUTCOMMAND TIMES + \MOVETO.PSC) \DRAWCIRCLE.PSC ( TERPRI POSTSCRIPT.PUTCOMMAND TIMES \MOVETO.PSC) \DRAWCURVE.PSC (TERPRI TIMES PARAMETRICSPLINE SELECTQ ELT FQUOTIENT FPLUS FDIFFERENCE PLUS) \DRAWELLIPSE.PSC (TERPRI TIMES \MOVETO.PSC) \DRAWLINE.PSC ( FLOATP POSTSCRIPT.PUTCOMMAND TIMES) \DRAWPOINT.PSC (BITBLT - IQUOTIENT \DRAWLINE.PSC) \DRAWPOLYGON.PSC (LAST TERPRI TIMES SELECTQ POSTSCRIPT.PUTCOMMAND \MOVETO.PSC) \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC (\COERCEFONTDESC FONTCOPY IMINUS FIXR TIMES \FGETWIDTH \GETBASE LISTGET) \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC ( REPLACEFIELD CONS COPY FETCHFIELD) \DSPPOPSTATE.PSC (FETCHFIELD) \DSPRESET.PSC (\MOVETO.PSC DIFFERENCE FONTPROP) \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC (QUOTIENT) \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC (FIXR TIMES) \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC (DIFFERENCE LIST) \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC (BITMAPCREATE MIN LSH TIMES QUOTIENT DSPSCALE \MOVETO.PSC) \FILLPOLYGON.PSC (LAST BITMAPCREATE MIN POSTSCRIPT.PUTCOMMAND LSH TIMES QUOTIENT DSPSCALE \MOVETO.PSC) \FIXLINELENGTH.PSC (MIN FIX QUOTIENT DIFFERENCE) \MOVETO.PSC NIL \NEWPAGE.PSC ( POSTSCRIPT.STARTPAGE) \POSTSCRIPT.CHANGECHARSET (PROG* \GETCHARSETINFO \GETBASEPTR UNFOLD LLSH \CREATECHARSET) \POSTSCRIPT.OUTCHARFN (\CHARSET LRSH \POSTSCRIPT.CHANGECHARSET SELCHARQ \FGETWIDTH \GETBASE \CHAR8CODE LOGAND IPLUS GETHASH \POSTSCRIPTTAB \DSPFONT.PSC LIST) \POSTSCRIPT.PRINTSLUG ( \FGETWIDTH \GETBASE \CHAR8CODE LOGAND \MOVETO.PSC IPLUS) \POSTSCRIPT.SPECIALOUTCHARFN (\DSPFONT.PSC LIST IPLUS LOGAND LRSH) \UPDATE.PSC (\SETPOS.PSC) \POSTSCRIPT.ACCENTFN (SUBSTRING CONCAT OCTALSTRING SUB1 IPLUS ADD1 \GETBASEFAT \GETBASE \GETBASETHIN \GETBASEBYTE) \POSTSCRIPT.ACCENTPAIR (SUBSTRING CONCAT OCTALSTRING SUB1 IPLUS ADD1 \GETBASEFAT \GETBASE \GETBASETHIN \GETBASEBYTE IEQP / FONTPROP) \PSC.SPACEDISP (POSTSCRIPT.PUTCOMMAND \PSC.SPACEWID DSPFONT) \PSC.SPACEWID (FIXR FTIMES CHARWIDTH CHARCODE.DECODE) \PSC.SYMBOLS (\DSPFONT.PSC LIST) \POSTSCRIPT.NSHASH (CHARCODE.DECODE DESTRUCTURING-BIND CONS SELECTQ LIST APPLY* FUNCTION ERROR CL:AREF) POSTSCRIPTSEND (SELECTQ MKATOM UNIX-GETPARM DOSPRINT UnixPrint) NIL BIND POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE (ROTATION) PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE (ROTATION DEVICE) PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT ( *READTABLE*) READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE (ROTATION) OPENPOSTSCRIPTSTREAM (SI::*RESETFORMS*) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE (BOUNDINGBOX) POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC (TEXTURE CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC (OPERATION) \CHARWIDTH.PSC NIL \CREATECHARSET.PSC (FAMILY SIZE FACE ROTATION DEVICE NOSLUG?) \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC (LAND C0 P0 C P ML MB MR MT) \DSPSCALE.PSC NIL \DSPSCALE2.PSC (OSCALE NSCALE) \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC (OPERATION) \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN (FONT) \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL NLAMBDA POSTSCRIPT.INIT (CHARCODE) PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE ( CHARCODE) CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE (CHARCODE) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM ( CL:UNWIND-PROTECT CHARCODE) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP (CHARCODE) MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR (CHARCODE) POSTSCRIPT.PUTBITMAPBYTES (CHARCODE) POSTSCRIPT.PUTCOMMAND (CHARCODE) POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM (CHARCODE) POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP (CHARCODE ) \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC (CHARCODE) \CREATECHARSET.PSC (CHARCODE) \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC (CHARCODE) \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN (CHARCODE) \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN (CHARCODE) \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN (CHARCODE) \POSTSCRIPT.ACCENTPAIR (CHARCODE) \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL NOBIND POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL RECORD POSTSCRIPT.INIT (FONTCLASS) PSCFONT.READFONT (PSCFONT) PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT (PSCFONT) READ-AFM-FILE (PSCFONT MENU) CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID (FONTID) POSTSCRIPT.FONTCREATE (PSCFONT FONTDESCRIPTOR CHARSETINFO) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS (FONTDESCRIPTOR PSCFONT) POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM (STREAM \POSTSCRIPTDATA REGION) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW (STREAM \POSTSCRIPTDATA REGION) POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE (REGION) POSTSCRIPT.CLOSESTRING (STREAM \POSTSCRIPTDATA) POSTSCRIPT.ENDPAGE (STREAM \POSTSCRIPTDATA) POSTSCRIPT.OUTSTR (STRINGP LITATOM PNAMEBASE) POSTSCRIPT.PUTBITMAPBYTES (ARRAYP) POSTSCRIPT.PUTCOMMAND (STREAM \POSTSCRIPTDATA) POSTSCRIPT.SET-FAKE-LANDSCAPE (STREAM \POSTSCRIPTDATA REGION) POSTSCRIPT.SHOWACCUM (STREAM \POSTSCRIPTDATA) POSTSCRIPT.STARTPAGE (STREAM \POSTSCRIPTDATA) \POSTSCRIPTTAB (\POSTSCRIPTDATA) \PS.BOUTFIXP (ARRAYP \POSTSCRIPTDATA STREAM) \PS.SCALEHACK (STREAM \POSTSCRIPTDATA REGION) \PS.SCALEREGION (REGION) \SCALEDBITBLT.PSC (STREAM \POSTSCRIPTDATA) \SETPOS.PSC (\POSTSCRIPTDATA) \SETXFORM.PSC (\POSTSCRIPTDATA REGION) \STRINGWIDTH.PSC (STREAM \POSTSCRIPTDATA) \SWITCHFONTS.PSC (\POSTSCRIPTDATA PSCFONT FONTDESCRIPTOR FONTID) \TERPRI.PSC (STREAM \POSTSCRIPTDATA FONTDESCRIPTOR) \BITBLT.PSC NIL \BLTSHADE.PSC (STREAM \POSTSCRIPTDATA REGION) \CHARWIDTH.PSC (\POSTSCRIPTDATA STREAM CHARSETINFO) \CREATECHARSET.PSC (CHARSETINFO) \DRAWARC.PSC ( STREAM \POSTSCRIPTDATA) \DRAWCIRCLE.PSC (STREAM \POSTSCRIPTDATA) \DRAWCURVE.PSC (STREAM \POSTSCRIPTDATA) \DRAWELLIPSE.PSC (STREAM \POSTSCRIPTDATA) \DRAWLINE.PSC (STREAM \POSTSCRIPTDATA) \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC (STREAM \POSTSCRIPTDATA POSITION) \DSPBOTTOMMARGIN.PSC ( \POSTSCRIPTDATA STREAM) \DSPCLIPPINGREGION.PSC (STREAM \POSTSCRIPTDATA REGION) \DSPCOLOR.PSC ( \POSTSCRIPTDATA STREAM) \DSPFONT.PSC (STREAM \POSTSCRIPTDATA FONTDESCRIPTOR PSCFONT FONTID) \DSPLEFTMARGIN.PSC (STREAM \POSTSCRIPTDATA) \DSPLINEFEED.PSC (\POSTSCRIPTDATA STREAM) \DSPPUSHSTATE.PSC (STREAM \POSTSCRIPTDATA) \DSPPOPSTATE.PSC (STREAM \POSTSCRIPTDATA POSTSCRIPTXFORM) \DSPRESET.PSC (STREAM \POSTSCRIPTDATA) \DSPRIGHTMARGIN.PSC (STREAM \POSTSCRIPTDATA) \DSPROTATE.PSC ( STREAM \POSTSCRIPTDATA) \DSPSCALE.PSC (STREAM \POSTSCRIPTDATA) \DSPSCALE2.PSC (STREAM \POSTSCRIPTDATA) \DSPSPACEFACTOR.PSC (STREAM \POSTSCRIPTDATA) \DSPTOPMARGIN.PSC (\POSTSCRIPTDATA STREAM) \DSPTRANSLATE.PSC (STREAM \POSTSCRIPTDATA REGION) \DSPXPOSITION.PSC (STREAM \POSTSCRIPTDATA) \DSPYPOSITION.PSC (STREAM \POSTSCRIPTDATA) \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC (POSITION) \FIXLINELENGTH.PSC (\POSTSCRIPTDATA STREAM) \MOVETO.PSC (STREAM \POSTSCRIPTDATA) \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET (CHARSETINFO) \POSTSCRIPT.OUTCHARFN (STREAM \POSTSCRIPTDATA FONTDESCRIPTOR) \POSTSCRIPT.PRINTSLUG (STREAM \POSTSCRIPTDATA FONTDESCRIPTOR) \POSTSCRIPT.SPECIALOUTCHARFN (STREAM FONTDESCRIPTOR \POSTSCRIPTDATA) \UPDATE.PSC (\POSTSCRIPTDATA) \POSTSCRIPT.ACCENTFN (STREAM \POSTSCRIPTDATA STRINGP) \POSTSCRIPT.ACCENTPAIR (STREAM \POSTSCRIPTDATA STRINGP) \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS (STREAM FONTDESCRIPTOR) \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL CREATE POSTSCRIPT.INIT (IMAGEOPS) PSCFONT.READFONT (PSCFONT) PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE (PSCFONT) PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE (PSCFONT MENU) CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID (FONTID) POSTSCRIPT.FONTCREATE (FONTDESCRIPTOR) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM (\POSTSCRIPTDATA) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW (REGION) POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE (REGION) POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION (REGION ) \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC (CHARSETINFO) \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC ( POSTSCRIPTXFORM) \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL FETCH POSTSCRIPT.INIT (INTERPRESSFD PRESSFD DISPLAYFD OTHERFDS) PSCFONT.READFONT (DESCENT) PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT (WIDTHS FID HIBYTE LOBYTE FIRSTCHAR LASTCHAR ASCENT DESCENT) READ-AFM-FILE (FID ASCENT DESCENT) CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID (FONTXFACTOR) POSTSCRIPT.FONTCREATE (ASCENT DESCENT FID OTHERDEVICEFONTPROPS WIDTHS FONTCHARSETVECTOR FONTDEVICESPEC ) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS (FONTSIZE FONTFACE WIDTHS) POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM (LEFT BOTTOM HEIGHT WIDTH POSTSCRIPTFONT) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW (IMAGEDATA POSTSCRIPTCLIPPINGREGION BITMAPWIDTH LEFT WIDTH BITMAPHEIGHT BOTTOM HEIGHT POSTSCRIPTSCALE) POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE ( XSIZE YSIZE XKERN YDESC) POSTSCRIPT.BITMAPSCALE (WIDTH HEIGHT) POSTSCRIPT.CLOSESTRING (IMAGEDATA POSTSCRIPTCHARSTOSHOW) POSTSCRIPT.ENDPAGE (IMAGEDATA POSTSCRIPTPAGEBLANK) POSTSCRIPT.OUTSTR ( FATSTRINGP OFFST BASE LENGTH PNAMEBASE PNAMELENGTH FATPNAMEP) POSTSCRIPT.PUTBITMAPBYTES (BITMAPWIDTH BITMAPHEIGHT BITMAPBASE BITMAPRASTERWIDTH BASE) POSTSCRIPT.PUTCOMMAND (IMAGEDATA POSTSCRIPTCHARSTOSHOW POSTSCRIPTPENDINGXFORM) POSTSCRIPT.SET-FAKE-LANDSCAPE (IMAGEDATA POSTSCRIPTLANDSCAPE POSTSCRIPTCLIPPINGREGION POSTSCRIPTPAGEREGION HEIGHT WIDTH BOTTOM LEFT POSTSCRIPTBOTTOMMARGIN POSTSCRIPTRIGHTMARGIN POSTSCRIPTTOPMARGIN POSTSCRIPTLEFTMARGIN) POSTSCRIPT.SHOWACCUM (IMAGEDATA POSTSCRIPTCHARSTOSHOW POSTSCRIPTSPACEFACTOR POSTSCRIPTSPACEWIDTH POSTSCRIPTNATURALSPACEWIDTH) POSTSCRIPT.STARTPAGE (IMAGEDATA POSTSCRIPTPAGENUM POSTSCRIPTHEADING POSTSCRIPTHEADINGFONT) \POSTSCRIPTTAB (FONTAVGCHARWIDTH POSTSCRIPTFONT POSTSCRIPTX POSTSCRIPTLEFTMARGIN) \PS.BOUTFIXP (BASE POSTSCRIPTTEMPARRAY IMAGEDATA) \PS.SCALEHACK (IMAGEDATA POSTSCRIPTSCALEHACK POSTSCRIPTCLIPPINGREGION POSTSCRIPTPAGEREGION LEFT BOTTOM WIDTH HEIGHT POSTSCRIPTX POSTSCRIPTY POSTSCRIPTLEFTMARGIN POSTSCRIPTRIGHTMARGIN POSTSCRIPTBOTTOMMARGIN POSTSCRIPTTOPMARGIN POSTSCRIPTTRANSX POSTSCRIPTTRANSY) \PS.SCALEREGION (LEFT BOTTOM WIDTH HEIGHT) \SCALEDBITBLT.PSC (IMAGEDATA POSTSCRIPTSCALE BITMAPWIDTH BITMAPHEIGHT POSTSCRIPTX POSTSCRIPTY POSTSCRIPTCLIPPINGREGION) \SETPOS.PSC (POSTSCRIPTX POSTSCRIPTY) \SETXFORM.PSC (POSTSCRIPTCLIPPINGREGION POSTSCRIPTSCALEHACK POSTSCRIPTLANDSCAPE POSTSCRIPTROTATION POSTSCRIPTTRANSX POSTSCRIPTTRANSY HEIGHT WIDTH LEFT BOTTOM) \STRINGWIDTH.PSC (IMAGEDATA POSTSCRIPTFONT POSTSCRIPTSPACEWIDTH) \SWITCHFONTS.PSC (POSTSCRIPTFONT IL-FONTID OTHERDEVICEFONTPROPS FONTIDNAME POSTSCRIPTFONTSUSED FONTXFACTOR FONTSIZE FONTOBLIQUEFACTOR) \TERPRI.PSC (IMAGEDATA POSTSCRIPTY POSTSCRIPTLINESPACING POSTSCRIPTBOTTOMMARGIN \SFDescent POSTSCRIPTFONT POSTSCRIPTLEFTMARGIN) \BITBLT.PSC NIL \BLTSHADE.PSC (IMAGEDATA POSTSCRIPTCLIPPINGREGION LEFT BOTTOM WIDTH HEIGHT BITMAPWIDTH BITMAPHEIGHT BITMAPRASTERWIDTH) \CHARWIDTH.PSC (POSTSCRIPTSPACEWIDTH IMAGEDATA WIDTHS FONTCHARSETVECTOR POSTSCRIPTFONT) \CREATECHARSET.PSC (WIDTHS) \DRAWARC.PSC (IMAGEDATA BRUSHSHAPE BRUSHSIZE BRUSHCOLOR POSTSCRIPTSCALE) \DRAWCIRCLE.PSC (IMAGEDATA BRUSHSHAPE BRUSHSIZE BRUSHCOLOR POSTSCRIPTSCALE) \DRAWCURVE.PSC (IMAGEDATA BRUSHSIZE BRUSHSHAPE BRUSHCOLOR POSTSCRIPTSCALE) \DRAWELLIPSE.PSC (IMAGEDATA BRUSHSHAPE BRUSHSIZE BRUSHCOLOR POSTSCRIPTSCALE) \DRAWLINE.PSC (IMAGEDATA POSTSCRIPTSCALE) \DRAWPOINT.PSC (BITMAPWIDTH BITMAPHEIGHT) \DRAWPOLYGON.PSC (IMAGEDATA BRUSHSIZE BRUSHSHAPE BRUSHCOLOR POSTSCRIPTSCALE XCOORD YCOORD) \DSPBOTTOMMARGIN.PSC (POSTSCRIPTBOTTOMMARGIN IMAGEDATA) \DSPCLIPPINGREGION.PSC (IMAGEDATA POSTSCRIPTCLIPPINGREGION LEFT BOTTOM WIDTH HEIGHT) \DSPCOLOR.PSC (POSTSCRIPTCOLOR IMAGEDATA) \DSPFONT.PSC (IMAGEDATA POSTSCRIPTFONT \SFHeight POSTSCRIPTSPACEFACTOR POSTSCRIPTWIDTHS IL-FONTID OTHERDEVICEFONTPROPS FONTIDNAME) \DSPLEFTMARGIN.PSC ( IMAGEDATA POSTSCRIPTLEFTMARGIN) \DSPLINEFEED.PSC (POSTSCRIPTLINESPACING IMAGEDATA) \DSPPUSHSTATE.PSC ( IMAGEDATA POSTSCRIPTXFORMSTACK POSTSCRIPTCLIPPINGREGION POSTSCRIPTPAGEREGION POSTSCRIPTLEFTMARGIN POSTSCRIPTRIGHTMARGIN POSTSCRIPTTOPMARGIN POSTSCRIPTBOTTOMMARGIN POSTSCRIPTTRANSX POSTSCRIPTTRANSY POSTSCRIPTLANDSCAPE POSTSCRIPTPENDINGXFORM) \DSPPOPSTATE.PSC (IMAGEDATA POSTSCRIPTXFORMSTACK PSXCLIP PSXPAGE PSXBOTTOM PSXTOP PSXLEFT PSXRIGHT PSXLAND PSXXFORMPEND PSXTRANX PSXTRANY) \DSPRESET.PSC ( IMAGEDATA POSTSCRIPTLEFTMARGIN POSTSCRIPTTOPMARGIN POSTSCRIPTFONT) \DSPRIGHTMARGIN.PSC (IMAGEDATA POSTSCRIPTRIGHTMARGIN) \DSPROTATE.PSC (IMAGEDATA POSTSCRIPTROTATION) \DSPSCALE.PSC (IMAGEDATA POSTSCRIPTSCALE) \DSPSCALE2.PSC (IMAGEDATA POSTSCRIPTSCALE) \DSPSPACEFACTOR.PSC (IMAGEDATA POSTSCRIPTSPACEFACTOR POSTSCRIPTNATURALSPACEWIDTH) \DSPTOPMARGIN.PSC (POSTSCRIPTTOPMARGIN IMAGEDATA) \DSPTRANSLATE.PSC (IMAGEDATA POSTSCRIPTTRANSX POSTSCRIPTTRANSY POSTSCRIPTCLIPPINGREGION POSTSCRIPTPAGEREGION LEFT BOTTOM POSTSCRIPTX POSTSCRIPTY POSTSCRIPTLEFTMARGIN POSTSCRIPTRIGHTMARGIN POSTSCRIPTBOTTOMMARGIN POSTSCRIPTTOPMARGIN) \DSPXPOSITION.PSC (IMAGEDATA POSTSCRIPTX POSTSCRIPTY) \DSPYPOSITION.PSC (IMAGEDATA POSTSCRIPTY POSTSCRIPTX) \FILLCIRCLE.PSC (BITMAPWIDTH BITMAPHEIGHT BITMAPRASTERWIDTH) \FILLPOLYGON.PSC (BITMAPWIDTH BITMAPHEIGHT XCOORD YCOORD BITMAPRASTERWIDTH) \FIXLINELENGTH.PSC (POSTSCRIPTRIGHTMARGIN POSTSCRIPTLEFTMARGIN FONTAVGCHARWIDTH POSTSCRIPTFONT) \MOVETO.PSC (IMAGEDATA POSTSCRIPTX POSTSCRIPTY) \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET ( POSTSCRIPTFONT FONTCHARSETVECTOR WIDTHS) \POSTSCRIPT.OUTCHARFN (IMAGEDATA POSTSCRIPTX POSTSCRIPTFONT POSTSCRIPTNSCHARSET POSTSCRIPTSPACEWIDTH POSTSCRIPTWIDTHS POSTSCRIPTACCENTED POSTSCRIPTRIGHTMARGIN POSTSCRIPTCHARSTOSHOW POSTSCRIPTY FONTSIZE FONTFACE) \POSTSCRIPT.PRINTSLUG (IMAGEDATA POSTSCRIPTX POSTSCRIPTY POSTSCRIPTWIDTHS \SFAscent POSTSCRIPTFONT) \POSTSCRIPT.SPECIALOUTCHARFN (IMAGEDATA FONTSIZE FONTFACE POSTSCRIPTCHARSTOSHOW) \UPDATE.PSC (POSTSCRIPTPENDINGXFORM POSTSCRIPTFONTCHANGEDFLG POSTSCRIPTMOVEFLG) \POSTSCRIPT.ACCENTFN (IMAGEDATA POSTSCRIPTCHARSTOSHOW OFFST BASE LENGTH FATSTRINGP) \POSTSCRIPT.ACCENTPAIR (IMAGEDATA POSTSCRIPTFONT OFFST BASE LENGTH FATSTRINGP \SFAscent) \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS (IMAGEDATA FONTSIZE FONTFACE) \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL REPLACE POSTSCRIPT.INIT (OTHERFDS IMAGETYPE IMCLOSEFN IMXPOSITION IMYPOSITION IMMOVETO IMFONT IMLEFTMARGIN IMRIGHTMARGIN IMLINEFEED IMDRAWLINE IMDRAWCURVE IMDRAWCIRCLE IMDRAWELLIPSE IMFILLCIRCLE IMBLTSHADE IMBITBLT IMSCALEDBITBLT IMNEWPAGE IMSCALE IMSCALE2 IMCOLOR IMTERPRI IMTOPMARGIN IMBOTTOMMARGIN IMSPACEFACTOR IMFONTCREATE IMCLIPPINGREGION IMRESET IMDRAWPOLYGON IMFILLPOLYGON IMSTRINGWIDTH IMCHARWIDTH IMDRAWARC IMROTATE IMTRANSLATE IMDRAWPOINT IMPUSHSTATE IMPOPSTATE) PSCFONT.READFONT (FID IL-FONTID FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTHS) PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE (ITEMS MENUFONT FID IL-FONTID DESCENT ASCENT WIDTHS FIRSTCHAR LASTCHAR) CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID (FONTIDNAME FONTXFACTOR FONTOBLIQUEFACTOR) POSTSCRIPT.FONTCREATE (IL-FONTID OTHERDEVICEFONTPROPS FONTSCALE FONTDEVICE FONTFAMILY FONTSIZE FONTFACE ROTATION \SFHeight \SFAscent \SFDescent FONTDEVICESPEC) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM (OUTCHARFN IMAGEDATA IMAGEOPS POSTSCRIPTSCALE POSTSCRIPTPAGEREGION POSTSCRIPTCLIPPINGREGION POSTSCRIPTLEFTMARGIN POSTSCRIPTBOTTOMMARGIN POSTSCRIPTTOPMARGIN POSTSCRIPTRIGHTMARGIN POSTSCRIPTHEADING POSTSCRIPTHEADINGFONT) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW (WIDTH HEIGHT LEFT BOTTOM) POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING (POSTSCRIPTCHARSTOSHOW) POSTSCRIPT.ENDPAGE (POSTSCRIPTPENDINGXFORM POSTSCRIPTFONTSUSED) POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND ( POSTSCRIPTPAGEBLANK) POSTSCRIPT.SET-FAKE-LANDSCAPE (WIDTH HEIGHT LEFT BOTTOM POSTSCRIPTCLIPPINGREGION POSTSCRIPTPAGEREGION POSTSCRIPTLEFTMARGIN POSTSCRIPTBOTTOMMARGIN POSTSCRIPTRIGHTMARGIN POSTSCRIPTTOPMARGIN POSTSCRIPTLANDSCAPE POSTSCRIPTPENDINGXFORM) POSTSCRIPT.SHOWACCUM ( POSTSCRIPTCHARSTOSHOW) POSTSCRIPT.STARTPAGE (POSTSCRIPTPENDINGXFORM POSTSCRIPTFONTCHANGEDFLG POSTSCRIPTPAGEBLANK) \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK (LEFT BOTTOM WIDTH HEIGHT POSTSCRIPTX POSTSCRIPTY POSTSCRIPTLEFTMARGIN POSTSCRIPTRIGHTMARGIN POSTSCRIPTBOTTOMMARGIN POSTSCRIPTTOPMARGIN POSTSCRIPTTRANSX POSTSCRIPTTRANSY POSTSCRIPTSCALEHACK POSTSCRIPTPENDINGXFORM) \PS.SCALEREGION (LEFT BOTTOM WIDTH HEIGHT) \SCALEDBITBLT.PSC NIL \SETPOS.PSC (POSTSCRIPTMOVEFLG) \SETXFORM.PSC (POSTSCRIPTPENDINGXFORM POSTSCRIPTMOVEFLG POSTSCRIPTFONTCHANGEDFLG) \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC (POSTSCRIPTACCENTED POSTSCRIPTFONTCHANGEDFLG) \TERPRI.PSC (CHARPOSITION) \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC (OFFSETS IMAGEWIDTHS) \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC (POSTSCRIPTX POSTSCRIPTY POSTSCRIPTMOVEFLG) \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC ( POSTSCRIPTBOTTOMMARGIN) \DSPCLIPPINGREGION.PSC (POSTSCRIPTCLIPPINGREGION POSTSCRIPTPENDINGXFORM) \DSPCOLOR.PSC (POSTSCRIPTCOLOR) \DSPFONT.PSC (POSTSCRIPTFONT POSTSCRIPTSPACEWIDTH POSTSCRIPTNATURALSPACEWIDTH POSTSCRIPTACCENTED POSTSCRIPTFONTCHANGEDFLG) \DSPLEFTMARGIN.PSC ( POSTSCRIPTLEFTMARGIN) \DSPLINEFEED.PSC (POSTSCRIPTLINESPACING) \DSPPUSHSTATE.PSC (POSTSCRIPTXFORMSTACK PSXCLIP PSXPAGE PSXLEFT PSXRIGHT PSXTOP PSXBOTTOM PSXTRANX PSXTRANY PSXLAND PSXXFORMPEND) \DSPPOPSTATE.PSC (POSTSCRIPTXFORMSTACK POSTSCRIPTCLIPPINGREGION POSTSCRIPTPAGEREGION POSTSCRIPTBOTTOMMARGIN POSTSCRIPTTOPMARGIN POSTSCRIPTLEFTMARGIN POSTSCRIPTRIGHTMARGIN POSTSCRIPTLANDSCAPE POSTSCRIPTPENDINGXFORM POSTSCRIPTTRANSX POSTSCRIPTTRANSY) \DSPRESET.PSC ( CHARPOSITION) \DSPRIGHTMARGIN.PSC (POSTSCRIPTRIGHTMARGIN) \DSPROTATE.PSC (POSTSCRIPTROTATION POSTSCRIPTPENDINGXFORM) \DSPSCALE.PSC (POSTSCRIPTSCALE) \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC ( POSTSCRIPTSPACEFACTOR POSTSCRIPTSPACEWIDTH) \DSPTOPMARGIN.PSC (POSTSCRIPTTOPMARGIN) \DSPTRANSLATE.PSC (POSTSCRIPTTRANSX POSTSCRIPTTRANSY POSTSCRIPTPENDINGXFORM) \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC (LINELENGTH) \MOVETO.PSC (POSTSCRIPTX POSTSCRIPTY POSTSCRIPTMOVEFLG) \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET (POSTSCRIPTWIDTHS POSTSCRIPTNSCHARSET) \POSTSCRIPT.OUTCHARFN (POSTSCRIPTCHARSTOSHOW POSTSCRIPTY POSTSCRIPTX) \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN (POSTSCRIPTCHARSTOSHOW) \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN (POSTSCRIPTCHARSTOSHOW) \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL REFFREE POSTSCRIPT.INIT (FONTDEFS *POSTSCRIPT-NS-TRANSLATIONS*) PSCFONT.READFONT NIL PSCFONT.SPELLFILE (POSTSCRIPT.FONT.ALIST) PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE (POSTSCRIPT.FONT.ALIST POSTSCRIPTFONTCACHE) PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE ( WeightMenuItems SlopeMenuItems *POSTSCRIPT-EXTRA-CHARACTERS*) CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID (GOLDEN.RATIO) POSTSCRIPT.FONTCREATE (\MAXTHINCHAR *POSTSCRIPT-NS-HASH*) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE (POSTSCRIPT.FONT.ALIST POSTSCRIPTFONTDIRECTORIES \POSTSCRIPT.MAX.WILD.FONTSIZE) OPENPOSTSCRIPTSTREAM (*POSTSCRIPT-FILE-TYPE* \POSTSCRIPTIMAGEOPS \PS.SCALE0 USERNAME \POSTSCRIPT.JOB.SETUP POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS POSTSCRIPT.IMAGESIZEFACTOR DEFAULTFONT \POSTSCRIPT.ORIENTATION.MENU) CLOSEPOSTSCRIPTSTREAM (:EOL) POSTSCRIPT.HARDCOPYW (POSTSCRIPT.BITMAP.SCALE) POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT (POSTSCRIPT.DEFAULT.PAGEREGION) POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE (POSTSCRIPT.BITMAP.SCALE POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS POSTSCRIPT.PREFER.LANDSCAPE \POSTSCRIPT.ORIENTATION.MENU) POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE (:EOL) POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES (PS.BITMAPARRAY) POSTSCRIPT.PUTCOMMAND (:EOL) POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE (:EOL \PS.SCALE0) \POSTSCRIPTTAB NIL \PS.BOUTFIXP (\PS.TEMPARRAYLEN) \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC (POSTSCRIPT.BITMAP.SCALE :EOL) \SETPOS.PSC NIL \SETXFORM.PSC (:EOL) \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC (*POSTSCRIPT-UNACCENTED-FONTS* :EOL) \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC (BLACKSHADE WHITESHADE :EOL POSTSCRIPT.TEXTURE.SCALE) \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC (:EOL) \DRAWCIRCLE.PSC (:EOL) \DRAWCURVE.PSC ( :EOL) \DRAWELLIPSE.PSC (:EOL) \DRAWLINE.PSC (:EOL) \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC (:EOL) \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC (:EOL) \DSPFONT.PSC ( *POSTSCRIPT-UNACCENTED-FONTS*) \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC (:EOL) \DSPSCALE2.PSC (:EOL) \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC (:EOL POSTSCRIPT.TEXTURE.SCALE) \FILLPOLYGON.PSC (:EOL FILL.WRULE POSTSCRIPT.TEXTURE.SCALE) \FIXLINELENGTH.PSC (MAX.SMALLP) \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN ( \POSTSCRIPT.CHARTYPE *POSTSCRIPT-NS-HASH*) \POSTSCRIPT.PRINTSLUG (BLACKSHADE) \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR ( ACCENT) \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH (*POSTSCRIPT-NS-HASH* \POSTSCRIPT.CHARTYPE) POSTSCRIPTSEND NIL NIL REF POSTSCRIPT.INIT (FD) PSCFONT.READFONT (FONTFILENAME S) PSCFONT.SPELLFILE (FAMILY SIZE FACE DEVICE) PSCFONT.COERCEFILE (EXPANSION FAMILY SIZE WEIGHT SLOPE ROTATION DEVICE) PSCFONTFROMCACHE.SPELLFILE ( FAMILY SIZE FACE) PSCFONTFROMCACHE.COERCEFILE (EXPANSION FAMILY SIZE WEIGHT SLOPE ROTATION DEVICE) PSCFONT.WRITEFONT (FONTFILENAME PF S STREAM W) READ-AFM-FILE (FILE PSCFONT IFILE BOLDNESS ITALICNESS A W) CONVERT-AFM-FILES (FILE-LIST FNAME) POSTSCRIPT.GETFONTID (FID SLOPE WEIGHT EXPANSION) POSTSCRIPT.FONTCREATE (FACE SIZE FAMILY ROTATION DEVICE WEIGHT SLOPE EXPANSION MAPPING A0176 A0177 KIND FONTDESC CHARCODE WIDTH CODE CODE2 BASECHAR) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS (FD TYPE ROTATION DEVICE SIZE) POSTSCRIPT.FONTSAVAILABLE (FAMILY SIZE FACE PAIR DIRECTORY PATTERN FILE DEVICE RAWNAME INVERSE.ALIST NFD) OPENPOSTSCRIPTSTREAM (FILE OPTIONS X) CLOSEPOSTSCRIPTSTREAM (STREAM) POSTSCRIPT.HARDCOPYW (FILE TITLE Landscape? SCALEFACTOR STREAM IMAGEDATA BITMAP SCLIP) POSTSCRIPT.TEDIT (PFILE) POSTSCRIPT.TEXT (FILE PSCFILE FONTS HEADING TABS) POSTSCRIPTFILEP (FILE) MAKEEPSFILE (IMAGEOBJ IMAGEBOX FILENAME) POSTSCRIPT.BITMAPSCALE (PAGEREGION LONGEDGE SHORTEDGE MINDIML MINDIMP) POSTSCRIPT.CLOSESTRING (STREAM) POSTSCRIPT.ENDPAGE (STREAM) POSTSCRIPT.OUTSTR (STREAM) POSTSCRIPT.PUTBITMAPBYTES (BITMAP WIDTH STREAM HEIGHT BYTEOFFSETPERROW BYTESPERROW BMBASE PS.BITMAPARRAYBASE PRVBM PRVBASE) POSTSCRIPT.PUTCOMMAND (S.STRS STREAM) POSTSCRIPT.SET-FAKE-LANDSCAPE (STREAM OLAND) POSTSCRIPT.SHOWACCUM (STREAM) POSTSCRIPT.STARTPAGE (STREAM FONT) \POSTSCRIPTTAB ( POSTSCRIPTDATA TABSPACE) \PS.BOUTFIXP (STREAM BASE c) \PS.SCALEHACK (STREAM SCALEFACTOR OLDSCALE) \PS.SCALEREGION (SCALE REGION) \SCALEDBITBLT.PSC (STREAM IMAGEDATA SCALE1 SOURCEBITMAP BITMAPWIDTH BITMAPHEIGHT SOURCELEFT SOURCEBOTTOM SOURCETYPE SCALE2 OPERATION) \SETPOS.PSC (STREAM) \SETXFORM.PSC ( STREAM CLIP) \STRINGWIDTH.PSC (STREAM STR IMAGEDATA RDTBL) \SWITCHFONTS.PSC (FONT FONTID STREAM) \TERPRI.PSC (IMAGEDATA NEWY) \BITBLT.PSC (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) \BLTSHADE.PSC (DESTINATIONLEFT DESTINATIONBOTTOM STREAM IMAGEDATA) \CHARWIDTH.PSC (CHARCODE STREAM FONTDESCA0178) \CREATECHARSET.PSC (WIDTHS CHARSET FONTDESC) \DRAWARC.PSC (STREAM BRUSH IMAGEDATA DASHING D CENTERX CENTERY RADIUS STARTANGLE NDEGREES) \DRAWCIRCLE.PSC (STREAM BRUSH IMAGEDATA DASHING D CENTERX CENTERY RADIUS) \DRAWCURVE.PSC (STREAM BRUSH IMAGEDATA DASHING D KNOTS CLOSED) \DRAWELLIPSE.PSC (STREAM BRUSH IMAGEDATA DASHING D CENTERX CENTERY MAJORRADIUS MINORRADIUS ORIENTATION) \DRAWLINE.PSC (STREAM X2 X1 Y2 Y1 OPERATION COLOR DASHING D) \DRAWPOINT.PSC (BRUSH STREAM X WIDTH Y HEIGHT OPERATION) \DRAWPOLYGON.PSC (POINTS STREAM BRUSH IMAGEDATA DASHING D P LASTPOINT) \DSPBOTTOMMARGIN.PSC (STREAM) \DSPCLIPPINGREGION.PSC (STREAM OLDCLIP) \DSPCOLOR.PSC (STREAM) \DSPFONT.PSC (STREAM OLDFONT) \DSPLEFTMARGIN.PSC (STREAM) \DSPLINEFEED.PSC (STREAM) \DSPPUSHSTATE.PSC (STREAM IMAGEDATA) \DSPPOPSTATE.PSC (STREAM XFORM) \DSPRESET.PSC (IMAGEDATA) \DSPRIGHTMARGIN.PSC ( STREAM) \DSPROTATE.PSC (STREAM OROT) \DSPSCALE.PSC (STREAM SCALE OSCALE) \DSPSCALE2.PSC (STREAM IMAGEDATA Y-SCALE) \DSPSPACEFACTOR.PSC (STREAM FACTOR OLDFACTOR) \DSPTOPMARGIN.PSC (STREAM) \DSPTRANSLATE.PSC (STREAM TX TY MDX MDY REG) \DSPXPOSITION.PSC (STREAM IMAGEDATA) \DSPYPOSITION.PSC ( STREAM IMAGEDATA) \FILLCIRCLE.PSC (STREAM CENTERX CENTERY RADIUS) \FILLPOLYGON.PSC (KNOTS STREAM K LASTPOINT) \FIXLINELENGTH.PSC (IMAGEDATA TMP) \MOVETO.PSC (STREAM X Y) \NEWPAGE.PSC (STREAM) \POSTSCRIPT.CHANGECHARSET (FONT CHARSET CSINFO) \POSTSCRIPT.OUTCHARFN (STREAM XPOS OLDFONT) \POSTSCRIPT.PRINTSLUG (STREAM IMAGEDATA CHAR) \POSTSCRIPT.SPECIALOUTCHARFN (STREAM CHAR) \UPDATE.PSC ( IMAGEDATA STREAM) \POSTSCRIPT.ACCENTFN (STREAM CHAR) \POSTSCRIPT.ACCENTPAIR (STREAM IMAGEDATA CHAR ACCENTS UNDER-ACCENTS FONT) \PSC.SPACEDISP (STREAM WIDTH) \PSC.SPACEWID (CHAR FONTDESC) \PSC.SYMBOLS ( STREAM OLDFONT IMAGEDATA CHAR) \POSTSCRIPT.NSHASH (MAPPING-LIST CHARCODE A0179 A0180 A0181 KIND CODE2 BASECHAR) POSTSCRIPTSEND (HOST FILE PRINTOPTIONS) NIL SETFREE POSTSCRIPT.INIT (POSTSCRIPTFONTCACHE \POSTSCRIPT.CHARTYPE \POSTSCRIPTIMAGEOPS *POSTSCRIPT-NS-HASH*) PSCFONT.READFONT (POSTSCRIPTFONTCACHE) PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE (WeightMenu SlopeMenu CWIDTH CNAME) CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL SET POSTSCRIPT.INIT (CLASS COPYFD OLDPSCFD x) PSCFONT.READFONT (FID W C) PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT (C) READ-AFM-FILE (TOKEN WEIGHT SLOPE FBBOX HEIGHT CMCOUNT CCODE FCHAR LCHAR CC) CONVERT-AFM-FILES (FL AFM-FILE WEIGHT SLOPE FONT FILENAME) POSTSCRIPT.GETFONTID (FONTID) POSTSCRIPT.FONTCREATE (PSCFD FACECHANGED FULLNAME ASCENT DESCENT UNITFONT SCALEFONTP FD WIDTHSBLOCK FIXPWIDTHS CH PSCWIDTHSBLOCK) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS (TYPEFONT FONTFILE WIDTHS NEWWIDTHS CH) POSTSCRIPT.FONTSAVAILABLE (FONTSAVAILABLE FD S NF) OPENPOSTSCRIPTSTREAM (PAPER IMAGESIZEFACTOR CLIP REG) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW (REGION SCALE) POSTSCRIPT.TEDIT (FILE) POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE (STREAM) POSTSCRIPT.BITMAPSCALE (HEIGHT WIDTH MINDIM OTHERDIM SF1 SF2) POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR (c X) POSTSCRIPT.PUTBITMAPBYTES (POS BYTE B BYTEOFFSET R ROWOFFSET REPC BB BO PO PRVO) POSTSCRIPT.PUTCOMMAND (S#S STR#) POSTSCRIPT.SET-FAKE-LANDSCAPE (LAND C0 P0 C P ML MB MR MT) POSTSCRIPT.SHOWACCUM (KERN) POSTSCRIPT.STARTPAGE (NEW-PAGE) \POSTSCRIPTTAB NIL \PS.BOUTFIXP (N i) \PS.SCALEHACK (FACTOR) \PS.SCALEREGION NIL \SCALEDBITBLT.PSC (SCALE DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT DESTREGION TEMPBM) \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC (RGN LEFT BOTTOM WIDTH HEIGHT TEXTURE TEXTUREBM TEXTUREWIDTH) \CHARWIDTH.PSC NIL \CREATECHARSET.PSC (AVGCHARWIDTH I) \DRAWARC.PSC (WIDTH COLOR) \DRAWCIRCLE.PSC ( WIDTH COLOR) \DRAWCURVE.PSC (WIDTH SHAPE COLOR PSPLINE N XA YA DXA DYA PREVX PREVY PREV-DX3 PREV-DY3 C ) \DRAWELLIPSE.PSC (WIDTH COLOR) \DRAWLINE.PSC (WIDTH) \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC (WIDTH SHAPE COLOR) \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC ( NEWFONT FONTID) \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC (NSCALE) \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC (OLDX) \DSPYPOSITION.PSC (OLDY) \FILLCIRCLE.PSC (TEXTURE TEXTUREBM TEXTUREWIDTH) \FILLPOLYGON.PSC (WINDNUMBER TEXTURE TEXTUREBM TEXTUREWIDTH) \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN (CHARWID NEWXPOS MAPPING CHAR) \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN (CH) \POSTSCRIPT.ACCENTPAIR (CH ACCENT) \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH (MAPPING) POSTSCRIPTSEND NIL NIL SMASHFREE POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL SMASH POSTSCRIPT.INIT (OLDPSCFD FP) PSCFONT.READFONT (PF) PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID (FONTID) POSTSCRIPT.FONTCREATE (PSCFD FD) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE (RAWFD) OPENPOSTSCRIPTSTREAM (FP IMAGEDATA) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW (REGION) POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING (IMAGEDATA) POSTSCRIPT.ENDPAGE (IMAGEDATA) POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND (IMAGEDATA) POSTSCRIPT.SET-FAKE-LANDSCAPE (C IMAGEDATA) POSTSCRIPT.SHOWACCUM (IMAGEDATA) POSTSCRIPT.STARTPAGE (IMAGEDATA) \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK (REG IMAGEDATA) \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC ( IMAGEDATA) \SETXFORM.PSC (IMAGEDATA) \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC (POSTSCRIPTDATA) \TERPRI.PSC (STREAM) \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC (CSINFO) \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC (IMAGEDATA) \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC (IMAGEDATA) \DSPCOLOR.PSC NIL \DSPFONT.PSC (IMAGEDATA) \DSPLEFTMARGIN.PSC (IMAGEDATA) \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC (IMAGEDATA) \DSPRESET.PSC (STREAM) \DSPRIGHTMARGIN.PSC ( IMAGEDATA) \DSPROTATE.PSC (IMAGEDATA) \DSPSCALE.PSC (IMAGEDATA) \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC (IMAGEDATA) \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC (IMAGEDATA) \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC (STREAM) \MOVETO.PSC (IMAGEDATA) \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET (PSDATA) \POSTSCRIPT.OUTCHARFN (IMAGEDATA) \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN (IMAGEDATA) \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN (IMAGEDATA) \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL PROP POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE (PSCFONT) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM ( BOUNDINGBOX DOCUMENT.NAME PAGETYPE PAPERTYPE IMAGESIZEFACTOR REGION FONTS HEADING HEADINGFONT LANDSCAPE ROTATION) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC (PSCFONT ) \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC (PSCFONT) \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL TEST POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE (CACHE) PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE (CCODE) CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE (PSCFD FACECHANGED SCALEFONTP FULLNAME UNITFONT TMP SYMWIDTHS DINGWIDTHS) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS (TYPEFONT) POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM (BBOX) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW (REGION) POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE (PPL) POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES (DELIMFLG) POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE ( ROTATION LAND) POSTSCRIPT.SHOWACCUM (KERN) POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC (DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT DESTREGION CLIPPINGREGION) \SETPOS.PSC NIL \SETXFORM.PSC (NORESTORE) \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC (CLIPPINGREGION RGN TEXTURE TEXTUREBM) \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC (CLOSED) \DSPBOTTOMMARGIN.PSC (YPOSITION) \DSPCLIPPINGREGION.PSC (REGION) \DSPCOLOR.PSC (COLOR) \DSPFONT.PSC ( FONT) \DSPLEFTMARGIN.PSC (XPOSITION) \DSPLINEFEED.PSC (LINELEADING) \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC (XPOSITION) \DSPROTATE.PSC (ROTATION) \DSPSCALE.PSC NIL \DSPSCALE2.PSC (X-SCALE) \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC (YPOSITION) \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC (XPOSITION) \DSPYPOSITION.PSC (YPOSITION) \FILLCIRCLE.PSC ( TEXTURE TEXTUREBM) \FILLPOLYGON.PSC (TEXTURE TEXTUREBM) \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN (FAMILY OLDFONT) \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH ( UNDERACCENTS) POSTSCRIPTSEND NIL NIL TESTFREE POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE (POSTSCRIPTFONTDIRECTORIES) PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM (POSTSCRIPT.PREFER.LANDSCAPE) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT (POSTSCRIPT.TEXTFILE.LANDSCAPE) POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL PREDICATE POSTSCRIPT.INIT (BOUNDP TYPEP GREATERP FMEMB) PSCFONT.READFONT (GREATERP) PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT (GREATERP) READ-AFM-FILE (STRING-EQUAL BOUNDP TYPENAMEP IGEQ GREATERP CL:PLUSP ILESSP IGREATERP) CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE (GREATERP) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS (GREATERP) POSTSCRIPT.FONTSAVAILABLE (EQUAL MEMBER GREATERP) OPENPOSTSCRIPTSTREAM (CL:PLUSP EQL MENU) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW (<) POSTSCRIPT.TEDIT (STRINGP) POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE (GREATERP LESSP) POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR (FIXP STRINGP IGREATERP LITATOM ZEROP TYPEP) POSTSCRIPT.PUTBITMAPBYTES (LESSP GREATERP IGEQ IGREATERP CL:PLUSP FMEMB) POSTSCRIPT.PUTCOMMAND (GREATERP) POSTSCRIPT.SET-FAKE-LANDSCAPE (ZEROP) POSTSCRIPT.SHOWACCUM (EQP) POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP (MINUSP LESSP) \PS.SCALEHACK (NUMBERP EQP) \PS.SCALEREGION NIL \SCALEDBITBLT.PSC (GREATERP REGIONSINTERSECTP EQP) \SETPOS.PSC NIL \SETXFORM.PSC (EQP ZEROP) \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC ( LESSP) \BITBLT.PSC NIL \BLTSHADE.PSC (FIXP FLOATP <= TEXTUREP BITMAPP) \CHARWIDTH.PSC NIL \CREATECHARSET.PSC (GREATERP) \DRAWARC.PSC (NUMBERP ZEROP FLOATP) \DRAWCIRCLE.PSC (NUMBERP ZEROP FLOATP) \DRAWCURVE.PSC (NUMBERP ZEROP FLOATP GREATERP) \DRAWELLIPSE.PSC (NUMBERP ZEROP FLOATP) \DRAWLINE.PSC (NUMBERP ZEROP LESSP) \DRAWPOINT.PSC (BITMAPP) \DRAWPOLYGON.PSC (NUMBERP ZEROP FLOATP) \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC (EQP) \DSPCOLOR.PSC (NUMBERP <=) \DSPFONT.PSC ( TYPENAMEP MEMB) \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC (NUMBERP CL:PLUSP) \DSPSCALE2.PSC (NUMBERP CL:PLUSP) \DSPSPACEFACTOR.PSC (NUMBERP EQUAL) \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC (ZEROP) \DSPXPOSITION.PSC (EQUAL) \DSPYPOSITION.PSC (EQUAL) \FILLCIRCLE.PSC (FIXP ZEROP EQL FLOATP TEXTUREP BITMAPP) \FILLPOLYGON.PSC (ZEROP EQL FIXP FLOATP TEXTUREP BITMAPP) \FIXLINELENGTH.PSC (GREATERP) \MOVETO.PSC (EQP) \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN (ILEQ CL:AREF IGREATERP ILESSP IGEQ) \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN (ILESSP IGEQ) \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN (IGREATERP) \POSTSCRIPT.ACCENTPAIR (IGREATERP ILESSP) \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS (EQUAL) \POSTSCRIPT.NSHASH (<=) POSTSCRIPTSEND NIL NIL EFFECT POSTSCRIPT.INIT (DECLARE) PSCFONT.READFONT (CL:DO SETA CLOSEF) PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT (PRIN3 BOUT \WOUT DECLARE CLOSEF) READ-AFM-FILE (PRIN1 DECLARE RATOMS SETA CLOSEF) CONVERT-AFM-FILES (PSCFONT.WRITEFONT) POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE (\FSETWIDTH MAPHASH) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS (SETA) POSTSCRIPT.FONTSAVAILABLE (FRPLACD) OPENPOSTSCRIPTSTREAM (printout DECLARE PRIN1 CL:WHEN SI::RESETUNWIND MAPC POSTSCRIPT.OUTSTR \DSPFONT.PSC \SWITCHFONTS.PSC POSTSCRIPT.SET-FAKE-LANDSCAPE POSTSCRIPT.STARTPAGE) CLOSEPOSTSCRIPTSTREAM (POSTSCRIPT.ENDPAGE POSTSCRIPT.PUTCOMMAND) POSTSCRIPT.HARDCOPYW ( ALLOW.BUTTON.EVENTS BITBLT CLOSEF) POSTSCRIPT.TEDIT (TEDIT.FORMAT.HARDCOPY CLOSEF?) POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP (SETFILEPTR) MAKEEPSFILE (MOVETO) POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING (POSTSCRIPT.OUTSTR) POSTSCRIPT.ENDPAGE (POSTSCRIPT.SHOWACCUM POSTSCRIPT.PUTCOMMAND) POSTSCRIPT.OUTSTR (DECLARE) POSTSCRIPT.PUTBITMAPBYTES (DECLARE BOUT \MOVEBYTES) POSTSCRIPT.PUTCOMMAND (POSTSCRIPT.SHOWACCUM \SETXFORM.PSC \FILEOUTCHARFN POSTSCRIPT.OUTSTR) POSTSCRIPT.SET-FAKE-LANDSCAPE (POSTSCRIPT.SHOWACCUM \DSPTRANSLATE.PSC \DSPRESET.PSC) POSTSCRIPT.SHOWACCUM (POSTSCRIPT.OUTSTR \FILEOUTCHARFN) POSTSCRIPT.STARTPAGE (POSTSCRIPT.PUTCOMMAND \SETXFORM.PSC PRIN3 RELMOVETO \TERPRI.PSC) \POSTSCRIPTTAB NIL \PS.BOUTFIXP (DECLARE \PUTBASEBYTE) \PS.SCALEHACK (POSTSCRIPT.SHOWACCUM MAPC REPLACEFIELD) \PS.SCALEREGION NIL \SCALEDBITBLT.PSC (BITBLT POSTSCRIPT.PUTCOMMAND POSTSCRIPT.PUTBITMAPBYTES \MOVETO.PSC) \SETPOS.PSC (POSTSCRIPT.PUTCOMMAND) \SETXFORM.PSC (POSTSCRIPT.OUTSTR POSTSCRIPT.PUTCOMMAND) \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC ( POSTSCRIPT.PUTCOMMAND) \TERPRI.PSC (DSPNEWPAGE \MOVETO.PSC) \BITBLT.PSC NIL \BLTSHADE.PSC ( POSTSCRIPT.PUTCOMMAND BLTSHADE BITBLT POSTSCRIPT.PUTBITMAPBYTES \MOVETO.PSC) \CHARWIDTH.PSC (DECLARE) \CREATECHARSET.PSC (CL:UNLESS CL:WHEN \FSETWIDTH) \DRAWARC.PSC (printout PRIN1 POSTSCRIPT.OUTSTR MAPC) \DRAWCIRCLE.PSC (printout PRIN1 POSTSCRIPT.OUTSTR MAPC) \DRAWCURVE.PSC (printout PRIN1 POSTSCRIPT.PUTCOMMAND POSTSCRIPT.OUTSTR MAPC \MOVETO.PSC) \DRAWELLIPSE.PSC (printout PRIN1 POSTSCRIPT.PUTCOMMAND POSTSCRIPT.OUTSTR MAPC) \DRAWLINE.PSC (\DRAWLINE.PSC MAPC) \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC (printout PRIN1 POSTSCRIPT.OUTSTR MAPC) \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC (POSTSCRIPT.SHOWACCUM \FIXLINELENGTH.PSC) \DSPCOLOR.PSC (POSTSCRIPT.SHOWACCUM POSTSCRIPT.PUTCOMMAND \ILLEGAL.ARG) \DSPFONT.PSC (POSTSCRIPT.SHOWACCUM \POSTSCRIPT.CHANGECHARSET \DSPLINEFEED.PSC \FIXLINELENGTH.PSC) \DSPLEFTMARGIN.PSC (\FIXLINELENGTH.PSC) \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC (REPLACEFIELD) \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC ( \FIXLINELENGTH.PSC) \DSPROTATE.PSC (POSTSCRIPT.SHOWACCUM \DSPRESET.PSC) \DSPSCALE.PSC ( POSTSCRIPT.PUTCOMMAND) \DSPSCALE2.PSC (POSTSCRIPT.SHOWACCUM \UPDATE.PSC POSTSCRIPT.PUTCOMMAND) \DSPSPACEFACTOR.PSC (DECLARE POSTSCRIPT.SHOWACCUM) \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC ( POSTSCRIPT.SHOWACCUM MAPC) \DSPXPOSITION.PSC (\MOVETO.PSC) \DSPYPOSITION.PSC (\MOVETO.PSC) \FILLCIRCLE.PSC (POSTSCRIPT.PUTCOMMAND BLTSHADE BITBLT POSTSCRIPT.PUTBITMAPBYTES) \FILLPOLYGON.PSC ( DECLARE BLTSHADE BITBLT MAPC POSTSCRIPT.PUTBITMAPBYTES) \FIXLINELENGTH.PSC NIL \MOVETO.PSC ( POSTSCRIPT.SHOWACCUM) \NEWPAGE.PSC (POSTSCRIPT.ENDPAGE) \POSTSCRIPT.CHANGECHARSET (UNINTERRUPTABLY) \POSTSCRIPT.OUTCHARFN (DECLARE CL:UNLESS \TERPRI.PSC \UPDATE.PSC BOUT SELECTQ \POSTSCRIPT.SPECIALOUTCHARFN \POSTSCRIPT.ACCENTFN \POSTSCRIPT.ACCENTPAIR POSTSCRIPT.SHOWACCUM APPLY* POSTSCRIPT.OUTSTR \ILLEGAL.ARG DSPNEWPAGE \MOVETO.PSC \POSTSCRIPT.PRINTSLUG) \POSTSCRIPT.PRINTSLUG ( DECLARE \BLTSHADE.PSC) \POSTSCRIPT.SPECIALOUTCHARFN (DECLARE CL:WHEN CL:UNLESS \UPDATE.PSC BOUT SELCHARQ) \UPDATE.PSC (\SETXFORM.PSC \SWITCHFONTS.PSC) \POSTSCRIPT.ACCENTFN (DECLARE \UPDATE.PSC BOUT) \POSTSCRIPT.ACCENTPAIR (DECLARE POSTSCRIPT.SHOWACCUM \UPDATE.PSC BOUT POSTSCRIPT.PUTCOMMAND) \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS (POSTSCRIPT.SHOWACCUM \UPDATE.PSC POSTSCRIPT.OUTSTR) \POSTSCRIPT.NSHASH (PUTHASH CL:WHEN) POSTSCRIPTSEND NIL NIL CLISP POSTSCRIPT.INIT (for in join collect FOR IN DO from to unless do) PSCFONT.READFONT (for from to do) PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT (for from to do) READ-AFM-FILE (repeatuntil do repeatwhile type? for from to) CONVERT-AFM-FILES (for in do as) POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE (for from to do) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS (FOR FROM TO DO) POSTSCRIPT.FONTSAVAILABLE (for in collect when join unless from to) OPENPOSTSCRIPTSTREAM (for in do) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR (for infatstring do inatom in) POSTSCRIPT.PUTBITMAPBYTES (for from to by as do while count) POSTSCRIPT.PUTCOMMAND (for from to do) POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP (for old by do repeatwhile in) \PS.SCALEHACK (for in do) \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC (FOR FROM TO FIRST DO) \DRAWARC.PSC (for in do ) \DRAWCIRCLE.PSC (for in do) \DRAWCURVE.PSC (for in do from to) \DRAWELLIPSE.PSC (for in do) \DRAWLINE.PSC (for in do) \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC (for in do) \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC (type?) \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC (for in do) \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC (for in do) \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN (for instring do) \POSTSCRIPT.ACCENTPAIR (for instring do inside) \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH (for in unless do) POSTSCRIPTSEND NIL NIL SPECVARS POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM ( SI::*RESETFORMS*) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC (FILL.WRULE) \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL LOCALVARS POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT (STREAM W) READ-AFM-FILE (A) CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE (FONTDESC CHARCODE WIDTH) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR (T $$TEM1 $$TEM2 $$TEM3 $$TEM4 $$TEM5) POSTSCRIPT.PUTBITMAPBYTES (T) POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP (T) \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC (FONTDESCA0178) \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC (T) \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN (T) \POSTSCRIPT.PRINTSLUG (T) \POSTSCRIPT.SPECIALOUTCHARFN (T) \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN (T $$TEM1 $$TEM2 $$TEM3 $$TEM4 $$TEM5) \POSTSCRIPT.ACCENTPAIR (T $$TEM1 $$TEM2 $$TEM3 $$TEM4 $$TEM5) \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL APPLY POSTSCRIPT.INIT (SETFONTDESCRIPTOR CLOSEPOSTSCRIPTSTREAM \DSPXPOSITION.PSC \DSPYPOSITION.PSC \MOVETO.PSC \DSPFONT.PSC \DSPLEFTMARGIN.PSC \DSPRIGHTMARGIN.PSC \DSPLINEFEED.PSC \DRAWLINE.PSC \DRAWCURVE.PSC \DRAWCIRCLE.PSC \DRAWELLIPSE.PSC \FILLCIRCLE.PSC \BLTSHADE.PSC \BITBLT.PSC \SCALEDBITBLT.PSC \NEWPAGE.PSC \DSPSCALE.PSC \DSPSCALE2.PSC \DSPCOLOR.PSC \TERPRI.PSC \DSPTOPMARGIN.PSC \DSPBOTTOMMARGIN.PSC \DSPSPACEFACTOR.PSC \DSPCLIPPINGREGION.PSC \DSPRESET.PSC \DRAWPOLYGON.PSC \FILLPOLYGON.PSC \STRINGWIDTH.PSC \CHARWIDTH.PSC \DRAWARC.PSC \DSPROTATE.PSC \DSPTRANSLATE.PSC \DRAWPOINT.PSC \DSPPUSHSTATE.PSC \DSPPOPSTATE.PSC) PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE (DESTRUCTURING-BIND SELECTQ \FSETCHARWIDTH DECLARE \FSETWIDTH \PUTBASE \GETCHARSETINFO \GETBASEPTR UNFOLD LLSH \CHARSET LRSH \CREATECHARSET \CHAR8CODE LOGAND \FGETWIDTH \GETBASE ELT IPLUS FIXR FTIMES CHARCODE CL:WHEN APPLY*) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM ( SI::RESETUNWIND STRING-EQUAL) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP (STRING-EQUAL) MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH (CL:IDENTITY) POSTSCRIPTSEND NIL NIL ERROR POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE (apply) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE (apply) POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN (apply) \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH (apply) POSTSCRIPTSEND NIL NIL LOCALFREEVARS POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE (FD PSCWIDTHSBLOCK SYMWIDTHS DINGWIDTHS) \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL ARGS POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL USERTEMPLATES WINDOWDELPROP (CALL EVAL PROP EVAL . PPE) CH.PROPERTY (CALL PROP) CATCH (CALL |..| EVAL) PERFORM (MACRO ARGS (PERFORMTRAN ARGS T)) IBM-INIT (CALL KEYWORDS :FONT-DIRECTORY :MACHINETYPE :DEFAULT-FONTPROFILE :REDEFINE-KEYBOARD) PROCESSPROP (CALL EVAL PROP EVAL . PPE) OP# (CALL) FCACHE.GETPROP (CALL EVAL PROP . PPE) CL:PUSH (NIL @ EXPR (IF (ATOM (CADR EXPR)) THEN (QUOTE (EVAL SET )) ELSE (QUOTE (EVAL SMASH)))) TEXTPROP (CALL EVAL PROP EVAL . PPE) perform (MACRO ARGS (PERFORMTRAN ARGS T)) SPREADAPPLY* (CALL FUNCTIONAL |..| EVAL) SETQ.NOREF (CALL SET EVAL . PPE) CL:DECF (NIL @ EXPR (IF (LITATOM (CAR EXPR)) THEN (QUOTE (SET EVAL)) ELSE (QUOTE (SMASH EVAL)))) FCACHE.PUTPROP (CALL EVAL PROP EVAL . PPE) WINDOWPROP (CALL EVAL PROP EVAL . PPE) SPREADAPPLY (CALL FUNCTIONAL EVAL . PPE) UNINTERRUPTABLY (CALL |..| EVAL) SHAZAM (CALL |..| NIL) WINDOWADDPROP (CALL EVAL PROP EVAL EVAL . PPE) CL:INCF (NIL @ EXPR (IF (LITATOM (CAR EXPR)) THEN (QUOTE (SET EVAL)) ELSE (QUOTE (SMASH EVAL)))) NIL 0 POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE ( MENU) CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC (FONTDESCRIPTOR) \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL FPTYPE POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL KEYACCEPT POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL KEYSPECIFY POSTSCRIPT.INIT (:INITIAL-ELEMENT) PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM (:TEST) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP (:TEST) MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL KEYCALL POSTSCRIPT.INIT (CL:MAKE-ARRAY) PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM (CL:ASSOC) CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP (CL:MEMBER) MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL FLET POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL LABEL POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL MACROLET POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL COMPILER-LET POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL SENDNOTSELF POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL SENDSELF POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL IMPLEMENT POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL GETNOTSELF POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL GETSELF POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL GETCVSELF POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL GETCVNOTSELF POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL PUTNOTSELF POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL PUTSELF POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL PUTCVSELF POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL PUTCVNOTSELF POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL OBJECT POSTSCRIPT.INIT NIL PSCFONT.READFONT NIL PSCFONT.SPELLFILE NIL PSCFONT.COERCEFILE NIL PSCFONTFROMCACHE.SPELLFILE NIL PSCFONTFROMCACHE.COERCEFILE NIL PSCFONT.WRITEFONT NIL READ-AFM-FILE NIL CONVERT-AFM-FILES NIL POSTSCRIPT.GETFONTID NIL POSTSCRIPT.FONTCREATE NIL \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS NIL POSTSCRIPT.FONTSAVAILABLE NIL OPENPOSTSCRIPTSTREAM NIL CLOSEPOSTSCRIPTSTREAM NIL POSTSCRIPT.HARDCOPYW NIL POSTSCRIPT.TEDIT NIL POSTSCRIPT.TEXT NIL POSTSCRIPTFILEP NIL MAKEEPSFILE NIL POSTSCRIPT.BITMAPSCALE NIL POSTSCRIPT.CLOSESTRING NIL POSTSCRIPT.ENDPAGE NIL POSTSCRIPT.OUTSTR NIL POSTSCRIPT.PUTBITMAPBYTES NIL POSTSCRIPT.PUTCOMMAND NIL POSTSCRIPT.SET-FAKE-LANDSCAPE NIL POSTSCRIPT.SHOWACCUM NIL POSTSCRIPT.STARTPAGE NIL \POSTSCRIPTTAB NIL \PS.BOUTFIXP NIL \PS.SCALEHACK NIL \PS.SCALEREGION NIL \SCALEDBITBLT.PSC NIL \SETPOS.PSC NIL \SETXFORM.PSC NIL \STRINGWIDTH.PSC NIL \SWITCHFONTS.PSC NIL \TERPRI.PSC NIL \BITBLT.PSC NIL \BLTSHADE.PSC NIL \CHARWIDTH.PSC NIL \CREATECHARSET.PSC NIL \DRAWARC.PSC NIL \DRAWCIRCLE.PSC NIL \DRAWCURVE.PSC NIL \DRAWELLIPSE.PSC NIL \DRAWLINE.PSC NIL \DRAWPOINT.PSC NIL \DRAWPOLYGON.PSC NIL \DSPBOTTOMMARGIN.PSC NIL \DSPCLIPPINGREGION.PSC NIL \DSPCOLOR.PSC NIL \DSPFONT.PSC NIL \DSPLEFTMARGIN.PSC NIL \DSPLINEFEED.PSC NIL \DSPPUSHSTATE.PSC NIL \DSPPOPSTATE.PSC NIL \DSPRESET.PSC NIL \DSPRIGHTMARGIN.PSC NIL \DSPROTATE.PSC NIL \DSPSCALE.PSC NIL \DSPSCALE2.PSC NIL \DSPSPACEFACTOR.PSC NIL \DSPTOPMARGIN.PSC NIL \DSPTRANSLATE.PSC NIL \DSPXPOSITION.PSC NIL \DSPYPOSITION.PSC NIL \FILLCIRCLE.PSC NIL \FILLPOLYGON.PSC NIL \FIXLINELENGTH.PSC NIL \MOVETO.PSC NIL \NEWPAGE.PSC NIL \POSTSCRIPT.CHANGECHARSET NIL \POSTSCRIPT.OUTCHARFN NIL \POSTSCRIPT.PRINTSLUG NIL \POSTSCRIPT.SPECIALOUTCHARFN NIL \UPDATE.PSC NIL \POSTSCRIPT.ACCENTFN NIL \POSTSCRIPT.ACCENTPAIR NIL \PSC.SPACEDISP NIL \PSC.SPACEWID NIL \PSC.SYMBOLS NIL \POSTSCRIPT.NSHASH NIL POSTSCRIPTSEND NIL NIL ) \ No newline at end of file diff --git a/library/RDSYS b/library/RDSYS new file mode 100644 index 00000000..68737d31 --- /dev/null +++ b/library/RDSYS @@ -0,0 +1,321 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") +(FILECREATED "20-Dec-98 14:54:54" |{DSK}disk3>lispcore3.0>library>RDSYS.;17| 56574 ) + + +(PRETTYCOMPRINT RDSYSCOMS) + +(RPAQQ RDSYSCOMS ((FNS VREADPAGEMAP VREADPAGEMAPBLOCK VCHECKIFPAGE V\\LOCKEDPAGEP V\\LOOKUPPAGEMAP VCHECKPAGEMAP VCHECKFPTOVP VCHECKFPTOVP1 V\\SHOWPAGETABLE V\\PRINTFPTOVP) (FNS VRAIDCOMMAND VRAIDSHOWFRAME VRAIDSTACKCMD VRAIDROOTFRAME VPRINTADDRS VPRINTVA VREADVA VREADOCT VREADATOM VSHOWSTACKBLOCKS VSHOWSTACKBLOCK1 VPRINCOPY VNOSUCHATOM) (FNS V\\BACKTRACE V\\STKNAME V\\PRINTBF V\\PRINTFRAME V\\SCANFORNTENTRY V\\PRINTSTK) (FNS V\\CHECKARRAYBLOCK V\\PARSEARRAYSPACE V\\PARSEARRAYSPACE1) (FNS VPRINTCODE VPRINTCODENT VBROKENDEF) (FNS V\\CAR.UFN V\\CDR.UFN) (FNS V\\COPY V\\UNCOPY) (FNS V\\GETBASEBYTE V\\PUTBASEBYTE) (FNS VNTYPX VTYPENAME V\\TYPENAMEFROMNUMBER) (FNS VUNCOPYATOM VMAKE.LOCAL.ATOM VSYMBOL.VALUE VSYMBOL.PNAME VSYMBOL.PACKAGE VOLD.FIND.SYMBOL VLOOKUP-SYMBOL VFIND.PACKAGE VFIND.SYMBOL VPACKAGE.NAME V\\MKATOM VGETTOPVAL VGETPROPLIST VSETTOPVAL VGETDEFN V\\ATOMCELL) (FNS VLISTP) (VARS (COPYATOMSTR)) (FNS V\\GET-COMPILED-CODE-BASE) (* |;;| "YOU MUST REMAKE THIS FILE using (DORENAME 'R) (after CONNing to library) whenever the SYSOUT layout changes in LLPARAMS (e.g., if MDSTypeTable moves)") (FILES VMEM) (VARS RDVALS RDPTRS) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) VMEM))) +) +(DEFINEQ + +(VREADPAGEMAP +(LAMBDA NIL (*) (*) (PROG (D) (MAPVMPAGE (IPLUS (LLSH (VHILOC (VVAG2 20 0)) 8) (LRSH (VLOLOC (VVAG2 20 0)) 8)) 1) (*) (*) (MAPVMPAGE (IPLUS (LLSH (VHILOC (VVAG2 5 0)) 8) (LRSH (VLOLOC (VVAG2 5 0)) 8)) (SUB1 (VGETBASE (VVAG2 20 0) 22))) (*) (SETVMPTR (VVAG2 5 0)) (|for| I |from| 0 |to| (SUB1 (LRSH (IPLUS 256 31) 5)) |as| VP |from| (IPLUS (LLSH (VHILOC (VVAG2 5 0)) 8) (LRSH (VLOLOC (VVAG2 5 0)) 8)) |by| 32 |do| (*) (VREADPAGEMAPBLOCK VP)) (|for| J |from| 0 |to| (SUB1 8) |as| FP |from| (SUB1 (VGETBASE (VVAG2 20 0) 23)) |do| (*) (MAPVMPAGE (IPLUS (IPLUS (LLSH (VHILOC (VVAG2 20 512)) 8) (LRSH (VLOLOC (VVAG2 20 512)) 8)) J) FP)) (|for| I |from| 0 |to| (SUB1 (LLSH 8 8)) |do| (COND ((IEQ (SETQ D (VGETBASE (VVAG2 20 512) I)) 65535)) (T (SETVMPTR (VADDBASE (VVAG2 5 0) D)) (VREADPAGEMAPBLOCK (LLSH I 5))))))) +) + +(VREADPAGEMAPBLOCK +(LAMBDA (VP) (*) (PROG ((B VP) P) (FRPTQ 32 (COND ((NEQ (SETQ P (VBIN2)) 0) (MAPVMPAGE B (SUB1 P)))) (SETQ B (ADD1 B))))) +) + +(VCHECKIFPAGE +(LAMBDA NIL (*) (COND ((NOT (EQUAL 5603 (VGETBASE (VVAG2 20 0) 15))) (|printout| T "Warning: " "Interface page key" "= " (PROGN 5603) ", but \\InterfacePage says " (VGETBASE (VVAG2 20 0) 15) T)))) +) + +(V\\LOCKEDPAGEP +(LAMBDA (VP TEMP) (*) (*) (OR (NEQ 0 (LOGAND (LLSH 1 (IMOD VP 16)) (VGETBASE (VADDBASE (VVAG2 20 28672) (LRSH VP 4)) 0))) NIL)) +) + +(V\\LOOKUPPAGEMAP +(LAMBDA (VP) (*) (*) (LET ((PRIMENTRY (VGETBASE (VVAG2 20 512) (LRSH VP 5)))) (COND ((EQ PRIMENTRY 65535) 0) (T (VGETBASE (VVAG2 5 0) (IPLUS PRIMENTRY (LOGAND VP 31))))))) +) + +(VCHECKPAGEMAP +(LAMBDA NIL (*) (LET ((*PRINT-BASE* 8) (NUMOCCUPIED 0) (NUMLOCKED 0) (CHAINOCCUPIED 0) (CHAINLOCKED 0) RPTR FPBASE FP VP RP) (VCHECKFPTOVP) (|for| RPTINDEX |from| 1 |to| (SUB1 VRPTSIZE) |when| (ILESSP (VGETBASE (PROGN (SETQ RPTR (VADDBASE (VADDBASE VREALPAGETABLE (LLSH RPTINDEX 1)) RPTINDEX))) 1) 65534) |do| (SETQ NUMOCCUPIED (PLUS NUMOCCUPIED 1)) (SETQ VP (VGETBASE RPTR 1)) (SETQ FP (VGETBASE RPTR 2)) (COND ((VCHECKFPTOVP1 FP VP RPTINDEX)) ((NEQ VP (\\GETBASEFIXP (SETQ FPBASE (VADDBASE (VVAG2 2 0) FP)) 0)) (|printout| T "RPT for RP " (RPFROMRPT RPTINDEX) " says VP ") (\\PRINTVP VP T) (|printout| T " lives in FP " FP "; but FP Map says that FP contains ") (\\PRINTVP (\\GETBASEFIXP FPBASE 0) T) (|printout| T T)) ((V\\LOCKEDPAGEP VP) (SETQ NUMLOCKED (PLUS NUMLOCKED 1)) (COND ((NOT (NEQ 0 (LRSH (VGETBASE RPTR 0) 15))) (|printout| T "VP " VP ", living in RP " (RPFROMRPT RPTINDEX) " should be locked but isn't." T)) ((IGREATERP FP (DLRPFROMFP (VGETBASE (VVAG2 20 0) 57))) (|printout| T "VP " VP " is locked, but living in FP " FP ", which is not in the locked page area" T)))))) (PROGN (SETQ RPTR VREALPAGETABLE) (*) (|while| (NEQ (SETQ RP (LOGAND (VGETBASE RPTR 0) 32767)) 0) |when| (ILESSP (VGETBASE (PROGN (SETQ RPTR (VADDBASE (VADDBASE VREALPAGETABLE (LLSH RP 1)) RP))) 1) 65534) |do| (SETQ CHAINOCCUPIED (PLUS CHAINOCCUPIED 1)) (COND ((NEQ 0 (LRSH (VGETBASE RPTR 0) 15)) (SETQ CHAINLOCKED (PLUS CHAINLOCKED 1))))) (COND ((ILESSP CHAINOCCUPIED NUMOCCUPIED) (|printout| T NUMOCCUPIED " occupied pages, but only " CHAINOCCUPIED " are on page chain. " NUMLOCKED " pages are permanently locked; " CHAINLOCKED " pages on chain are locked somehow." T)))))) +) + +(VCHECKFPTOVP +(LAMBDA NIL (*) (|for| FP |from| 1 |to| (\\GETBASEFIXP (VVAG2 20 0) 82) |as| (FPBASE _ (VADDBASE (VVAG2 2 0) 1)) |by| (VADDBASE FPBASE 1) |when| (NEQ (VGETBASE FPBASE 0) 65535) |do| (VCHECKFPTOVP1 FP (\\GETBASEFIXP FPBASE 0)))) +) + +(VCHECKFPTOVP1 +(LAMBDA (FP VP RPTINDEX) (*) (PROG ((FP2 (V\\LOOKUPPAGEMAP VP))) (RETURN (COND ((NEQ FP2 FP) (COND (NIL (|printout| T "RPT for RP " (RPFROMRPT RPTINDEX))) (T (|printout| T "FP map"))) (|printout| T " says FP " FP " contains VP ") (\\PRINTVP VP T) (|printout| T "; but PageMap says that page is in FP " FP2 T) T))))) +) + +(V\\SHOWPAGETABLE +(LAMBDA (MODE FILE) (*) (PROG ((*PRINT-BASE* 8) (OUTSTREAM (GETSTREAM FILE (QUOTE OUTPUT))) (RPTR VREALPAGETABLE) (RP 0) FLAGS VP STATE FIRSTONE LASTONE) (|printout| OUTSTREAM " RP VP FilePage Status" T) (|until| (SELECTQ MODE (CHAIN (EQ (SETQ RP (LOGAND (VGETBASE RPTR 0) 32767)) 0)) (NIL (SETQ RP (PLUS RP 1)) (IGEQ RP VRPTSIZE)) (\\ILLEGAL.ARG MODE)) |do| (SETQ RPTR (VADDBASE (VADDBASE VREALPAGETABLE (LLSH RP 1)) RP)) (SETQ VP (VGETBASE RPTR 1)) (COND ((AND (NULL MODE) (EQ VP STATE)) (SETQ LASTONE RP)) (T (COND (LASTONE (|printout| OUTSTREAM "ditto thru " LASTONE T) (SETQ LASTONE NIL))) (SETQ FIRSTONE RP) (SETQ STATE VP) (|printout| OUTSTREAM .I7.8 (RPFROMRPT RP)) (COND ((EQ (VGETBASE RPTR 1) 65534) (PRIN1 " Empty" OUTSTREAM)) ((NOT (ILESSP (VGETBASE RPTR 1) 65534)) (PRIN1 " Unavailable" OUTSTREAM)) (T (|printout| OUTSTREAM .I8.8 VP \,) (\\PRINTVP VP OUTSTREAM) (|printout| OUTSTREAM 28 .I6.8 (VGETBASE RPTR 2) |,,|) (COND ((NEQ 0 (LRSH (VGETBASE RPTR 0) 15)) (COND ((NOT (V\\LOCKEDPAGEP VP)) (*) (PRIN1 "Temp" OUTSTREAM))) (PRIN1 "Locked " OUTSTREAM))) NIL)) (TERPRI OUTSTREAM)))))) +) + +(V\\PRINTFPTOVP +(LAMBDA (FIRSTPAGE NWORDS TYPEFLG STREAM VPRAWFLG) (*) (SETQ STREAM (GETSTREAM STREAM (QUOTE OUTPUT))) (OR FIRSTPAGE (SETQ FIRSTPAGE 1)) (OR NWORDS (SETQ NWORDS (\\GETBASEFIXP (VVAG2 20 0) 82))) (LET ((BASE (VADDBASE (VVAG2 2 0) (SUB1 FIRSTPAGE))) (*PRINT-BASE* 8) (LASTVP -2) (NEXTFP (SUB1 FIRSTPAGE)) FIRSTFP FIRSTVP NEXTVP LOCKEDP TYPE NEXTLOCKED NEXTTYPE) (|while| (IGEQ NWORDS 0) |do| (SETQ NEXTFP (PLUS NEXTFP 1)) (COND ((EQ NWORDS 0) (SETQ NEXTVP -1)) ((NEQ (SETQ NEXTVP (VGETBASE (SETQ BASE (VADDBASE BASE 1)) 0)) 65535) (SETQ NEXTLOCKED (V\\LOCKEDPAGEP NEXTVP)) (|if| TYPEFLG |then| (SETQ NEXTTYPE (VTYPENAME ((LAMBDA ($$1) (VVAG2 (LRSH (SETQ $$1 NEXTVP) 8) (LLSH (LOGAND $$1 255) 8))) NIL))) (|if| (NULL NEXTTYPE) |then| (SETQ NEXTTYPE (SELECTC (LRSH NEXTVP 8) ((LIST 8 (CL:1+ 8)) "Pnames") ((LIST 10 (CL:1+ 10)) "Definitions") ((LIST 12 (CL:1+ 12)) "Value cells") ((LIST 2 (CL:1+ 2)) "Property lists") ((VHILOC (VVAG2 2 0)) "\\FPTOVP") (1 "Stack") ((VHILOC (VVAG2 22 0)) "GC Main table") ((VHILOC (VVAG2 23 0)) "GC Overflow table") NIL)))))) (COND ((COND ((EQ NEXTVP 65535) (NEQ LASTVP 65535)) (T (OR (NEQ NEXTVP (ADD1 LASTVP)) (NEQ NEXTLOCKED LOCKEDP) (NEQ TYPE NEXTTYPE)))) (COND ((IGEQ LASTVP 0) (COND (FIRSTFP (|printout| STREAM FIRSTFP "-"))) (|printout| STREAM (SUB1 NEXTFP) 12) (COND ((EQ LASTVP 65535) (|printout| STREAM "empty")) (T (COND (FIRSTFP (|if| VPRAWFLG |then| (PRIN1 FIRSTVP STREAM) |else| (\\PRINTVP FIRSTVP STREAM)) (PRIN1 "-" STREAM))) (|if| VPRAWFLG |then| (PRIN1 LASTVP STREAM) |else| (\\PRINTVP LASTVP STREAM)) (COND (LOCKEDP (PRIN1 (QUOTE *) STREAM))) (|if| TYPE |then| (|printout| STREAM 32 TYPE)))))) (SETQ FIRSTFP) (TERPRI STREAM) (SETQ FIRSTVP NEXTVP)) (T (*) (OR FIRSTFP (SETQ FIRSTFP (SUB1 NEXTFP))))) (SETQ LASTVP NEXTVP) (SETQ LOCKEDP NEXTLOCKED) (SETQ TYPE NEXTTYPE) (SETQ NWORDS (PLUS NWORDS -1))))) +) +) +(DEFINEQ + +(VRAIDCOMMAND +(LAMBDA NIL (*) (DECLARE (USEDFREE ROOTFRAME ALINKS? RAIDIX FRAME# VPRINTLEVEL)) (FRESHLINE T) (PROG (CMD) (SELECTQ (SETQ CMD (ASKUSER NIL NIL "@" (QUOTE ((Q "uit [confirm]" CONFIRMFLG T) (\ "^N - remote return [confirm]" NOECHOFLG T CONFIRMFLG T RETURN (QUOTE ^N)) (L "isp stack ") (\ "Lisp stack " NOECHOFLG T EXPLAINSTRING "^L -- Lisp stack from arbitrary frame or context" RETURN (QUOTE ^L)) (F "rame ") (\ + "Next frame " EXPLAINSTRING "LF - next frame" RETURN (QUOTE LF)) (^ " Previous frame ") (A "tom top-level value of atom: ") (D "efinition for atom: ") (P "roperty list for atom: ") (V " -- show object at Virtual address: ") (B "lock of storage starting at address: ") (S "how raw stack from address: ") (C "ode for function:") (\ "Basic frame at: " EXPLAINSTRING "^F - print basic frame at octal address" RETURN (QUOTE ^F)) (\ "frame extension at: " EXPLAINSTRING "^X - print frame extension at octal address" RETURN (QUOTE ^X)) (W "alk stack blocks starting at: ") (K "" EXPLAINSTRING "K -- Set linKtype for stack ops") (_ " Set word at address: ") (\ " Set value of atom " EXPLAINSTRING "^V -- Set value of atom" RETURN (QUOTE ^V)) (\ "atom number for atom: " EXPLAINSTRING "^O - look up atom" RETURN (QUOTE ^O)) (Z "Zap Print level to: ") (I "nspect InterfacePage [confirm]" CONFIRMFLG T) (U " -- Show remote screen [confirm]" CONFIRMFLG T) (" +" "" RETURN NIL) (\ " Enter Lisp " EXPLAINSTRING "^Y -- Enter Lisp" RETURN (QUOTE ^Y)))) T)) (^N (RETURN (QUOTE RETURN))) (Q (TERPRI T) (RETURN (QUOTE QUIT))) (NIL) (A (VPRINCOPY (VGETTOPVAL (VREADATOM)))) (P (VPRINCOPY (VGETPROPLIST (VREADATOM)))) (C (VPRINTCODE (VREADATOM) T RAIDIX)) (V (VPRINCOPY (VREADVA))) (B (VPRINTADDRS (VREADVA) (VREADOCT " for (number of words): "))) (S (VPRINTADDRS (VVAG2 1 (VREADOCT)) (VREADOCT " for (number of words): "))) (D (VPRINTADDRS (V\\ATOMCELL (PROGN (VREADATOM)) 10) 2)) (^O (PRINTNUM .I2 (VATOMNUMBER (VREADATOM)) T)) (^V (PROG ((ATM (VREADATOM))) (|printout| T " to be ") (VSETTOPVAL ATM (READ T T)))) ((L ^L) (VRAIDSTACKCMD CMD)) (F (VRAIDSHOWFRAME (SETQ FRAME# (PROG1 (READ T T) (READC T))))) (LF (OR FRAME# (SETQ FRAME# 0)) (|printout| T "(" .I1 (SETQ FRAME# (PLUS FRAME# 1)) ")" T) (VRAIDSHOWFRAME FRAME#)) (^ (COND ((OR (NULL FRAME#) (ILEQ FRAME# 1)) (|printout| T "No previous frame" T)) (T (|printout| T "(" .I1 (SETQ FRAME# (PLUS FRAME# -1)) ")" T) (VRAIDSHOWFRAME FRAME#)))) (^F (V\\PRINTBF (VREADOCT) NIL (FUNCTION VPRINCOPY))) (Z (LET ((A (PROG1 (READ T T) (READC T))) (D (PROG1 (READ T T) (READC T)))) (COND ((AND (FIXP A) (FIXP D)) (SETQ VPRINTLEVEL (CONS A D))) (T (PRINTOUT T "Must be two integers, car level then cdr level" T) (ERROR!))))) (W (VSHOWSTACKBLOCKS (COND ((EQ (PEEKC T) (QUOTE \ +)) (READC T) (VGETBASE (VVAG2 20 0) 30)) (T (VREADOCT))))) (^X (V\\PRINTFRAME (VREADOCT) (QUOTE PRINCOPY))) (^Y (TERPRI T) (USEREXEC (QUOTE :\:))) (K (SETQ ALINKS? (EQ (ASKUSER NIL NIL " Set link type for stack operations to " (QUOTE ((A "links +") (C "links +"))) T) (QUOTE A)))) (_ (PROG ((VA (VREADVA))) (|printout| T " Currently ") (PRINTNUM .I7 (VGETBASE VA 0) T) (|printout| T " to be ") (VPUTBASE VA 0 (VREADOCT)))) (I (COND ((NULL (GETD (QUOTE INSPECT)))) ((RECLOOK (QUOTE IFPAGE)) (INSPECT (COND ((LISTP VMEMFILE) (VMAPPAGE (|fetch| (POINTER PAGE#) |of| |\\InterfacePage|))) (T (PROG ((PAGE (NCREATE (QUOTE VMEMPAGEP)))) (SETVMPTR (VGETTOPVAL (QUOTE |\\InterfacePage|))) (\\BINS (GETSTREAM VMEMFILE) PAGE 0 BYTESPERPAGE) (RETURN PAGE)))) (QUOTE IFPAGE))) (T (PRIN1 " Can't -- no record for IFPAGE"))) (TERPRI T)) (U (SHOWREMOTESCREEN)) (HELP)) (RETURN NIL))) +) + +(VRAIDSHOWFRAME +(LAMBDA (N) (*) (PROG ((FRAME (OR ROOTFRAME (VRAIDROOTFRAME)))) (FRPTQ (SUB1 N) (COND ((EQ (PROGN (SETQ FRAME (COND (ALINKS? (IDIFFERENCE (LOGAND (VGETBASE (VVAG2 1 FRAME) 1) (CONSTANT (LOGXOR (SUB1 2) -1))) 10)) (T (IDIFFERENCE (COND ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 FRAME) 1) 1))) (VGETBASE (VVAG2 1 FRAME) 1)) (T (VGETBASE (VVAG2 1 FRAME) 9))) 10))))) 0) (RETURN (|printout| T N " is beyond the bottom of the stack" T))))) (V\\BACKTRACE FRAME FRAME T NIL T T NIL (FUNCTION VPRINCOPY) NIL RAIDIX))) +) + +(VRAIDSTACKCMD +(LAMBDA (CMD) (*) (DECLARE (USEDFREE FRAME# ROOTFRAME)) (PROG (FRAME) (SETQ FRAME# 0) (COND ((EQ CMD (QUOTE L)) (VRAIDROOTFRAME)) (T (SETQ ROOTFRAME (SELECTQ (SETQ FRAME (ASKUSER NIL NIL "in context (? for help): " (QUOTE ((P "age fault") (G "arbage collection") (K "eyboard handler") (H "ard Return") (S "tack manipulator") (R "eset") (M "iscellaneous") (F "rame at location: "))) T)) (P (VGETBASE (VVAG2 20 0) 6)) (G (VGETBASE (VVAG2 20 0) 5)) (K (VGETBASE (VVAG2 20 0) 3)) (H (VGETBASE (VVAG2 20 0) 4)) (S (VGETBASE (VVAG2 20 0) 2)) (R (VGETBASE (VVAG2 20 0) 1)) (M (VGETBASE (VVAG2 20 0) 14)) (COND ((AND (ILESSP (SETQ FRAME (VREADOCT)) 256) (ILESSP (VGETBASE (VVAG2 20 0) FRAME) (VGETBASE (VVAG2 20 0) 7)) (IEQ (LRSH (VGETBASE (VVAG2 1 (PROGN (PROGN (VGETBASE (VVAG2 20 0) FRAME)))) 0) 13) 6)) (VGETBASE (VVAG2 20 0) FRAME)) ((IEQ (LRSH (VGETBASE (VVAG2 1 FRAME) 0) 13) 6) FRAME) (T (PRINTNUM .I7 FRAME) (|printout| T " not a valid frame." T) (RETURN))))))) (FRESHLINE T) (V\\BACKTRACE ROOTFRAME NIL T NIL NIL NIL ALINKS? (FUNCTION VPRINCOPY) 1 RAIDIX))) +) + +(VRAIDROOTFRAME +(LAMBDA NIL (*) (SETQ ROOTFRAME (PROG1 (COND ((LISTP VMEMFILE) (PRIN1 "in TeleRaid Context" T) (VGETBASE (VVAG2 20 0) 24)) (T (VGETBASE (VVAG2 20 0) 0))) (TERPRI T)))) +) + +(VPRINTADDRS +(LAMBDA (BASE CNT) (*) (PRIN1 "words from ") (VPRINTVA BASE) (PRIN1 " to ") (VPRINTVA (VADDBASE BASE (SUB1 CNT))) (TERPRI) (SPACES 7) (|for| I |from| 0 |to| 7 |do| (PRINTNUM .I7 I)) (PROG ((NB (VVAG2 (VHILOC BASE) (LOGAND (VLOLOC BASE) (CONSTANT (LOGXOR (SUB1 8) -1))))) (LB (VADDBASE BASE CNT))) (|do| (COND ((EVENP (VLOLOC NB) 8) (TAB 0 0) (PRINTNUM .I5 (VLOLOC NB)) (PRIN1 ": "))) (COND ((IGREATERP BASE NB) (SPACES 7)) (T (PRINTNUM .I7 (VGETBASE NB 0)))) (SETQ NB (VADDBASE NB 1)) |repeatwhile| (IGREATERP LB NB)) (TAB 0 0))) +) + +(VPRINTVA +(LAMBDA (X) (*) (PRIN1 "{") (PRINTNUM .I2 (VHILOC X)) (PRIN1 ",") (PRINTNUM .I2 (VLOLOC X)) (PRIN1 "}")) +) + +(VREADVA +(LAMBDA NIL (*) (VVAG2 (VREADOCT) (VREADOCT)))) + +(VREADOCT +(LAMBDA (PROMPT) (*) (DECLARE (USEDFREE RAIDIX)) (COND ((AND PROMPT (NOT (READP T))) (|printout| T PROMPT))) (|bind| STR |while| (EQUAL (SETQ STR (RSTRING T T)) "") |do| (READC T) |finally| (RETURN (PROG1 (OR (FIXP (SELECTQ RAIDIX (8 (MKATOM (CONCAT STR "Q"))) (16 (|bind| (N _ 0) CHAR |while| (SETQ CHAR (GNC STR)) |do| (SETQ N (IPLUS (ITIMES N 16) (COND ((FIXP CHAR) CHAR) ((AND (IGEQ (SETQ CHAR (CHCON1 CHAR)) (CHARCODE A)) (ILEQ CHAR (CHARCODE F))) (IPLUS (IDIFFERENCE CHAR (CHARCODE A)) 10)) (T (ERROR CHAR (QUOTE ?) T))))) |finally| (RETURN N))) (SHOULDNT))) (PROGN (PRIN1 "?" T) (ERROR!))) (READC T))))) +) + +(VREADATOM +(LAMBDA NIL (*) (PROG1 (HANDLER-BIND ((XCL:MISSING-EXTERNAL-SYMBOL (CL:FUNCTION (LAMBDA (CONDITION) (* |;;| "MAKE AN INTERNAL SYMBOL INSTEAD") (CL:INTERN (XCL:MISSING-EXTERNAL-SYMBOL-NAME CONDITION) (XCL:MISSING-EXTERNAL-SYMBOL-PACKAGE CONDITION))))) (XCL:MISSING-PACKAGE (CL:FUNCTION (LAMBDA (CONDITION) (* |;;| "FAKE A PACKAGE BY THIS NAME AND MAKE THE SYMBOL IN IT") (CL:INTERN (XCL:MISSING-PACKAGE-SYMBOL-NAME CONDITION) (CL:MAKE-PACKAGE (XCL:MISSING-PACKAGE-PACKAGE-NAME CONDITION) :USE NIL)))))) (CL:READ T)) (READC T))) +) + +(VSHOWSTACKBLOCKS +(LAMBDA (SCANPTR WAITFLG) (*) (*) (PROG ((EASP (VGETBASE (VVAG2 20 0) 7))) SCAN (SELECTC (LRSH (VGETBASE (VVAG2 1 SCANPTR) 0) 13) (5 (VSHOWSTACKBLOCK1 SCANPTR "free block" (IEQ (VGETBASE (VVAG2 1 SCANPTR) 0) 40960)) (SETQ SCANPTR (PLUS SCANPTR (VGETBASE (VVAG2 1 SCANPTR) 1)))) (7 (VSHOWSTACKBLOCK1 SCANPTR "guard block" T) (SETQ SCANPTR (PLUS SCANPTR (VGETBASE (VVAG2 1 SCANPTR) 1)))) (6 (*) (VSHOWSTACKBLOCK1 SCANPTR "Frame extn = " (AND (IEQ (LRSH (VGETBASE (VVAG2 1 SCANPTR) 0) 13) 6) (OR (IEQ (IDIFFERENCE SCANPTR 2) (COND ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 SCANPTR) 1) 1))) (IDIFFERENCE SCANPTR 2)) (T (VGETBASE (VVAG2 1 SCANPTR) 8)))) (AND (NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 (PROGN (IDIFFERENCE SCANPTR 2))) 0) 9) 1)) (IEQ (VGETBASE (VVAG2 1 (PROGN (IDIFFERENCE SCANPTR 2))) 1) (VGETBASE (VVAG2 1 (PROGN (COND ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 SCANPTR) 1) 1))) (IDIFFERENCE SCANPTR 2)) (T (VGETBASE (VVAG2 1 SCANPTR) 8))))) 1)))))) (PRIN2 (V\\UNCOPY (VGETBASEPTR (PROGN (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 SCANPTR) 0) 9) 1)) (VGETBASEPTR (VVAG2 1 SCANPTR) 6)) (T (VGETBASEPTR (VVAG2 1 SCANPTR) 2)))) 4))) (SETQ SCANPTR (VGETBASE (VVAG2 1 SCANPTR) 4))) (PROG ((ORIG SCANPTR) IVAR) (*) (|while| (EQ (LRSH (VGETBASE (VVAG2 1 SCANPTR) 0) 13) 0) |do| (SETQ SCANPTR (PLUS SCANPTR 2))) (COND ((NOT (IEQ (LRSH (VGETBASE (VVAG2 1 SCANPTR) 0) 13) 4)) (VSHOWSTACKBLOCK1 ORIG "Garbage" T)) (T (SETQ IVAR (VGETBASE (VVAG2 1 SCANPTR) 1)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 SCANPTR) 0) 9) 1)) (VSHOWSTACKBLOCK1 SCANPTR "Residual BF" (EQ SCANPTR ORIG)) (PRIN1 " with IVar = ") (PRINTNUM .I7 IVAR)) (T (VSHOWSTACKBLOCK1 SCANPTR "Basic frame" (AND (EQ ORIG IVAR) (AND (IEQ (LRSH (VGETBASE (VVAG2 1 SCANPTR) 0) 13) 4) (|for| I |from| (VGETBASE (VVAG2 1 SCANPTR) 1) |to| (IDIFFERENCE SCANPTR 2) |by| 2 |always| (IEQ 0 (LRSH (VGETBASE (VVAG2 1 I) 0) 13)))))))) (SETQ SCANPTR (PLUS SCANPTR 2)))))) (TERPRI) (COND ((IGREATERP SCANPTR EASP) (RETURN))) (AND WAITFLG (READC T)) (GO SCAN))) +) + +(VSHOWSTACKBLOCK1 +(LAMBDA (PTR STR GOODFLG) (*) (PRINTNUM .I7 PTR) (SPACES 1) (OR GOODFLG (PRIN1 "[bad] ")) (PRIN1 STR)) +) + +(VPRINCOPY +(LAMBDA (X) (*) (PRINT (V\\UNCOPY X (CAR VPRINTLEVEL) (CDR VPRINTLEVEL)) T T))) + +(VNOSUCHATOM +(LAMBDA (ATM) (*) (*) (|printout| T "No such atom: " ATM T) (ERROR "No such atom: "))) +) +(DEFINEQ + +(V\\BACKTRACE +(LAMBDA (IPOS EPOS NAMES VARS LOCALS JUNK ALINKS PRINTFN CNT RADIX) (*) (OR RADIX (SETQ RADIX 8)) (PROG (NARGS NPVARS NAME ARGNAME BLINK (.I7 (NUMFORMATCODE (LIST (QUOTE FIX) 7 RADIX)))) (DECLARE (SPECVARS .I7)) POSLP (COND (CNT (|printout| NIL .I3 CNT ": ") (SETQ CNT (PLUS CNT 1)))) (SETQ NAME (V\\STKNAME IPOS)) (COND (JUNK (TERPRI) (TERPRI) (PRIN1 "Basic frame at ") (PRINTNUM .I7 (SETQ BLINK (COND ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 IPOS) 1) 1))) (IDIFFERENCE IPOS 2)) (T (VGETBASE (VVAG2 1 IPOS) 8))))) (TERPRI) (V\\PRINTBF BLINK (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 IPOS) 0) 9) 1)) (VGETBASEPTR (VVAG2 1 IPOS) 6)) (T (VGETBASEPTR (VVAG2 1 IPOS) 2))) PRINTFN) (PROGN (TERPRI) (PRIN1 "Frame xtn at ") (PRINTNUM .I7 IPOS) (PRIN1 ", frame name= ")) (APPLY* PRINTFN NAME) (V\\PRINTFRAME IPOS PRINTFN)) ((OR VARS LOCALS) (V\\PRINTBF (COND ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 IPOS) 1) 1))) (IDIFFERENCE IPOS 2)) (T (VGETBASE (VVAG2 1 IPOS) 8))) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 IPOS) 0) 9) 1)) (VGETBASEPTR (VVAG2 1 IPOS) 6)) (T (VGETBASEPTR (VVAG2 1 IPOS) 2))) PRINTFN (COND (LOCALS (QUOTE LOCALS)) (T T))) (COND (NAMES (APPLY* PRINTFN NAME) (TERPRI))) (V\\PRINTFRAME IPOS PRINTFN (COND (LOCALS (QUOTE LOCALS)) (T T)))) (NAMES (APPLY* PRINTFN NAME))) (COND ((AND (NEQ EPOS IPOS) (NOT (EQ (PROGN (SETQ IPOS (COND (ALINKS (IDIFFERENCE (LOGAND (VGETBASE (VVAG2 1 IPOS) 1) (CONSTANT (LOGXOR (SUB1 2) -1))) 10)) (T (IDIFFERENCE (COND ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 IPOS) 1) 1))) (VGETBASE (VVAG2 1 IPOS) 1)) (T (VGETBASE (VVAG2 1 IPOS) 9))) 10))))) 0))) (GO POSLP))) (RETURN T))) +) + +(V\\STKNAME +(LAMBDA (POS) (*) (*) (LET ((NAME (VGETBASEPTR (PROGN (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 POS) 0) 9) 1)) (VGETBASEPTR (VVAG2 1 POS) 6)) (T (VGETBASEPTR (VVAG2 1 POS) 2)))) 4))) (|if| (EQ NAME (QUOTE \\INTERPRETER)) |then| (VGETBASEPTR (VVAG2 1 0) (LET ((BFLINK (COND ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 POS) 1) 1))) (IDIFFERENCE POS 2)) (T (VGETBASE (VVAG2 1 POS) 8))))) (+ (VGETBASE (VVAG2 1 BFLINK) 1) (TIMES (CL:1- (IDIFFERENCE (LRSH (IDIFFERENCE BFLINK (VGETBASE (VVAG2 1 BFLINK) 1)) 1) (LOGAND (LRSH (VGETBASE (VVAG2 1 BFLINK) 0) 8) 1))) 2)))) |else| NAME))) +) + +(V\\PRINTBF +(LAMBDA (BL NMT PRINTFN VARSONLY) (*) (|bind| NM |for| I |from| (VGETBASE (VVAG2 1 BL) 1) |by| 2 |as| J |from| 0 |to| (SUB1 (IDIFFERENCE (LRSH (IDIFFERENCE BL (VGETBASE (VVAG2 1 BL) 1)) 1) (LOGAND (LRSH (VGETBASE (VVAG2 1 BL) 0) 8) 1))) |do| (OR VARSONLY (V\\PRINTSTK I)) (COND ((OR (SETQ NM (V\\SCANFORNTENTRY (OR NMT (RETURN (OR VARSONLY (TERPRI)))) (MAKE-NTENTRY 0 J))) (AND (NEQ VARSONLY T) (SETQ NM (QUOTE |*local*|)))) (AND VARSONLY (SPACES 3)) (PRIN2 NM) (SPACES 1) (APPLY* PRINTFN (VGETBASEPTR (VVAG2 1 0) I)))) |finally| (OR VARSONLY (|while| (ILESSP I BL) |do| (V\\PRINTSTK I) (|printout| NIL "[padding]" T) (SETQ I (PLUS I 2))))) (COND ((NOT VARSONLY) (V\\PRINTSTK BL) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 BL) 0) 9) 1)) (PRIN1 "residual "))) (COND ((NEQ (LOGAND (VGETBASE (VVAG2 1 BL) 0) 255) 0) (|printout| NIL "usecnt= " (LOGAND (VGETBASE (VVAG2 1 BL) 0) 255) \,))) (TERPRI)))) +) + +(V\\PRINTFRAME +(LAMBDA (FRAME PRINTFN VARSONLY) (*) (PROG ((NMT (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 FRAME) 0) 9) 1)) (VGETBASEPTR (VVAG2 1 FRAME) 6)) (T (VGETBASEPTR (VVAG2 1 FRAME) 2)))) (I 0) (FT (IPLUS (IPLUS FRAME (PROGN 10)) (LLSH (ADD1 (SIGNED (VGETBASE (PROGN (VGETBASEPTR (VVAG2 1 FRAME) 2)) 2) 16)) 2) (PROGN 4))) TMP NLOCALS) (COND ((NOT VARSONLY) (V\\PRINTSTK FRAME) (PRIN1 "[") (PROGN (PROG ((FAST (NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 FRAME) 0) 12) 1)))) (DECLARE (LOCALVARS FAST)) (COND (FAST (PRIN1 (QUOTE "F, ")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "F, ") -1)) (= (|printout| NIL \, FAST NIL)) NIL) T))) (PROG ((INCALL (NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 FRAME) 0) 10) 1)))) (DECLARE (LOCALVARS INCALL)) (COND (INCALL (PRIN1 (QUOTE "C, ")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "C, ") -1)) (= (|printout| NIL \, INCALL NIL)) NIL) T))) (PROG ((VALIDNAMETABLE (NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 FRAME) 0) 9) 1)))) (DECLARE (LOCALVARS VALIDNAMETABLE)) (COND (VALIDNAMETABLE (PRIN1 (QUOTE "V, ")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "V, ") -1)) (= (|printout| NIL \, VALIDNAMETABLE NIL)) NIL) T))) (PROG ((NOPUSH (NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 FRAME) 0) 8) 1)))) (DECLARE (LOCALVARS NOPUSH)) (COND (NOPUSH (PRIN1 (QUOTE "N, ")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "N, ") -1)) (= (|printout| NIL \, NOPUSH NIL)) NIL) T))) (PROG ((USECNT (LOGAND (VGETBASE (VVAG2 1 FRAME) 0) 255))) (DECLARE (LOCALVARS USECNT)) (COND ((NEQ USECNT 0) (PRIN1 (QUOTE "USE=")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "USE=") -1)) (= (|printout| NIL \, USECNT ", ")) NIL) T))) (PROG ((SLOWP (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 FRAME) 1) 1)))) (DECLARE (LOCALVARS SLOWP)) (COND (SLOWP (PRIN1 (QUOTE "X, ")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "X, ") -1)) (= (|printout| NIL \, SLOWP NIL)) NIL) T))) (PROG ((ALINK (IDIFFERENCE (LOGAND (VGETBASE (VVAG2 1 FRAME) 1) (CONSTANT (LOGXOR (SUB1 2) -1))) 10))) (DECLARE (LOCALVARS ALINK)) (COND (T (PRIN1 (QUOTE " alink]")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE " alink]") -1)) (= (|printout| NIL \, ALINK NIL)) NIL) T)))) (TERPRI) (PROGN (V\\PRINTSTK (IPLUS FRAME 2)) (PROGN (PROG ((FNHEADER (VGETBASEPTR (VVAG2 1 FRAME) 2))) (DECLARE (LOCALVARS FNHEADER)) (COND (T (PRIN1 (QUOTE "[fn header]")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "[fn header]") -1)) (= (|printout| NIL \, FNHEADER NIL)) NIL) T)))) (TERPRI)) (PROGN (V\\PRINTSTK (IPLUS FRAME 4)) (PROGN (PROG ((NEXTBLOCK (VGETBASE (VVAG2 1 FRAME) 4))) (DECLARE (LOCALVARS NEXTBLOCK)) (COND (T (PRIN1 (QUOTE "[next, pc]")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "[next, pc]") -1)) (= (|printout| NIL \, NEXTBLOCK NIL)) NIL) T)))) (TERPRI)) (PROGN (V\\PRINTSTK (IPLUS FRAME 6)) (PROGN (PROG ((NAMETABLE (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE (VVAG2 1 FRAME) 0) 9) 1)) (VGETBASEPTR (VVAG2 1 FRAME) 6)) (T (VGETBASEPTR (VVAG2 1 FRAME) 2))))) (DECLARE (LOCALVARS NAMETABLE)) (COND (T (PRIN1 (QUOTE "[nametable]")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "[nametable]") -1)) (= (|printout| NIL \, NAMETABLE NIL)) NIL) T)))) (TERPRI)) (PROGN (V\\PRINTSTK (IPLUS FRAME 8)) (PROGN (PROG ((BLINK (COND ((NOT (NEQ 0 (LOGAND (VGETBASE (VVAG2 1 FRAME) 1) 1))) (IDIFFERENCE FRAME 2)) (T (VGETBASE (VVAG2 1 FRAME) 8))))) (DECLARE (LOCALVARS BLINK)) (COND (T (PRIN1 (QUOTE "[blink, clink]")) (SELECTQ (CONSTANT (NTHCHAR (QUOTE "[blink, clink]") -1)) (= (|printout| NIL \, BLINK NIL)) NIL) T)))) (TERPRI)))) (SETQ NLOCALS (LRSH (VGETBASE NMT 7) 8)) (|for| |old| I |from| (IPLUS FRAME (PROGN 10)) |by| 2 |while| (ILESSP I FT) |as| J |from| 0 |do| (OR VARSONLY (V\\PRINTSTK I)) (COND ((ILESSP J NLOCALS) (COND ((OR (SETQ TMP (V\\SCANFORNTENTRY NMT (MAKE-NTENTRY 32768 J))) (AND (NEQ VARSONLY T) (SETQ TMP "local"))) (COND ((EQ (LRSH (VGETBASE (PROGN (VVAG2 1 I)) 0) 12) 0) (AND VARSONLY (SPACES 3)) (PRIN2 TMP) (SPACES 1) (APPLY* PRINTFN (VGETBASEPTR (VVAG2 1 I) 0))) ((NOT VARSONLY) (|printout| NIL TMP " [unbound]" T)))))) ((NOT VARSONLY) (COND ((SETQ TMP (V\\SCANFORNTENTRY NMT (MAKE-NTENTRY 49152 J))) (|printout| NIL "[fvar " .P2 TMP " " (COND ((EVENP (VGETBASE (PROGN (VVAG2 1 I)) 0)) (COND ((EQ (SETQ TMP (VHILOC ((LAMBDA ($$1) (VVAG2 (VGETBASE (PROGN $$1) 1) (VGETBASE $$1 0))) (VVAG2 1 I)))) 1) " on stack]") ((NEQ (LOGAND TMP (CONSTANT (LOGXOR (SUB1 2) -1))) (VHILOC (VVAG2 12 0))) (*) " non-stack binding]") (T " top value]"))) (T " not looked up]")) T)) (T (|printout| NIL "[padding]" T)))))) (COND ((NOT VARSONLY) (SETQ FT (VGETBASE (VVAG2 1 FRAME) 4)) (|for| |old| I |by| 2 |while| (ILESSP I FT) |do| (*) (V\\PRINTSTK I) (COND ((EQ (LRSH (VGETBASE (PROGN (VVAG2 1 I)) 0) 12) 0) (APPLY* PRINTFN (VGETBASEPTR (VVAG2 1 I) 0))) (T (TERPRI)))))))) +) + +(V\\SCANFORNTENTRY +(LAMBDA (NMT NTENTRY) (*) (*) (|bind| NM |for| NT1 |from| (PROGN 8) |by| (CONSTANT (PROGN 2)) |as| NT2 |from| (IPLUS (PROGN 8) (VGETBASE NMT 6)) |by| (CONSTANT (WORDSPERNTOFFSETENTRY)) |do| (COND ((NULL-NTENTRY (SETQ NM (GETSTKNAMEENTRY NMT NT1))) (RETURN))) (COND ((IEQP NTENTRY (GETSTKNTOFFSETENTRY NMT NT2)) (RETURN (VATOM NM)))))) +) + +(V\\PRINTSTK +(LAMBDA (I) (*) (PRINTNUM .I7 I) (PRIN1 ": ") (PRINTNUM .I7 (VGETBASE (VVAG2 1 0) I)) (PRINTNUM .I7 (VGETBASE (VVAG2 1 0) (ADD1 I))) (SPACES 1)) +) +) +(DEFINEQ + +(V\\CHECKARRAYBLOCK +(LAMBDA (BASE FREE ONFREELIST) (*) (COND (T (PROG (ERROR TRAILER) (COND ((NEQ (LRSH (VGETBASE BASE 0) 3) 5461) (SETQ ERROR "ARRAYBLOCK Password wrong")) ((NEQ (NEQ 0 (LOGAND (VGETBASE BASE 0) 1)) (NOT FREE)) (SETQ ERROR "ARRAYBLOCK INUSE bit set wrong")) (NIL (SETQ ERROR "Free ARRAYBLOCK with RefCnt not 1")) ((NEQ (LRSH (VGETBASE (SETQ TRAILER ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (VADDBASE (VADDBASE BASE N) N)) BASE (IDIFFERENCE (VGETBASE BASE 1) 1))) 0) 3) 5461) (SETQ ERROR "ARRAYBLOCK Trailer password wrong")) ((NEQ (VGETBASE BASE 1) (VGETBASE TRAILER 1)) (SETQ ERROR "ARRAYBLOCK Header and Trailer length don't match")) ((NEQ (NEQ 0 (LOGAND (VGETBASE BASE 0) 1)) (NOT FREE)) (SETQ ERROR "ARRAYBLOCK Trailer INUSE bit set wrong")) ((OR (NOT ONFREELIST) (ILESSP (VGETBASE BASE 1) 4)) (*) (RETURN)) ((OR (NOT (EQUAL (VGETBASEPTR (VGETBASEPTR BASE 4) 2) BASE)) (NOT (EQUAL (VGETBASEPTR (VGETBASEPTR BASE 2) 4) BASE))) (SETQ ERROR "ARRAYBLOCK links fouled")) ((|bind| (FBL _ ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (VADDBASE (VADDBASE BASE N) N)) VFREEBLOCKBUCKETS (IMIN (INTEGERLENGTH (VGETBASE BASE 1)) 30))) ROVER |first| (OR (SETQ ROVER (VGETBASEPTR FBL 0)) (RETURN (SETQ ERROR "Free block's bucket empty"))) |do| (AND (EQUAL ROVER BASE) (RETURN)) (V\\CHECKARRAYBLOCK ROVER T) |repeatuntil| (EQ (SETQ ROVER (VGETBASEPTR ROVER 2)) (VGETBASEPTR FBL 0)))) (T (*) (RETURN))) (ERROR BASE ERROR) (RETURN ERROR))))) +) + +(V\\PARSEARRAYSPACE +(LAMBDA (FN) (*) (COND ((NEQ |VArrayFrLst2| (VVAG2 64 0)) (*) (V\\PARSEARRAYSPACE1 FN (VVAG2 46 0) |VArrayFrLst2|) (V\\PARSEARRAYSPACE1 FN (VVAG2 64 0) |VArrayFrLst|)) (T (V\\PARSEARRAYSPACE1 FN (VVAG2 46 0) |VArrayFrLst|)))) +) + +(V\\PARSEARRAYSPACE1 +(LAMBDA (FN START END) (*) (|for| (ROVER _ START) |repeatuntil| (EQUAL END (SETQ ROVER ((LAMBDA (BASE N) (DECLARE (LOCALVARS BASE N)) (VADDBASE (VADDBASE BASE N) N)) ROVER (VGETBASE ROVER 1)))) |do| (V\\CHECKARRAYBLOCK ROVER (NOT (NEQ 0 (LOGAND (VGETBASE ROVER 0) 1))) (AND (NOT (NEQ 0 (LOGAND (VGETBASE ROVER 0) 1))) (VGETBASEPTR ROVER 2))) (AND FN (APPLY* FN ROVER (VGETBASE ROVER 1) (NEQ 0 (LOGAND (VGETBASE ROVER 0) 1)) (LOGAND (LRSH (VGETBASE ROVER 0) 1) 3))))) +) +) +(DEFINEQ + +(VPRINTCODE +(LAMBDA (FN LVFLG RADIX OUTF FIRSTBYTE PC FN.IS.CODEBASE) (*) (*) (*) (*) (*) (*) (DECLARE (SPECVARS OUTF)) (OR RADIX (SETQ RADIX 8)) (LET ((CODEBASE (COND (FN.IS.CODEBASE FN) (T (OR (V\\GET-COMPILED-CODE-BASE FN) (AND (LITATOM FN) (V\\GET-COMPILED-CODE-BASE (GET FN (QUOTE CODE)))) (ERROR FN "not compiled code"))))) (I4 (NUMFORMATCODE (LIST (QUOTE FIX) 4 RADIX))) (I6 (NUMFORMATCODE (LIST (QUOTE FIX) 6 RADIX))) NTSIZE STARTPC TAG TEMP OP# PVARS FVARS IVARS) (DECLARE (SPECVARS CODEBASE IVARS PVARS FVARS I4 I6)) (*) (LET ((*PRINT-BASE* RADIX)) (|for| I |from| 0 |by| 2 |while| (ILESSP I (LLSH (PROGN 8) 1)) |do| (PRINTNUM I4 I OUTF) (PRIN1 ": " OUTF) (PRINTNUM I6 (LOGOR (LLSH (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR I 3))) (T (V\\GETBASEBYTE CODEBASE I))) 8) ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (ADD1 I))) OUTF) (SELECTQ I (0 (PRIN1 " stkmin" OUTF)) (2 (PRIN1 " na" OUTF)) (4 (PRIN1 " pv" OUTF)) (6 (PRIN1 " startpc" OUTF)) (8 (AND (NEQ 0 (LRSH (VGETBASE CODEBASE 4) 15)) (PRIN1 "[CLOSUREP]" OUTF)) (|printout| OUTF " byteswapped: " (NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1))) (|printout| OUTF " argtype: " (LOGAND (LRSH (VGETBASE CODEBASE 4) 12) 3))) (10 (|printout| OUTF " frame name: " .P2 (V\\UNCOPY (VGETBASEPTR CODEBASE 4)))) (12 (PRIN1 " ntsize" OUTF)) (14 (|printout| OUTF " nlocals: " (LRSH (VGETBASE CODEBASE 7) 8)) (|printout| OUTF " fvaroffset: " (LOGAND (VGETBASE CODEBASE 7) 255))) NIL) (*) (TERPRI OUTF))) (SETQ NTSIZE (VGETBASE CODEBASE 6)) (VPRINTCODENT "name table: " (LLSH (PROGN 8) 1) (LLSH NTSIZE 1)) (SETQ STARTPC (VGETBASE CODEBASE 3)) (COND ((GREATERP (SETQ NTSIZE (IDIFFERENCE (COND ((PROGN NIL) (*) (- STARTPC 4)) (T STARTPC)) (SETQ TEMP (IPLUS (LLSH (PROGN 8) 1) (COND ((EQ NTSIZE 0) (*) 8) (T (LLSH NTSIZE 2))))))) 4) (VPRINTCODENT "Local args: " TEMP (LRSH NTSIZE 1))) ((EQ NTSIZE 4) (*) (|printout| OUTF T "Info: " .P2 (VGETBASEPTR CODEBASE (LRSH TEMP 1)) T))) (|printout| OUTF T "----" T) (PROG ((CODELOC STARTPC) (LEVEL (AND LVFLG 0)) B B1 B2 B3 B4 B5 FN LEN LEVADJ STK) (COND (LEVEL (SETUPHASHARRAY (QUOTE \\PRINTCODE.LEVEL)) (SETUPHASHARRAY (QUOTE \\PRINTCODE.STKSTATE)) (CLRHASH \\PRINTCODE.LEVEL) (CLRHASH \\PRINTCODE.STKSTATE))) LP (COND ((AND PC (IGEQ CODELOC PC)) (*) (COND ((NOT (IEQP CODELOC PC)) (PRINTOUT OUTF "(PC ") (PRINTNUM I4 PC OUTF) (PRINTOUT OUTF " not found)"))) (|printout| OUTF "------------------------------" T) (SETQ PC))) (COND ((OR (NULL FIRSTBYTE) (IGEQ CODELOC FIRSTBYTE)) (PRINTNUM I4 CODELOC OUTF) (PRIN1 ": " OUTF) (COND (LVFLG (SETQ TEMP (GETHASH CODELOC \\PRINTCODE.LEVEL)) (COND (LEVEL (COND ((AND TEMP (OR (NEQ LEVEL TEMP) (NOT (EQUAL STK (GETHASH CODELOC \\PRINTCODE.STKSTATE))))) (PRIN1 "*" OUTF)))) (T (SETQ LEVEL TEMP) (SETQ STK (GETHASH CODELOC \\PRINTCODE.STKSTATE)))) (COND (LEVEL (TAB 7 NIL OUTF) (PRINTNUM I4 LEVEL OUTF))))) (TAB 12 NIL OUTF)) (T (*) (SETQ TAG (\\FINDOP ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1)))))) (SELECTQ (OR (|fetch| OPPRINT |of| TAG) (|fetch| OPCODENAME |of| TAG)) (-X- (TERPRI OUTF) (RETURN)) (BIND (COND (LEVEL (|push| STK (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL (LOGAND (CODEBASELT CODEBASE CODELOC) 15)))))))) (UNBIND (AND LEVEL (SETQ LEVEL (|pop| STK)))) (DUNBIND (AND LEVEL (SETQ LEVEL (SUB1 (|pop| STK))))) (RETURN (SETQ LEVEL)) (SUBRCALL (AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (ADD1 CODELOC))))))) (MISCN (AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (IPLUS 2 CODELOC))))))) NIL) (COND ((AND LEVEL (SETQ LEVADJ (|fetch| LEVADJ |of| TAG))) (COND ((LISTP LEVADJ) (SETQ LEVADJ (CAR LEVADJ)))) (SELECTQ LEVADJ (FNX (SETQ LEVEL (PLUS LEVEL (IDIFFERENCE 1 (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR CODELOC 3))) (T (V\\GETBASEBYTE CODEBASE CODELOC))))))) (POP.N (SETQ LEVEL (IDIFFERENCE LEVEL (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR CODELOC 3))) (T (V\\GETBASEBYTE CODEBASE CODELOC)))))) ((JUMP UNWIND) (SETQ LEVEL)) ((CJUMP NCJUMP) (SETQ LEVEL (PLUS LEVEL -1))) (COND ((NUMBERP LEVADJ) (SETQ LEVEL (PLUS LEVEL LEVADJ))))))) (|add| CODELOC (|fetch| OPNARGS |of| TAG)) (GO LP))) (SETQ LEN (|fetch| OPNARGS |of| (SETQ TAG (\\FINDOP (SETQ B ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))))))) (PRINTNUM I4 B OUTF) (COND ((IGREATERP LEN 0) (PRINTNUM I4 (SETQ B1 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))) OUTF))) (COND ((IGREATERP LEN 1) (PRINTNUM I4 (SETQ B2 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))) OUTF))) (COND ((IGREATERP LEN 2) (PRINTNUM I4 (SETQ B3 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))) OUTF))) (COND ((IGREATERP LEN 3) (PRINTNUM I4 (SETQ B4 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))) OUTF))) (COND ((IGREATERP LEN 4) (PRINTNUM I4 (SETQ B5 ((LAMBDA (CODEBASE OFFSET) (DECLARE (LOCALVARS CODEBASE OFFSET)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (V\\GETBASEBYTE CODEBASE OFFSET)))) CODEBASE (PROG1 CODELOC (SETQ CODELOC (PLUS CODELOC 1))))) OUTF))) (PROGN (|printout| OUTF 30 (|fetch| OPCODENAME |of| TAG)) (SETQ OP# (|fetch| OP# |of| TAG)) (SETQ LEVADJ (|fetch| LEVADJ |of| TAG))) (COND ((LISTP OP#) (SETQ OP# (CAR OP#)))) (SELECTQ (SETQ TAG (OR (|fetch| OPPRINT |of| TAG) (|fetch| OPCODENAME |of| TAG))) (-X- (TERPRI OUTF) (RETURN)) (IVAR (TAB 40 NIL OUTF) (PROGN (*) (PROG NIL (PRIN2 (CADR (OR (ASSOC (SELECTQ LEN (0 (IDIFFERENCE B OP#)) (LRSH B1 1)) IVARS) (RETURN (|printout| OUTF "[" (QUOTE |ivar|) (SELECTQ LEN (0 (IDIFFERENCE B OP#)) (LRSH B1 1)) "]")))) OUTF)))) (PVAR (TAB 40 NIL OUTF) (PROGN (*) (PROG NIL (PRIN2 (CADR (OR (ASSOC (SELECTQ LEN (0 (IDIFFERENCE B OP#)) (LRSH B1 1)) PVARS) (RETURN (|printout| OUTF "[" (QUOTE |pvar|) (SELECTQ LEN (0 (IDIFFERENCE B OP#)) (LRSH B1 1)) "]")))) OUTF)))) (FVAR (TAB 40 NIL OUTF) (PROGN (*) (PROG NIL (PRIN2 (CADR (OR (ASSOC (SELECTQ LEN (0 (IDIFFERENCE B OP#)) (LRSH B1 1)) FVARS) (RETURN (|printout| OUTF "[" (QUOTE |fvar|) (SELECTQ LEN (0 (IDIFFERENCE B OP#)) (LRSH B1 1)) "]")))) OUTF)))) (JUMP ((LAMBDA (N) (PRIN1 "->" OUTF) (PRINTNUM I4 (SETQ N (IPLUS N (IDIFFERENCE CODELOC (ADD1 LEN)))) OUTF) (COND (LEVEL (PUTHASH N (SELECTQ LEVADJ ((NCJUMP JUMP) LEVEL) (SUB1 LEVEL)) \\PRINTCODE.LEVEL) (PUTHASH N STK \\PRINTCODE.STKSTATE)))) (IPLUS (IDIFFERENCE B OP#) 2))) (SIC (|printout| OUTF 40 .P2 B1)) (SNIC (|printout| OUTF 40 .P2 (IDIFFERENCE B1 256))) (SICX (|printout| OUTF 40 .P2 (IPLUS (LLSH B1 8) B2))) (JUMPX ((LAMBDA (N) (PRIN1 "->" OUTF) (PRINTNUM I4 (SETQ N (IPLUS N (IDIFFERENCE CODELOC (ADD1 LEN)))) OUTF) (COND (LEVEL (PUTHASH N (SELECTQ LEVADJ ((NCJUMP JUMP) LEVEL) (SUB1 LEVEL)) \\PRINTCODE.LEVEL) (PUTHASH N STK \\PRINTCODE.STKSTATE)))) (COND ((IGEQ B1 128) (IDIFFERENCE B1 256)) (T B1)))) (FN (*) (NEW-SYMBOL-CODE (BIG-VMEM-HOST (SETQ B (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3) 8) B4)) (SETQ B (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3))) (SETQ B (IPLUS (LLSH B1 8) B2))) (|printout| OUTF 40 .P2 (VATOM B))) (BIND (TAB 40 NIL OUTF) (PROG ((NNILS (LRSH B1 4)) (NVALS (LOGAND B1 15))) (|for| I |from| (ADD1 (IDIFFERENCE B2 (IPLUS NNILS NVALS))) |to| (IDIFFERENCE B2 NNILS) |do| (SPACES 1 OUTF) (PCVAR I PVARS (QUOTE |pvar|))) (PRIN1 (QUOTE \;) OUTF) (|for| I |from| (ADD1 (IDIFFERENCE B2 NNILS)) |to| B2 |do| (SPACES 1 OUTF) (PCVAR I PVARS (QUOTE |pvar|))) (COND (LEVEL (|push| STK (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL NVALS)))))))) (JUMPXX ((LAMBDA (N) (PRIN1 "->" OUTF) (PRINTNUM I4 (SETQ N (IPLUS N (IDIFFERENCE CODELOC (ADD1 LEN)))) OUTF) (COND (LEVEL (PUTHASH N (SELECTQ LEVADJ ((NCJUMP JUMP) LEVEL) (SUB1 LEVEL)) \\PRINTCODE.LEVEL) (PUTHASH N STK \\PRINTCODE.STKSTATE)))) (IPLUS (LLSH B1 8) B2 (COND ((IGREATERP B1 127) -65536) (T 0))))) (ATOM (|printout| OUTF 40 .P2 (VATOM (NEW-SYMBOL-CODE (BIG-VMEM-HOST (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3) 8) B4) (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3)) (IPLUS (LLSH B1 8) B2))))) (GCONST (|printout| OUTF 40 .P2 (V\\UNCOPY (BIG-VMEM-HOST (VVAG2 (IPLUS (LLSH B1 8) B2) (IPLUS (LLSH B3 8) B4)) (VVAG2 B1 (IPLUS (LLSH B2 8) B3)))))) (FNX (|printout| OUTF "(" B1 ")" 40 .P2 (VATOM (NEW-SYMBOL-CODE (BIG-VMEM-HOST (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B2 8) B3) 8) B4) 8) B5) (IPLUS (LLSH (IPLUS (LLSH B2 8) B3) 8) B4)) (IPLUS (LLSH B2 8) B3))))) (TYPEP (|printout| OUTF "(" .P2 (OR (V\\TYPENAMEFROMNUMBER B1) (QUOTE ?)) ")")) (UNBIND (AND LEVEL (SETQ LEVEL (|pop| STK)))) (DUNBIND (AND LEVEL (SETQ LEVEL (SUB1 (|pop| STK))))) (RETURN (SETQ LEVEL)) (SUBRCALL (|printout| OUTF 40 (|for| X |in| \\INITSUBRS |when| (EQ B1 (CADR X)) |do| (RETURN (CAR X)) |finally| (RETURN "?"))) (AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL B2))))) (MISCN (|printout| OUTF 40 (|for| X |in| \\USER-SUBR-LIST |when| (EQ B1 (CADR X)) |do| (RETURN (CAR X)) |finally| (RETURN "?"))) (AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL B2))))) (COND ((LISTP TAG) (|printout| OUTF 40 (CAR (NTH TAG (ADD1 B1))))))) (TERPRI OUTF) (COND ((AND LEVEL LEVADJ) (SELECTQ LEVADJ (FNX (SETQ LEVEL (PLUS LEVEL (IDIFFERENCE 1 B1)))) (POP.N (SETQ LEVEL (IDIFFERENCE LEVEL B1))) ((JUMP UNWIND) (SETQ LEVEL)) ((CJUMP NCJUMP) (SETQ LEVEL (PLUS LEVEL -1))) (COND ((NUMBERP LEVADJ) (SETQ LEVEL (PLUS LEVEL LEVADJ))))))) (GO LP)))) +) + +(VPRINTCODENT +(LAMBDA (STR START1 START2) (DECLARE (USEDFREE CODEBASE IVARS PVARS FVARS I4 I6 OUTF)) (*) (*) (LET (NAME TAG) (COND ((ILESSP START1 (SETQ START2 (IPLUS START2 START1))) (|printout| OUTF STR T) (|for| NT1 |from| START1 |by| (LLSH (CONSTANT (PROGN 2)) 1) |while| (ILESSP NT1 START2) |as| NT2 |from| START2 |by| (LLSH (PROGN 2) 1) |do| (PRINTNUM I4 NT1 OUTF) (PRIN1 ": " OUTF) (PRINTNUM I6 (GETNAMEENTRY CODEBASE NT1) OUTF) (SPACES 3 OUTF) (PRINTNUM I4 NT2 OUTF) (PRIN1 ": " OUTF) (PRINTNUM I6 (GETNTOFFSETENTRY CODEBASE NT2) OUTF) (COND ((SETQ NAME (VATOM (CODEBASEGETNAME CODEBASE NT1))) (SETQ TAG (GETNTOFFSET CODEBASE NT2)) (|printout| OUTF .SP 5 (SELECTC (NTSLOT-VARTYPE (GETNTOFFSETENTRY CODEBASE NT2)) (0 (|push| IVARS (LIST TAG NAME)) (QUOTE IVAR)) (32768 (|push| PVARS (LIST TAG NAME)) (QUOTE PVAR)) (PROGN (|push| FVARS (LIST TAG NAME)) (QUOTE FVAR))) " " TAG ": " .P2 NAME))) (TERPRI OUTF)))))) +) + +(VBROKENDEF +(LAMBDA (DEF WHEN) (*) (PROG ((CA (V\\GET-COMPILED-CODE-BASE DEF)) BEFORE AFTER SIZE FIRSTBYTE NEWCA) (SETQ FIRSTBYTE (VGETBASE CA 3)) NIL (*) (PROGN (*) (PROGN (*) (SETQ NEWCA CA) (SETQ AFTER T) (GO DOSCAN)) (COND (AFTER (*) (|bind| OP |do| (SELECTQ (CADR (SETQ OP (\\FINDOP (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE NEWCA 4) 14) 1)) (V\\GETBASEBYTE NEWCA (LOGXOR FIRSTBYTE 3))) (T (V\\GETBASEBYTE NEWCA FIRSTBYTE)))))) (-X- (RETURN)) (GCONST NIL) (RETURN ((LAMBDA (CODEBASE OFFSET NEWVALUE) (DECLARE (LOCALVARS CODEBASE OFFSET NEWVALUE)) (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE CODEBASE 4) 14) 1)) (V\\PUTBASEBYTE CODEBASE (LOGXOR OFFSET 3) NEWVALUE)) (T (V\\PUTBASEBYTE CODEBASE OFFSET NEWVALUE)))) NEWCA FIRSTBYTE (V\\CAR.UFN (\\FINDOP (QUOTE \\RETURN))))) NIL) (SETQ FIRSTBYTE (PLUS FIRSTBYTE 1 (CADDR OP))))))) (RETURN NEWCA))) +) +) +(DEFINEQ + +(V\\CAR.UFN +(LAMBDA (X) (*) (*) (*) (COND ((VLISTP X) (COND ((ZEROP 1) (VGETBASEPTR X 0)) (T (COND ((EQ (LRSH (VGETBASE X 0) 12) 0) (VGETBASEPTR (VGETBASEPTR X 0) 0)) (T (VGETBASEPTR X 0)))))) ((NULL X) NIL) (T (SELECTQ T (T (LISPERROR "ARG NOT LIST" X)) ((NIL V\\CDR.UFN) (COND ((EQ X T) T) ((LITATOM X) NIL) (T (QUOTE "{car of non-list}")))) (COND ((EQ X T) T) ((STRINGP X) (LISPERROR "ARG NOT LIST" X)) (T (QUOTE "{car of non-list}"))))))) +) + +(V\\CDR.UFN +(LAMBDA (X) (*) (*) (*) (COND ((VLISTP X) (COND ((ZEROP 1) (VGETBASEPTR X 2)) (T (PROG ((Q (LRSH (VGETBASE X 0) 12))) (RETURN (COND ((EQ Q 8) NIL) ((IGREATERP Q 8) (VADDBASE (VVAG2 (VHILOC X) (LOGAND (VLOLOC X) 65280)) (LLSH (IDIFFERENCE Q 8) 1))) ((EQ Q 0) (V\\CDR.UFN (VGETBASEPTR X 0))) (T (VGETBASEPTR (VADDBASE (VVAG2 (VHILOC X) (LOGAND (VLOLOC X) 65280)) (LLSH Q 1)) 0)))))))) ((NULL X) NIL) (T (SELECTQ T ((T V\\CDR.UFN) (LISPERROR "ARG NOT LIST" X)) (NIL (COND ((LITATOM X) (VGETPROPLIST X)) (T "{cdr of non-list}"))) (COND ((STRINGP X) (LISPERROR "ARG NOT LIST" X)) (T "{cdr of non-list}")))))) +) +) +(DEFINEQ + +(V\\COPY +(LAMBDA (X) (*) (*) (SELECTQ (TYPENAME X) ((LITATOM NEW-ATOM) (VATOMNUMBER X T)) (VLISTP (PROG ((R (REVERSE X)) (V (V\\COPY (CDR (LAST X))))) LP (COND ((LISTP R) (SETQ V (CONS (V\\COPY (CAR R)) V)) (SETQ R (CDR R)) (GO LP))) (RETURN V))) ((FIXP SMALLP) (PROG (V) (COND ((IGREATERP 0 X) (*) (COND ((IGREATERP X -65537) (*) (RETURN (VADDBASE (VVAG2 15 0) (LOGAND X 65535)))))) ((ILESSP X 65536) (*) (RETURN (VADDBASE (VVAG2 14 0) X)))) (*) (SETQ V (CREATECELL 2)) (VPUTBASE V 0 (LOGOR (COND ((IGREATERP 0 X) 32768) (T 0)) (LOGAND (LRSH X 16) 32767))) (VPUTBASE V 1 (LOGAND X 65535)) (RETURN V))) (ONED-ARRAY (%COPY-ONED-ARRAY X)) (STRINGP (*) (%COPY-STRING-TO-ARRAY X)) (FLOATP (PROG ((VAL (CREATECELL 3))) (SELECTQ (SYSTEMTYPE) ((ALTO D) (VPUTBASE VAL 0 (\\GETBASE X 0)) (VPUTBASE VAL 1 (\\GETBASE X 1))) (MKI.IEEE X VAL)) (RETURN VAL))) (CHARACTER (VVAG2 7 (CL:CHAR-CODE X))) (ERROR X "can't be copied to remote file"))) +) + +(V\\UNCOPY +(LAMBDA (X CARLVL CDRLVL) (*) (SELECTC (VNTYPX X) (1 (COND ((EQ (VHILOC X) 14) (*) (VLOLOC X)) (T (IPLUS (VLOLOC X) -65536)))) (2 (*) (|create| FIXP HINUM _ (VGETBASE X 0) LONUM _ (VGETBASE X 1))) (3 (|create| FLOATP HIWORD _ (VGETBASE X 0) LOWORD _ (VGETBASE X 1))) (4 (VATOM (VLOLOC X))) (7 (PROG ((PTR (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE X 2) 14) 1)) (%ARRAY-BASE X)) (T (VGETBASEPTR X 0)))) (OFFST (COND ((NEQ 0 (LOGAND (LRSH (VGETBASE X 2) 14) 1)) (%ARRAY-OFFSET X)) (T (VGETBASE X 3)))) (LENGTH (\\GETBASEFIXP X 4)) (I 1) STR) (*) (SETQ STR (ALLOCSTRING LENGTH)) (FRPTQ LENGTH (RPLSTRING STR I (FCHARACTER (V\\GETBASEBYTE PTR OFFST))) (SETQ I (PLUS I 1)) (SETQ OFFST (PLUS OFFST 1))) (RETURN STR))) (9 (\\VAG2 7 (VLOLOC X))) (%ONED-ARRAY (LET ((SIZE (\\GETBASEFIXP X 6)) (BASE (VGETBASEPTR X 0)) (OFFSET (VGETBASE X 3)) (TYPENUMBER (LOGAND (VGETBASE X 2) 255)) NCELLS LOCAL-ARRAY LOCAL-BASE) (|if| (EQ (%TYPENUMBER-TO-GC-TYPE TYPENUMBER) 1) |then| (VTYPEDPOINTER (VTYPENAME X) X) |else| (SETQ NCELLS (LRSH (IPLUS (ITIMES (IPLUS SIZE OFFSET) (%TYPENUMBER-TO-BITS-PER-ELEMENT TYPENUMBER)) 31) 5)) (SETQ LOCAL-ARRAY (|create| ONED-ARRAY)) (SETQ LOCAL-BASE (\\ALLOCBLOCK NCELLS)) (|freplace| (ONED-ARRAY BASE) |of| LOCAL-ARRAY |with| LOCAL-BASE) (|freplace| (ONED-ARRAY STRING-P) |of| LOCAL-ARRAY |with| (%CHAR-TYPE-P TYPENUMBER)) (|freplace| (ONED-ARRAY FILL-POINTER-P) |of| LOCAL-ARRAY |with| (NEQ 0 (LOGAND (LRSH (VGETBASE X 2) 9) 1))) (|freplace| (ONED-ARRAY TYPE-NUMBER) |of| LOCAL-ARRAY |with| TYPENUMBER) (|freplace| (ONED-ARRAY FILL-POINTER) |of| LOCAL-ARRAY |with| (\\GETBASEFIXP X 4)) (|if| (NEQ OFFSET 0) |then| (|freplace| (ONED-ARRAY OFFSET) |of| LOCAL-ARRAY |with| OFFSET) (|freplace| (ONED-ARRAY DISPLACED-P) |of| LOCAL-ARRAY |with| T)) (|freplace| (ONED-ARRAY TOTAL-SIZE) |of| LOCAL-ARRAY |with| SIZE) (|for| I |from| 0 |to| (SUB1 (LLSH NCELLS 1)) |do| (\\PUTBASE LOCAL-BASE I (VGETBASE BASE I))) LOCAL-ARRAY))) (5 (COND ((VLISTP X) (COND ((EQ CDRLVL 0) (*) (QUOTE (--))) (T (CONS (COND ((OR (EQ CARLVL 0) (AND (OR (EQ CARLVL 1) (EQ CDRLVL 1)) (VLISTP (V\\CAR.UFN X)))) (QUOTE &)) (T (V\\UNCOPY (V\\CAR.UFN X) (AND CARLVL (SUB1 CARLVL)) (AND CDRLVL (SUB1 CDRLVL))))) (V\\UNCOPY (V\\CDR.UFN X) CARLVL (AND CDRLVL (SUB1 CDRLVL))))))) (T (*) (VTYPEDPOINTER (QUOTE LISTP) X)))) (0 (VTYPEDPOINTER NIL X)) (VTYPEDPOINTER (VTYPENAME X) X))) +) +) +(DEFINEQ + +(V\\GETBASEBYTE +(LAMBDA (PTR N) (*) (*) (COND ((EVENP N) (LRSH (PROGN (VGETBASE PTR (LRSH N 1))) 8)) (T (LOGAND (PROGN (VGETBASE PTR (LRSH N 1))) 255)))) +) + +(V\\PUTBASEBYTE +(LAMBDA (PTR DISP BYTE) (*) (*) (SETQ BYTE (PROG1 BYTE)) (VPUTBASE PTR (LRSH (SETQ DISP (\\DTEST DISP (QUOTE SMALLP))) 1) (COND ((EVENP DISP 2) ((LAMBDA ($$1) (IPLUS (LLSH BYTE 8) (LOGAND $$1 255))) (VGETBASE PTR (LRSH DISP 1)))) (T ((LAMBDA ($$1) (IPLUS (LLSH (LRSH $$1 8) 8) BYTE)) (VGETBASE PTR (LRSH DISP 1)))))) BYTE) +) +) +(DEFINEQ + +(VNTYPX +(LAMBDA (X) (*) (*) (LOGAND (VGETBASE (VVAG2 24 0) (LRSH (IPLUS (LLSH (VHILOC X) 8) (LRSH (VLOLOC X) 8)) 1)) 2047)) +) + +(VTYPENAME +(LAMBDA (DATUM) (*) (LET ((N (VNTYPX DATUM))) (COND ((EQ N 6) ((LAMBDA (X) (QUOTE ARRAYP)) DATUM)) ((%STRINGP DATUM) (*) (QUOTE STRINGP)) (T (VATOM (VGETBASEPTR (VADDBASE (VVAG2 20 4096) (ITIMES N 18)) 0)))))) +) + +(V\\TYPENAMEFROMNUMBER +(LAMBDA (N) (*) (COND ((ILESSP N (ADD1 |VMaxTypeNumber|)) (VATOM (VGETBASEPTR (VADDBASE (VVAG2 20 4096) (ITIMES N 18)) 0))))) +) +) +(DEFINEQ + +(VUNCOPYATOM +(LAMBDA (N) (*) (*) (PROG (ATOM.NAME VPACKAGE.NAME) (*) (SETQ ATOM.NAME (VSYMBOL.PNAME N)) (*) (SETQ VPACKAGE.NAME (IF (READSYS.HAS.PACKAGES) THEN (VPACKAGE.NAME (VSYMBOL.PACKAGE N)) ELSE "INTERLISP")) (RETURN (VMAKE.LOCAL.ATOM VPACKAGE.NAME ATOM.NAME)))) +) + +(VMAKE.LOCAL.ATOM +(LAMBDA (PKG.NAME ATM.NAME) (*) (*) (CL:INTERN ATM.NAME (OR (CL:FIND-PACKAGE PKG.NAME) (CL:MAKE-PACKAGE PKG.NAME :USES NIL)))) +) + +(VSYMBOL.VALUE +(LAMBDA (SYMBOL) (*) (*) (LET ((LOC (VOLD.FIND.SYMBOL SYMBOL 1 (NCHARS SYMBOL)))) (COND (NIL (*) (VGETBASEPTR (VADDBASE (VVAG2 12 LOC) LOC) 0)) (T (*) (VGETBASEPTR (VADDBASE (VVAG2 44 0) (IPLUS (ITIMES (LOGAND LOC 65535) 10) 2)) 0))))) +) + +(VSYMBOL.PNAME +(LAMBDA (N BUFFER) (*) (*) (SETQ BUFFER (OR BUFFER (ALLOCSTRING \\PNAMELIMIT))) (PROG (ADDR LEN) (*) (COND (NIL (SETQ ADDR (VGETBASEPTR (VADDBASE (VADDBASE (VVAG2 8 0) N) N) 0))) (T (SETQ ADDR (VGETBASEPTR (VADDBASE (VVAG2 44 0) (IPLUS (ITIMES (LOGAND N 65535) 10) 0)) 0)))) (SETQ LEN (V\\GETBASEBYTE ADDR 0)) (|for| I |from| 1 |to| LEN |do| (RPLSTRING BUFFER I (FCHARACTER (V\\GETBASEBYTE ADDR I)))) (RETURN (SUBSTRING BUFFER 1 LEN)))) +) + +(VSYMBOL.PACKAGE +(LAMBDA (N) (*) (*) (PROG ((INDEX (COND (NIL (*) (LRSH (VGETBASE (VADDBASE (VADDBASE (VVAG2 8 0) N) N) 0) 8)) (NIL (T (LRSH (VGETBASE (VADDBASE (VVAG2 44 0) (IPLUS (ITIMES 10 N) 0 8)) 0) 8))) (T (LRSH (VGETBASE (V\\ATOMCELL N 8) 8) 8))))) (RETURN (COND ((EQ INDEX *UNINTERNED-PACKAGE-INDEX*) NIL) (T (VGETBASEPTR (VGETBASEPTR READSYS.PACKAGE.FROM.INDEX 0) (LLSH INDEX 1))))))) +) + +(VOLD.FIND.SYMBOL +(LAMBDA (BASE OFFST LEN FATP NONNUMERICP) (*) (PROG ((FATCHARSEENP (AND FATP (NOT (NULL (|for| I |from| OFFST |to| (SUB1 (IPLUS OFFST LEN)) |suchthat| (IGREATERP (VGETBASE BASE I) 255)))))) HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE) (*) (COND ((EQ LEN 0) (*) (SETQ HASH 0) (SETQ FIRSTBYTE 255) (GO LP))) (SETQ FIRSTCHAR (NTHCHARCODE BASE OFFST)) (*) NIL (*) (SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255)) (*) (PROGN (*) (SETQ HASH (LLSH FIRSTBYTE 8)) (|for| CHAR# |from| (ADD1 OFFST) |to| (SUB1 (IPLUS OFFST LEN)) |do| (SETQ HASH (IPLUS16 (IPLUS16 (SETQ HASH (IPLUS16 HASH (LLSH (LOGAND HASH 4095) 2))) (LLSH (LOGAND HASH 255) 8)) (NTHCHARCODE BASE CHAR#))))) (*) LP (*) (COND ((NEQ 0 (SETQ HASHENT (VGETBASE (VVAG2 21 0) HASH))) (*) (COND ((STREQUAL (CL:SYMBOL-NAME BASE) (VSYMBOL.PNAME (SETQ ATM# (SUB1 HASHENT)))) (RETURN ATM#)) (T (*) (SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (LOGAND 63 (LOGOR 1 (LOGXOR FIRSTBYTE HASH))))))) (GO LP))))) (*) (RETURN (PROGN (LET ((NEWATOM (VNOSUCHATOM BASE OFFST LEN FATP FATCHARSEENP))) NIL NEWATOM))))) +) + +(VLOOKUP-SYMBOL +(LAMBDA (TABLE STRING SXHASH ENTRY-HASH) (*) (*) (LET* ((VEC (VGETBASEPTR TABLE 0)) (*) (HASH (VGETBASEPTR TABLE 2)) (*) (LEN (\\GETBASEFIXP VEC 6)) (*) (H2 (ADD1 (IREMAINDER SXHASH (IDIFFERENCE LEN 2)))) (*)) (DECLARE (TYPE (CL:SIMPLE-ARRAY (CL:UNSIGNED-BYTE 8)) HASH) (TYPE (CL:SIMPLE-ARRAY (CL:UNSIGNED-BYTE 16)) VEC)) (PROG ((INDEX-VAR (IREMAINDER SXHASH LEN)) SYMBOL-NUMBER EHASH) (IF NIL THEN (CL:FORMAT T "Probe @ ~s~%" INDEX-VAR)) LOOP (SETQ EHASH (V\\GETBASEBYTE (VGETBASEPTR HASH 0) INDEX-VAR)) (*) (COND ((EQL EHASH ENTRY-HASH) (IF NIL THEN (CL:FORMAT T "Entry hash MATCHES~%")) (LET ((SYMBOL-NAME (VSYMBOL.PNAME (SETQ SYMBOL-NUMBER (VGETBASE (VGETBASEPTR VEC 0) INDEX-VAR))))) (*) (IF NIL THEN (CL:FORMAT T "Got symbol index~%")) (*) (COND ((STREQUAL SYMBOL-NAME STRING) (IF NIL THEN (CL:FORMAT T " found~%")) (GO DOIT)) (T (IF NIL THEN (CL:FORMAT T "Didn't match~%")))))) ((EQL 0 EHASH) (IF NIL THEN (CL:FORMAT T "Hit deleted entry (no match)~%")) (SETQ INDEX-VAR NIL) (GO DOIT)) (T (IF NIL THEN (CL:FORMAT T "Entry hash does not match~%")))) (SETQ INDEX-VAR (IREMAINDER (IPLUS INDEX-VAR H2) LEN)) (*) (IF NIL THEN (CL:FORMAT T "Reprobe @ ~s~%" INDEX-VAR)) (GO LOOP) DOIT (RETURN SYMBOL-NUMBER)))) +) + +(VFIND.PACKAGE +(LAMBDA (NAME) (*) (*) (PROG ((ITEM (MKSTRING NAME)) (HA READSYS.PACKAGE.FROM.NAME) BITS INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT ABASE VALUE) (SETQ BITS (STRINGHASHBITS ITEM)) (SETQ INDEX (LOGAND BITS (VGETBASE HA 1))) (*) (SETQ ABASE (VGETBASEPTR HA 2)) (SETQ FIRSTINDEX INDEX) (SETQ REPROBE (LOGOR (LOGAND (LOGXOR BITS (LRSH BITS 8)) (IMIN 63 (VGETBASE HA 1))) 1)) (*) (SETQ LIMIT (VGETBASE HA 1)) LP (SETQ SLOT ((LAMBDA (BASEA0294) (DECLARE (LOCALVARS BASEA0294)) (VADDBASE (VADDBASE BASEA0294 INDEX) INDEX)) (VADDBASE (VADDBASE ABASE INDEX) INDEX))) (*) (COND ((SETQ VALUE (VGETBASEPTR SLOT 2)) (*) (SETQ SKEY (V\\UNCOPY (VGETBASEPTR SLOT 0))) (COND ((STREQUAL ITEM SKEY) (*) (GO FOUND)))) ((NULL (VGETBASEPTR SLOT 0)) (*) (RETURN NIL))) (SETQ INDEX (LOGAND (IPLUS16 INDEX REPROBE) LIMIT)) (*) (COND ((EQ INDEX FIRSTINDEX) (*) (SHOULDNT "Hashing in full hash table"))) (GO LP) FOUND (RETURN (AND (NEQ VALUE \\HASH.NULL.VALUE) VALUE)))) +) + +(VFIND.SYMBOL +(LAMBDA (STRING PACKAGE) (*) (*) (LET* ((LENGTH (FFETCH (STRINGP LENGTH) OF STRING)) (HASH (COND ((EQL 0 LENGTH) 0) (T (PROG* ((TERMINUS LENGTH) (HASH (LLSH (NTHCHARCODE STRING 1) 8)) (CHAR# 2)) A0355 (COND ((IGREATERP CHAR# TERMINUS) (RETURN (PROGN HASH)))) (PROGN) (SETQ HASH (IPLUS16 (IPLUS16 (SETQ HASH (IPLUS16 HASH (LLSH (LOGAND HASH 4095) 2))) (LLSH (LOGAND HASH 255) 8)) (NTHCHARCODE STRING CHAR#))) (SETQ CHAR# (ADD1 CHAR#)) (GO A0355))))) (*) (EHASH (IPLUS (IREMAINDER (LOGXOR LENGTH HASH (RSH HASH 8) (RSH HASH 16) (RSH HASH 19)) 254) 2)) (*) (SYM) (WHERE) (DONE)) (COND ((NOT (VGETBASEPTR PACKAGE 14)) (*) (IF NIL THEN (PRINT "Checking INTERNAL symbols")) (LET ((INDEX (VLOOKUP-SYMBOL (VGETBASEPTR PACKAGE 16) STRING HASH EHASH))) (*) (COND (INDEX (SETQ SYM INDEX) (SETQ WHERE :INTERNAL) (SETQ DONE T)))))) (COND ((NOT DONE) (IF NIL THEN (PRINT "Checking EXTERNAL symbols")) (LET ((INDEX (VLOOKUP-SYMBOL (VGETBASEPTR PACKAGE 18) STRING HASH EHASH))) (*) (COND (INDEX (SETQ SYM INDEX) (SETQ WHERE :EXTERNAL) (SETQ DONE T)))))) (COND ((NOT DONE) (IF NIL THEN (CL:FORMAT T "Checking USE'd packages~%")) (LET ((HEAD (VGETBASEPTR PACKAGE 2)) (*)) (PROG ((PREV HEAD) (TABLE (V\\CDR.UFN HEAD))) USED-PACKAGE-LOOP (COND ((OR DONE (NULL TABLE)) (RETURN (PROGN (CL:VALUES NIL NIL))))) (PROGN (LET ((INDEX (VLOOKUP-SYMBOL (V\\CAR.UFN TABLE) STRING HASH EHASH))) (*) (COND (INDEX (COND ((NEQ PREV HEAD) (LET* ((A0347 PREV) (A0346 (V\\CDR.UFN A0347)) (A0349 TABLE) (A0348 (V\\CDR.UFN A0349)) (A0351 HEAD) (A0350 (V\\CDR.UFN A0351))) (V\\CDR.UFN (RPLACD A0347 A0348)) (V\\CDR.UFN (RPLACD A0349 A0350)) (V\\CDR.UFN (RPLACD A0351 TABLE)) A0346))) (SETQ SYM INDEX) (SETQ WHERE :INHERITED) (SETQ DONE T)) (T)))) (PROGN (SETQ PREV (PROG1 TABLE (PROGN (SETQ TABLE (V\\CDR.UFN TABLE)) NIL))) NIL) (GO USED-PACKAGE-LOOP))))) (CL:VALUES SYM WHERE))) +) + +(VPACKAGE.NAME +(LAMBDA (RMPKG) (*) (AND RMPKG (V\\UNCOPY (VGETBASEPTR RMPKG 4))))) + +(V\\MKATOM +(LAMBDA (BASE OFFST LEN FATP NONNUMERICP) (*) (PROG ((FATCHARSEENP (AND FATP (NOT (NULL (|for| I |from| OFFST |to| (SUB1 (IPLUS OFFST LEN)) |suchthat| (IGREATERP (VGETBASE BASE I) 255)))))) HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE) (*) (COND ((EQ LEN 0) (*) (SETQ HASH 0) (SETQ FIRSTBYTE 255) (GO LP))) (SETQ FIRSTCHAR (NTHCHARCODE BASE OFFST)) (*) NIL (*) (SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255)) (*) (PROGN (*) (SETQ HASH (LLSH FIRSTBYTE 8)) (|for| CHAR# |from| (ADD1 OFFST) |to| (SUB1 (IPLUS OFFST LEN)) |do| (SETQ HASH (IPLUS16 (IPLUS16 (SETQ HASH (IPLUS16 HASH (LLSH (LOGAND HASH 4095) 2))) (LLSH (LOGAND HASH 255) 8)) (NTHCHARCODE BASE CHAR#))))) (*) LP (*) (COND ((NEQ 0 (SETQ HASHENT (VGETBASE (VVAG2 21 0) HASH))) (*) (COND ((EQ (VATOM (SETQ ATM# (SUB1 HASHENT))) BASE) (RETURN (VADDBASE (VVAG2 0 0) ATM#))) (T (*) (SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (LOGAND 63 (LOGOR 1 (LOGXOR FIRSTBYTE HASH))))))) (GO LP))))) (*) (RETURN (PROGN (LET ((NEWATOM (VNOSUCHATOM BASE OFFST LEN FATP FATCHARSEENP))) NIL NEWATOM))))) +) + +(VGETTOPVAL +(LAMBDA (X) (*) (VGETBASEPTR (V\\ATOMCELL X 12) 0))) + +(VGETPROPLIST +(LAMBDA (ATM) (*) (VGETBASEPTR (V\\ATOMCELL ATM (CONSTANT 2)) 0))) + +(VSETTOPVAL +(LAMBDA (ATM VAL) (*) (SELECTQ ATM (NIL (AND VAL (LISPERROR "ATTEMPT TO SET NIL OR T" VAL))) (T (OR (EQ VAL T) (LISPERROR "ATTEMPT TO SET NIL OR T" VAL))) (VPUTBASEPTR (V\\ATOMCELL ATM 12) 0 (V\\COPY VAL)))) +) + +(VGETDEFN +(LAMBDA (A) (*) (VGETBASEPTR (V\\ATOMCELL A 10) 0))) + +(V\\ATOMCELL +(LAMBDA (X N) (*) (LET ((ATOMNO (VATOMNUMBER X))) (COND (NIL (*) (EQ (VHILOC ATOMNO) 0) (*) (LET ((LOC (SELECTC N (10 (VATOMNUMBER ATOMNO)) (12 (VATOMNUMBER ATOMNO)) (2 (VATOMNUMBER ATOMNO)) (8 (\\ATOMPNAMEINDEX ATOMNO)) (SHOULDNT)))) (VADDBASE (VVAG2 N LOC) LOC))) ((FIXP ATOMNO) (*) (LET ((LOC (SELECTC N (10 4) (12 2) (2 6) (8 0) (SHOULDNT)))) (VADDBASE (VVAG2 44 0) (IPLUS LOC (ITIMES 10 ATOMNO))))) (T (*) (LET ((OFFSET (SELECTC N (10 4) (12 2) (2 6) (8 0) (SHOULDNT)))) (VADDBASE ATOMNO OFFSET)))))) +) +) +(DEFINEQ + +(VLISTP +(LAMBDA (X) (*) (*) (AND (EQ (VNTYPX X) 5) (COND ((EQ 1 0) T) (T (*) (NEQ (LOGAND (VLOLOC X) 255) 0))) X)) +) +) + +(RPAQQ COPYATOMSTR NIL) +(DEFINEQ + +(V\\GET-COMPILED-CODE-BASE +(LAMBDA (X) (*) (*) (PROG NIL (COND ((LITATOM X) (COND ((PROG1 (NEQ 0 (LRSH (VGETBASE (V\\ATOMCELL X 10) 0) 15)) (SETQ X (VGETBASEPTR (V\\ATOMCELL X 10) 0))) (RETURN X))))) (RETURN (AND (EQ (VNTYPX X) 13) (VGETBASEPTR (\\DTEST X (QUOTE COMPILED-CLOSURE)) 0))))) +) +) + + + +(* |;;| +"YOU MUST REMAKE THIS FILE using (DORENAME 'R) (after CONNing to library) whenever the SYSOUT layout changes in LLPARAMS (e.g., if MDSTypeTable moves)" +) + + +(FILESLOAD VMEM) + +(RPAQQ RDVALS ((\\RPTSIZE) (|\\ArrayFrLst|) (|\\ArrayFrLst2|) (|\\MaxTypeNumber|) (|\\AtomFrLst|)) +) + +(RPAQQ RDPTRS ((\\REALPAGETABLE) (\\FREEBLOCKBUCKETS))) +(DECLARE\: EVAL@COMPILE DONTCOPY + +(FILESLOAD (LOADCOMP) VMEM) +) +(DECLARE\: DONTCOPY + (FILEMAP (NIL (1392 8231 (VREADPAGEMAP 1402 . 2230) (VREADPAGEMAPBLOCK 2232 . 2378) (VCHECKIFPAGE 2380 + . 2596) (V\\LOCKEDPAGEP 2598 . 2747) (V\\LOOKUPPAGEMAP 2749 . 2944) (VCHECKPAGEMAP 2946 . 4630) ( +VCHECKFPTOVP 4632 . 4879) (VCHECKFPTOVP1 4881 . 5217) (V\\SHOWPAGETABLE 5219 . 6359) (V\\PRINTFPTOVP +6361 . 8229)) (8232 17921 (VRAIDCOMMAND 8242 . 11844) (VRAIDSHOWFRAME 11846 . 12375) (VRAIDSTACKCMD +12377 . 13457) (VRAIDROOTFRAME 13459 . 13648) (VPRINTADDRS 13650 . 14198) (VPRINTVA 14200 . 14320) ( +VREADVA 14322 . 14382) (VREADOCT 14384 . 15010) (VREADATOM 15012 . 15555) (VSHOWSTACKBLOCKS 15557 . +17590) (VSHOWSTACKBLOCK1 17592 . 17718) (VPRINCOPY 17720 . 17814) (VNOSUCHATOM 17816 . 17919)) (17922 +26243 (V\\BACKTRACE 17932 . 19569) (V\\STKNAME 19571 . 20167) (V\\PRINTBF 20169 . 21087) ( +V\\PRINTFRAME 21089 . 25715) (V\\SCANFORNTENTRY 25717 . 26076) (V\\PRINTSTK 26078 . 26241)) (26244 +28463 (V\\CHECKARRAYBLOCK 26254 . 27713) (V\\PARSEARRAYSPACE 27715 . 27966) (V\\PARSEARRAYSPACE1 27968 + . 28461)) (28464 41387 (VPRINTCODE 28474 . 39613) (VPRINTCODENT 39615 . 40538) (VBROKENDEF 40540 . +41385)) (41388 42471 (V\\CAR.UFN 41398 . 41846) (V\\CDR.UFN 41848 . 42469)) (42472 45791 (V\\COPY +42482 . 43417) (V\\UNCOPY 43419 . 45789)) (45792 46309 (V\\GETBASEBYTE 45802 . 45961) (V\\PUTBASEBYTE +45963 . 46307)) (46310 46835 (VNTYPX 46320 . 46449) (VTYPENAME 46451 . 46677) (V\\TYPENAMEFROMNUMBER +46679 . 46833)) (46836 55661 (VUNCOPYATOM 46846 . 47120) (VMAKE.LOCAL.ATOM 47122 . 47272) ( +VSYMBOL.VALUE 47274 . 47530) (VSYMBOL.PNAME 47532 . 47989) (VSYMBOL.PACKAGE 47991 . 48390) ( +VOLD.FIND.SYMBOL 48392 . 49471) (VLOOKUP-SYMBOL 49473 . 50705) (VFIND.PACKAGE 50707 . 51668) ( +VFIND.SYMBOL 51670 . 53528) (VPACKAGE.NAME 53530 . 53616) (V\\MKATOM 53618 . 54682) (VGETTOPVAL 54684 + . 54752) (VGETPROPLIST 54754 . 54838) (VSETTOPVAL 54840 . 55065) (VGETDEFN 55067 . 55133) ( +V\\ATOMCELL 55135 . 55659)) (55662 55794 (VLISTP 55672 . 55792)) (55824 56130 ( +V\\GET-COMPILED-CODE-BASE 55834 . 56128))))) +STOP diff --git a/library/READNUMBER b/library/READNUMBER new file mode 100644 index 00000000..96041a07 --- /dev/null +++ b/library/READNUMBER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "25-May-93 00:28:30" |{PELE:MV:ENVOS}LIBRARY>READNUMBER.;3| 29420 changes to%: (FNS NUMBERPAD.READ) previous date%: "12-Jun-90 10:56:07" |{PELE:MV:ENVOS}LIBRARY>READNUMBER.;2|) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1989, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT READNUMBERCOMS) (RPAQQ READNUMBERCOMS [(FNS \NUMBERPAD.READER.CLOSEFN \READNUMBER.FLASHAREA RNUMBER NUMBERPAD.READ NUMBERPAD.READER.HANDLE.CHAR NUMBERPAD.READER.DECODE CREATE.NUMBERPAD.READER BREAK.MSG.INTO.LINES REGIONONSCREEN DISPLAY/NUMBER/READER/TOTAL NUMBER.READER.HANDLER NUMBERPAD.HELDFN \READNUMBER.OUTLINEREGION) (UGLYVARS RNUMBER.CLEAR.BITMAP RNUMBER.ABORT.BITMAP) (COMS (* stuff to dummy up a definition of TEDIT.GETSYNTAX if it isn't defined.) (INITVARS (TEDIT.READTABLE T)) (P (MOVD? 'GETSYNTAX 'TEDIT.GETSYNTAX]) (DEFINEQ (\NUMBERPAD.READER.CLOSEFN [LAMBDA (WINDOW) (WINDOWPROP WINDOW 'FINISHEDFLG 'ABORT]) (\READNUMBER.FLASHAREA [LAMBDA (LFT BTM WDTH HGHT WIN) (* rrb "28-JUN-82 19:17") (* flashes a region of a window.) (BITBLT NIL NIL NIL WIN LFT BTM WDTH HGHT 'TEXTURE 'INVERT BLACKSHADE) (DISMISS 60) (BITBLT NIL NIL NIL WIN LFT BTM WDTH HGHT 'TEXTURE 'INVERT BLACKSHADE]) (RNUMBER [LAMBDA (MSG POSITION MSGFONT DIGITFONT INCLUDEABORTFLG FLOATINGPTFLG POSITIVEONLYFLG ACCEPTTYPEINFLG) (* rrb "14-May-86 19:02") (* creates a numberpad window menu  and lets the user enter a number.) (* it is substantially more  efficient to save the  NUMBERPAD/READER and call  NUMBERPAD.READ directly.) (NUMBERPAD.READ (CREATE.NUMBERPAD.READER MSG POSITION MSGFONT DIGITFONT INCLUDEABORTFLG FLOATINGPTFLG POSITIVEONLYFLG) ACCEPTTYPEINFLG]) (NUMBERPAD.READ [LAMBDA (NUMBERPAD/READER ACCEPTTYPEINFLG) (* ;  "Edited 24-May-93 23:40 by sybalsky:mv:envos") (* ;; "allows the user to enter a number with the numberpad. if ACCEPTTYPEINFLG is T, it also allows the user to type in numbers as well.") (* ;; "position the number pad near the current reading location.") (WINDOWPROP NUMBERPAD/READER 'TOTAL 0) (* ;  "start a mouse process in case this one is it.") (SPAWN.MOUSE) (* ;  "make sure the finished flag is initialized.") (WINDOWPROP NUMBERPAD/READER 'FINISHEDFLG NIL) (* ;  "fix it so that closing the window does an abort.") (WINDOWADDPROP NUMBERPAD/READER 'CLOSEFN (FUNCTION \NUMBERPAD.READER.CLOSEFN)) (RESETLST [COND (ACCEPTTYPEINFLG (RESETSAVE (TTYDISPLAYSTREAM NUMBERPAD/READER)) (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (RESETSAVE (CONTROL T)) (RESETSAVE (ECHOMODE NIL] (RESETSAVE (OPENW NUMBERPAD/READER) (LIST 'CLOSEW NUMBERPAD/READER)) (DISPLAY/NUMBER/READER/TOTAL NUMBERPAD/READER) (* ;  "wait for the menu handler to set that it is finished.") [bind FINISHVAL until (SETQ FINISHVAL (WINDOWPROP NUMBERPAD/READER 'FINISHEDFLG NIL)) do (* ;  "keep bringing the numberpad to the top.") (TOTOPW NUMBERPAD/READER) (COND ((AND ACCEPTTYPEINFLG (HASTTYWINDOWP) (READP T)) (* ;  "this process has the tty and the user typed a character") (NUMBERPAD.READER.HANDLE.CHAR (NUMBERPAD.READER.DECODE (READC T)) NUMBERPAD/READER))) (DISMISS 100) finally (* ;  "remove the closefn so that it doesn't get run on the way out.") (WINDOWDELPROP NUMBERPAD/READER 'CLOSEFN (FUNCTION \NUMBERPAD.READER.CLOSEFN )) (RETURN (COND ((EQ FINISHVAL 'ABORT) (* ;; "means the numberpad reader was closed. If the number pad includes the ABORT command, do what it would do, otherwise the program is not expecting NIL so cause an error.") (COND ([MEMBER '% (fetch (MENU ITEMS) of (CAR (WINDOWPROP NUMBERPAD/READER 'MENU] (* ; "no ABORT command") (ERROR!)) (T NIL))) (T (WINDOWPROP NUMBERPAD/READER 'TOTAL])]) (NUMBERPAD.READER.HANDLE.CHAR [LAMBDA (DIGIT WIN) (* ; "Edited 19-Jan-89 17:50 by gadener") (* handles a key stroke or menu  digit selection for a number pad  reader.) (PROG (TOTAL POWER) (SETQ TOTAL (WINDOWPROP WIN 'TOTAL)) [WINDOWPROP WIN 'TOTAL (SELECTQ DIGIT (bs (COND [(SETQ POWER (WINDOWPROP WIN 'DECIMALPOWER)) (* have read decimal pt -  much harder) (COND ((EQ POWER 1) (* backspace over the decimal point.) (WINDOWPROP WIN 'DECIMALPOWER NIL) (FIX TOTAL)) (T (WINDOWPROP WIN 'DECIMALPOWER (SETQ POWER (SUB1 POWER))) (* dirty but effective.) (PROG ((TOTSTR (MKSTRING TOTAL))) (* SUBSTRING will be NIL if the  total has a trailing zero.) (RETURN (MKATOM (OR (SUBSTRING TOTSTR 1 (PLUS (STRPOS "." TOTSTR) (SUB1 POWER))) TOTSTR] (T (* no decimal point) (IQUOTIENT TOTAL 10)))) (- (MINUS TOTAL)) (% (* empty key) TOTAL) (%. (* decimal point) (COND ((WINDOWPROP WIN 'DECIMALPOWER) (* already has a decimal pt, don't  do anything) (RETURN)) (T (WINDOWPROP WIN 'DECIMALPOWER 1) (FLOAT TOTAL)))) (ok (WINDOWPROP WIN 'FINISHEDFLG T) (RETURN)) (COND ((OR (EQ DIGIT RNUMBER.ABORT.BITMAP) (EQ DIGIT 'abt)) (* abort key) (WINDOWPROP WIN 'TOTAL NIL) (WINDOWPROP WIN 'FINISHEDFLG T) (RETURN)) ((OR (EQ DIGIT RNUMBER.CLEAR.BITMAP) (EQ DIGIT 'clr)) (* clear key) (WINDOWPROP WIN 'DECIMALPOWER NIL) 0) ((EQ (WINDOWPROP WIN 'MAXDIGITS) (NCHARS (ABS TOTAL))) (* don't take any more.) (\READNUMBER.FLASHAREA 0 0 1000 1000 WIN) TOTAL) [(NUMBERP DIGIT) (COND [(SETQ POWER (WINDOWPROP WIN 'DECIMALPOWER)) (* have read decimal pt) (WINDOWPROP WIN 'DECIMALPOWER (ADD1 POWER)) (COND [(GEQ TOTAL 0) (PLUS TOTAL (FQUOTIENT DIGIT (EXPT 10 POWER] (T (DIFFERENCE TOTAL (FQUOTIENT DIGIT (EXPT 10 POWER] ((GEQ TOTAL 0) (PLUS (TIMES TOTAL 10) DIGIT)) (T (DIFFERENCE (TIMES TOTAL 10) DIGIT] (T (* uninteresting key struck, ignore  it) (RETURN] (DISPLAY/NUMBER/READER/TOTAL WIN]) (NUMBERPAD.READER.DECODE [LAMBDA (CHAR) (* rrb "14-May-86 18:49") (* decodes a keystroke into the  corresponding number pad reader menu  item.) (OR (NUMBERP CHAR) (SELECTQ (TEDIT.GETSYNTAX CHAR TEDIT.READTABLE) (CHARDELETE 'bs) ((WORDDELETE LINEDELETE) 'clr) (DELETE 'abt) (COND ((OR (EQ CHAR '% ) (EQ CHAR '% )) 'ok) (T CHAR]) (CREATE.NUMBERPAD.READER [LAMBDA (MSG WPOSITION MSGFONT DIGITFONT INCLUDEABORTFLG FLOATINGPTFLG POSITIVEONLYFLG) (* rrb "14-May-86 18:57") (* creates a window menu that displays the digits in a numberpad and lets the  user enter a number. It also includes a backspace and a enter) (RESETFORM (RADIX 10) (PROG ((NUMBER/READER/MAXDIGITS (COND (FLOATINGPTFLG 8) (T 6))) WIN READERWIDTH PADLEFT TOTALREGION (DIGITFONT (OR DIGITFONT (FONTCREATE BOLDFONT)) ) (MSGFONT (OR MSGFONT (FONTCREATE DEFAULTFONT))) NUMBERPAD TOTALWIDTH FONTHEIGHT MSGLINES) [SETQ NUMBERPAD (create MENU ITEMS _ [CONS (COND [POSITIVEONLYFLG (COND ((AND INCLUDEABORTFLG FLOATINGPTFLG) (* no other place to put the  backspace) 'bs) (T '% ] (T '-)) (APPEND [COND [INCLUDEABORTFLG (COND ((AND (IGREATERP (SETQ FONTHEIGHT (FONTPROP MSGFONT 'HEIGHT)) 10) (ILESSP FONTHEIGHT 20)) (* only use the bitmap for fonts  near 10 or 12.0) (LIST RNUMBER.ABORT.BITMAP RNUMBER.CLEAR.BITMAP)) (T '(abt clr] (FLOATINGPTFLG (* put backspace in top row because  decimal pt appears in the bottom.) '(bs clr)) (T '(% clr] '(1 2 3 4 5 6 7 8 9) [COND (FLOATINGPTFLG (* if floating point numbers are ok,  include decimal point.) '(%.)) (T '(bs] '(0 ok] MENUCOLUMNS _ 3 CENTERFLG _ T MENUFONT _ DIGITFONT WHENHELDFN _ (FUNCTION NUMBERPAD.HELDFN) WHENSELECTEDFN _ (FUNCTION NUMBER.READER.HANDLER) MENUOUTLINESIZE _ 2 ITEMHEIGHT _ (IPLUS 2 (FONTPROP DIGITFONT 'HEIGHT] (* leave room for three lines at the  top and the number at the left.) (SETQ WIN (CREATEW [REGIONONSCREEN WPOSITION [WIDTHIFWINDOW (SETQ READERWIDTH (IPLUS [SETQ PADLEFT (IPLUS 12 (SETQ TOTALWIDTH (ITIMES (ADD1 NUMBER/READER/MAXDIGITS ) (CHARWIDTH (CHARCODE 0) DIGITFONT] (fetch (MENU IMAGEWIDTH) of NUMBERPAD] (HEIGHTIFWINDOW (IPLUS (COND [MSG (* if there is a msg, leave room for  it at the top.) (ITIMES (LENGTH (SETQ MSGLINES (  BREAK.MSG.INTO.LINES MSG MSGFONT READERWIDTH))) (FONTPROP MSGFONT 'HEIGHT] (T 0)) (fetch (MENU IMAGEHEIGHT) of NUMBERPAD] NIL NIL T)) [COND (MSG (* if there is a msg, print it at  the top.) (DSPFONT MSGFONT WIN) (MOVETOUPPERLEFT WIN) (for LINE in MSGLINES do (PRIN3 LINE WIN) (TERPRI WIN] (OPENW WIN) (* window is opened because of bug in ADDMENU that it doesn't work unless  window is open.) (ADDMENU NUMBERPAD WIN (create POSITION XCOORD _ PADLEFT YCOORD _ 0)) [WINDOWPROP WIN 'TOTALREG (SETQ TOTALREGION (create REGION LEFT _ 6 BOTTOM _ (IQUOTIENT (fetch (MENU IMAGEHEIGHT) of NUMBERPAD) 2) WIDTH _ TOTALWIDTH HEIGHT _ (FONTPROP DIGITFONT 'HEIGHT] (\READNUMBER.OUTLINEREGION TOTALREGION WIN 2) (DSPFONT DIGITFONT WIN) (WINDOWPROP WIN 'TOTAL 0) (WINDOWPROP WIN 'MAXDIGITS NUMBER/READER/MAXDIGITS) (DISPLAY/NUMBER/READER/TOTAL WIN) (CLOSEW WIN) (RETURN WIN]) (BREAK.MSG.INTO.LINES [LAMBDA (MSG FONT WIDTH) (* rrb "27-Aug-85 14:35") (* returns a list of string that  will fit in WIDTH if printed in FONT) (PROG ([MSGSTR (COND ((LISTP MSG) (* remove the outer parens) (SUBSTRING (MKSTRING MSG) 2 -2)) (T (MKSTRING MSG] (THISLINE 0) (BEGIN 1) LASTSPACE STRLST CHARWIDTH CHARCODE) [for I from 1 to (NCHARS MSGSTR) do (SETQ CHARWIDTH (CHARWIDTH (SETQ CHARCODE (NTHCHARCODE MSGSTR I)) FONT)) (COND [(GREATERP (SETQ THISLINE (IPLUS THISLINE CHARWIDTH)) WIDTH) (* this character would go past) (COND ((EQ CHARCODE (CHARCODE SPACE)) [SETQ STRLST (NCONC1 STRLST (SUBSTRING MSGSTR BEGIN (SUB1 I] (SETQ THISLINE 0) (SETQ BEGIN (ADD1 I)) (SETQ LASTSPACE)) (LASTSPACE (* this line has a space in it.) [SETQ STRLST (NCONC1 STRLST (SUBSTRING MSGSTR BEGIN (SUB1 LASTSPACE] (SETQ BEGIN (ADD1 LASTSPACE)) (SETQ THISLINE 0) (for NL from (ADD1 LASTSPACE) to I do (SETQ THISLINE (IPLUS (CHARWIDTH (NTHCHARCODE MSGSTR NL) FONT) THISLINE))) (SETQ LASTSPACE)) (T (* this line doesn't have a space) [SETQ STRLST (NCONC1 STRLST (SUBSTRING MSGSTR BEGIN (SUB1 I] (SETQ BEGIN I) (SETQ THISLINE CHARWIDTH] ((EQ CHARCODE (CHARCODE SPACE)) (* note the position of the space) (SETQ LASTSPACE I))) finally (COND ((GREATERP (SUB1 I) BEGIN) (SETQ STRLST (NCONC1 STRLST (SUBSTRING MSGSTR BEGIN -1] (RETURN STRLST]) (REGIONONSCREEN [LAMBDA (POS WIDTH HEIGHT) (* rrb "20-May-86 11:42") (* returns the region WIDTH by HEIGHT that is nearest to POS or the cursor  position while still being on the screen.) (PROG (LEFT BOTTOM) (COND ((POSITIONP POS) (SETQ LEFT (IMAX (fetch (POSITION XCOORD) of POS) 0)) (SETQ BOTTOM (IMAX (fetch (POSITION YCOORD) of POS) 0))) (T (GETMOUSESTATE) (SETQ LEFT LASTMOUSEX) (SETQ BOTTOM LASTMOUSEY))) [COND ((IGREATERP (IPLUS LEFT WIDTH) SCREENWIDTH) (SETQ LEFT (IMAX 0 (IDIFFERENCE SCREENWIDTH WIDTH] [COND ((IGREATERP (IPLUS BOTTOM HEIGHT) SCREENHEIGHT) (SETQ BOTTOM (IMAX 0 (IDIFFERENCE SCREENHEIGHT HEIGHT] (RETURN (create REGION LEFT _ LEFT BOTTOM _ BOTTOM WIDTH _ WIDTH HEIGHT _ HEIGHT]) (DISPLAY/NUMBER/READER/TOTAL [LAMBDA (WIN) (* rrb "14-May-86 18:36") (* displays the number total in the  box in the window.) (PROG [(TOTALREG (WINDOWPROP WIN 'TOTALREG)) (DECIMALPLACES (WINDOWPROP WIN 'DECIMALPOWER] (DSPFILL TOTALREG WHITESHADE 'REPLACE WIN) (RESETFORM (RADIX 10) (CENTERPRINTINREGION [COND [DECIMALPLACES (* printing a decimal number must check to make sure the correct number of  decimal places print.) (PROG ([TOTSTR (MKSTRING (WINDOWPROP WIN 'TOTAL] DECPOS NAFTERDEC NCHARS) (SETQ NCHARS (NCHARS TOTSTR)) (SETQ DECPOS (STRPOS "." TOTSTR)) (RETURN (COND ((EQ (SUB1 DECIMALPLACES) (SETQ NAFTERDEC (DIFFERENCE NCHARS DECPOS))) (* right number of places) TOTSTR) [(GEQ NAFTERDEC DECIMALPLACES) (* strip off the unwanted ones.) (SUBSTRING TOTSTR 1 (PLUS DECPOS (SUB1 DECIMALPLACES] (T (* not enough zeros on the end) (CONCAT TOTSTR (bind STR for I from 1 to (DIFFERENCE (SUB1 DECIMALPLACES) NAFTERDEC) do (COND (STR (SETQ STR (CONCAT STR "0") )) (T (SETQ STR "0"))) finally (RETURN STR] (T (WINDOWPROP WIN 'TOTAL] TOTALREG WIN]) (NUMBER.READER.HANDLER [LAMBDA (DIGIT MENU BUTTON) (* rrb "14-May-86 15:37") (* selected fn for a numberpad reader. adds the digit to the current total and  updates the display.) (NUMBERPAD.READER.HANDLE.CHAR DIGIT (WFROMMENU MENU]) (NUMBERPAD.HELDFN [LAMBDA (ITEM MENU BUTTON) (* rrb "26-Aug-85 13:50") (* prints the help information for a  numberpad.) (PROMPTPRINT (SELECTQ ITEM (bs "Will erase the last digit entered.") (ok "Indicates that you are through entering the number.") (clr "Will reset the total to 0") (abt "will abort this question.") (- " will change the sign of the total") (%. "will enter a decimal point.") (% "doesn't do anything.") (COND ((EQ ITEM RNUMBER.ABORT.BITMAP) (* abort bitmap) "will abort this question.") ((EQ ITEM RNUMBER.CLEAR.BITMAP) (* abort bitmap) "Will reset the total to 0") ((NLISTP ITEM) "Will put this digit on the right of the total."]) (\READNUMBER.OUTLINEREGION [LAMBDA (REG WIN OUTLINESIZE) (* ; "Edited 12-Jun-90 10:55 by mitani") (* puts a black outline around REG.) (PROG ((N (OR (FIXP OUTLINESIZE) 2))) (BITBLT NIL NIL NIL WIN (IDIFFERENCE (fetch (REGION LEFT) of REG) N) (IDIFFERENCE (fetch (REGION BOTTOM) of REG) N) (IPLUS (fetch (REGION WIDTH) of REG) (ITIMES N 2)) (IPLUS (fetch (REGION HEIGHT) of REG) (ITIMES N 2)) 'TEXTURE 'REPLACE BLACKSHADE) (BITBLT NIL NIL NIL WIN (fetch (REGION LEFT) of REG) (fetch (REGION BOTTOM) of REG) (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG) 'TEXTURE 'REPLACE (DSPTEXTURE NIL WIN]) ) (READVARS-FROM-STRINGS '(RNUMBER.CLEAR.BITMAP RNUMBER.ABORT.BITMAP) "({(READBITMAP)(14 14 %"GJ@@%" %"DJCL%" %"DBBD%" %"DBCL%" %"DJB@%" %"GKKL%" %"@@@@%" %"@@@@%" %"@GKL%" %"@DJD%" %"@GKL%" %"@DJH%" %"@DJD%" %"@@@@%")} {(READBITMAP)(14 14 %"GKL@%" %"DJD@%" %"DKL@%" %"GJD@%" %"DJD@%" %"DKL@%" %"@@@@%" %"@@CH%" %"GKM@%" %"DJE@%" %"DKM@%" %"DJI@%" %"GJM@%" %"@@@@%")}) ") (* stuff to dummy up a definition of TEDIT.GETSYNTAX if it isn't defined.) (RPAQ? TEDIT.READTABLE T) (MOVD? 'GETSYNTAX 'TEDIT.GETSYNTAX) (PUTPROPS READNUMBER COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1989 1990 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1063 28765 (\NUMBERPAD.READER.CLOSEFN 1073 . 1167) (\READNUMBER.FLASHAREA 1169 . 1553) (RNUMBER 1555 . 2497) (NUMBERPAD.READ 2499 . 6270) (NUMBERPAD.READER.HANDLE.CHAR 6272 . 10472) ( NUMBERPAD.READER.DECODE 10474 . 11190) (CREATE.NUMBERPAD.READER 11192 . 19590) (BREAK.MSG.INTO.LINES 19592 . 22564) (REGIONONSCREEN 22566 . 23747) (DISPLAY/NUMBER/READER/TOTAL 23749 . 26180) ( NUMBER.READER.HANDLER 26182 . 26489) (NUMBERPAD.HELDFN 26491 . 27646) (\READNUMBER.OUTLINEREGION 27648 . 28763))))) STOP \ No newline at end of file diff --git a/library/READSYS b/library/READSYS new file mode 100644 index 00000000..09a6ff43 --- /dev/null +++ b/library/READSYS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 9-Nov-92 03:25:43" "{Pele:mv:envos}library>READSYS.;3" 20241 changes to%: (FNS VATOMNUMBER) previous date%: "12-Jun-90 10:57:50" "{Pele:mv:envos}library>READSYS.;2") (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT READSYSCOMS) (RPAQQ READSYSCOMS ((FNS READSYS TELERAID VLISTGET VLOADFNS VLOADFILEPKGTYPECHANGE VLOADFUNCTIONS VLOADVAR VLOADVARS VRAID VSAVEWORK SHOWREMOTESCREEN VGETVAL VINSPECT VUNSAVEDEF VCADR VPUTDEFN VYANKDEF) [INITVARS (RDSYSINIT) (ATOMPAGELST NIL) (ATOMCACHE NIL) (NEWATOMARRAY (HASHARRAY 30)) (TELERAIDPRINTLEVEL '(2 . 20] (FNS VATOM VATOMNUMBER) (DECLARE%: EVAL@COMPILE DONTCOPY (PROP (DMACRO MACRO) IEQ) DONTEVAL@LOAD (FILES (LOADCOMP) VMEM)) (FILES VMEM))) (DEFINEQ (READSYS [LAMBDA (FILE WRITEABLE) (* ; "Edited 6-Mar-87 17:09 by raf") (COND [FILE (INITVMEM FILE WRITEABLE) (* ;; "clear atom cache") (for X in ATOMPAGELST do (for I from 0 to 255 do (FASTSETA (CDR X) I 0))) (* ;; "Cache the remote package globals, also used by READSYS.HAS.PACKAGES to determine whether packges are on in the remote sysout.") (SETQ READSYS.PACKAGE.FROM.NAME (VSYMBOL.VALUE '*PACKAGE-FROM-NAME*)) (SETQ READSYS.PACKAGE.FROM.INDEX (VSYMBOL.VALUE '*PACKAGE-FROM-INDEX*)) (* ;; "initialize those variables which are renamed 'pointers' , e.g., the array free list") [for X in RDPTRS do (SET (PACK* 'V (SUBATOM (CAR X) 2 -1)) (VGETTOPVAL (CAR X] (* ;;  "Initialize those variables which are renamed 'values' , e.g., \AtomFrLst = # of allocated atoms") (for X in RDVALS do (SET (PACK* 'V (SUBATOM (CAR X) 2 -1)) (VGETVAL (CAR X] ((LISTP VMEMFILE) (CLOSEREMOTEVMEMFILE)) (T (CLOSEVMEMFILE]) (TELERAID [LAMBDA (HOST RAIDIX) (* bvm%: "13-Jul-84 17:24") (RESETLST [COND (HOST (RESETSAVE NIL '(CLOSEVMEMFILE)) (READSYS (LIST HOST] (COND ((LISTP VMEMFILE) (VRAID RAIDIX]) (VLISTGET [LAMBDA (LST TOKEN) (* edited%: "11-Jun-85 04:24") (AND LST (if (EQ TOKEN (V\UNCOPY (V\CAR.UFN LST))) then (V\UNCOPY (V\CAR.UFN (V\CDR.UFN LST))) else (VLISTGET (V\CDR.UFN (V\CDR.UFN LST)) TOKEN]) (VLOADFNS [LAMBDA (FNS) (* mpl " 8-Aug-85 23:05") (for FN inside FNS do (PRINTOUT T "Reading function " FN) [SAVEPUT FN 'EXPR (LET [(DEFN (V\UNCOPY (VGETDEFN FN] (COND [(NLISTP DEFN) (* * Hmm, must have been a compiled function.  Let's try to get its proplist and save the defn from the EXPR prop) (LET [(PLIST (V\UNCOPY (VGETPROPLIST FN] (COND ([AND (LISTP PLIST) (LISTP (LISTGET PLIST 'EXPR] (LISTGET PLIST 'EXPR] (T DEFN] (TERPRI T]) (VLOADFILEPKGTYPECHANGE [LAMBDA (CHANGE FILEPKGTYPE) (* gbn "19-Jun-86 00:46") (PRINTOUT T "Reading" %, FILEPKGTYPE %, CHANGE "...") [LET [(PLIST (V\UNCOPY (VGETPROPLIST CHANGE] (COND ([AND (LITATOM CHANGE) (LISTP PLIST) (LISTP (LISTGET PLIST FILEPKGTYPE)) (LISTP (NLSETQ (PUTDEF CHANGE FILEPKGTYPE (LISTGET PLIST FILEPKGTYPE] (PRINTOUT T "done")) (T (PRINTOUT T "failed"] (PRINTOUT T T]) (VLOADFUNCTIONS [LAMBDA (FUNCTIONS) (* gbn "18-Jun-86 22:48") (for FUNCTION inside FUNCTIONS do (PRINTOUT T "Reading function " FUNCTION) [SAVEPUT FUNCTION 'FUNCTIONS (LET [(PLIST (V\UNCOPY (VGETPROPLIST FUNCTION] (COND ([AND (LISTP PLIST) (LISTP (LISTGET PLIST 'FUNCTIONS] (LISTGET PLIST 'FUNCTIONS] (TERPRI T]) (VLOADVAR [LAMBDA (VAR) (* edited%: "11-Jun-85 03:09") (SAVESET VAR (VGETVAL VAR) T]) (VLOADVARS [LAMBDA (VARS) (* lmm " 7-Aug-85 18:44") (for VAR inside VARS do (PRINTOUT T "Reading variable: " VAR) (SAVEPUT VAR 'VALUE (VGETVAL VAR)) (TERPRI T]) (VRAID [LAMBDA (RAIDIX) (* bvm%: "23-Jan-86 18:44") (DECLARE (SPECVARS RAIDIX ROOTFRAME ALINKS? FRAME# REMOTESCREEN VPRINTLEVEL)) (printout T "virtual RAID" T) (OR RAIDIX (SETQ RAIDIX 8)) (PROG ((ROOTFRAME) (ALINKS? T) (FRAME#) (REMOTESCREEN) (VPRINTLEVEL TELERAIDPRINTLEVEL)) (RESETLST (RESETSAVE (OUTPUT T)) (RESETSAVE (INTCHAR (CHARCODE ^G))) (SETQ |.I2| (NUMFORMATCODE (LIST 'FIX 2 RAIDIX))) (SETQ |.I5| (NUMFORMATCODE (LIST 'FIX 5 RAIDIX))) (SETQ |.I6| (NUMFORMATCODE (LIST 'FIX 6 RAIDIX))) (SETQ |.I7| (NUMFORMATCODE (LIST 'FIX 7 RAIDIX))) (bind RESULT until [SETQ RESULT (ERSETQ (when (SETQ $$VAL (VRAIDCOMMAND)) do (RETURN $$VAL] finally (COND ((AND (LISTP VMEMFILE) (EQ (CAR RESULT) 'RETURN)) (CLEARPAGECACHE) (REMOTERETURN]) (VSAVEWORK [LAMBDA NIL (* gbn "19-Jun-86 00:46") (LET (FNS VARS FILES CHANGES (ALLCHANGES (LIST NIL))) (PRINTOUT T "Functions on CHANGEDFNSLST: " (SETQ FNS (VGETVAL 'CHANGEDFNSLST)) T) (PRINTOUT T "Variables on CHANGEDVARSLST: " (SETQ VARS (VGETVAL 'CHANGEDVARSLST)) T) (PRINTOUT T "Files on FILELST: " (SETQ FILES (VGETVAL 'FILELST)) T) (for FILE in FILES do [SETQ CHANGES (CDR (VLISTGET (VGETPROPLIST FILE) 'FILE] (if CHANGES then (PRINTOUT T FILE " has changes " CHANGES T) [for TYPEPAIR in CHANGES do (LET ((FILEPKGTYPE (CAR TYPEPAIR)) (FILEPKGTYPECHANGES (CDR TYPEPAIR))) (SELECTQ FILEPKGTYPE (FNS (SETQ FNS (UNION FNS FILEPKGTYPECHANGES))) (VARS (SETQ VARS (UNION VARS FILEPKGTYPECHANGES))) (PROGN (* "try to grab random filepkgtypes off the prop list. It's gets lots of cases, so is better than just giving up.") (PUTASSOC FILEPKGTYPE (UNION (CDR (ASSOC FILEPKGTYPE ALLCHANGES)) FILEPKGTYPECHANGES) ALLCHANGES] else (PRINTOUT T FILE " has no changes recorded." T))) (for FN in (INTERSECTION FNS FNS) when (EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "save function" FN) NIL T)) do (VLOADFNS FN)) (for VAR in (INTERSECTION VARS VARS) when (EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "save variable" VAR) NIL T)) do (VLOADVARS VAR)) (for TYPEPAIR in ALLCHANGES do (LET ((FILEPKGTYPE (CAR TYPEPAIR))) (for FILEPKGTYPECHANGE in (CDR TYPEPAIR) do (if (EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "save" FILEPKGTYPE FILEPKGTYPECHANGE) NIL T)) then (VLOADFILEPKGTYPECHANGE FILEPKGTYPECHANGE FILEPKGTYPE]) (SHOWREMOTESCREEN [LAMBDA NIL (* ; "Edited 23-Nov-86 11:58 by MASINTER") (DECLARE (USEDFREE REMOTESCREEN)) (RESETLST (PROG ((WINDOW (AND (BOUNDP 'REMOTESCREEN) REMOTESCREEN)) HEIGHT WIDTH BITMAPBASE LASTPAGE NWORDS POS NEWPOS MINBOTTOM MINLEFT DELTAX DELTAY REG X Y) (COND ((NOT WINDOW) (SETQ WINDOW (CREATEW [CREATEREGION 0 0 (SETQ WIDTH (VGETVAL 'SCREENWIDTH)) (SETQ HEIGHT (VGETVAL 'SCREENHEIGHT] NIL 0 T)) (* ;  "WINDOW has the dimensions of the remote screen") [SETQ BITMAPBASE (fetch BITMAPBASE of (WINDOWPROP WINDOW 'IMAGECOVERED] (SETQ NWORDS (TIMES HEIGHT (QUOTIENT WIDTH 16))) (* ;;; "Now fetch remote display to local window. Display memory is contiguous bitmap, and its virtual address is known constant") [COND [(LISTP VMEMFILE) (* ;  "Remote machine. Get it a page at a time with REMOTEPMAP then finish any leftover specially") (for I from \VP.DISPLAY to [SUB1 (SETQ LASTPAGE (IPLUS \VP.DISPLAY (IQUOTIENT NWORDS 256] do (REMOTEPMAP VMEMFILE I BITMAPBASE) (SETQ BITMAPBASE (\ADDBASE BITMAPBASE 256))) (COND ((NEQ (SETQ NWORDS (IMOD NWORDS 256)) 0) (* ;  "Screen bitmap not an integral number of pages, so have to get the rest of it more carefully") (LET [(BUF (NCREATE 'VMEMPAGEP] (REMOTEPMAP VMEMFILE LASTPAGE BUF) (\BLT BITMAPBASE BUF NWORDS] (T (SETVMPTR (CL:* \VP.DISPLAY 256)) (\BINS (GETSTREAM VMEMFILE) BITMAPBASE 0 (CL:* \NP.DISPLAY 512) (CL:* NWORDS 2] (SETQ REMOTESCREEN WINDOW)) (T (SETQ WIDTH (WINDOWPROP WINDOW 'WIDTH)) (SETQ HEIGHT (WINDOWPROP WINDOW 'HEIGHT)) (MOVEW WINDOW 0 0))) (RESETSAVE NIL (LIST 'CLOSEW WINDOW)) (OPENW WINDOW) [COND ((OR (GREATERP HEIGHT SCREENHEIGHT) (GREATERP WIDTH SCREENWIDTH)) (* ;  "Remote screen is bigger than local, so allow user to move window around") (SETQ MINLEFT (IMIN 0 (IDIFFERENCE SCREENWIDTH WIDTH))) (SETQ MINBOTTOM (IMIN 0 (IDIFFERENCE SCREENHEIGHT HEIGHT))) (SETQ POS (CURSORPOSITION] (until (OR (READP T) (NOT (OPENWP WINDOW))) do (* ;  "Keep window on top until user types something or explicitly closes the window") (COND ((AND POS (NOT (EQUAL (SETQ NEWPOS (CURSORPOSITION NIL NIL NEWPOS)) POS))) (* ; "Track mouse while button down") [COND ((LASTMOUSESTATE (OR LEFT MIDDLE)) (SETQ REG (WINDOWPROP WINDOW 'REGION)) (SETQ X (fetch (REGION LEFT) of REG)) (SETQ Y (fetch (REGION BOTTOM) of REG)) (SETQ DELTAX (IDIFFERENCE [IMAX MINLEFT (IMIN 0 (IPLUS X (IDIFFERENCE (fetch XCOORD of NEWPOS) (fetch XCOORD of POS] X)) (SETQ DELTAY (IDIFFERENCE [IMAX MINBOTTOM (IMIN 0 (IPLUS Y (IDIFFERENCE (fetch YCOORD of NEWPOS) (fetch YCOORD of POS] Y)) (COND ((OR (NEQ DELTAX 0) (NEQ DELTAY 0)) (* ;; "Bound the movement so that window always covers our screen. Don't call MOVEW if no actual movement, so as to avoid excess flashing") (RELMOVEW WINDOW (create POSITION XCOORD _ DELTAX YCOORD _ DELTAY] (swap POS NEWPOS))) (TOTOPW WINDOW) (BLOCK]) (VGETVAL [LAMBDA (X) (* lmm "20-AUG-81 12:51") (V\UNCOPY (VGETTOPVAL X]) (VINSPECT [LAMBDA (HI LO ASTYPE) (* kbr%: " 8-Aug-85 19:05") (* Virtual inspector.  *) (PROG (PTR OBJECT D FIELDSPEC WINDOW) (* TBW%: This is not completely  generalized. *) (SETQ PTR (VVAG2 HI LO)) (SETQ OBJECT (NCREATE ASTYPE)) [FOR DESCRIPTOR IN (GETDESCRIPTORS ASTYPE) DO (SETQ D (CADR DESCRIPTOR)) (SETQ FIELDSPEC (CADDR DESCRIPTOR)) (COND [(EQ FIELDSPEC 'POINTER) (\PUTBASEPTR OBJECT D (V\UNCOPY (VGETBASEPTR PTR D] ((EQUAL FIELDSPEC '(BITS . 15)) (\PUTBASE OBJECT D (VGETBASE PTR D] (SETQ WINDOW (INSPECT OBJECT ASTYPE)) (WINDOWPROP WINDOW 'TITLE (CONCAT (V\UNCOPY PTR) " Inspector")) (RETURN WINDOW]) (VUNSAVEDEF [LAMBDA (SYMBOL) (* gbn " 8-Aug-85 15:37") (for (X _ (VGETPROPLIST SYMBOL)) by (V\CDR.UFN (V\CDR.UFN X)) while X do (SELECTQ (V\UNCOPY (V\CAR.UFN X)) (CODE (PRINTOUT T "Found a CODE property, doing UNSAVEDEF" T) (VPUTDEFN SYMBOL (LOGOR (VGETBASEPTR0 (VCADR X)) (LLSH 1 31))) (RETURN)) (BROKEN (PRINTOUT T "Found a BROKEN property, unbreaking" T) (RETURN (VYANKDEF SYMBOL (VCADR X)))) (ADVISED (PRINTOUT T "Found a ADVISED property, unbreaking" T) (RETURN (VYANKDEF SYMBOL (VCADR X)))) NIL) finally (PRINTOUT T "No CODE property found" T]) (VCADR [LAMBDA (X) (V\CAR.UFN (V\CDR.UFN X]) (VPUTDEFN [LAMBDA (SYMBOL VDEF CODEP) (* gbn " 8-Aug-85 15:40") (LET ((CELL (V\ATOMCELL SYMBOL 10))) (VPUTBASE0 CELL (LRSH VDEF 16)) (VPUTBASE0 (ADD1 CELL) (LOGAND VDEF 65535]) (VYANKDEF [LAMBDA (NEWSYMBOL OLDSYMBOL) (VPUTDEFN NEWSYMBOL (VGETDEFN OLDSYMBOL]) ) (RPAQ? RDSYSINIT ) (RPAQ? ATOMPAGELST NIL) (RPAQ? ATOMCACHE NIL) (RPAQ? NEWATOMARRAY (HASHARRAY 30)) (RPAQ? TELERAIDPRINTLEVEL '(2 . 20)) (DEFINEQ (VATOM [LAMBDA (N) (* lmm " 6-Aug-84 13:20") (* Converts a VM atom number into a  Lisp atom.) (PROG ((PAGE (FASSOC (LRSH N 8) ATOMPAGELST)) ATM FPTR) (COND ((AND PAGE (NEQ (SETQ ATM (FASTELT (CDR PAGE) (LOGAND N 255))) 0)) (RETURN ATM))) (SETQ ATM (VUNCOPYATOM N)) [COND ((NULL PAGE) (SETQ PAGE (CONS (LRSH N 8) (POINTERARRAY 256 0))) (COND (ATOMCACHE (ATTACH PAGE ATOMCACHE)) (T (SETQ ATOMPAGELST (NCONC ATOMPAGELST (SETQ ATOMCACHE (LIST PAGE] (FASTSETA (CDR PAGE) (LOGAND N 255) ATM) (RETURN ATM]) (VATOMNUMBER [LAMBDA (ATOM NEWOK) (* ;  "Edited 9-Nov-92 03:24 by sybalsky:mv:envos") (* ;;; "See the comment on MAKE.LOCAL.ATOM for a warning about symbols being created with the wrong package.") (COND ((FIXP ATOM) (* ;; "ALREADY HAVE THE ATOM'S NUMBER ") ATOM) (T (if (READSYS.HAS.PACKAGES) then [VFIND.SYMBOL (CL:SYMBOL-NAME ATOM) (VFIND.PACKAGE (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ATOM] else (VOLD.FIND.SYMBOL ATOM 1 (NCHARS ATOM]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (PUTPROPS IEQ DMACRO (= . EQ)) (PUTPROPS IEQ MACRO ((X Y) (IEQP X Y))) DONTEVAL@LOAD (FILESLOAD (LOADCOMP) VMEM) ) (FILESLOAD VMEM) (PUTPROPS READSYS COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1990 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1138 18058 (READSYS 1148 . 2566) (TELERAID 2568 . 2886) (VLISTGET 2888 . 3247) ( VLOADFNS 3249 . 4123) (VLOADFILEPKGTYPECHANGE 4125 . 4669) (VLOADFUNCTIONS 4671 . 5246) (VLOADVAR 5248 . 5411) (VLOADVARS 5413 . 5657) (VRAID 5659 . 6941) (VSAVEWORK 6943 . 9569) (SHOWREMOTESCREEN 9571 . 15429) (VGETVAL 15431 . 15568) (VINSPECT 15570 . 16686) (VUNSAVEDEF 16688 . 17642) (VCADR 17644 . 17698) (VPUTDEFN 17700 . 17959) (VYANKDEF 17961 . 18056)) (18222 19896 (VATOM 18232 . 19253) ( VATOMNUMBER 19255 . 19894))))) STOP \ No newline at end of file diff --git a/library/REMOTEVMEM b/library/REMOTEVMEM new file mode 100644 index 00000000..1394ce39 --- /dev/null +++ b/library/REMOTEVMEM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "12-Jun-90 11:00:52" {DSK}local>lde>lispcore>library>REMOTEVMEM.;2 10969 changes to%: (VARS REMOTEVMEMCOMS) previous date%: "15-Feb-85 18:17:43" {DSK}local>lde>lispcore>library>REMOTEVMEM.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT REMOTEVMEMCOMS) (RPAQQ REMOTEVMEMCOMS ((FNS CLEARPAGECACHE OPENREMOTEVMEMFILE CLOSEREMOTEVMEMFILE VMAPPAGE REMOTEPMAP REMOTERETURN REMOTESETWORD \TR.NOSERVER DEBUGGINGTRSERVER) (INITVARS (REMOTEPAGELST) (REMOTECACHESIZE 100)) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS REMOTEVMEMFILE) (CONSTANTS \PUPSOC.TELERAID) (CONSTANTS * TRPUPTYPES) (ADDVARS * (LIST (CONS 'PUPTYPES TRPUPTYPES))) (GLOBALVARS REMOTECACHESIZE REMOTEPAGELST) (ADDVARS (DONTCOMPILEFNS DEBUGGINGTRSERVER)) (FILES (LOADCOMP) PUP VMEM)))) (DEFINEQ (CLEARPAGECACHE [LAMBDA NIL (* lmm "20-AUG-81 16:45") (SETQ REMOTEPAGELST]) (OPENREMOTEVMEMFILE [LAMBDA (HOST) (* bvm%: "13-Jul-84 17:20") (SETQ VMEMFILE (create REMOTEVMEMFILE REMOTEVMEMADDR _ (ETHERPORT HOST) REMOTEVMEMSOCKET _ (OPENPUPSOCKET]) (CLOSEREMOTEVMEMFILE [LAMBDA NIL (* bvm%: "13-Jul-84 17:11") (CLEARPAGECACHE) (AND VMEMFILE (fetch REMOTEVMEMSOCKET of VMEMFILE) (CLOSEPUPSOCKET (fetch REMOTEVMEMSOCKET of VMEMFILE]) (VMAPPAGE [LAMBDA (PAGE#) (* lmm " 4-Oct-84 15:45") (PROG ((ENTRY (ASSOC PAGE# REMOTEPAGELST)) TAIL) (IF ENTRY THEN (MOVETOP ENTRY REMOTEPAGELST) (RETURN (CDR ENTRY))) [push REMOTEPAGELST (CONS PAGE# (SETQ ENTRY (REMOTEPMAP VMEMFILE PAGE# (\ALLOCBLOCK WORDSPERPAGE ] (IF (CDR (SETQ TAIL (NTH REMOTEPAGELST REMOTECACHESIZE))) THEN (RPLACD TAIL)) (RETURN ENTRY]) (REMOTEPMAP [LAMBDA (FL PAGE# BUFFER) (* bvm%: "13-Feb-85 12:35") (OR (EQ FL VMEMFILE) (SHOULDNT)) (PROG ((SOC (fetch REMOTEVMEMSOCKET of FL)) INPUP OUTPUP) (SETUPPUP (SETQ OUTPUP (ALLOCATE.PUP)) (fetch REMOTEVMEMADDR of FL) \PUPSOC.TELERAID TR.GIVEPAGE (LLSH PAGE# 8) SOC) (to \MAXETHERTRIES when (SETQ INPUP (\EXCHANGEPUPS SOC OUTPUP NIL T)) do (SELECTC (fetch PUPTYPE of INPUP) (TR.HEREISPAGE (RETURN (\BLT BUFFER (fetch PUPCONTENTS of INPUP) WORDSPERPAGE))) (TR.ERROR (RETURN (INVALIDADDR (UNFOLD PAGE# WORDSPERPAGE)))) (\PT.ERROR (RETURN (\TR.NOSERVER))) NIL) finally (ERROR "REMOTE SYSTEM NOT RESPONDING")) (RELEASE.PUP OUTPUP) (AND INPUP (RELEASE.PUP INPUP)) (RETURN BUFFER]) (REMOTERETURN [LAMBDA NIL (* bvm%: "13-Feb-85 12:35") (bind INPUP (OUTPUP _ (ALLOCATE.PUP)) (SOC _ (fetch REMOTEVMEMSOCKET of VMEMFILE)) first (SETUPPUP OUTPUP (fetch REMOTEVMEMADDR of VMEMFILE) \PUPSOC.TELERAID TR.GO NIL SOC) to \MAXETHERTRIES when (SETQ INPUP (EXCHANGEPUPS SOC OUTPUP NIL T)) do (SELECTC (PROG1 (fetch PUPTYPE of INPUP) (RELEASE.PUP INPUP)) (TR.GOACK (replace PUPTYPE of OUTPUP with TR.GOREPLY) (add (fetch PUPID of OUTPUP) 1) (replace EPREQUEUE of OUTPUP with 'FREE) (SENDPUP SOC OUTPUP) (RETURN)) (\PT.ERROR (RETURN (\TR.NOSERVER))) NIL) finally (ERROR "REMOTE SYSTEM NOT RESPONDING") (RELEASE.PUP OUTPUP]) (REMOTESETWORD [LAMBDA (PTR VALUE) (* bvm%: "13-Feb-85 12:35") (bind INPUP (OUTPUP _ (ALLOCATE.PUP)) (SOC _ (fetch REMOTEVMEMSOCKET of VMEMFILE)) first (SETUPPUP OUTPUP (fetch REMOTEVMEMADDR of VMEMFILE) \PUPSOC.TELERAID TR.STORE NIL SOC) (PROGN (PUTPUPWORD OUTPUP 0 (VHILOC PTR)) (PUTPUPWORD OUTPUP 1 (VLOLOC PTR)) (PUTPUPWORD OUTPUP 2 VALUE) (add (fetch PUPLENGTH of OUTPUP) (UNFOLD 3 BYTESPERWORD))) to \MAXETHERTRIES when (SETQ INPUP (EXCHANGEPUPS SOC OUTPUP NIL T)) do (SELECTC (fetch PUPTYPE of INPUP) (TR.STOREDONE (RETURN)) (TR.ERROR (RETURN (ERROR "INVALID ADDRESS" PTR))) (\PT.ERROR (RETURN (\TR.NOSERVER))) NIL) finally (ERROR "REMOTE SYSTEM NOT RESPONDING")) VALUE]) (\TR.NOSERVER [LAMBDA NIL (* bvm%: "13-Feb-85 12:38") (ERROR (PORTSTRING (fetch REMOTEVMEMADDR of VMEMFILE)) "not running TeleRaid server" T]) (DEBUGGINGTRSERVER [LAMBDA NIL (* bvm%: "14-MAR-83 18:07") (PROG ((SOC (\CREATESOCKET \PUPSOC.TELERAID)) VA STLOC STVAL INPUP OUTPUP) LP (SETQ INPUP (GETPUP SOC T)) (SELECTC (fetch PUPTYPE of INPUP) (TR.GIVEPAGE (printout T "REQUEST FOR VA " (SETQ VA (fetch PUPID of INPUP)) T) (SETUPPUP INPUP (fetch PUPSOURCE of INPUP) (fetch PUPSOURCESOCKET of INPUP) TR.HEREISPAGE VA SOC) (replace PUPLENGTH of INPUP with (IPLUS BYTESPERPAGE \PUPOVLEN )) (for I from 0 to 511 do (PUTPUPBYTE INPUP I (VGETBASEBYTE VA I))) (replace EPREQUEUE of INPUP with 'FREE) (SENDPUP SOC INPUP)) (TR.STORE [SETQ STPTR (VVAG2 (GETPUPBYTE INPUP 1) (IPLUS (LLSH (GETPUPBYTE INPUP 2) 8) (GETPUPBYTE INPUP 3] (SETQ STVAL (IPLUS (LLSH (GETPUPBYTE INPUP 4) 8) (GETPUPBYTE INPUP 5))) (printout T "store word " STVAL " at " STPTR T) (VPUTBASE STPTR 0 STVAL) (SETUPPUP INPUP (fetch PUPSOURCE of INPUP) (fetch PUPSOURCESOCKET of INPUP) TR.STOREDONE (fetch PUPID of INPUP) SOC) (replace EPREQUEUE of INPUP with 'FREE) (SENDPUP SOC INPUP)) (TR.GO (SETUPPUP (SETQ OUTPUP (ALLOCATE.PUP)) (fetch PUPSOURCE of INPUP) (fetch PUPSOURCESOCKET of INPUP) TR.GOACK (fetch PUPID of INPUP) SOC) (COND ([AND (SETQ INPUP (EXCHANGEPUPS SOC OUTPUP NIL NIL 10000)) (EQ (fetch PUPTYPE of INPUP) TR.GOREPLY) (EQUAL (fetch PUPID of INPUP) (IPLUS 1 (fetch PUPID of OUTPUP] (GO DONE)) (T (printout T "GO SEQUENCE ABORTED" T))) (* acknowledge pup AND WAIT FOR  REPLY) ) (printout T "WRONG PUP TYPE" T)) (GO LP) DONE (RETURN]) ) (RPAQ? REMOTEPAGELST ) (RPAQ? REMOTECACHESIZE 100) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD REMOTEVMEMFILE (RVFTAG RVFFN (REMOTEVMEMADDR . REMOTEVMEMSOCKET)) RVFTAG _ 'PMAP RVFFN _ (FUNCTION REMOTEPMAP)) ) (DECLARE%: EVAL@COMPILE (RPAQQ \PUPSOC.TELERAID 27) (CONSTANTS \PUPSOC.TELERAID) ) (RPAQQ TRPUPTYPES ((TR.GIVEPAGE 197) (TR.HEREISPAGE 193) (TR.STORE 198) (TR.STOREDONE 192) (TR.GO 199) (TR.GOACK 194) (TR.GOREPLY 131) (TR.ERROR 196))) (DECLARE%: EVAL@COMPILE (RPAQQ TR.GIVEPAGE 197) (RPAQQ TR.HEREISPAGE 193) (RPAQQ TR.STORE 198) (RPAQQ TR.STOREDONE 192) (RPAQQ TR.GO 199) (RPAQQ TR.GOACK 194) (RPAQQ TR.GOREPLY 131) (RPAQQ TR.ERROR 196) (CONSTANTS (TR.GIVEPAGE 197) (TR.HEREISPAGE 193) (TR.STORE 198) (TR.STOREDONE 192) (TR.GO 199) (TR.GOACK 194) (TR.GOREPLY 131) (TR.ERROR 196)) ) (ADDTOVAR PUPTYPES (TR.GIVEPAGE 197) (TR.HEREISPAGE 193) (TR.STORE 198) (TR.STOREDONE 192) (TR.GO 199) (TR.GOACK 194) (TR.GOREPLY 131) (TR.ERROR 196)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS REMOTECACHESIZE REMOTEPAGELST) ) (ADDTOVAR DONTCOMPILEFNS DEBUGGINGTRSERVER) (FILESLOAD (LOADCOMP) PUP VMEM) ) (PUTPROPS REMOTEVMEM COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1098 9242 (CLEARPAGECACHE 1108 . 1244) (OPENREMOTEVMEMFILE 1246 . 1530) ( CLOSEREMOTEVMEMFILE 1532 . 1808) (VMAPPAGE 1810 . 2620) (REMOTEPMAP 2622 . 3689) (REMOTERETURN 3691 . 4783) (REMOTESETWORD 4785 . 5812) (\TR.NOSERVER 5814 . 6036) (DEBUGGINGTRSERVER 6038 . 9240))))) STOP \ No newline at end of file diff --git a/library/SAMEDIR b/library/SAMEDIR new file mode 100644 index 00000000..b8b26a55 --- /dev/null +++ b/library/SAMEDIR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "15-Apr-2018 19:10:08" {DSK}kaplan>Local>medley3.5>lispcore>library>SAMEDIR.;3 5140 changes to%: (FNS CHECKSAMEDIR HOST&DIRECTORYFIELD) previous date%: "12-Jun-90 11:18:52" {DSK}kaplan>Local>medley3.5>lispcore>library>SAMEDIR.;1) (* ; " Copyright (c) 1982, 1984, 1985, 1986, 1987, 1990, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SAMEDIRCOMS) (RPAQQ SAMEDIRCOMS ((FNS CHECKSAMEDIR HOST&DIRECTORYFIELD) (ADDVARS [MAKEFILEFORMS (OR (NLSETQ (CHECKSAMEDIR FILE)) (RETFROM 'MAKEFILE] (MIGRATIONS)) (GLOBALVARS MIGRATIONS))) (DEFINEQ (CHECKSAMEDIR [LAMBDA (FILE) (* ; "Edited 15-Apr-2018 19:09 by rmk:") (* ;; "Check (a) that we are writing FILE to the same directory we last read/wrote it and (b) that a version newer than the current one has not since appeared.") (* ;; " OKHOST/DIRS is a list of places it's OK for the file to be winding up, so if your'e migrating code from one place ot another, you can do it gracefully.") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (DATES (GET (SETQ FILE (MKATOM (U-CASE FILE))) 'FILEDATES)) HOST/DIR HOST DIR NEWV OKHOST/DIRS) AGAIN (OR (LISTP DATES) (RETURN)) (* ;  "RMK: Use HOST&DIRECTORYFIELD to canonicalize both file and connected directory") [SETQ OKHOST/DIRS (CONS (SETQ HOST/DIR (HOST&DIRECTORYFIELD (DIRECTORYNAME T))) (MKLIST (CDR (ASSOC HOST/DIR MIGRATIONS :TEST 'STRING-EQUAL] (COND ((for OLDFILE in DATES bind HOST DIR never (CL:MEMBER (HOST&DIRECTORYFIELD (CDR OLDFILE)) OKHOST/DIRS :TEST 'STRING-EQUAL)) (* ;; "The file is going somewhere it has never been before. ") (* ;; "Check that that is really what the user wants.") (SELECTQ (ASKUSER 10 'Y (LIST "You haven't loaded or written" FILE "in your connected directory" HOST/DIR "-- write it out anyway") `((O ,(CONCAT "Oops! Connect to " (SETQ HOST/DIR (  HOST&DIRECTORYFIELD (CDAR DATES))) " [confirm] ") CONFIRMFLG T) (C "Connect to other directory: ") (Y "Yes, write it here ") (N "No, abort MAKEFILE ")) NIL NIL '(NOECHOFLG T)) (Y (RETURN)) (N (ERROR!)) (C (SETQ HOST/DIR)) (O (TERPRI T)) (SHOULDNT)) [NLSETQ (CNDIR (OR HOST/DIR (READ T T] (GO AGAIN)) ([AND [SETQ NEWV (INFILEP (PACKFILENAME.STRING 'VERSION NIL 'BODY (CDAR DATES] (NOT (STRING-EQUAL NEWV (CDAR DATES] (* ;; "A newer version appeared while the user was editing this file.") (* ;; "Ask if he should over-write it.") (SELECTQ (ASKUSER 15 'Y (LIST (CDAR DATES) "is not the most recent version (version" (MKSTRING (FILENAMEFIELD NEWV 'VERSION)) "has since appeared)." "Do you want to make the file anyway")) (Y) (N (ERROR!)) (SHOULDNT]) (HOST&DIRECTORYFIELD [LAMBDA (FILENAME) (* ; "Edited 15-Apr-2018 19:05 by rmk:") (* ;; "Returns the host&dir fields packed together. HOST and device are upper cased") (PACKFILENAME.STRING 'DEVICE (U-CASE (FILENAMEFIELD FILENAME 'DEVICE)) 'HOST (U-CASE (FILENAMEFIELD FILENAME 'HOST)) 'DIRECTORY (FILENAMEFIELD FILENAME 'DIRECTORY]) ) (ADDTOVAR MAKEFILEFORMS (OR (NLSETQ (CHECKSAMEDIR FILE)) (RETFROM 'MAKEFILE))) (ADDTOVAR MIGRATIONS ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MIGRATIONS) ) (PUTPROPS SAMEDIR COPYRIGHT ("Venue & Xerox Corporation" 1982 1984 1985 1986 1987 1990 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (815 4817 (CHECKSAMEDIR 825 . 4374) (HOST&DIRECTORYFIELD 4376 . 4815))))) STOP \ No newline at end of file diff --git a/library/SCALEBITMAP b/library/SCALEBITMAP new file mode 100644 index 00000000..78635d4b --- /dev/null +++ b/library/SCALEBITMAP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "12-Jun-90 11:20:16" {DSK}local>lde>lispcore>library>SCALEBITMAP.;2 11772 changes to%: (VARS SCALEBITMAPCOMS) previous date%: " 1-Nov-85 17:51:44" {DSK}local>lde>lispcore>library>SCALEBITMAP.;1) (* ; " Copyright (c) 1985, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SCALEBITMAPCOMS) (RPAQQ SCALEBITMAPCOMS ((FNS SCALEBITMAP))) (DEFINEQ (SCALEBITMAP [LAMBDA (BITMAP FACTOR) (* rrb " 1-Nov-85 17:50") (* 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 NEWBITMAPWIDTH 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] (* I don't know why this code was in here but it causes the bitmap to scale  incorrectly if it clips Y but not X; e.g.  (BITMAPHEIGHT (SCALEBITMAP (BITMAPCREATE 3 3) 10.0)) was 24 not 30.0 Therefore,  I commented it out. rrb -  1-nov-85 (PROGN (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 (SETQ NEWBITMAPWIDTH (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 (COND ((GREATERP XFACTOR 100) (* Subtract the 1 differently  depending on whether the size is  going up or down.) (SUB1 (IQUOTIENT (IPLUS XROUND (ITIMES X XFACTOR)) 100))) (T (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 (SUB1 NEWBITMAPWIDTH)) (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]) ) (PUTPROPS SCALEBITMAP COPYRIGHT ("Venue & Xerox Corporation" 1985 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (476 11676 (SCALEBITMAP 486 . 11674))))) STOP \ No newline at end of file diff --git a/library/SEDIT-COMMONLISP b/library/SEDIT-COMMONLISP new file mode 100644 index 00000000..16a68889 --- /dev/null +++ b/library/SEDIT-COMMONLISP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "SEDIT" BASE 10) (IL:FILECREATED "11-Jan-91 23:44:41" IL:|{DSK}bane>LISP>SEDIT-COMMONLISP.;5| 47901 IL:|changes| IL:|to:| (IL:FNS INITIALIZE-COMMONLISP STRING-FLIP INSERT-FLIPPED-READ-TIME-CONDITIONAL ASSIGN-FORMAT-READ-TIME-CONDITIONAL CFV-READ-TIME-CONDITIONAL COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL COPY-STRUCTURE-READ-TIME-CONDITIONAL CREATE-NEW-READ-TIME-CONDITIONAL LINEARIZE-READ-TIME-CONDITIONAL PARSE--CONDITIONAL-READ SET-POINT-READ-TIME-CONDITIONAL STRINGIFY-READ-TIME-CONDITIONAL INSERT-NEW-READ-TIME-CONDITIONAL-GAP REPLACE-READ-TIME-CONDITIONAL) (IL:VARS IL:SEDIT-COMMONLISPCOMS) (IL:FUNCTIONS ICL TM::MUNG-SEDIT-READ-TABLE ADD-NEW-QUOTE-LIKE) (IL:ADVICE SETUP-PROFILE) (IL:VARIABLES TM::*SEDIT-READ-TABLES*) IL:|previous| IL:|date:| "12-Jun-90 12:53:24" IL:|{DSK}local>lde>lispcore>library>SEDIT-COMMONLISP.;1|) ; Copyright (c) 1987, 1988, 1989, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-COMMONLISPCOMS) (IL:RPAQQ IL:SEDIT-COMMONLISPCOMS ((IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:GLOBALVARS TYPE-NEW-QUOTE TYPE-READABLE-READ-TIME-CONDITIONAL TYPE-UNREADABLE-READ-TIME-CONDITIONAL) (IL:* IL:|;;;| "You must also have EXPORTS.ALL loaded to compile this file, but it shouldn't be neccessary to set DFNFLG to PROP.") (IL:* IL:|;;| "Support for NEW-QUOTE, the type for #, and #.") (IL:FNS COPY-STRUCTURE-NEW-QUOTE INPUT-NEW-QUOTE PARSE--NEW-QUOTE REPLACE-NEW-QUOTE SUBNODE-CHANGED-NEW-QUOTE) (IL:* IL:|;;| "Support for READABLE-READ-TIME-CONDITIONAL and UNREADABLE-READ-TIME-CONDITIONAL, the types for #+ and #-") (IL:FNS ASSIGN-FORMAT-READ-TIME-CONDITIONAL BACKSPACE-READ-TIME-CONDITIONAL CFV-READ-TIME-CONDITIONAL COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL COPY-STRUCTURE-READ-TIME-CONDITIONAL CREATE-NEW-READ-TIME-CONDITIONAL DELETE-READ-TIME-CONDITIONAL INPUT-CONDITIONAL-READ INSERT-READ-TIME-CONDITIONAL INSERT-FLIPPED-READ-TIME-CONDITIONAL LINEARIZE-READ-TIME-CONDITIONAL PARSE--CONDITIONAL-READ REPLACE-READ-TIME-CONDITIONAL SET-POINT-READ-TIME-CONDITIONAL SET-SELECTION-READ-TIME-CONDITIONAL STRINGIFY-READ-TIME-CONDITIONAL SUBNODE-CHANGED-READABLE-RTC SUBNODE-CHANGED-UNREADABLE-RTC UNDO-REPLACE-READ-TIME-CONDITIONAL) (IL:* IL:|;;| "Other junk including INITIALIZE-COMMONLISP, the installation function and STRING-FLIP, the convenient string/unstring key ") (IL:FNS CONDITIONALIZE-CURRENT-SELECTION CREATE-NEW-QUOTED-GAP INITIALIZE-COMMONLISP INSERT-NEW-QUOTED-GAP INSERT-NEW-READ-TIME-CONDITIONAL-GAP INPUT-PLUS-OR-MINUS STRING-FLIP) (IL:* IL:|;;| "Advice implementing readtable hack") (IL:FUNCTIONS ADD-NEW-QUOTE-LIKE ICL TM::MUNG-SEDIT-READ-TABLE) (IL:ADVISE SETUP-PROFILE) (IL:VARIABLES TM::*SEDIT-READ-TABLES*) (IL:* IL:|;;| "Temporarily commenting this out for playing-around purposes") (IL:P (INITIALIZE-COMMONLISP)) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:SEDIT-COMMONLISP))) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:GLOBALVARS TYPE-NEW-QUOTE TYPE-READABLE-READ-TIME-CONDITIONAL TYPE-UNREADABLE-READ-TIME-CONDITIONAL) ) (IL:* IL:|;;;| "You must also have EXPORTS.ALL loaded to compile this file, but it shouldn't be neccessary to set DFNFLG to PROP." ) (IL:* IL:|;;| "Support for NEW-QUOTE, the type for #, and #.") (IL:DEFINEQ (COPY-STRUCTURE-NEW-QUOTE (IL:LAMBDA (NODE) (IL:* IL:\; "Edited 18-Feb-88 16:07 by raf") (IL:REPLACE STRUCTURE IL:OF NODE IL:WITH (LET ((STRUC (TM::COPY-PREFIX-QUOTE (IL:FETCH STRUCTURE IL:OF NODE)))) (SETF (TM::PREFIX-QUOTE-CONTENTS STRUC) (IL:FETCH STRUCTURE IL:OF (SUBNODE 1 NODE))) STRUC)))) (INPUT-NEW-QUOTE (IL:LAMBDA (CONTEXT CHARCODE QUOTE-TYPE) (IL:* IL:\; "Edited 18-Feb-88 17:10 by raf") (IL:* IL:|;;;| "Control character command to insert a new quote type with gap.") (CASE (TYPE-OF-INPUT CONTEXT) (STRUCTURE (IL:* IL:\; "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 (IL:* IL:\; "If we're pointing somewhere random inside of a structure we'll just call the default character handler. Not great, but a fine failsafe.") (IL:APPLY* (IL:FETCH DEFAULT-CHAR-HANDLER IL:OF (IL:FETCH ENVIRONMENT IL:OF CONTEXT)) CONTEXT CHARCODE))))) (PARSE--NEW-QUOTE (IL:LAMBDA (STRUCTURE CONTEXT MODE) (IL:* IL:\; "Edited 18-Feb-88 17:24 by raf") (WHEN (AND (OR (NULL MODE) (EQ MODE 'DATA)) (TM::PREFIX-QUOTE-CONTENTS STRUCTURE)) (BUILD-NODE STRUCTURE CONTEXT TYPE-NEW-QUOTE) (IL:|replace| UNASSIGNED IL:|of| (IL:|fetch| CURRENT-NODE IL:|of| CONTEXT) IL:|with| (IL:LISTGET (IL:|fetch| QUOTE-STRING IL:|of| (IL:|fetch| ENVIRONMENT IL:|of| CONTEXT) ) (TM::PREFIX-QUOTE-TYPE STRUCTURE))) (PARSE (TM::PREFIX-QUOTE-CONTENTS STRUCTURE) CONTEXT NIL) T))) (REPLACE-NEW-QUOTE (IL:LAMBDA (NODE CONTEXT WHERE SUBNODES POINT) (IL:* IL:\; "Edited 23-Feb-88 18:58 by raf") (LET ((SUBNODE (CAR SUBNODES))) (UNLESS (OR (AND (IL:TYPE? EDIT-SELECTION WHERE) (EQ (IL:FETCH SELECT-START IL:OF WHERE) 1) (EQ (IL:FETCH SELECT-END IL:OF WHERE) 1)) (IL:TYPE? EDIT-NODE WHERE)) (IL:SHOULDNT "weird bounds for replace.quote")) (UNDO-BY UNDO-REPLACE-QUOTE NODE (SUBNODE 1 NODE)) (KILL-NODE (SUBNODE 1 NODE)) (RPLACA (CDR (IL:FETCH SUB-NODES IL:OF NODE)) SUBNODE) (IL:REPLACE SUPER-NODE IL:OF SUBNODE IL:WITH NODE) (IL:REPLACE SUB-NODE-INDEX IL:OF SUBNODE IL:WITH 1) (SETF (TM::PREFIX-QUOTE-CONTENTS (IL:FETCH STRUCTURE IL:OF NODE)) (IL:FETCH STRUCTURE IL:OF SUBNODE)) (SET-DEPTH SUBNODE (IL:ADD1 (IL:FETCH DEPTH IL:OF NODE))) (NOTE-CHANGE NODE CONTEXT) (WHEN POINT (PUNT-SET-POINT POINT CONTEXT NODE T)) (CDR SUBNODES)))) (SUBNODE-CHANGED-NEW-QUOTE (IL:LAMBDA (NODE SUBNODE) (IL:* IL:\; "Edited 18-Feb-88 17:39 by raf") (SETF (TM::PREFIX-QUOTE-CONTENTS (IL:FETCH STRUCTURE IL:OF NODE)) (IL:FETCH STRUCTURE IL:OF SUBNODE)))) ) (IL:* IL:|;;| "Support for READABLE-READ-TIME-CONDITIONAL and UNREADABLE-READ-TIME-CONDITIONAL, the types for #+ and #-" ) (IL:DEFINEQ (ASSIGN-FORMAT-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT FORMAT) (IL:* IL:\; "Edited 2-Jan-91 22:15 by jrb:") (IL:* IL:|;;| "We only have to worry about setting up the expression node's list-format.") (LET ((EXPR-NODE (THIRD (IL:|fetch| SUB-NODES IL:|of| NODE)))) (WHEN (EQ TYPE-LIST (IL:|fetch| NODE-TYPE IL:|of| EXPR-NODE)) (IL:|replace| UNASSIGNED IL:|of| EXPR-NODE IL:|with| (COND ((IL:|type?| LIST-FORMAT FORMAT) FORMAT) (T (OR (GETHASH (CAR (IL:|fetch| STRUCTURE IL:|of| EXPR-NODE)) LIST-FORMATS-TABLE) (GET-LIST-FORMAT :DEFAULT)))))))) ) (BACKSPACE-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT INDEX) (IL:* IL:\; "Edited 18-Feb-88 15:26 by raf") (COND ((NULL INDEX) (IL:* IL:\;  "backspace from right boundary puts caret into the read.time.conditional's FORM.") (LET ((POINT (IL:FETCH CARET-POINT IL:OF CONTEXT))) (IL:REPLACE POINT-NODE IL:OF POINT IL:WITH NODE) (IL:REPLACE POINT-INDEX IL:OF POINT IL:WITH (CAR (IL:FETCH SUB-NODES IL:OF NODE))) (IL:REPLACE POINT-TYPE IL:OF POINT IL:WITH 'STRUCTURE)) (SET-SELECTION-NOWHERE (IL:FETCH SELECTION IL:OF CONTEXT))) ((EQ 0 INDEX) (IL:* IL:\;  "backspace from before first element deletes the read.time.conditional if its empty.") (IF (NULL (CDR (IL:FETCH SUB-NODES IL:OF NODE))) (DELETE-NODES (IL:FETCH SUPER-NODE IL:OF NODE) CONTEXT NODE NIL (IL:FETCH CARET-POINT IL:OF CONTEXT)))) (T (IL:* IL:\;  "backspacing after an element of the read.time.conditional is handled by that subnode.") (IL:SETQ NODE (SUBNODE INDEX NODE)) (IL:APPLY* (IL:FETCH BACK-SPACE IL:OF (IL:FETCH NODE-TYPE IL:OF NODE)) NODE CONTEXT))))) (CFV-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE ENVIRONMENT CONTEXT) (IL:* IL:\; "Edited 31-Dec-90 13:30 by jrb:") (LET ((HASH-WIDTH (IL:|fetch| WIDTH IL:|of| (IL:LISTGET (IL:|fetch| QUOTE-STRING IL:|of| ENVIRONMENT) (ECASE (TM::READ-TIME-CONDITIONAL-SIGN (IL:|fetch| STRUCTURE IL:|of| NODE)) (#\+ :HASH-PLUS) (#\- :HASH-MINUS))))) (FEATURE (SECOND (IL:|fetch| SUB-NODES IL:|of| NODE))) (FORM (THIRD (IL:|fetch| SUB-NODES IL:|of| NODE)))) (LET ((TOTAL-WIDTH (IL:IPLUS HASH-WIDTH (IL:|fetch| INLINE-WIDTH IL:|of| FEATURE) (IL:|fetch| PREFERRED-WIDTH IL:|of| FORM)))) (IL:|replace| INLINE-WIDTH IL:|of| NODE IL:|with| TOTAL-WIDTH) (IL:|replace| PREFERRED-WIDTH IL:|of| NODE IL:|with| TOTAL-WIDTH)))) ) (COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL (IL:LAMBDA (POINT CONTEXT) (IL:* IL:\; "Edited 2-Jan-91 16:14 by jrb:") (IL:* IL:|;;| "I'm not !00% sure but I think this will work fof the new RTCs - JRB") (LET ((NODE (IL:|fetch| POINT-NODE IL:|of| POINT)) SUBNODE ITEM) (COND ((EQ 0 (IL:|fetch| POINT-INDEX IL:|of| POINT)) (IL:* IL:|;;| "Before the first element -- right after the hash, which we assume is the first item in the linear form.") (IL:|replace| POINT-X IL:|of| POINT IL:|with| (IL:IPLUS (IL:|fetch| START-X IL:|of| NODE) (IL:|fetch| WIDTH IL:|of| (CAR (IL:|fetch| LINEAR-FORM IL:|of| NODE))))) (IL:|replace| POINT-LINE IL:|of| POINT IL:|with| (IL:|fetch| FIRST-LINE IL:|of| NODE))) (T (IL:* IL:\; "Find the subnode the point will follow.") (SETQ SUBNODE (SUBNODE (IL:FETCH POINT-INDEX IL:OF POINT) NODE)) (IL:|replace| POINT-LINE IL:|of| POINT IL:|with| (IL:|fetch| LAST-LINE IL:|of| SUBNODE)) (SETQ ITEM (CADR (IL:FETCH LINEAR-THREAD IL:OF SUBNODE))) (IL:|replace| POINT-X IL:|of| POINT IL:|with| (IL:IPLUS (IL:|fetch| START-X IL:|of| SUBNODE) (IL:|fetch| ACTUAL-LLENGTH IL:|of| SUBNODE) (IL:|if| (IL:SMALLP ITEM) IL:|then| (IL:* IL:\; "it's followed by space -- put the caret in the middle") (IL:IMIN (IL:HALF ITEM) 6) IL:|else| (IL:* IL:\; "it's followed by something else -- presumably the close paren -- so put the caret immediately after it") 0))))))) ) (COPY-STRUCTURE-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE) (IL:* IL:\; "Edited 3-Jan-91 15:57 by jrb:") (IL:|replace| STRUCTURE IL:|of| NODE IL:|with| (LET ((NEWSTRUCT (FUNCALL (ETYPECASE (IL:|fetch| STRUCTURE IL:|of| NODE) (TM::HASH-IL-READABLE (QUOTE TM::COPY-HASH-IL-READABLE)) (TM::HASH-IL-UNREADABLE (QUOTE TM::COPY-HASH-IL-UNREADABLE))) (IL:|fetch| STRUCTURE IL:|of| NODE)))) (IL:* IL:|;;| "Mondo bizarro code below goes out into the node structure, finds the list structures that really belong in the FEATURE and FORM slots of the new node and puts them there. Since COPY-NODE copies the node-tree and THEN the underlying structure, the actual list structure that needs to be in the FEATURE and FORM slots has ALREADY been copied into the node-tree. In my opinion this is a *BUG*, and the structure should be copied FIRST, with the new tree reflecting the copy. Changing this behavior in COPY-NODE is easy, but God only knows what doing so will break, so I'm going to work around it... JRB") (SETF (TM::READ-TIME-CONDITIONAL-FEATURE NEWSTRUCT) (IL:|fetch| STRUCTURE IL:|of| (SUBNODE 1 NODE)) (TM::READ-TIME-CONDITIONAL-FORM NEWSTRUCT) (IL:|fetch| STRUCTURE IL:|of| (SUBNODE 2 NODE))) NEWSTRUCT))) ) (CREATE-NEW-READ-TIME-CONDITIONAL (IL:LAMBDA (GAP CONTEXT TYPE) (IL:* IL:\; "Edited 2-Jan-91 22:55 by jrb:") (IL:* IL:|;;;| "Create a new read time conditional with gaps in it, and the node to represent it.") (LET* ((FEATURE-NODE (CREATE-GAP-NODE GAP)) (FORM-NODE (CREATE-GAP-NODE GAP)) (RTC-NODE (IL:|create| EDIT-NODE NODE-TYPE IL:_ TYPE-READABLE-READ-TIME-CONDITIONAL STRUCTURE IL:_ (TM::MAKE-HASH-IL-READABLE :FEATURE GAP :SIGN TYPE :FORM GAP) SUB-NODES IL:_ (LIST 2 FEATURE-NODE FORM-NODE)))) (IL:|replace| SUPER-NODE IL:|of| FEATURE-NODE IL:|with| RTC-NODE) (IL:|replace| SUPER-NODE IL:|of| FORM-NODE IL:|with| RTC-NODE) (IL:|replace| SUB-NODE-INDEX IL:|of| FEATURE-NODE IL:|with| 1) (IL:|replace| SUB-NODE-INDEX IL:|of| FORM-NODE IL:|with| 2) (IL:|replace| LINEAR-FORM IL:|of| RTC-NODE IL:|with| (CREATE-WEAK-LINK RTC-NODE)) (NOTE-CHANGE RTC-NODE CONTEXT) RTC-NODE)) ) (DELETE-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT START END SET.POINT?) (IL:* IL:\; "Edited 18-Feb-88 16:31 by raf") (IL:* IL:|;;| "Replace any deleted subnodes with gaps, since this is a fixed length object.") (WHEN (NOT (IL:SMALLP START)) (SETQ START (IL:FETCH SUB-NODE-INDEX IL:OF START)) (SETQ END START)) (REPLACE-READ-TIME-CONDITIONAL NODE CONTEXT START END (IL:FOR I IL:FROM START IL:TO END IL:COLLECT (CREATE-GAP-NODE BASIC-GAP))) (WHEN SET.POINT? (SET-SELECTION-ME (IL:FETCH SELECTION IL:OF CONTEXT) CONTEXT (SUBNODE END NODE)) (PENDING-DELETE SET.POINT? (IL:FETCH SELECTION IL:OF CONTEXT))) T)) (INPUT-CONDITIONAL-READ (IL:LAMBDA (CONTEXT CHARCODE TYPE) (IL:* IL:\; "Edited 24-Feb-88 18:43 by raf") (CASE (TYPE-OF-INPUT CONTEXT) (STRUCTURE (IL:* IL:\; "If we're structure pointing (between the hairs of the universe) a new read time conditional is made and inserted.") (CLOSE-OPEN-NODE CONTEXT) (INSERT-NEW-READ-TIME-CONDITIONAL-GAP CONTEXT CHARCODE TYPE)) (ATOM (IL:* IL:\; "If we're pointing somewhere random inside of a structure we'll just call the default character handler. Not great, but a fine failsafe.") (IL:APPLY* (IL:FETCH DEFAULT-CHAR-HANDLER IL:OF (IL:FETCH ENVIRONMENT IL:OF CONTEXT)) CONTEXT CHARCODE))))) (INSERT-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT WHERE SUBNODES POINT) (IL:* IL:\; "Edited 18-Feb-88 17:17 by raf") (LET (START END) (IL:|if| (IL:|type?| EDIT-SELECTION WHERE) IL:|then| (SETQ START (IL:FETCH SELECT-START IL:OF WHERE)) (SETQ END (OR (IL:FETCH SELECT-END IL:OF WHERE) START)) IL:|elseif| (IL:|type?| EDIT-POINT WHERE) IL:|then| (SETQ END (IL:FETCH POINT-INDEX IL:OF WHERE)) (SETQ START (IL:ADD1 END)) IL:|else| (SETQ START (IL:FETCH SUB-NODE-INDEX IL:OF WHERE)) (SETQ END START)) (REPLACE-READ-TIME-CONDITIONAL NODE CONTEXT START END SUBNODES POINT)))) (INSERT-FLIPPED-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE FEATURE-NODE CONTEXT) (IL:* IL:\; "Edited 9-Jan-91 01:37 by jrb:") (IL:* IL:|;;| "NODE is a read-time-conditional whose FEATURE changed changing its readability; we're replacing it with a new node of the opposite readability, reading and unreading structure as necessary.") (LET ((READABLE? (EQ (IL:|fetch| NODE-TYPE IL:|of| NODE) TYPE-READABLE-READ-TIME-CONDITIONAL)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) (OLD-FORM-NODE (SUBNODE 2 NODE)) (NEW-FORM-NODE (SUBNODE 2 NODE)) (OLD-STRUCTURE (IL:|fetch| STRUCTURE IL:|of| NODE)) NEW-FORM) (IL:* IL:|;;| "The following mess sets NEW-FORM and NEW-FORM-NODE to appropriate things. If the current form is a GAP, just use it; otherwise flip it between string-form and structure-form") (IL:|if| (EQ (IL:|fetch| NODE-TYPE IL:|of| OLD-FORM-NODE) TYPE-GAP) IL:|then| (SETQ NEW-FORM (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE)) IL:|else| (IL:|if| READABLE? IL:|then| (IL:* IL:\; "was readable, stringify it") (SETQ NEW-FORM (FORMAT NIL "~s" (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE))) (SETQ NEW-FORM-NODE (PARSE-NEW NEW-FORM CONTEXT)) IL:|else| (IL:* IL:\; "was unreadable, reread it from string") (WHEN (STRINGP (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE)) (IL:* IL:|;;| "If the current structure ISN'T a string, who knows what may be wrong...") (WITH-INPUT-FROM-STRING (S (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE)) (LET ((FORM (IL:NLSETQ (READ S)))) (COND (FORM (SETQ NEW-FORM (CAR FORM) NEW-FORM-NODE (PARSE-NEW (CAR FORM) CONTEXT))) (T (IL:PRINTOUT (GET-PROMPT-WINDOW CONTEXT) T "Warning: Problem trying to read conditional expression. Not read.") (SETQ NEW-FORM (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE))))))))) (IL:* IL:|;;| "I now think the right thing to do here is to smash the current node's type in place. This may cause problems of its own, but the replace-it strategy was eating us alive.") (SETF (IL:|fetch| NODE-TYPE IL:|of| NODE) (IL:|if| READABLE? IL:|then| TYPE-UNREADABLE-READ-TIME-CONDITIONAL IL:|else| TYPE-READABLE-READ-TIME-CONDITIONAL)) (SETF (IL:|fetch| STRUCTURE IL:|of| NODE) (FUNCALL (IL:|if| READABLE? IL:|then| (FUNCTION TM::MAKE-HASH-IL-UNREADABLE) IL:|else| (FUNCTION TM::MAKE-HASH-IL-READABLE)) :FEATURE (IL:|fetch| STRUCTURE IL:|of| FEATURE-NODE) :SIGN (TM::READ-TIME-CONDITIONAL-SIGN OLD-STRUCTURE) :FORM (TM::READ-TIME-CONDITIONAL-FORM OLD-STRUCTURE))) (UNLESS (EQ OLD-FORM-NODE NEW-FORM-NODE) (REPLACE-NODE CONTEXT OLD-FORM-NODE NEW-FORM-NODE) (IL:* IL:|;;| "The old node is out there on the UNDO list; we need to mung its form so things will undo correctly (trust me...)") (SETF (IL:|fetch| STRUCTURE IL:|of| OLD-FORM-NODE) (IL:|fetch| STRUCTURE IL:|of| NEW-FORM-NODE)) (IL:* IL:|;;| "Maybe this should be done elsewhere; we'll see...")) (IL:* IL:|;;| "The following seems to be sufficient to get the new structure sane before the next operation. These conniptions are necessary for the following strange reason: ") (IL:* IL:|;;| "Assume we're editing #+:interlisp(foo) and we select the 'l' in :interlisp and hit the delete key. We now have #+:interlsp(foo); SEdit hasn't closed the :interlsp node, so no other structure has had a chance to change. Now, take the mouse and click on foo. On the click, SEdit closes the :interlsp node, which changes the #+ from readable to unreadable, which causes this function to be run and (foo) to be replaced with \"(foo)\". Without the reformat-and relinearization below, that mouse-click will select something from the nodes for (foo), but these nodes are dead.") (IL:* IL:|;;| "Of course, with the reformatting below, that last mouse-click will cause the displayed structure to squirm out from under the mouse, but at least SEdit won't BREAK while doing it!") (SUBNODE-CHANGED NODE CONTEXT) (NOTE-CHANGE NODE CONTEXT) (COMPUTE-FORMATS-AND-FORMAT-VALUES NODE CONTEXT) (RELINEARIZE NODE CONTEXT) T)) ) (LINEARIZE-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT RIGHT-MARGIN) (IL:* IL:\; "Edited 2-Jan-91 22:11 by jrb:") (LET ((HASH (IL:LISTGET (IL:|fetch| QUOTE-STRING IL:|of| (IL:|fetch| ENVIRONMENT IL:|of| CONTEXT)) (ECASE (TM::READ-TIME-CONDITIONAL-SIGN (IL:|fetch| STRUCTURE IL:|of| NODE)) (#\+ :HASH-PLUS) (#\- :HASH-MINUS)))) (FEATURE (SECOND (IL:|fetch| SUB-NODES IL:|of| NODE))) (FORM (THIRD (IL:|fetch| SUB-NODES IL:|of| NODE)))) (OUTPUT-CONSTANT-STRING CONTEXT HASH) (LINEARIZE FEATURE CONTEXT RIGHT-MARGIN) (IL:* IL:|;;| "Should add some space between FEATURE and FORM here...") (LINEARIZE FORM CONTEXT RIGHT-MARGIN))) ) (PARSE--CONDITIONAL-READ (IL:LAMBDA (STRUCTURE CONTEXT MODE) (IL:* IL:\; "Edited 2-Jan-91 19:58 by jrb:") (COND ((TM::HASH-IL-READABLE-P STRUCTURE) (BUILD-NODE STRUCTURE CONTEXT TYPE-READABLE-READ-TIME-CONDITIONAL) (PARSE (TM::READ-TIME-CONDITIONAL-FEATURE STRUCTURE) CONTEXT NIL) (PARSE (TM::READ-TIME-CONDITIONAL-FORM STRUCTURE) CONTEXT NIL) T) ((TM::HASH-IL-UNREADABLE-P STRUCTURE) (BUILD-NODE STRUCTURE CONTEXT TYPE-UNREADABLE-READ-TIME-CONDITIONAL) (PARSE (TM::READ-TIME-CONDITIONAL-FEATURE STRUCTURE) CONTEXT NIL) (PARSE (TM::READ-TIME-CONDITIONAL-FORM STRUCTURE) CONTEXT NIL) T))) ) (REPLACE-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE CONTEXT START END SUBNODES POINT) (IL:* IL:\; "Edited 7-Jan-91 14:33 by jrb:") (UNDO-BY UNDO-REPLACE-READ-TIME-CONDITIONAL NODE (IL:|for| I IL:|from| START IL:|to| END IL:|collect| (SUBNODE I NODE))) (IL:|for| I IL:|from| START IL:|to| END IL:|as| SUBNODE IL:|in| SUBNODES IL:|as| SMASHNODE IL:|on| (IL:NTH (CDR (IL:|fetch| SUB-NODES IL:|of| NODE)) START) IL:|do| (IL:* IL:|;;| "Update the EditNode itself.") (KILL-NODE (SUBNODE I NODE)) (RPLACA SMASHNODE SUBNODE) (IL:|replace| SUPER-NODE IL:|of| SUBNODE IL:|with| NODE) (IL:|replace| SUB-NODE-INDEX IL:|of| SUBNODE IL:|with| I) (SET-DEPTH SUBNODE (IL:ADD1 (IL:|fetch| DEPTH IL:|of| NODE))) (SUBNODE-CHANGED SUBNODE CONTEXT) (IL:* IL:\; "Updates the data underlying this EditNode.")) (NOTE-CHANGE NODE CONTEXT) (WHEN POINT (PUNT-SET-POINT POINT CONTEXT NODE T)) NIL) ) (SET-POINT-READ-TIME-CONDITIONAL (IL:LAMBDA (POINT CONTEXT NODE INDEX OFFSET ITEM TYPE COMPUTE-LOCATION?) (IL:* IL:\; "Edited 2-Jan-91 16:15 by jrb:") (COND ((IL:|type?| STRING-ITEM ITEM) (IL:* IL:\; "pointing to the HASH.") (SETQ OFFSET (IL:ILESSP OFFSET (IL:HALF (IL:FETCH WIDTH IL:OF ITEM))))) (T (IL:|type?| EDIT-NODE ITEM) (SETQ TYPE (QUOTE STRUCTURE)))) (COND ((NULL INDEX) (PUNT-SET-POINT POINT CONTEXT NODE OFFSET COMPUTE-LOCATION?)) (T (COND ((AND (EQ TYPE (QUOTE ATOM)) (IL:NEQ INDEX 0) (IL:ILEQ INDEX 2)) (SET-POINT POINT CONTEXT (SUBNODE INDEX NODE) NIL OFFSET NIL (QUOTE ATOM) COMPUTE-LOCATION?)) ((EQ INDEX 2) (IL:* IL:\; "can't insert structure after the last item") (SET-POINT-NOWHERE POINT)) (T (IL:|replace| POINT-NODE IL:|of| POINT IL:|with| NODE) (IL:|replace| POINT-INDEX IL:|of| POINT IL:|with| (IF OFFSET INDEX (SETQ INDEX (IL:SUB1 INDEX)))) (IL:|replace| POINT-TYPE IL:|of| POINT IL:|with| (QUOTE STRUCTURE)) (WHEN COMPUTE-LOCATION? (COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL POINT CONTEXT))))))) ) (SET-SELECTION-READ-TIME-CONDITIONAL (IL:LAMBDA (SELECTION CONTEXT NODE INDEX OFFSET ITEM TYPE) (IL:* IL:\; "Edited 18-Feb-88 17:38 by raf") (IL:* IL:|;;| "Pointing to the hash selects the whole read.time.conditional.") (SET-SELECTION-ME SELECTION CONTEXT NODE))) (STRINGIFY-READ-TIME-CONDITIONAL (IL:LAMBDA (NODE ENVIRONMENT) (IL:* IL:\; "Edited 2-Jan-91 16:38 by jrb:") (IL:* IL:|;;| "There used to be a lot of junk here about getting the sign and the stringification right; (let ((structure (IL:FETCH STRUCTURE IL:OF NODE)))(IL:CONCAT (LET ((*PACKAGE* IL:*KEYWORD-PACKAGE*)) (FORMAT NIL \"#~a~s\" (ETYPECASE STRUCTURE (TM::HASH-PLUS \"+\") (TM::HASH-MINUS \"-\")) (TM::READ-TIME-CONDITIONAL-FEATURE STRUCTURE))) (IF (TM::READ-TIME-CONDITIONAL-UNREAD-P STRUCTURE) (TM::READ-TIME-CONDITIONAL-FORM STRUCTURE) (FORMAT NIL \"~S\" (TM::READ-TIME-CONDITIONAL-FORM STRUCTURE)))))") (IL:* IL:|;;| "All that stuff is supposedly handled by the print methods for the RTC objects, isn't it?") (FORMAT NIL "~s" (IL:FETCH STRUCTURE IL:OF NODE))) ) (SUBNODE-CHANGED-READABLE-RTC (IL:LAMBDA (NODE SUBNODE CONTEXT) (IL:* IL:\; "Edited 31-Dec-90 15:12 by jrb:") (LET ((SUBNODE-STRUCTURE (IL:|fetch| STRUCTURE IL:|of| SUBNODE)) (NODE-STRUCTURE (IL:|fetch| STRUCTURE IL:|of| NODE))) (CASE (IL:|fetch| SUB-NODE-INDEX IL:|of| SUBNODE) (1 (IL:* IL:\; "Changing the FEATURE. ") (IL:|if| (ECASE (TM::READ-TIME-CONDITIONAL-SIGN NODE-STRUCTURE) (#\+ (NOT (IL:CMLREAD.FEATURE.PARSER SUBNODE-STRUCTURE))) (#\- (IL:CMLREAD.FEATURE.PARSER SUBNODE-STRUCTURE))) IL:|then| (IL:* IL:|;;| "We became unreadable, dump this node and replace with an UNREADABLE-READ-TIME-CONDITIONAL.") (INSERT-FLIPPED-READ-TIME-CONDITIONAL NODE SUBNODE CONTEXT) IL:|else| (SETF (TM::READ-TIME-CONDITIONAL-FEATURE NODE-STRUCTURE) SUBNODE-STRUCTURE))) (2 (IL:* IL:\; "Changing the FORM; just replace it.") (SETF (TM::READ-TIME-CONDITIONAL-FORM NODE-STRUCTURE) SUBNODE-STRUCTURE)) (T (IL:SHOULDNT "Bad subnode index"))) (NOTE-CHANGE NODE CONTEXT))) ) (SUBNODE-CHANGED-UNREADABLE-RTC (IL:LAMBDA (NODE SUBNODE CONTEXT) (IL:* IL:\; "Edited 31-Dec-90 15:23 by jrb:") (LET ((SUBNODE-STRUCTURE (IL:|fetch| STRUCTURE IL:|of| SUBNODE)) (NODE-STRUCTURE (IL:|fetch| STRUCTURE IL:|of| NODE))) (CASE (IL:|fetch| SUB-NODE-INDEX IL:|of| SUBNODE) (1 (IL:* IL:\; "Changing the FEATURE. ") (IL:|if| (ECASE (TM::READ-TIME-CONDITIONAL-SIGN NODE-STRUCTURE) (#\+ (IL:CMLREAD.FEATURE.PARSER SUBNODE-STRUCTURE)) (#\- (NOT (IL:CMLREAD.FEATURE.PARSER SUBNODE-STRUCTURE)))) IL:|then| (IL:* IL:|;;| "We became readable, dump this node and replace with an UNREADABLE-READ-TIME-CONDITIONAL.") (INSERT-FLIPPED-READ-TIME-CONDITIONAL NODE SUBNODE CONTEXT) IL:|else| (SETF (TM::READ-TIME-CONDITIONAL-FEATURE NODE-STRUCTURE) SUBNODE-STRUCTURE))) (2 (IL:* IL:\; "Changing the FORM; just replace it.") (IL:* IL:|;;| "This is one place where you COULD catch someone putting a non-string into an unreadable-rtc. I think a better thing to do is give users a \"stringify all unreadable-rtcs\" command, and hack the install for unreadable stuff to break and let you stringify (or even do it behind your back, what the heck...).") (SETF (TM::READ-TIME-CONDITIONAL-FORM NODE-STRUCTURE) SUBNODE-STRUCTURE)) (T (IL:SHOULDNT "Bad subnode index"))) (NOTE-CHANGE NODE CONTEXT))) ) (UNDO-REPLACE-READ-TIME-CONDITIONAL (IL:LAMBDA (CONTEXT NODE OLD-SUBNODES) (IL:* IL:\; "Edited 18-Feb-88 17:45 by raf") (REPLACE-READ-TIME-CONDITIONAL NODE CONTEXT (IL:FETCH SUB-NODE-INDEX IL:OF (CAR OLD-SUBNODES)) (IL:FETCH SUB-NODE-INDEX IL:OF (CAR (LAST OLD-SUBNODES))) OLD-SUBNODES NIL))) ) (IL:* IL:|;;| "Other junk including INITIALIZE-COMMONLISP, the installation function and STRING-FLIP, the convenient string/unstring key " ) (IL:DEFINEQ (CONDITIONALIZE-CURRENT-SELECTION (IL:LAMBDA (CONTEXT CHARCODE QUOTE-TYPE) (IL:* IL:\; "Edited 28-Dec-90 18:40 by jrb:") (CLOSE-OPEN-NODE CONTEXT) (LET* ((SELECTION (IL:FETCH SELECTION IL:OF CONTEXT)) (POINT (IL:FETCH CARET-POINT IL:OF CONTEXT)) (NODE (IL:FETCH SELECT-NODE IL:OF SELECTION)) (CR-NODE)) (IL:* IL:|;;| "I'm unsure about this conditinalization below, and suspect it's wrong.") (WHEN (AND NODE (EQ (IL:FETCH SELECT-TYPE IL:OF SELECTION) (QUOTE STRUCTURE))) (IL:SETQ CR-NODE (CREATE-NEW-READ-TIME-CONDITIONAL BASIC-GAP CONTEXT QUOTE-TYPE)) (START-UNDO-BLOCK) (REPLACE-NODE CONTEXT NODE CR-NODE) (REPLACE-NODE CONTEXT (SUBNODE 1 CR-NODE) NODE) (NOTE-CHANGE CR-NODE CONTEXT) (IL:* IL:|;;| "Set selection and point to the form-gap") (SET-SELECTION-ME SELECTION CONTEXT (SUBNODE 2 CR-NODE)) (PENDING-DELETE POINT SELECTION) (END-UNDO-BLOCK))) (IL:* IL:|;;| "must return non-NIL if command executed") T) ) (CREATE-NEW-QUOTED-GAP (IL:LAMBDA (GAP CONTEXT QUOTE-TYPE) (IL:* IL:\; "Edited 6-Apr-89 16:50 by raf") (IL:* IL:|;;;| "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 (IL:|create| EDIT-NODE NODE-TYPE IL:_ TYPE-NEW-QUOTE STRUCTURE IL:_ (FUNCALL (CASE QUOTE-TYPE (:HASH-DOT #'TM::MAKE-HASH-DOT) (:HASH-COMMA #'TM::MAKE-HASH-COMMA) (:HASH-O #'TM::MAKE-HASH-O) (:HASH-X #'TM::MAKE-HASH-X) (:HASH-B #'TM::MAKE-HASH-B) (T (IL:SHOULDNT "Bad quote type " QUOTE-TYPE))) :CONTENTS GAP) SUB-NODES IL:_ (LIST 1 GAP-NODE) UNASSIGNED IL:_ (IL:LISTGET (IL:|fetch| QUOTE-STRING IL:|of| (IL:|fetch| ENVIRONMENT IL:|of| CONTEXT)) QUOTE-TYPE)))) (IL:|replace| SUPER-NODE IL:|of| GAP-NODE IL:|with| QUOTE-NODE) (IL:|replace| SUB-NODE-INDEX IL:|of| GAP-NODE IL:|with| 1) (IL:|replace| LINEAR-FORM IL:|of| QUOTE-NODE IL:|with| (CREATE-WEAK-LINK QUOTE-NODE)) (NOTE-CHANGE QUOTE-NODE CONTEXT) QUOTE-NODE))) (INITIALIZE-COMMONLISP (IL:LAMBDA NIL (IL:* IL:\; "Edited 11-Jan-91 23:41 by jrb:") "Creates SEdit nodes for Common Lisp presentation types. Fully re-entrant." (IL:* IL:|;;| "First, add the handling for #{b,o,x,r,*}; they get parsed and generally handled like litatoms (once we hack the SEdit readtable to generate them)") (DOLIST (P (QUOTE (TM::HASH-BASED-NUMBER TM::HASH-STAR))) (IL:LISTPUT (IL:|fetch| (EDIT-ENV PARSE-INFO) IL:|of| LISP-EDIT-ENVIRONMENT) P (QUOTE PARSE--LITATOM))) (IL:* IL:|;;| "Now for the weirder ones; #. and #, and #+ and #-") (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-NEW-QUOTE (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ (QUOTE NEW-QUOTE) ASSIGN-FORMAT IL:_ (QUOTE ASSIGN-FORMAT-QUOTE) COMPUTE-FORMAT-VALUES IL:_ (QUOTE CFV-QUOTE) LINEARIZE IL:_ (QUOTE LINEARIZE-QUOTE) SUB-NODE-CHANGED IL:_ (QUOTE SUBNODE-CHANGED-NEW-QUOTE) SET-POINT IL:_ (QUOTE SET-POINT-QUOTE) SET-SELECTION IL:_ (QUOTE SET-SELECTION-QUOTE) GROW-SELECTION IL:_ (QUOTE GROW-SELECTION-DEFAULT) INSERT IL:_ (QUOTE REPLACE-NEW-QUOTE) DELETE IL:_ (QUOTE DELETE-QUOTE) COPY-STRUCTURE IL:_ (QUOTE COPY-STRUCTURE-NEW-QUOTE) COPY-SELECTION IL:_ (QUOTE COPY-SELECTION-DEFAULT) STRINGIFY IL:_ (QUOTE STRINGIFY-QUOTE) BACK-SPACE IL:_ (QUOTE BACKSPACE-QUOTE))) (QUOTE ((TM::HASH-DOT :HASH-DOT "^Q" PARSE--NEW-QUOTE INPUT-NEW-QUOTE) (TM::HASH-COMMA :HASH-COMMA "^F" PARSE--NEW-QUOTE INPUT-NEW-QUOTE))) (QUOTE (("#." :HASH-DOT) ("#," :HASH-COMMA)))) (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-READABLE-READ-TIME-CONDITIONAL (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ (QUOTE READABLE-READ-TIME-CONDITIONAL) ASSIGN-FORMAT IL:_ (QUOTE ASSIGN-FORMAT-READ-TIME-CONDITIONAL) COMPUTE-FORMAT-VALUES IL:_ (QUOTE CFV-READ-TIME-CONDITIONAL) LINEARIZE IL:_ (QUOTE LINEARIZE-READ-TIME-CONDITIONAL) SUB-NODE-CHANGED IL:_ (QUOTE SUBNODE-CHANGED-READABLE-RTC) COMPUTE-POINT-POSITION IL:_ (QUOTE COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL) COMPUTE-SELECTION-POSITION IL:_ (QUOTE COMPUTE-SELECTION-POSITION-DEFAULT) SET-POINT IL:_ (QUOTE SET-POINT-READ-TIME-CONDITIONAL) SET-SELECTION IL:_ (QUOTE SET-SELECTION-READ-TIME-CONDITIONAL) GROW-SELECTION IL:_ (QUOTE GROW-SELECTION-DEFAULT) INSERT IL:_ (QUOTE INSERT-READ-TIME-CONDITIONAL) DELETE IL:_ (QUOTE DELETE-READ-TIME-CONDITIONAL) COPY-STRUCTURE IL:_ (QUOTE COPY-STRUCTURE-READ-TIME-CONDITIONAL) COPY-SELECTION IL:_ (QUOTE COPY-SELECTION-DEFAULT) STRINGIFY IL:_ (QUOTE STRINGIFY-READ-TIME-CONDITIONAL) BACK-SPACE IL:_ (QUOTE BACKSPACE-READ-TIME-CONDITIONAL))) (QUOTE ((TM::HASH-IL-READABLE NIL NIL PARSE--CONDITIONAL-READ) (TM::HASH-IL-UNREADABLE NIL NIL PARSE--CONDITIONAL-READ))) (QUOTE (("#+" :HASH-PLUS) ("#-" :HASH-MINUS)))) (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-UNREADABLE-READ-TIME-CONDITIONAL (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ (QUOTE UNREADABLE-READ-TIME-CONDITIONAL) ASSIGN-FORMAT IL:_ (QUOTE ASSIGN-FORMAT-READ-TIME-CONDITIONAL) COMPUTE-FORMAT-VALUES IL:_ (QUOTE CFV-READ-TIME-CONDITIONAL) LINEARIZE IL:_ (QUOTE LINEARIZE-READ-TIME-CONDITIONAL) SUB-NODE-CHANGED IL:_ (QUOTE SUBNODE-CHANGED-UNREADABLE-RTC) COMPUTE-POINT-POSITION IL:_ (QUOTE COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL) COMPUTE-SELECTION-POSITION IL:_ (QUOTE COMPUTE-SELECTION-POSITION-DEFAULT) SET-POINT IL:_ (QUOTE SET-POINT-READ-TIME-CONDITIONAL) SET-SELECTION IL:_ (QUOTE SET-SELECTION-READ-TIME-CONDITIONAL) GROW-SELECTION IL:_ (QUOTE GROW-SELECTION-DEFAULT) INSERT IL:_ (QUOTE INSERT-READ-TIME-CONDITIONAL) DELETE IL:_ (QUOTE DELETE-READ-TIME-CONDITIONAL) COPY-STRUCTURE IL:_ (QUOTE COPY-STRUCTURE-READ-TIME-CONDITIONAL) COPY-SELECTION IL:_ (QUOTE COPY-SELECTION-DEFAULT) STRINGIFY IL:_ (QUOTE STRINGIFY-READ-TIME-CONDITIONAL) BACK-SPACE IL:_ (QUOTE BACKSPACE-READ-TIME-CONDITIONAL))) NIL NIL) (IL:* IL:|;;| "Just for the heck of it, add a command for stringifying/unstringifying things. I'd put it in the command menu, but it's too much trouble") (SETF (GETHASH (CHARCODE "^S") (IL:|fetch| (EDIT-ENV COMMAND-TABLE) IL:|of| LISP-EDIT-ENVIRONMENT)) (QUOTE (STRING-FLIP NIL))) (IL:* IL:|;;| "And for the final indignity, mung the command table to add a minor flakiness in the handling of + and -") (IL:|for| CP IL:|in| (QUOTE ((#\+ INPUT-PLUS-OR-MINUS) (#\- INPUT-PLUS-OR-MINUS))) IL:|bind| (COMTAB IL:_ (IL:|fetch| (EDIT-ENV COMMAND-TABLE) IL:|of| LISP-EDIT-ENVIRONMENT)) IL:|do| (SETF (GETHASH (CHAR-CODE (FIRST CP)) COMTAB) (IL:BQUOTE ((IL:\\\, (SECOND CP)) NIL (IL:\\\, (FIRST CP)))))) T) ) (INSERT-NEW-QUOTED-GAP (IL:LAMBDA (CONTEXT CHARCODE QUOTE-TYPE) (IL:* IL:\; "Edited 24-Feb-88 18:44 by raf") (IL:* IL:|;;| "implements the ' command: insert a quoted gap") (WHEN (EQ (TYPE-OF-INPUT CONTEXT) 'STRUCTURE) (LET ((SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) NEW-QUOTE GAP) (SETQ NEW-QUOTE (CREATE-NEW-QUOTED-GAP BASIC-GAP CONTEXT QUOTE-TYPE)) (SETQ GAP (SUBNODE 1 NEW-QUOTE)) (IL:* IL:\;  "we get our hands on the gap node now, to handle the case where the insert reparses the new.quote") (INSERT (IL:|fetch| CARET-POINT IL:|of| CONTEXT) CONTEXT (LIST NEW-QUOTE)) (UNLESS (DEAD-NODE? NEW-QUOTE) (SET-SELECTION-ME SELECTION CONTEXT GAP) (PENDING-DELETE POINT SELECTION))) (IL:* IL:\;  "must return non-NIL if command executed") T))) (INSERT-NEW-READ-TIME-CONDITIONAL-GAP (IL:LAMBDA (CONTEXT CHARCODE TYPE) (IL:* IL:\; "Edited 28-Dec-90 19:19 by jrb:") (IL:* IL:|;;| "implements the command: insert a read time conditional with gaps") (WHEN (EQ (TYPE-OF-INPUT CONTEXT) (QUOTE STRUCTURE)) (LET ((SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) NEW-RTC GAP) (SETQ NEW-RTC (CREATE-NEW-READ-TIME-CONDITIONAL BASIC-GAP CONTEXT TYPE)) (SETQ GAP (SUBNODE 1 NEW-RTC)) (IL:* IL:\; "point us at the feature") (INSERT (IL:|fetch| CARET-POINT IL:|of| CONTEXT) CONTEXT (LIST NEW-RTC)) (UNLESS (DEAD-NODE? NEW-RTC) (SET-SELECTION-ME SELECTION CONTEXT GAP) (PENDING-DELETE POINT SELECTION))) (IL:* IL:\; "must return non-NIL if command executed") T)) ) (INPUT-PLUS-OR-MINUS (IL:LAMBDA (CONTEXT CHARCODE QUOTE-TYPE) (IL:* IL:\; "Edited 2-Jan-91 22:12 by jrb:") (IL:* IL:|;;| "Serious weirdness afoot below; we're catching the case of typing a +/- right after a # and then creating a new readable-read-time-conditional (what the heck; assume it's readable until forced to believe otherwise). Strategy stolen from INPUT-QUOTE, with suitable modifications.") (SETQ CHARCODE (CODE-CHAR CHARCODE)) (IL:* IL:\; "Oops...") (IL:SELECTQ (TYPE-OF-INPUT CONTEXT) (STRUCTURE) (ATOM (LET* ((POINT (IL:FETCH CARET-POINT IL:OF CONTEXT)) (NODE (IL:FETCH POINT-NODE IL:OF POINT)) (SUPER-NODE (AND (IL:TYPE? EDIT-NODE NODE) (IL:FETCH SUPER-NODE IL:OF NODE)))) (WHEN (AND SUPER-NODE (EQ 1 (IL:FETCH POINT-INDEX POINT)) (EQ (IL:CHARCODE \#) (IL:CHCON1 (IL:FETCH POINT-STRING IL:OF POINT)))) (COND ((EQ 1 (IL:NCHARS (IL:FETCH POINT-STRING IL:OF POINT))) (IL:* IL:|;;| "Just \"#+\"; close the node, get rid of it, and replace it with a readable-rtc. Oh yeah, do this undoably by just closing and calling an undoable thing,") (CLOSE-OPEN-NODE CONTEXT) (SET-SELECTION-ME (IL:FETCH SELECTION IL:OF CONTEXT) CONTEXT NODE) (PENDING-DELETE POINT (IL:FETCH SELECTION IL:OF CONTEXT)) (INSERT-NEW-READ-TIME-CONDITIONAL-GAP CONTEXT CHARCODE CHARCODE) T) (T (IL:* IL:|;;| "Some joker typed a + in the middle of \"#foo\": remove the #, close the node, shove it into a newly created readable-rtc (which might turn it into an unreadable-rtc), and pending-delete the form gap. Oh yeah, do this undoably.") (START-UNDO-BLOCK) (REPLACE-STRING NODE CONTEXT 1 1 "" POINT (IL:FETCH POINT-STRING IL:OF POINT) (QUOTE ATOM)) (SET-SELECTION-ME (IL:FETCH SELECTION IL:OF CONTEXT) CONTEXT NODE) (CONDITIONALIZE-CURRENT-SELECTION CONTEXT CHARCODE CHARCODE) (END-UNDO-BLOCK) T))))) NIL)) ) (STRING-FLIP (IL:LAMBDA (CONTEXT CHARCODE TYPE) (IL:* IL:\; "Edited 11-Jan-91 23:25 by jrb:") (IL:* IL:|;;| "flip the current selection between structure and string") (IL:SELECTQ (TYPE-OF-INPUT CONTEXT) (STRUCTURE (CLOSE-OPEN-NODE CONTEXT) (LET* ((SELECTION (IL:FETCH SELECTION IL:OF CONTEXT)) (NODE (IL:FETCH SELECT-NODE IL:OF SELECTION)) (START (IL:FETCH SELECT-START IL:OF SELECTION)) (END (IL:FETCH SELECT-END IL:OF SELECTION))) (IL:IF (AND (NULL START) (NULL END) (STRINGP (IL:FETCH STRUCTURE IL:OF NODE))) IL:THEN (IL:* IL:\; "It's already a string, try and read it") (WITH-INPUT-FROM-STRING (S (IL:|fetch| STRUCTURE IL:|of| NODE)) (LET ((FORM (IL:NLSETQ (READ S)))) (COND (FORM (REPLACE-NODE CONTEXT NODE (PARSE-NEW (CAR FORM) CONTEXT))) (T (IL:PRINTOUT (GET-PROMPT-WINDOW CONTEXT) T "Problem trying to read from string. Not read.")))) T) IL:ELSE (IL:* IL:\; "It's something else, turn it into a string") (IL:IF (AND (NULL START) (NULL END)) IL:THEN (REPLACE-NODE CONTEXT NODE (PARSE-NEW (STRINGIFY NODE) CONTEXT)) IL:ELSE (IL:PRINTOUT (GET-PROMPT-WINDOW CONTEXT) T "Select one thing to stringify/unstringify")) T))) (ATOM (IL:PRINTOUT (GET-PROMPT-WINDOW CONTEXT) T "Select a structure to stringify/unstringify")) NIL)) ) ) (IL:* IL:|;;| "Advice implementing readtable hack") (DEFUN ADD-NEW-QUOTE-LIKE (EDIT-NODE-TYPE SUB-TYPE-LIST NEW-QUOTE-STRING-LIST) (IL:* IL:|;;| "This is a generalization of Ron's old INITIALIZE-COMMONLISP function; it adds a new \"quote-like\" presentation to SEdit's LISP-EDIT-ENVIRONMENT, taking care to do it in re-enterable fashion (you can call this more than once with the same arguments and you won't break SEdit).") (IL:* IL:|;;| "The format of the entries on the sub-type-list is:") (IL:* IL:|;;| "(object-type input-keyword create-key parse-function input-function)") (IL:* IL:|;;| "create-key can be anything ") (IL:* IL:|;;| "First add the new EDIT-NODE-TYPE; it has all the SEdit method names burned into it") (IL:FOR TL IL:ON TYPES IL:WHEN (EQ (IL:FFETCH (EDIT-NODE-TYPE NAME) IL:OF EDIT-NODE-TYPE) (IL:FFETCH (EDIT-NODE-TYPE NAME) IL:OF (CAR TL))) IL:DO (RPLACA TL EDIT-NODE-TYPE) (RETURN NIL) IL:FINALLY (PUSH EDIT-NODE-TYPE TYPES)) (IL:* IL:|;;| "Then walk the sub-type list adding everything in") (LET ((PARSE-INFO-TABLE (IL:|fetch| (EDIT-ENV PARSE-INFO) IL:|of| LISP-EDIT-ENVIRONMENT)) (COMMAND-TABLE (IL:|fetch| (EDIT-ENV COMMAND-TABLE) IL:|of| LISP-EDIT-ENVIRONMENT))) (DOLIST (ST SUB-TYPE-LIST) (DESTRUCTURING-BIND (OBJECT-TYPE QUOTE-KEYWORD CREATE-KEY PARSE-FUNCTION INPUT-FUNCTION) ST (IL:* IL:|;;| "First add the PARSE-- function") (IL:LISTPUT PARSE-INFO-TABLE OBJECT-TYPE PARSE-FUNCTION) (IL:* IL:|;;| "Then the create-key, if any") (SETQ CREATE-KEY (CHARCODE CREATE-KEY)) (WHEN CREATE-KEY (SETF (GETHASH CREATE-KEY COMMAND-TABLE) (LIST INPUT-FUNCTION NIL QUOTE-KEYWORD)))))) (IL:* IL:|;;| "Finally mung the quote strings, which are of the form (\"string\" :keyword)") (IL:FOR QSP IL:IN NEW-QUOTE-STRING-LIST IL:BIND QUOTE-STRING-LIST IL:_ (IL:|fetch| (EDIT-ENV QUOTE-STRING) IL:|of| LISP-EDIT-ENVIRONMENT) QUOTE-STRING-FONT IL:_ (IL:|fetch| (EDIT-ENV DEFAULT-FONT) IL:|of| LISP-EDIT-ENVIRONMENT) IL:DO (IL:LISTPUT QUOTE-STRING-LIST (SECOND QSP) (CREATE-STRING-ITEM (FIRST QSP) QUOTE-STRING-FONT)))) (DEFUN ICL NIL (IL:* IL:|;;| "First, add the handling for #{b,o,x,r,*}; they get parsed and generally handled like litatoms (once we hack the SEdit readtable to generate them)") (DOLIST (P (QUOTE (TM::HASH-BASED-NUMBER TM::HASH-STAR))) (IL:LISTPUT (IL:|fetch| (EDIT-ENV PARSE-INFO) IL:|of| LISP-EDIT-ENVIRONMENT) P (QUOTE PARSE--LITATOM))) (IL:* IL:|;;| "Now for the weirder ones; #. and #, and #+ and #-") (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-NEW-QUOTE (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ (QUOTE NEW-QUOTE) ASSIGN-FORMAT IL:_ (QUOTE ASSIGN-FORMAT-QUOTE) COMPUTE-FORMAT-VALUES IL:_ (QUOTE CFV-QUOTE) LINEARIZE IL:_ (QUOTE LINEARIZE-QUOTE) SUB-NODE-CHANGED IL:_ (QUOTE SUBNODE-CHANGED-NEW-QUOTE) SET-POINT IL:_ (QUOTE SET-POINT-QUOTE) SET-SELECTION IL:_ (QUOTE SET-SELECTION-QUOTE) GROW-SELECTION IL:_ (QUOTE GROW-SELECTION-DEFAULT) INSERT IL:_ (QUOTE REPLACE-NEW-QUOTE) DELETE IL:_ (QUOTE DELETE-QUOTE) COPY-STRUCTURE IL:_ (QUOTE COPY-STRUCTURE-NEW-QUOTE) COPY-SELECTION IL:_ (QUOTE COPY-SELECTION-DEFAULT) STRINGIFY IL:_ (QUOTE STRINGIFY-QUOTE) BACK-SPACE IL:_ (QUOTE BACKSPACE-QUOTE))) (QUOTE ((TM::HASH-DOT :HASH-DOT "^Q" PARSE--NEW-QUOTE INPUT-NEW-QUOTE) (TM::HASH-COMMA :HASH-COMMA "^F" PARSE--NEW-QUOTE INPUT-NEW-QUOTE))) (QUOTE (("#." :HASH-DOT) ("#," :HASH-COMMA)))) (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-READABLE-READ-TIME-CONDITIONAL (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ (QUOTE READABLE-READ-TIME-CONDITIONAL) ASSIGN-FORMAT IL:_ (QUOTE ASSIGN-FORMAT-READ-TIME-CONDITIONAL) COMPUTE-FORMAT-VALUES IL:_ (QUOTE CFV-READ-TIME-CONDITIONAL) LINEARIZE IL:_ (QUOTE LINEARIZE-READ-TIME-CONDITIONAL) SUB-NODE-CHANGED IL:_ (QUOTE SUBNODE-CHANGED-READABLE-RTC) COMPUTE-POINT-POSITION IL:_ (QUOTE COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL) COMPUTE-SELECTION-POSITION IL:_ (QUOTE COMPUTE-SELECTION-POSITION-DEFAULT) SET-POINT IL:_ (QUOTE SET-POINT-READ-TIME-CONDITIONAL) SET-SELECTION IL:_ (QUOTE SET-SELECTION-READ-TIME-CONDITIONAL) GROW-SELECTION IL:_ (QUOTE GROW-SELECTION-DEFAULT) INSERT IL:_ (QUOTE INSERT-READ-TIME-CONDITIONAL) DELETE IL:_ (QUOTE DELETE-READ-TIME-CONDITIONAL) COPY-STRUCTURE IL:_ (QUOTE COPY-STRUCTURE-READ-TIME-CONDITIONAL) COPY-SELECTION IL:_ (QUOTE COPY-SELECTION-DEFAULT) STRINGIFY IL:_ (QUOTE STRINGIFY-READ-TIME-CONDITIONAL) BACK-SPACE IL:_ (QUOTE BACKSPACE-READ-TIME-CONDITIONAL))) (QUOTE ((TM::HASH-IL-READABLE NIL NIL PARSE--CONDITIONAL-READ) (TM::HASH-IL-UNREADABLE NIL NIL PARSE--CONDITIONAL-READ))) (QUOTE (("#+" :HASH-PLUS) ("#-" :HASH-MINUS)))) (ADD-NEW-QUOTE-LIKE (IL:SETQ TYPE-UNREADABLE-READ-TIME-CONDITIONAL (IL:|create| EDIT-NODE-TYPE IL:|using| TYPE-ROOT NAME IL:_ (QUOTE UNREADABLE-READ-TIME-CONDITIONAL) ASSIGN-FORMAT IL:_ (QUOTE ASSIGN-FORMAT-READ-TIME-CONDITIONAL) COMPUTE-FORMAT-VALUES IL:_ (QUOTE CFV-READ-TIME-CONDITIONAL) LINEARIZE IL:_ (QUOTE LINEARIZE-READ-TIME-CONDITIONAL) SUB-NODE-CHANGED IL:_ (QUOTE SUBNODE-CHANGED-UNREADABLE-RTC) COMPUTE-POINT-POSITION IL:_ (QUOTE COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL) COMPUTE-SELECTION-POSITION IL:_ (QUOTE COMPUTE-SELECTION-POSITION-DEFAULT) SET-POINT IL:_ (QUOTE SET-POINT-READ-TIME-CONDITIONAL) SET-SELECTION IL:_ (QUOTE SET-SELECTION-READ-TIME-CONDITIONAL) GROW-SELECTION IL:_ (QUOTE GROW-SELECTION-DEFAULT) INSERT IL:_ (QUOTE INSERT-READ-TIME-CONDITIONAL) DELETE IL:_ (QUOTE DELETE-READ-TIME-CONDITIONAL) COPY-STRUCTURE IL:_ (QUOTE COPY-STRUCTURE-READ-TIME-CONDITIONAL) COPY-SELECTION IL:_ (QUOTE COPY-SELECTION-DEFAULT) STRINGIFY IL:_ (QUOTE STRINGIFY-READ-TIME-CONDITIONAL) BACK-SPACE IL:_ (QUOTE BACKSPACE-READ-TIME-CONDITIONAL))) NIL NIL) (IL:* IL:|;;| "And for the final indignity, mung the command table to add a minor flakiness in the handling of + and -") (IL:|for| CP IL:|in| (QUOTE ((#\+ INPUT-PLUS-OR-MINUS) (#\- INPUT-PLUS-OR-MINUS))) IL:|bind| (COMTAB IL:_ (IL:|fetch| (EDIT-ENV COMMAND-TABLE) IL:|of| LISP-EDIT-ENVIRONMENT)) IL:|do| (SETF (GETHASH (CHAR-CODE (FIRST CP)) COMTAB) (IL:BQUOTE ((IL:\\\, (SECOND CP)) NIL (IL:\\\, (FIRST CP))))))) (DEFUN TM::MUNG-SEDIT-READ-TABLE (TM::CONTEXT) (IL:* IL:|;;| "Install a presentation-hacked readtable if the current readtable is IL:COMMONLISP-p and the thing being edited is a definer (and will hence be translated before installation)") (IF (AND (IL:FETCH IL:COMMONLISP IL:OF *READTABLE*) (GET (IL:FETCH EDIT-TYPE IL:OF TM::CONTEXT) :DEFINED-BY)) (LET (TM::NEWTBL) (IF (NULL (SETQ TM::NEWTBL (GETHASH *READTABLE* TM::*SEDIT-READ-TABLES*))) (PROGN (SETQ TM::NEWTBL (COPY-READTABLE *READTABLE*)) (WHEN (IL:FETCH IL:READTBLNAME IL:OF *READTABLE*) (SETF (IL:FETCH IL:READTBLNAME IL:OF TM::NEWTBL) (IL:CONCAT (IL:FETCH IL:READTBLNAME IL:OF *READTABLE*) "-SEDIT"))) (MAPHASH (FUNCTION (LAMBDA (TM::KEY TM::VAL) (IF (CONSP TM::KEY) (PROGN (MAKE-DISPATCH-MACRO-CHARACTER (CAR TM::KEY) T TM::NEWTBL) (SET-DISPATCH-MACRO-CHARACTER (CAR TM::KEY) (CDR TM::KEY) TM::VAL TM::NEWTBL)) (SET-MACRO-CHARACTER TM::KEY T TM::VAL TM::NEWTBL)))) TM::*SEDIT-READ-MACROS*))) (SETQ *READTABLE* TM::NEWTBL)))) (REINSTALL-ADVICE (QUOTE SETUP-PROFILE) :BEFORE (QUOTE ((:LAST (TM::MUNG-SEDIT-READ-TABLE IL:CONTEXT))))) (IL:READVISE SETUP-PROFILE) (DEFVAR TM::*SEDIT-READ-TABLES* (MAKE-HASH-TABLE) "Cache for readtables modified in support of TEXTMODULES") (IL:* IL:|;;| "Temporarily commenting this out for playing-around purposes") (INITIALIZE-COMMONLISP) (IL:PUTPROPS IL:SEDIT-COMMONLISP IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-COMMONLISP IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "SEDIT" :BASE 10)) (IL:PUTPROPS IL:SEDIT-COMMONLISP IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1989 1990 1991)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (3519 7696 (COPY-STRUCTURE-NEW-QUOTE 3532 . 4313) (INPUT-NEW-QUOTE 4315 . 5291) ( PARSE--NEW-QUOTE 5293 . 6195) (REPLACE-NEW-QUOTE 6197 . 7423) (SUBNODE-CHANGED-NEW-QUOTE 7425 . 7694)) (7829 27782 (ASSIGN-FORMAT-READ-TIME-CONDITIONAL 7842 . 8396) (BACKSPACE-READ-TIME-CONDITIONAL 8398 . 9984) (CFV-READ-TIME-CONDITIONAL 9986 . 10685) (COMPUTE-POINT-POSITION-READ-TIME-CONDITIONAL 10687 . 12062) (COPY-STRUCTURE-READ-TIME-CONDITIONAL 12064 . 13274) (CREATE-NEW-READ-TIME-CONDITIONAL 13276 . 14156) (DELETE-READ-TIME-CONDITIONAL 14158 . 15127) (INPUT-CONDITIONAL-READ 15129 . 16043) ( INSERT-READ-TIME-CONDITIONAL 16045 . 16857) (INSERT-FLIPPED-READ-TIME-CONDITIONAL 16859 . 20814) ( LINEARIZE-READ-TIME-CONDITIONAL 20816 . 21450) (PARSE--CONDITIONAL-READ 21452 . 22046) ( REPLACE-READ-TIME-CONDITIONAL 22048 . 22920) (SET-POINT-READ-TIME-CONDITIONAL 22922 . 23952) ( SET-SELECTION-READ-TIME-CONDITIONAL 23954 . 24301) (STRINGIFY-READ-TIME-CONDITIONAL 24303 . 25080) ( SUBNODE-CHANGED-READABLE-RTC 25082 . 26045) (SUBNODE-CHANGED-UNREADABLE-RTC 26047 . 27334) ( UNDO-REPLACE-READ-TIME-CONDITIONAL 27336 . 27780)) (27933 40225 (CONDITIONALIZE-CURRENT-SELECTION 27946 . 28862) (CREATE-NEW-QUOTED-GAP 28864 . 30849) (INITIALIZE-COMMONLISP 30851 . 35286) ( INSERT-NEW-QUOTED-GAP 35288 . 36433) (INSERT-NEW-READ-TIME-CONDITIONAL-GAP 36435 . 37193) ( INPUT-PLUS-OR-MINUS 37195 . 38988) (STRING-FLIP 38990 . 40223))))) IL:STOP \ No newline at end of file diff --git a/library/SKETCH b/library/SKETCH new file mode 100644 index 00000000..d208c223 --- /dev/null +++ b/library/SKETCH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "21-Jan-93 11:59:03" {DSK}lde>lispcore>library>SKETCH.;3 491018 changes to%: (FNS SK.BUILD.IMAGEOBJ) previous date%: "20-Jan-93 14:46:57" {DSK}lde>lispcore>library>SKETCH.;2) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1990, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SKETCHCOMS) (RPAQQ SKETCHCOMS [[DECLARE%: FIRST DOCOPY DONTEVAL@LOAD (P (PROG ((NOTECARDSFLG (GETPROP 'NOTECARDS 'FILEDATES)) (SKETCHFLG (AND (BOUNDP 'ALL.SKETCHES) ALL.SKETCHES)) TEDITFLG) (* ;;  "current knows about SKETCH TEDIT and NOTECARDS. Everyone else loses.") [MAP.PROCESSES (FUNCTION (LAMBDA (PROC PROCNAME PROCFORM) (AND (EQ (CAR PROCFORM) '\TEDIT2) (SETQ TEDITFLG T] (COND ((AND (BOUNDP 'ALL.SKETCHES) (OR SKETCHFLG NOTECARDSFLG TEDITFLG)) (ERROR (CONCAT "Please close" (COND (SKETCHFLG " all open Sketch windows," ) (T "")) (COND (NOTECARDSFLG (CONCAT (COND (SKETCHFLG " and") (T "")) " any open notefiles,")) (T "")) (COND (TEDITFLG (CONCAT (COND ((OR SKETCHFLG NOTECARDSFLG) " and") (T "")) " any TEDIT windows that have sketches in them," )) (T "")) " then type 'RETURN'. To abort loading the new version of Sketch, type '^'."] (FNS SKETCH SKETCH.FROM.A.FILE SKETCHW.CREATE SKETCH.RESET SKETCHW.FIG.CHANGED SK.WINDOW.TITLE EDITSLIDE EDITSKETCH SK.PUT.ON.FILE SK.OUTPUT.FILE.NAME SKETCH.PUT SK.GET.FROM.FILE SK.INCLUDE.FILE SK.GET.IMAGEOBJ.FROM.FILE SKETCH.GET ADD.SKETCH.TO.VIEWER FILENAMELESSVERSION SK.ADD.ELEMENTS.TO.SKETCH SKETCH.SET.A.DEFAULT SK.POPUP.SELECTIONFN GETSKETCHWREGION SK.ADD.ELEMENT SK.ADD.PRIORITY.ELEMENT.TO.SKETCH SK.ELTS.BY.PRIORITY SK.ORDER.ELEMENTS SK.ADD.PRIORITY.LOCAL.ELEMENT.TO.SKETCH SK.ADD.ELEMENTS SK.CHECK.WHENADDEDFN SK.APPLY.MENU.COMMAND SK.DELETE.ELEMENT1 SK.MARK.DIRTY SK.MARK.UNDIRTY SK.MENU.AND.RETURN.FIELD SKETCH.SET.BRUSH.SHAPE SKETCH.SET.BRUSH.SIZE SKETCHW.CLOSEFN SK.CONFIRM.DESTRUCTION SKETCHW.OUTFN SKETCHW.REOPENFN MAKE.LOCAL.SKETCH MAP.SKETCHSPEC.INTO.VIEWER SKETCHW.REPAINTFN SKETCHW.REPAINTFN1 SK.DRAWFIGURE.IF SKETCHW.SCROLLFN SKETCHW.RESHAPEFN SK.UPDATE.EVENT.SELECTION LIGHTGRAYWINDOW SK.ADD.SPACES SK.SKETCH.MENU SK.CHECK.IMAGEOBJ.WHENDELETEDFN SK.APPLY.IMAGEOBJ.WHENDELETEDFN SK.RETURN.TTY SK.TAKE.TTY) (COMS (* ;  "fns for dealing with the sketch menu") (FNS SKETCH.COMMANDMENU SKETCH.COMMANDMENU.ITEMS CREATE.SKETCHW.COMMANDMENU SKETCHW.SELECTIONFN SKETCH.MONITORLOCK SK.EVAL.AS.PROCESS SK.EVAL.WITH.LOCK) (FNS SK.FIX.MENU SK.SET.UP.MENUS SK.INSURE.HAS.MENU SK.CREATE.STANDARD.MENU SK.ADD.ITEM.TO.MENU SK.GET.VIEWER.POPUP.MENU SK.CLEAR.POPUP.MENU)) (COMS (* ;  "fns for dealing with sketch structures") (FNS SKETCH.CREATE GETSKETCHPROP PUTSKETCHPROP CREATE.DEFAULT.SKETCH.CONTEXT) (PROP ARGNAMES SKETCH.CREATE)) (COMS (* ;  "fns for implementing copy and delete functions under keyboard control.") (FNS SK.COPY.BUTTONEVENTFN SK.BUTTONEVENT.MARK SK.BUILD.IMAGEOBJ SK.BUTTONEVENT.OVERP SK.BUTTONEVENT.SAME.KEYS) (MACROS .DELETEKEYDOWNP. .MOVEKEYDOWNP.)) (COMS (* ;  "fns for implementing the CHANGE command.") (FNS SK.SEL.AND.CHANGE SK.CHECK.WHENCHANGEDFN SK.CHECK.PRECHANGEFN SK.CHANGE.ELT SK.CHANGE.THING SKETCH.CHANGE.ELEMENTS SK.APPLY.SINGLE.CHANGEFN SK.DO.CHANGESPECS SK.VIEWER.FROM.SKETCH.ARG SK.DO.CHANGESPEC1 SK.CHANGEFN SK.READCHANGEFN SK.DEFAULT.CHANGEFN CHANGEABLEFIELDITEMS SK.APPLY.CHANGE.COMMAND SK.DO.AND.RECORD.CHANGES SK.APPLY.CHANGE.COMMAND1 SK.ELEMENTS.CHANGEFN READ.POINT.TO.ADD GLOBAL.KNOT.FROM.LOCAL SK.ADD.KNOT.TO.ELEMENT SK.GROUP.CHANGEFN SK.GROUP.CHANGEFN1) (DECLARE%: DONTCOPY (RECORDS SKHISTORYCHANGESPEC))) (COMS (* ; "fns for adding elements") (FNS ADD.ELEMENT.TO.SKETCH ADD.SKETCH.VIEWER REMOVE.SKETCH.VIEWER ALL.SKETCH.VIEWERS SKETCH.ALL.VIEWERS VIEWER.BUCKET ELT.INSIDE.REGION? ELT.INSIDE.SKWP SCALE.FROM.SKW SK.ADDELT.TO.WINDOW SK.CALC.REGION.VIEWED SK.DRAWFIGURE SK.DRAWFIGURE1 SK.LOCAL.FROM.GLOBAL SKETCH.REGION.VIEWED SKETCH.VIEW.FROM.NAME SK.UPDATE.REGION.VIEWED SKETCH.ADD.AND.DISPLAY SKETCH.ADD.AND.DISPLAY1 SK.ADD.ITEM SKETCHW.ADD.INSTANCE)) (* ; "fns for deleting things") (FNS SK.SEL.AND.DELETE SK.ERASE.AND.DELETE.ITEM REMOVE.ELEMENT.FROM.SKETCH SK.DELETE.ELEMENT SK.DELETE.ELEMENT2 SK.DELETE.KNOT SK.SEL.AND.DELETE.KNOT SK.DELETE.ELEMENT.KNOT SK.CHECK.WHENDELETEDFN SK.CHECK.PREEDITFN SK.CHECK.END.INITIAL.EDIT SK.CHECK.WHENPOINTDELETEDFN SK.ERASE.ELT SK.DELETE.ELT SK.DELETE.ITEM DELFROMTCONC) (* ; "fns for copying stuff") (FNS SK.COPY.ELT SK.SEL.AND.COPY SK.COPY.ELEMENTS SK.ADD.COPY.OF.ELEMENTS SK.GLOBAL.FROM.LOCAL.ELEMENTS SK.COPY.ITEM SK.INSERT.SKETCH) (COMS (* ; "fns for moving things.") (FNS SK.MOVE.ELT SK.MOVE.ELT.OR.PT SK.APPLY.DEFAULT.MOVE SK.SEL.AND.MOVE SK.MOVE.ELEMENTS SKETCH.MOVE.ELEMENTS SKETCH.COPY.ELEMENTS \SKETCH.COPY.ELEMENT SK.TRANSLATE.ELEMENT SK.COPY.GLOBAL.ELEMENT SK.MAKE.ELEMENT.MOVE.ARG SK.MAKE.ELEMENTS.MOVE.ARG SK.MAKE.POINTS.AND.ELEMENTS.MOVE.ARG SK.SHOW.FIG.FROM.INFO SK.MOVE.THING UPDATE.ELEMENT.IN.SKETCH SK.UPDATE.ELEMENT SK.UPDATE.ELEMENTS SK.UPDATE.ELEMENT1 SK.MOVE.ELEMENT.POINT) (* ;  "fns for moving points or a collection of pts.") (FNS SK.MOVE.POINTS SK.SEL.AND.MOVE.POINTS SK.DO.MOVE.ELEMENT.POINTS SK.MOVE.ITEM.POINTS SK.TRANSLATEPTSFN SK.TRANSLATE.POINTS SK.SELECT.MULTIPLE.POINTS SK.CONTROL.POINTS.IN.REGION SK.ADD.PT.SELECTION SK.REMOVE.PT.SELECTION SK.ADD.POINT SK.ELTS.CONTAINING.PTS SK.HOTSPOTS.NOT.ON.LIST ) (MACROS .SHIFTKEYDOWNP.) (FNS SK.SET.MOVE.MODE SK.SET.MOVE.MODE.POINTS SK.SET.MOVE.MODE.ELEMENTS SK.SET.MOVE.MODE.COMBINED READMOVEMODE) (FNS SK.ALIGN.POINTS SK.SEL.AND.ALIGN.POINTS SK.ALIGN.POINTS.LEFT SK.ALIGN.POINTS.RIGHT SK.ALIGN.POINTS.TOP SK.ALIGN.POINTS.BOTTOM SK.EVEN.SPACE.POINTS.IN.X SK.EVEN.SPACE.POINTS.IN.Y SK.DO.ALIGN.POINTS SK.NTH.CONTROL.POINT SK.GET.SELECTED.ELEMENT.STRUCTURE SK.CORRESPONDING.CONTROL.PT SK.CONTROL.POINT.NUMBER SK.DO.ALIGN.SETVALUE)) (COMS (* ;  "stuff for supporting the GROUP sketch element.") (FNS SKETCH.CREATE.GROUP SK.CREATE.GROUP1 SK.UPDATE.GROUP.AFTER.CHANGE SK.GROUP.ELTS SK.SEL.AND.GROUP SK.GROUP.ELEMENTS SK.UNGROUP.ELT SK.SEL.AND.UNGROUP SK.UNGROUP.ELEMENT SK.GLOBAL.REGION.OF.LOCAL.ELEMENTS SK.LOCAL.REGION.OF.LOCAL.ELEMENTS SK.GLOBAL.REGION.OF.GLOBAL.ELEMENTS SK.UNIONREGIONS SKETCH.REGION.OF.SKETCH SK.FLASHREGION) (FNS INIT.GROUP.ELEMENT GROUP.DRAWFN GROUP.EXPANDFN GROUP.INSIDEFN GROUP.REGIONFN GROUP.GLOBALREGIONFN GROUP.TRANSLATEFN GROUP.TRANSFORMFN GROUP.READCHANGEFN) (FNS REGION.CENTER REMOVE.LAST) (* ;  "moving the control point of a group") (FNS SK.MOVE.GROUP.CONTROL.PT SK.SEL.AND.MOVE.CONTROL.PT SK.MOVE.GROUP.ELEMENT.CONTROL.POINT SK.READ.NEW.GROUP.CONTROL.PT) (RECORDS GROUP LOCALGROUP) (COMS (* ;  "history and undo stuff for groups") (FNS SK.DO.GROUP SK.CHECK.WHENGROUPEDFN SK.DO.UNGROUP SK.CHECK.WHENUNGROUPEDFN SK.GROUP.UNDO SK.UNGROUP.UNDO) (IFPROP EVENTFNS GROUP UNGROUP))) (COMS (* ;  "stuff for supporting the freezing of elements") (FNS SK.FREEZE.ELTS SK.SEL.AND.FREEZE SK.FREEZE.ELEMENTS SK.UNFREEZE.ELT SK.SEL.AND.UNFREEZE SK.UNFREEZE.ELEMENTS SK.FREEZE.UNDO SK.UNFREEZE.UNDO SK.DO.FREEZE SK.DO.UNFREEZE) (IFPROP EVENTFNS FREEZE UNFREEZE)) (COMS (* ; "programmer interface entries") (FNS SKETCH.ELEMENTS.OF.SKETCH SKETCH.LIST.OF.ELEMENTS SKETCH.ADD.ELEMENT SKETCH.DELETE.ELEMENT DELFROMGROUPELT SKETCH.ELEMENT.TYPE SKETCH.ELEMENT.CHANGED SK.ELEMENT.CHANGED1 SK.UPDATE.GLOBAL.IMAGE.OBJECT.ELEMENT)) (* ;  "utility routines for sketch windows.") (FNS INSURE.SKETCH LOCALSPECS.FROM.VIEWER SK.LOCAL.ELT.FROM.GLOBALPART SKETCH.FROM.VIEWER INSPECT.SKETCH ELT.INSIDE.SKETCHWP SK.INSIDE.REGION) (FNS MAPSKETCHSPECS MAPCOLLECTSKETCHSPECS MAPSKETCHSPECSUNTIL MAPGLOBALSKETCHSPECS MAPGLOBALSKETCHELEMENTS) (COMS (* ;  "multiple selection and copy select functions") (FNS SK.ADD.SELECTION SK.COPY.INSERTFN SCREENELEMENTP SK.ITEM.REGION SK.ELEMENT.GLOBAL.REGION SK.LOCAL.ITEMS.IN.REGION SK.REGIONFN SK.GLOBAL.REGIONFN SK.REMOVE.SELECTION SK.SELECT.MULTIPLE.ITEMS SKETCH.GET.ELEMENTS SK.PUT.MARKS.UP SK.TAKE.MARKS.DOWN SK.TRANSLATE.GLOBALPART SK.TRANSLATE.ITEM SK.TRANSLATEFN TRANSLATE.SKETCH) (CONSTANTS (SK.NO.MOVE.DISTANCE 4)) (DECLARE%: DONTCOPY (RECORDS SKFIGUREIMAGE))) (COMS (* ;  "stuff for changing the input scale") (FNS SK.INPUT.SCALE SK.UPDATE.SKETCHCONTEXT SK.SET.INPUT.SCALE SK.SET.INPUT.SCALE.CURRENT SK.SET.INPUT.SCALE.VALUE)) (COMS (* ;  "stuff for setting feedback amount") (FNS SK.SET.FEEDBACK.MODE SK.SET.FEEDBACK.POINT SK.SET.FEEDBACK.VERBOSE SK.SET.FEEDBACK.ALWAYS) (INITVARS (SKETCH.VERBOSE.FEEDBACK T)) (GLOBALVARS SKETCH.VERBOSE.FEEDBACK)) (COMS (* ; "sketch icon support") (FNS SKETCH.TITLE SK.SHRINK.ICONCREATE) (UGLYVARS SKETCH.TITLED.ICON.TEMPLATE)) (COMS (* ;  "fns for reading in various values") (FNS READBRUSHSHAPE READ.FUNCTION READBRUSHSIZE READANGLE READARCDIRECTION) (FNS SK.CHANGE.DASHING READ.AND.SAVE.NEW.DASHING READ.NEW.DASHING READ.DASHING.CHANGE SK.CACHE.DASHING SK.DASHING.LABEL) (FNS READ.FILLING.CHANGE SK.CACHE.FILLING READ.AND.SAVE.NEW.FILLING SK.FILLING.LABEL) (INITVARS (SK.DASHING.PATTERNS) (SK.FILLING.PATTERNS)) (GLOBALVARS SK.DASHING.PATTERNS SK.FILLING.PATTERNS) (P (SK.CACHE.DASHING '(2 4)) (SK.CACHE.DASHING '(6 3 1 3)) (SK.CACHE.FILLING BLACKSHADE) (SK.CACHE.FILLING GRAYSHADE) (SK.CACHE.FILLING HIGHLIGHTSHADE))) (COMS (* ;  "stuff for reading input positions") (FNS SK.GETGLOBALPOSITION SKETCH.TRACK.ELEMENTS SK.PICKOUT.WHOLE.MOVE.ELEMENTS MAP.SKETCH.ELEMENTS.INTO.VIEWER MAP.GLOBAL.POSITION.INTO.VIEWER SKETCH.TO.VIEWER.POSITION SKETCH.TRACK.IMAGE SK.TRACK.IMAGE1 MAP.VIEWER.XY.INTO.GLOBAL SK.SET.POSITION MAP.VIEWER.PT.INTO.GLOBAL VIEWER.TO.SKETCH.POSITION SK.INSURE.SCALE SKETCH.TO.VIEWER.REGION VIEWER.TO.SKETCH.REGION SK.READ.POINT.WITH.FEEDBACK SKETCH.GET.POSITION \CLOBBER.POSITION NEAREST.HOT.SPOT GETWREGION GET.BITMAP.POSITION SK.TRACK.BITMAP1 ) (RECORDS INPUTPT) (COMS (* ;  "stuff to allow reading positions from a number pad") (INITVARS (SKETCH.USE.POSITION.PAD NIL)) (GLOBALVARS SKETCH.USE.POSITION.PAD) (FNS SK.BRING.UP.POSITION.PAD SK.PAD.READER.POSITION SK.POSITION.READER.REPAINTFN SK.POSITION.PAD.FROM.VIEWER SK.INIT.POSITION.NUMBER.PAD.MENU SK.READ.POSITION.PAD.HANDLER DISPLAY.POSITION.READER.TOTAL POSITION.PAD.READER.HANDLER POSITIONPAD.HELDFN \POSITION.PAD.ADD.DIGIT.MENU \POSITION.READER.NUMBERPAD))) (INITVARS (ALL.SKETCHES) (INITIAL.SCALE 1.0) (DEFAULT.VISIBLE.SCALE.FACTOR 10.0) (MINIMUM.VISIBLE.SCALE.FACTOR 4.0)) (VARS (SKETCH.ELEMENT.TYPES) (SKETCH.ELEMENT.TYPE.NAMES)) (GLOBALVARS ALL.SKETCHES INITIAL.SCALE DEFAULT.VISIBLE.SCALE.FACTOR MINIMUM.VISIBLE.SCALE.FACTOR SKETCH.ELEMENT.TYPES SKETCH.ELEMENT.TYPE.NAMES SK.SELECTEDMARK SK.LOCATEMARK COPYSELECTIONMARK MOVESELECTIONMARK DELETESELECTIONMARK) (UGLYVARS SK.SELECTEDMARK SK.LOCATEMARK COPYSELECTIONMARK MOVESELECTIONMARK DELETESELECTIONMARK OTHERCONTROLPOINTMARK) (* ;  "accessing functions for the methods of a sketch type.") (FNS SK.DRAWFN SK.TRANSFORMFN SK.EXPANDFN SK.INPUT SK.INSIDEFN SK.UPDATEFN) (INITRECORDS SKETCHTYPE) (DECLARE%: DONTCOPY (RECORDS SCREENELT GLOBALPART COMMONGLOBALPART INDIVIDUALGLOBALPART LOCALPART SKETCH SKETCHTYPE SKETCHCONTEXT)) [ADDVARS (BackgroundMenuCommands (Sketch '(SKETCHW.CREATE NIL NIL (GETREGION) NIL NIL T T) "Opens a sketch window for use." (SUBITEMS ("Page sized sketch" '(EDITSLIDE NIL) "Opens a sketch window the size of a page." ) ("Landscaped sketch" '(EDITSLIDE NIL T) "Opens a sketch window the size of a landscaped page." ) ("Sketch, from a file" '(SKETCH.FROM.A.FILE) "Reads a file name and opens a sketch window onto the sketch it contains." ] (VARS (BackgroundMenu)) (FILES SKETCHOPS SKETCHELEMENTS SKETCHEDIT SKETCHOBJ SKETCHBMELT) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILES (LOADCOMP) SKETCHOPS SKETCHELEMENTS SKETCHOBJ SKETCHEDIT)) (* ;  "recompute the sketch element types because loading SKETCH clobbers the previous ones.") (P (INIT.BITMAP.ELEMENT) (INIT.SKETCH.ELEMENTS) (INIT.GROUP.ELEMENT)) (COMS (* ; "version checking stuff") (CONSTANTS (SKETCH.VERSION 3)) (FNS SK.CHECK.SKETCH.VERSION SK.INSURE.RECORD.LENGTH SK.INSURE.HAS.LENGTH SK.RECORD.LENGTH SK.SET.RECORD.LENGTHS) (MACROS SK.SET.RECORD.LENGTHS.MACRO) (GLOBALVARS SKETCH.RECORD.LENGTHS) (P (SK.SET.RECORD.LENGTHS))) [COMS (* ;  "to correct for a bug in the file package that marks LOADCOMPed file as changed") (P (UNMARKASCHANGED 'SKETCH 'FILE) (UNMARKASCHANGED 'SKETCHELEMENTS 'FILE) (UNMARKASCHANGED 'SKETCHOPS 'FILE) (UNMARKASCHANGED 'SKETCHEDIT 'FILE) (UNMARKASCHANGED 'SKETCHOBJ 'FILE] (COMS (* ;  "add sketch as option to file browser edit command") (FNS SK.ADD.EDIT.COMMAND.TO.FILE.BROWSER) (P (SK.ADD.EDIT.COMMAND.TO.FILE.BROWSER))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA SK.UNIONREGIONS SKETCH.CREATE]) (DECLARE%: FIRST DOCOPY DONTEVAL@LOAD [PROG ((NOTECARDSFLG (GETPROP 'NOTECARDS 'FILEDATES)) (SKETCHFLG (AND (BOUNDP 'ALL.SKETCHES) ALL.SKETCHES)) TEDITFLG) (* ;; "current knows about SKETCH TEDIT and NOTECARDS. Everyone else loses.") [MAP.PROCESSES (FUNCTION (LAMBDA (PROC PROCNAME PROCFORM) (AND (EQ (CAR PROCFORM) '\TEDIT2) (SETQ TEDITFLG T] (COND ((AND (BOUNDP 'ALL.SKETCHES) (OR SKETCHFLG NOTECARDSFLG TEDITFLG)) (ERROR (CONCAT "Please close" (COND (SKETCHFLG " all open Sketch windows,") (T "")) (COND (NOTECARDSFLG (CONCAT (COND (SKETCHFLG " and") (T "")) " any open notefiles,")) (T "")) (COND (TEDITFLG (CONCAT (COND ((OR SKETCHFLG NOTECARDSFLG) " and") (T "")) " any TEDIT windows that have sketches in them,")) (T "")) " then type 'RETURN'. To abort loading the new version of Sketch, type '^'."] ) (DEFINEQ (SKETCH [LAMBDA (SKETCH WINDOW) (* rrb "17-Sep-86 10:21") (* opens a sketch window onto the  sketch SKETCH) (COND [(AND SKETCH (LITATOM SKETCH)) (* assume its a filename Get the region and scale from the file.) (PROG ((SKIMAGEOBJ (SK.GET.IMAGEOBJ.FROM.FILE SKETCH)) SCREENREG READSKETCH) (SETQ SCREENREG (SK.SCALE.REGION (fetch (SKETCHIMAGEOBJ SKIO.REGION) of SKIMAGEOBJ) (fetch (SKETCHIMAGEOBJ SKIO.SCALE) of SKIMAGEOBJ))) (SETQ READSKETCH (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of SKIMAGEOBJ)) (RETURN (SKETCHW.CREATE READSKETCH (fetch (SKETCHIMAGEOBJ SKIO.REGION) of SKIMAGEOBJ) (OR WINDOW (GETBOXREGION (MIN (WIDTHIFWINDOW (fetch (REGION WIDTH) of SCREENREG)) (DIFFERENCE (BITMAPWIDTH (SCREENBITMAP)) 16)) (MIN (HEIGHTIFWINDOW (fetch (REGION HEIGHT) of SCREENREG) T) (DIFFERENCE SCREENHEIGHT 16)) NIL NIL NIL "Position sketch window.")) (fetch (SKETCH SKETCHNAME) of READSKETCH) (fetch (SKETCHIMAGEOBJ SKIO.SCALE) of SKIMAGEOBJ) T (fetch (SKETCHIMAGEOBJ SKIO.GRID) of SKIMAGEOBJ] (T (SKETCHW.CREATE SKETCH NIL (OR WINDOW (GETREGION)) NIL NIL T T]) (SKETCH.FROM.A.FILE [LAMBDA NIL (* rrb "24-Jun-86 11:40") (* reads a file name from the user and calls sketch on it.) (PROG ((NAME (PopUpWindowAndGetAtom "Sketch file name: "))) (RETURN (AND NAME (SKETCH NAME]) (SKETCHW.CREATE (LAMBDA (SKETCH SKETCHREGION SCREENREGION TITLE INITIALSCALE BRINGUPMENU INITIALGRID) (* ; "Edited 25-Apr-88 15:18 by drc:") (* ;;; "creates a sketch window and returns it.") (PROG (W SCALE SKPROC SKETCHSTRUCTURE) (SETQ SKETCHSTRUCTURE (SK.CHECK.SKETCH.VERSION (COND ((NULL SKETCH) (SKETCH.CREATE NIL)) ((LITATOM SKETCH) (* ; "treat it like a file name") (SKETCH.GET SKETCH)) ((type? SKETCH SKETCH) SKETCH) ((type? IMAGEOBJ SKETCH) (* ; "pull things out of the image object.") (SETQ SKPROC (IMAGEOBJPROP SKETCH (QUOTE OBJECTDATUM))) (OR (REGIONP SKETCHREGION) (SETQ SKETCHREGION (fetch (SKETCHIMAGEOBJ SKIO.REGION) of SKPROC))) (OR (NUMBERP INITIALSCALE) (SETQ INITIALSCALE (fetch (SKETCHIMAGEOBJ SKIO.SCALE) of SKPROC))) (OR (NUMBERP INITIALGRID) (SETQ INITIALGRID (fetch (SKETCHIMAGEOBJ SKIO.GRID) of SKPROC))) (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of SKPROC)) ((AND (LITATOM (CAR SKETCH)) (for ELT in (CDR SKETCH) always (GLOBALELEMENTP ELT))) (* ; "old form, probably written out by notecards, update to new form.") (PROG (X) (SETQ X (SKIO.UPDATE.FROM.OLD.FORM SKETCH)) (* ; "smash sketch so this won't have to happen every time.") (RPLACA SKETCH (CAR X)) (RPLACD SKETCH (CDR X)) (RETURN X))) (T (\ILLEGAL.ARG SKETCH))))) (SETQ W (COND ((WINDOWP SCREENREGION) (AND TITLE (WINDOWPROP SCREENREGION (QUOTE TITLE) TITLE)) SCREENREGION) (T (CREATEW (COND ((REGIONP SCREENREGION)) (T (CREATEREGION LASTMOUSEX LASTMOUSEY 20 20))) (OR TITLE (SK.WINDOW.TITLE SKETCHSTRUCTURE)) NIL T)))) (SK.SET.UP.MENUS W (NOT (OPENWP SCREENREGION)) BRINGUPMENU) (COND ((OR (REGIONP SCREENREGION) (WINDOWP SCREENREGION)) (* ; "user gave a region, don't interact") NIL) (T (* ; "let prompting for reshape show room for both menu and window.") (SHAPEW W))) (* ;; "set the right margin so that text will never run into it. This can be removed when character positions are kept in points so \DSPPRINTCHAR doesn't have to look at the right margin.") (DSPRIGHTMARGIN 64000 W) (WINDOWPROP W (QUOTE SKETCH) SKETCHSTRUCTURE) (WINDOWPROP W (QUOTE SCALE) (SETQ SCALE (COND ((NUMBERP INITIALSCALE)) ((REGIONP SKETCHREGION) (* ; "determine the scale and offsets so that the given region of the sketch fits into the given window.") (FQUOTIENT (fetch (REGION HEIGHT) of SKETCHREGION) (fetch (REGION HEIGHT) of (DSPCLIPPINGREGION NIL W)))) ((NULL SKETCHREGION) INITIAL.SCALE) (T (\ILLEGAL.ARG SKETCHREGION))))) (* ; "check to make sure a context exists on the sketch because before July 1985 it didn't exist.") (WINDOWPROP W (QUOTE SKETCHCONTEXT) (OR (GETSKETCHPROP SKETCHSTRUCTURE (QUOTE SKETCHCONTEXT)) (PUTSKETCHPROP SKETCHSTRUCTURE (QUOTE SKETCHCONTEXT) (CREATE.DEFAULT.SKETCH.CONTEXT)))) (COND ((REGIONP SKETCHREGION) (* ; "if given a region, translate to it.") (WXOFFSET (IMINUS (FIX (QUOTIENT (fetch (REGION LEFT) of SKETCHREGION) SCALE))) W) (WYOFFSET (IMINUS (FIX (QUOTIENT (fetch (REGION BOTTOM) of SKETCHREGION) SCALE))) W))) (SK.UPDATE.REGION.VIEWED W) (* ; "calculate the sketch region being viewed before mapping the sketch into it.") (MAP.SKETCHSPEC.INTO.VIEWER SKETCHSTRUCTURE W) (SK.CREATE.HOTSPOT.CACHE W) (WINDOWPROP W (QUOTE GRIDFACTOR) (COND ((NUMBERP INITIALGRID) (LEASTPOWEROF2GT INITIALGRID)) (T (SK.DEFAULT.GRIDFACTOR W)))) (WINDOWPROP W (QUOTE USEGRID) (COND (INITIALGRID T))) (WINDOWPROP W (QUOTE BUTTONEVENTFN) (FUNCTION WB.BUTTON.HANDLER)) (WINDOWPROP W (QUOTE COPYBUTTONEVENTFN) (FUNCTION SK.COPY.BUTTONEVENTFN)) (WINDOWPROP W (QUOTE COPYINSERTFN) (FUNCTION SK.COPY.INSERTFN)) (WINDOWPROP W (QUOTE RIGHTBUTTONFN) (FUNCTION WB.BUTTON.HANDLER)) (WINDOWPROP W (QUOTE CURSOROUTFN) (FUNCTION SKETCHW.OUTFN)) (WINDOWPROP W (QUOTE REPAINTFN) (FUNCTION SKETCHW.REPAINTFN)) (WINDOWADDPROP W (QUOTE RESHAPEFN) (FUNCTION SKETCHW.RESHAPEFN)) (WINDOWADDPROP W (QUOTE SHRINKFN) (FUNCTION SK.RETURN.TTY)) (WINDOWPROP W (QUOTE ICONFN) (FUNCTION SK.SHRINK.ICONCREATE)) (WINDOWADDPROP W (QUOTE EXPANDFN) (FUNCTION SK.TAKE.TTY)) (WINDOWPROP W (QUOTE SCROLLFN) (FUNCTION SKETCHW.SCROLLFN)) (WINDOWPROP W (QUOTE HARDCOPYFN) (FUNCTION SKETCHW.HARDCOPYFN)) (* ; "I'm not sure why this ever gets called but it did once so to be sure, turn it off.") (WINDOWPROP W (QUOTE PAGEFULLFN) (FUNCTION NILL)) (WINDOWPROP W (QUOTE PROCESS) (SETQ SKPROC (ADD.PROCESS (LIST (FUNCTION WB.EDITOR) (KWOTE W)) (QUOTE RESTARTABLE) T (QUOTE TTYENTRYFN) (QUOTE SK.TTYENTRYFN) (QUOTE TTYEXITFN) (QUOTE SK.TTYEXITFN)))) (WINDOWPROP W (QUOTE SCROLLEXTENTUSE) T) (WINDOWADDPROP W (QUOTE CLOSEFN) (FUNCTION SKETCHW.CLOSEFN) T) (OPENW W) (ADD.SKETCH.VIEWER SKETCHSTRUCTURE W) (SKETCHW.REPAINTFN W) (RETURN W))) ) (SKETCH.RESET [LAMBDA (SKETCH) (* rrb "11-Dec-85 11:24") (* resets a sketch structure and all of the viewers onto it.) (PROG ((SKSTRUC (INSURE.SKETCH SKETCH))) (* delete all sketch elements) (replace (SKETCH SKETCHTCELL) of SKSTRUC with (CONS)) (for VIEWER in (ALL.SKETCH.VIEWERS SKSTRUC) do (SKED.CLEAR.SELECTION VIEWER) (DSPRESET VIEWER) (WINDOWPROP VIEWER 'SCALE INITIAL.SCALE) (SK.UPDATE.REGION.VIEWED VIEWER) (MAP.SKETCHSPEC.INTO.VIEWER SKSTRUC VIEWER) (SK.CREATE.HOTSPOT.CACHE VIEWER) (WINDOWPROP VIEWER 'GRIDFACTOR ( SK.DEFAULT.GRIDFACTOR VIEWER)) (WINDOWPROP VIEWER 'USEGRID NIL) (WINDOWPROP VIEWER 'SKETCHHISTORY NIL) (WINDOWPROP VIEWER 'SKETCHCHANGED NIL]) (SKETCHW.FIG.CHANGED [LAMBDA (W) (* rrb "29-Nov-84 17:59") (* W is a sketch window that is being reshaped.  Mark this fact in case it came out of a document.) (OR (WINDOWPROP W 'SKETCHCHANGED) (WINDOWPROP W 'SKETCHCHANGED 'OLD]) (SK.WINDOW.TITLE [LAMBDA (SKETCH) (* rrb " 7-May-85 14:00") (* returns the window title of a window onto a sketch.) (COND ((fetch (SKETCH SKETCHNAME) of SKETCH) (CONCAT "Viewer onto " (fetch (SKETCH SKETCHNAME) of SKETCH))) (T "Viewer onto a sketch"]) (EDITSLIDE [LAMBDA (SKETCH LANDSCAPE) (* ; "Edited 20-Feb-87 10:44 by rrb") (* creates a sketch in a window the size of a screen.) (SKETCHW.CREATE SKETCH NIL (COND (LANDSCAPE (GETBOXREGION 780 612)) (T (GETBOXREGION 612 770))) NIL NIL T 16.0]) (EDITSKETCH [LAMBDA (SLIDENAME) (* rrb "14-Nov-84 17:15") (* edits a named sketch) (SKETCHW.CREATE (SETQ SLIDENAME (OR SLIDENAME (GENSYM "SLIDE"))) NIL NIL NIL NIL T 16.0) SLIDENAME]) (SK.PUT.ON.FILE [LAMBDA (SKETCHW) (* ; "Edited 6-Apr-87 18:18 by rrb") (* saves a sketch on a Tedit file.) (* also changes the name of the sketch to be the same as the name of the file.) (PROG ((SKETCH (INSURE.SKETCH (SKETCH.FROM.VIEWER SKETCHW))) NOWNAME NEWNAME TEXTSTREAM) (SETQ NOWNAME (SKETCH.TITLE SKETCH)) (OR [SETQ NEWNAME (MKATOM (PROMPT.GETINPUT SKETCHW "File to PUT to: " (SK.OUTPUT.FILE.NAME NOWNAME] (RETURN NIL)) (SETQ NEWNAME (SKETCH.PUT NEWNAME SKETCH SKETCHW)) [COND ((AND NEWNAME (NEQ NOWNAME NEWNAME)) (* change the name of the sketch to be the same as the file name.) (replace (SKETCH SKETCHNAME) of SKETCH with NEWNAME) (* change the titles of the viewers  onto this sketch.) (for SKW in (ALL.SKETCH.VIEWERS SKETCH) do (WINDOWPROP SKW 'TITLE (SK.WINDOW.TITLE SKETCH] (RETURN NEWNAME]) (SK.OUTPUT.FILE.NAME [LAMBDA (SKETCHFILENAME) (* rrb " 5-May-86 10:45") (COND ((STRPOS " " SKETCHFILENAME) (* don't put up dummy names that  contain spaces) NIL) (T (FILENAMELESSVERSION SKETCHFILENAME]) (SKETCH.PUT [LAMBDA (FILENAME SKETCH VIEWER REGION SCALE GRID) (* ; "Edited 17-Nov-87 17:47 by rrb") (* puts the sketch SKETCH on the file named FILENAME.  VIEWER if given provides promptwindows and PUTFNs.) (PROG (TEXTSTREAM FILESTREAM) [COND ((NOT (DEFINEDP (FUNCTION OPENTEXTSTREAM))) (COND ((MOUSECONFIRM "TEDIT must be loaded to save sketches." "Click LEFT to load TEDIT now, RIGHT to abort.") (FILESLOAD TEDIT)) (T (STATUSPRINT VIEWER "Sketch not saved.") (RETURN NIL] [SETQ TEXTSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (AND VIEWER (LIST 'PUTFN (WINDOWPROP VIEWER 'TEDIT.PUTFN) 'PROMPTWINDOW (GETPROMPTWINDOW VIEWER] (* make a text stream with nothing in it except the sketch.) (TEDIT.INSERT.OBJECT [SKETCH.IMAGEOBJ (INSURE.SKETCH SKETCH) (COND ((REGIONP REGION)) (VIEWER (SKETCH.REGION.VIEWED VIEWER))) (COND ((NUMBERP SCALE)) (VIEWER (VIEWER.SCALE VIEWER))) (COND ((NUMBERP GRID)) (VIEWER (SK.GRIDFACTOR VIEWER] TEXTSTREAM 1) (* set the margins so that if the user hardcopies it directly the margins  come out) (TEDIT.PARALOOKS TEXTSTREAM '(LEFTMARGIN 0 RIGHTMARGIN 0 QUAD CENTER) 1 1) (TEDIT.PAGEFORMAT TEXTSTREAM (TEDIT.SINGLE.PAGEFORMAT NIL NIL NIL NIL NIL 0 0 0 0)) (* save the stream so that it can be  closed.) (SETQ FILESTREAM (TEDIT.PUT TEXTSTREAM FILENAME)) (* grab the full file name if it is  available.) (AND (OPENP FILESTREAM) (SETQ FILENAME (CLOSEF FILESTREAM))) (SK.MARK.UNDIRTY SKETCH) (RETURN FILENAME]) (SK.GET.FROM.FILE [LAMBDA (SKETCHW) (* rrb " 1-Oct-86 18:24") (* retrieves a sketch from a file clobbering any existing sketch.) (COND ((SK.CONFIRM.DESTRUCTION SKETCHW "Press LEFT to delete current elements before GET.") (* put the delete on the history list so that it can be undone.  This leaves the gotten file there as well but seems better than nothing.) (SK.DELETE.ELEMENT2 (fetch (SKETCH SKETCHELTS) of (INSURE.SKETCH SKETCHW)) SKETCHW) (SK.INCLUDE.FILE SKETCHW)) ((SK.CONFIRM.DESTRUCTION SKETCHW "Press LEFT to include file, RIGHT to abort the GET.") (SK.INCLUDE.FILE SKETCHW)) (T (STATUSPRINT SKETCHW "GET aborted. The INCLUDE subcommand to GET doesn't delete."]) (SK.INCLUDE.FILE [LAMBDA (SKETCHW) (* rrb " 2-May-86 11:29") (* retrieves a sketch from a file and includes it into the existing sketch.) (* also changes the name of the sketch to be the same as the name of the file.) (PROG ((SKETCH (SKETCH.FROM.VIEWER SKETCHW)) NOWNAME FILENAME READSKETCH DIRTYSTATUS) (SETQ NOWNAME (fetch (SKETCH SKETCHNAME) of SKETCH)) (SETQ FILENAME (MKATOM (PROMPT.GETINPUT SKETCHW "File to GET: "))) (COND ((MEMB FILENAME '(NIL %])) (CLOSEPROMPTWINDOW SKETCHW) (RETURN))) (STATUSPRINT SKETCHW " ...") (SETQ FILENAME (OR (INFILEP FILENAME) (ERROR FILENAME "file not found."))) (OR (SETQ READSKETCH (SKETCH.GET FILENAME SKETCHW)) (RETURN)) [COND ((NEQ NOWNAME FILENAME) (* change the name of the sketch to be the same as the file name.) (replace (SKETCH SKETCHNAME) of SKETCH with FILENAME) (* change the name of the sketch to be the same as the file name.) (for SKW in (ALL.SKETCH.VIEWERS SKETCH) do (WINDOWPROP SKW 'TITLE (SK.WINDOW.TITLE SKETCH] (ADD.SKETCH.TO.VIEWER READSKETCH SKETCHW (COND ((fetch (SKETCH SKETCHELTS) of SKETCH) (* if the sketch has elements, ask about the defaults from the read file and  set the status to leave the sketch marked dirty after the read.) (SETQ DIRTYSTATUS T) 'ASK) (T (* if the sketch doesn't have any elements, use the defaults from the read file  and set the status to leave the sketch marked clean after the read.) NIL))) (COND ((NULL DIRTYSTATUS) (* if sketch was empty before, mark it as not needing to be dumped.) (SK.MARK.UNDIRTY SKETCH))) (STATUSPRINT SKETCHW " done."]) (SK.GET.IMAGEOBJ.FROM.FILE [LAMBDA (FILENAME VIEWER) (* ; "Edited 12-Feb-88 14:13 by rrb") (* reads the sketch image object  datum from a file.) (RESETFORM (CURSOR WAITINGCURSOR) (PROG ([TEXTSTREAM (OPENTEXTSTREAM FILENAME NIL NIL NIL (AND VIEWER (LIST 'PROMPTWINDOW (GETPROMPTWINDOW VIEWER] (READFILE (INFILEP FILENAME)) IMAGEOBJ READSKETCH) (SETQ IMAGEOBJ (BIN TEXTSTREAM)) (CLOSEF TEXTSTREAM) (COND ((NOT (IMAGEOBJP IMAGEOBJ)) (STATUSPRINT (OR VIEWER PROMPTWINDOW) FILENAME " is not a sketch file.") (RETURN NIL))) (COND ([NOT (type? SKETCH (SETQ READSKETCH (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (STATUSPRINT (OR VIEWER PROMPTWINDOW) FILENAME " is not a sketch file.") (RETURN)) (T (* save the name of where the sketch  came from.) (replace (SKETCH SKETCHNAME) of READSKETCH with (OR READFILE FILENAME)) (AND VIEWER (SK.CHANGE.GRID (fetch (SKETCHIMAGEOBJ SKIO.GRID) of (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) VIEWER)) (RETURN (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]) (SKETCH.GET [LAMBDA (FILENAME VIEWER) (* rrb "29-Jan-86 11:21") (* reads a sketch from a file.) (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of (SK.GET.IMAGEOBJ.FROM.FILE FILENAME VIEWER]) (ADD.SKETCH.TO.VIEWER [LAMBDA (SKETCHTOADD VIEWER ABOUTDEFAULTS?) (* rrb "20-Mar-86 15:55") (* adds the element in SKETCHTOADD to  the sketch TOSKETCH) (PROG ([ADDSKETCH (COND ((LITATOM SKETCHTOADD) (* if it's an atom, assume its a file  name.) (SKETCH.GET SKETCHTOADD VIEWER)) ((INSURE.SKETCH SKETCHTOADD] (TOSKETCH (INSURE.SKETCH VIEWER)) DEFAULTS) (* set the default from the new sketch  if appropriate) [AND (MEMB ABOUTDEFAULTS? '(NIL ASK)) [NOT (EQUAL (SETQ DEFAULTS (GETSKETCHPROP ADDSKETCH 'SKETCHCONTEXT)) (GETSKETCHPROP TOSKETCH 'SKETCHCONTEXT] (COND ((OR (NULL ABOUTDEFAULTS?) (MENU (create MENU ITEMS _ '((Yes T "Will use the defaults of the retrieved sketch." ) (No NIL "Will not change the defaults.")) CENTERFLG _ T TITLE _ "Use the defaults from the retrieved sketch?" MENUCOLUMNS _ 2))) (PUTSKETCHPROP TOSKETCH 'SKETCHCONTEXT DEFAULTS) (WINDOWPROP VIEWER 'SKETCHCONTEXT DEFAULTS] (SK.ADD.ELEMENTS.TO.SKETCH (fetch (SKETCH SKETCHELTS) of ADDSKETCH) VIEWER) (* copy properties from the read  sketch.) (for SKPROP in (fetch (SKETCH SKETCHPROPS) of ADDSKETCH) by (CDDR SKPROP) do (SELECTQ SKPROP (SKETCHCONTEXT NIL) (VIEWS [PUTSKETCHPROP TOSKETCH 'VIEWS (UNION (GETSKETCHPROP ADDSKETCH 'VIEWS) (GETSKETCHPROP TOSKETCH 'VIEWS]) (PUTSKETCHPROP TOSKETCH SKPROP (GETSKETCHPROP ADDSKETCH SKPROP]) (FILENAMELESSVERSION [LAMBDA (FILENAME) (* rrb "29-Jan-86 15:57") (* strips the version number off of FILENAME if it has one.) (PACKFILENAME (CONS 'VERSION (CONS NIL (UNPACKFILENAME FILENAME]) (SK.ADD.ELEMENTS.TO.SKETCH [LAMBDA (ELTS SKW) (* rrb "10-Mar-86 16:50") (* adds a list of elements to a sketch) (for ELT in ELTS do (* clear the priority so that they get a priority based on their position in  the new sketch.) (SK.SET.ELEMENT.PRIORITY ELT NIL) (SK.ADD.ELEMENT ELT SKW]) (SKETCH.SET.A.DEFAULT [LAMBDA (SKW) (* rrb "14-Jul-86 13:43") (* allows the user to set a default) (\CURSOR.IN.MIDDLE.MENU (create MENU ITEMS _ '[(Line SKETCH.SET.BRUSH.SIZE "Sets the characteristics of the default brush." (SUBITEMS (Size SKETCH.SET.BRUSH.SIZE "Sets the size of the default brush" ) (Shape SKETCH.SET.BRUSH.SHAPE "Sets the shape of the default brush" ) (Add% arrowhead SK.SET.LINE.ARROWHEAD "Sets the arrowhead characteristics of new lines." ) ("Mouse line specs" SK.SET.LINE.LENGTH.MODE "Sets whether the lines drawn with the middle mouse button connect to each other." ))) (Arrowhead SK.SET.ARROWHEAD.LENGTH "Sets the characteristics of the default arrowhead." (SUBITEMS (Size SK.SET.ARROWHEAD.LENGTH) (Angle SK.SET.ARROWHEAD.ANGLE) (Type SK.SET.ARROWHEAD.TYPE))) (Text SK.SET.TEXT.SIZE "Sets the size of newly added text." (SUBITEMS ("Font size" SK.SET.TEXT.SIZE "Sets the size of newly added text." ) ("Font family" SK.SET.TEXT.FONT "Sets the font family of newly added text." ) ("Horizontal justification" SK.SET.TEXT.HORIZ.ALIGN "Sets the horizontal justification mode of new text." ) ("Vertical justification" SK.SET.TEXT.VERT.ALIGN "Sets the vertical justification of new text." ) ("Bold and/or italic" SK.SET.TEXT.LOOKS "Sets the bold and italic look of new text." ))) (Text% Box SK.SET.TEXTBOX.HORIZ.ALIGN "Sets the alignment of text within new text boxes." (SUBITEMS ("Horizontal justification" SK.SET.TEXTBOX.HORIZ.ALIGN "Sets the horizontal alignment of text within new text boxes." ) ("Vertical justification" SK.SET.TEXTBOX.VERT.ALIGN "Sets the vertical alignment of text within new text boxes." ))) (Arc SK.SET.ARC.DIRECTION "Sets the direction arcs go around their circle." (SUBITEMS ("Clockwise" SK.SET.ARC.DIRECTION.CW "Makes new arcs go around in the clockwise direction" ) ("Counterclockwise" SK.SET.ARC.DIRECTION.CCW "Makes new arcs go around in the counterclockwise direction" ))) ("Input scale" SK.SET.INPUT.SCALE "Sets the scale for newly added lines and text." (SUBITEMS ("Read new input scale" SK.SET.INPUT.SCALE "Reads a new input scale.") ("Make input scale current" SK.SET.INPUT.SCALE.CURRENT "makes the input scale be the scale of the current view." ))) (Feedback SK.SET.FEEDBACK.MODE "Controls the amount of feedback when adding new curves, circles, etc." (SUBITEMS ("Points only" SK.SET.FEEDBACK.POINT "Only the control points will be shown when entering elements." ) ("Fast figures" SK.SET.FEEDBACK.VERBOSE "Wires, circles and ellipses are shown while they are being entered." ) ("All figures" SK.SET.FEEDBACK.ALWAYS "Most elements are shown while they are being entered. This will be slow for arcs and curves."] CENTERFLG _ T WHENSELECTEDFN _ (FUNCTION SK.POPUP.SELECTIONFN) MENUFONT _ (SK.FONTNAMELIST (FONTCREATE BOLDFONT]) (SK.POPUP.SELECTIONFN [LAMBDA (ITEM MENU) (* rrb " 3-Sep-85 14:27") (* * calls the function appropriate for the item selected from the command menu  associated with a figure window.) (* uses SKW freely from enclosing call  to MENU.) (CLOSEPROMPTWINDOW SKW) (SK.APPLY.MENU.COMMAND (CADR ITEM) SKW]) (GETSKETCHWREGION [LAMBDA (SKETCHWINDOW) (* rrb "11-Jul-86 15:48") (UNSCALE.REGION (GETWREGION SKETCHWINDOW) (VIEWER.SCALE SKETCHWINDOW]) (SK.ADD.ELEMENT [LAMBDA (GELT SKETCHW DONTCLEARCURSOR GROUPFLG DONTCALLWHENADDEDFN) (* rrb "30-Aug-86 15:08") (* adds a new element to a sketch window and handles propagation to all other  figure windows) (COND (GELT (PROG ([GELTTOADD (COND (DONTCALLWHENADDEDFN GELT) (T (SK.CHECK.WHENADDEDFN SKETCHW GELT] (SKETCH (SKETCH.FROM.VIEWER SKETCHW)) ADDEDELT) (* take down the caret.) (OR GELTTOADD (RETURN)) (OR DONTCLEARCURSOR (SKED.CLEAR.SELECTION SKETCHW)) (* add the element to the sketch.) (ADD.ELEMENT.TO.SKETCH GELT SKETCH) (* do the window that the interaction  occurred in first.) (SETQ ADDEDELT (SKETCH.ADD.AND.DISPLAY1 GELT SKETCHW NIL GROUPFLG)) (* propagate to other windows.) (for SKW in (ALL.SKETCH.VIEWERS SKETCH) when (AND (NEQ SKW SKETCHW) (ELT.INSIDE.SKETCHWP GELT SKW)) do (SKETCH.ADD.AND.DISPLAY1 GELT SKW GROUPFLG)) (RETURN ADDEDELT]) (SK.ADD.PRIORITY.ELEMENT.TO.SKETCH [LAMBDA (SKETCH ELEMENT PRIORITY) (* rrb "10-Mar-86 18:48") (* * adds an element to a sketch at its place according to PRIORITY.) (PROG ((SKELTSCELL (fetch (SKETCH SKETCHTCELL) of SKETCH))) (RETURN (COND ([OR (NULL (CAR SKELTSCELL)) (NOT (LESSP PRIORITY (SK.ELEMENT.PRIORITY (CADR SKELTSCELL] (* special cases of no elements or this element being greater than any others.  This means the other part of the COND doesn't have to worry about the TCONC  format.) (TCONC SKELTSCELL ELEMENT)) [(LESSP PRIORITY (SK.ELEMENT.PRIORITY (CAAR SKELTSCELL))) (* special check for first element. This allows the others to be handled by  replacing the tail of the element before.) (RPLACA SKELTSCELL (CONS ELEMENT (CAR SKELTSCELL] (T (for SKELTTAIL on (CAR SKELTSCELL) when (LESSP PRIORITY (SK.ELEMENT.PRIORITY (CADR SKELTTAIL))) do (RPLACD SKELTTAIL (CONS ELEMENT (CDR SKELTTAIL))) (RETURN ELEMENT]) (SK.ELTS.BY.PRIORITY [LAMBDA (GELTA GELTB) (* rrb "10-Mar-86 17:57") (* * sort function for sketch global elements that sorts by priority.) (ILESSP (SK.ELEMENT.PRIORITY GELTA) (SK.ELEMENT.PRIORITY GELTB]) (SK.ORDER.ELEMENTS [LAMBDA (GSKETCHELEMENTS) (* rrb "10-Mar-86 16:30") (* * puts a list of sketch global elements in order by priority.) (SORT GSKETCHELEMENTS (FUNCTION SK.ELTS.BY.PRIORITY]) (SK.ADD.PRIORITY.LOCAL.ELEMENT.TO.SKETCH [LAMBDA (LOCALSKETCHELTS LOCALELEMENT) (* rrb "26-Mar-86 10:21") (* * adds an element to a sketch at its place according to PRIORITY.) (PROG [(PRIORITY (SK.ELEMENT.PRIORITY (fetch (SCREENELT GLOBALPART) of LOCALELEMENT] (RETURN (COND ([OR (NULL (CDAR LOCALSKETCHELTS)) (NOT (LESSP PRIORITY (SK.ELEMENT.PRIORITY (fetch (SCREENELT GLOBALPART) of (CADR LOCALSKETCHELTS] (* special cases of no elements in which case the local elements has only a  name or this element being greater than any others.  This means the other part of the COND doesn't have to worry about the TCONC  format.) (TCONC LOCALSKETCHELTS LOCALELEMENT)) (T (* the first element of LOCALSKETCHELTS is the name of the sketch.) (for SKELTTAIL on (CAR LOCALSKETCHELTS) when [LESSP PRIORITY (SK.ELEMENT.PRIORITY (fetch (SCREENELT GLOBALPART) of (CADR SKELTTAIL] do (RPLACD SKELTTAIL (CONS LOCALELEMENT (CDR SKELTTAIL))) (RETURN LOCALELEMENT]) (SK.ADD.ELEMENTS [LAMBDA (ELEMENTS SKW) (* rrb "10-Mar-86 17:57") (* adds a list of global elements to a viewer but doesn't make an entry on the  history list.) (* sorts the elements so that their relative priority remains the same.) (for ELT in (SK.ORDER.ELEMENTS ELEMENTS) do (SK.SET.ELEMENT.PRIORITY ELT NIL) (SK.ADD.ELEMENT ELT SKW]) (SK.CHECK.WHENADDEDFN [LAMBDA (VIEWER GELT) (* rrb "19-Oct-85 17:36") (* checks if the sketch has a when added fn and if so, calls it and interprets  the result. Returns a list of the elements that should be deleted.) (PROG ((SKETCH (INSURE.SKETCH VIEWER)) ADDFN RESULT) (COND ([NULL (SETQ ADDFN (GETSKETCHPROP SKETCH 'WHENADDEDFN] (RETURN GELT))) (SETQ RESULT (APPLY* ADDFN VIEWER GELT)) (COND ((EQ RESULT 'DON'T) (RETURN NIL)) ((GLOBALELEMENTP RESULT) (RETURN RESULT)) (T (RETURN GELT]) (SK.APPLY.MENU.COMMAND [LAMBDA (COMMAND SKETCHW) (* rrb " 3-Jan-85 13:17") (* calls the function appropriate for the item selected from the command menu  associated with a figure window.) (* This is a separate function so it can be called by both pop up and fixed  menu operations.) (COND ((NULL COMMAND) NIL) ((type? SKETCHTYPE COMMAND) (* if the selected item is an element type, add an instance.) (SKETCHW.ADD.INSTANCE COMMAND SKETCHW)) [(LISTP COMMAND) (* EVAL it) (EVAL (APPEND COMMAND (CONS (KWOTE SKETCHW] (T (APPLY* COMMAND SKETCHW]) (SK.DELETE.ELEMENT1 [LAMBDA (OLDGELT SKETCHW GROUPFLG) (* rrb "19-Oct-85 17:09") (* deletes an element to a sketch window and handles propagation to all other  figure windows) (* GROUPFLG indicates that this is part of a group operation and hence display  and image object deleted fns don't need to be called.) (PROG ((SKETCH (SKETCH.FROM.VIEWER SKETCHW)) LOCALELT) (* delete the element to the sketch.) (OR (REMOVE.ELEMENT.FROM.SKETCH OLDGELT SKETCH) (RETURN NIL)) (* do the window that the interaction  occurred in first.) (SK.ERASE.AND.DELETE.ITEM (SK.LOCAL.ELT.FROM.GLOBALPART OLDGELT SKETCHW) SKETCHW GROUPFLG) (* propagate to other windows.) (for SKW in (ALL.SKETCH.VIEWERS SKETCH) when (AND (NEQ SKW SKETCHW) (SETQ LOCALELT (  SK.LOCAL.ELT.FROM.GLOBALPART OLDGELT SKW))) do (SK.ERASE.AND.DELETE.ITEM LOCALELT SKW GROUPFLG)) (OR GROUPFLG (SK.CHECK.IMAGEOBJ.WHENDELETEDFN OLDGELT SKETCHW)) (RETURN OLDGELT]) (SK.MARK.DIRTY [LAMBDA (SKETCH) (* rrb " 1-Oct-86 18:15") (* marks a sketch as having been changed.  Puts a flag on its viewers.) (* checks first because this is faster  than always putting.) (for SKW in (ALL.SKETCH.VIEWERS SKETCH) do (OR (EQ (WINDOWPROP SKW 'SKETCHCHANGED) T) (WINDOWPROP SKW 'SKETCHCHANGED T]) (SK.MARK.UNDIRTY [LAMBDA (SKETCH) (* rrb "29-Nov-84 18:03") (* marks a sketch as having been changed.  Puts a flag on its viewers.) (for SKW in (ALL.SKETCH.VIEWERS SKETCH) do (WINDOWPROP SKW 'SKETCHCHANGED 'OLD]) (SK.MENU.AND.RETURN.FIELD [LAMBDA (ELEMENTTYPE) (* rrb "11-May-84 16:03") (* returns a field list of the field to be changed.) (PROG ((ITEMS (CHANGEABLEFIELDITEMS ELEMENTTYPE))) (RETURN (COND ((NULL ITEMS) NIL) [(NULL (CDR ITEMS)) (EVAL (CADR (CAR ITEMS] (T (MENU (create MENU ITEMS _ ITEMS CENTERFLG _ T TITLE _ "Choose which property to change"]) (SKETCH.SET.BRUSH.SHAPE [LAMBDA (W) (* rrb "11-Dec-84 15:31") (* Sets the shape of the current brush) (PROG [(NEWSHAPE (PAINTW.READBRUSHSHAPE)) (NOWBRUSH (fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP W 'SKETCHCONTEXT] (RETURN (AND NEWSHAPE (replace (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP W 'SKETCHCONTEXT) with (create BRUSH using NOWBRUSH BRUSHSHAPE _ NEWSHAPE]) (SKETCH.SET.BRUSH.SIZE [LAMBDA (W) (* rrb "12-Jan-85 10:13") (* sets the size of the current brush) (SK.SET.DEFAULT.BRUSH.SIZE [READBRUSHSIZE (fetch (BRUSH BRUSHSIZE) of (fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP W 'SKETCHCONTEXT] W]) (SKETCHW.CLOSEFN [LAMBDA (SKW) (* rrb " 1-Oct-86 17:44") (* close function for a viewer. Removes itself from the list of viewers.) (PROG (PROCINFO) [COND [(SETQ PROCINFO (WINDOWPROP SKW 'DOCUMENTINFO)) (* this window came from a tedit  document.) [COND ((WINDOWPROP SKW 'SKETCHCHANGED) (COND ((EQ (UPDATE.IMAGE.IN.DOCUMENT SKW) 'DON'T) (RETURN 'DON'T] (COND ([OR (TTY.PROCESSP (THIS.PROCESS)) (TTY.PROCESSP (WINDOWPROP SKW 'PROCESS] (* if this process or the sketch process has the tty, give it back to the Tedit  that this window came from.) (AND [PROCESSP (SETQ PROCINFO (WINDOWPROP (fetch (SKETCHDOCUMENTINFO FROMTEDITWINDOW) of PROCINFO) 'PROCESS] (TTY.PROCESS PROCINFO] ((NULL (SK.CONFIRM.DESTRUCTION SKW "unsaved changes ... press LEFT to close anyway")) (RETURN 'DON'T] (REMOVE.SKETCH.VIEWER (WINDOWPROP SKW 'SKETCH) SKW) (* kill the process that supports the  typing.) (DEL.PROCESS (WINDOWPROP SKW 'PROCESS NIL)) (WINDOWADDPROP SKW 'OPENFN 'SKETCHW.REOPENFN]) (SK.CONFIRM.DESTRUCTION [LAMBDA (VIEWER MSG) (* rrb " 1-Oct-86 17:37") (* some destructive operation is about to take place, if the viewer is dirty,  confirm that this is what is intended. If so, return T.  If not, NIL.) (COND ((OR (WINDOWPROP VIEWER 'DONTQUERYCHANGES) (NEQ (WINDOWPROP VIEWER 'SKETCHCHANGED) T))) (T (* ask if user really wants to close) (STATUSPRINT VIEWER " ") (COND ((MOUSECONFIRM (OR MSG "unsaved changes ... press LEFT to do operation anyway") T (GETPROMPTWINDOW VIEWER)) (* close the prompt window which  MOUSECONFIRM brought up.) (CLOSEPROMPTWINDOW VIEWER) T) (T NIL]) (SKETCHW.OUTFN [LAMBDA (SKW) (* rrb "24-Jan-85 10:06") (* the cursor is leaving the window, updates any structures that may be spread  out for efficiency.) NIL]) (SKETCHW.REOPENFN [LAMBDA (SKW) (* rrb " 7-Feb-84 11:31") (* reopenfn for viewers. Adds it back onto the list of global viewers.) (ADD.SKETCH.VIEWER (WINDOWPROP SKW 'SKETCH) SKW) (WINDOWPROP SKW 'PROCESS (ADD.PROCESS (LIST (FUNCTION WB.EDITOR) (KWOTE SKW]) (MAKE.LOCAL.SKETCH [LAMBDA (SKETCH SKETCHREGION SCALE STREAM EVERYTHINGFLG) (* rrb "22-Apr-85 16:45") (* * calculate the local parts for the region of the sketch at a given scale.  EVERYTHINGFLG provides a way to override the inside check.  This is necessary because the inside check works on local elements.  When the inside check is change to work on global elements, this can be  removed.) (for SKELT in (fetch (SKETCH SKETCHELTS) of (INSURE.SKETCH SKETCH)) when (OR EVERYTHINGFLG (SK.INSIDE.REGION SKELT SKETCHREGION)) collect (SK.LOCAL.FROM.GLOBAL SKELT STREAM SCALE]) (MAP.SKETCHSPEC.INTO.VIEWER [LAMBDA (SKETCH SKW) (* rrb "12-May-85 17:02") (* creates the local parts of a sketch and puts it onto the viewer.) (PROG ((SKREGION (WINDOWPROP SKW 'REGION.VIEWED)) SPECS) (* local specs are kept as a TCONC cell so that additions to the end are fast.) (RETURN (WINDOWPROP SKW 'SKETCHSPECS (CONS [SETQ SPECS (CONS (fetch (SKETCH SKETCHNAME) of SKETCH) (for SKELT in (fetch (SKETCH SKETCHELTS) of SKETCH) when (SK.INSIDE.REGION SKELT SKREGION) collect (SK.LOCAL.FROM.GLOBAL SKELT SKW] (LAST SPECS]) (SKETCHW.REPAINTFN [LAMBDA (W REG STOPIFMOUSEDOWN NEWGRIDFLG) (* rrb "21-Feb-86 10:38") (* redisplays the sketch in a window) (* for now ignore the region.) (* if STOPIFMOUSEDOWN is T, it displays some but stops if the button left or  middle button is still down and returns STOPPED) (DSPOPERATION 'PAINT W) (DSPRIGHTMARGIN 65000 W) (* I don't know exactly how scrolling ever gets turned on but it has.) (DSPSCROLL 'OFF W) (PROG1 (SKETCHW.REPAINTFN1 W REG (AND STOPIFMOUSEDOWN (SETUPTIMER AUTOZOOM.REPAINT.TIME)) NEWGRIDFLG) (SKED.SELECTION.FEEDBACK W]) (SKETCHW.REPAINTFN1 [LAMBDA (SKW REGION TIMER NEWGRIDFLG) (* rrb "11-Jul-86 15:51") (* Draws all of the local elements in the sketch window SKW.  internal function to SKETCHW.REPAINTFN This entry is provided so that  SK.DRAWFIGURE.IF can RETFROM it if the timer has expired and a button is down.) (MAPSKETCHSPECS (LOCALSPECS.FROM.VIEWER SKW) (COND (TIMER (* call a version of SK.DRAWFIGURE  that checks the time.) (FUNCTION SK.DRAWFIGURE.IF)) (T (FUNCTION SK.DRAWFIGURE))) SKW REGION (VIEWER.SCALE SKW)) (COND ((WINDOWPROP SKW 'GRIDUP) (* if grid is up, redisplay it) (SK.DISPLAY.GRID.POINTS SKW NEWGRIDFLG]) (SK.DRAWFIGURE.IF [LAMBDA (SCREENELT STREAM REGION SCALE) (* rrb "22-Jan-85 11:34") (* draws an element of a sketch in a window.  If the free variable TIMER has expired and a button is down, it RETFROMs the  repainting function.) (PROG1 (SK.DRAWFIGURE SCREENELT STREAM REGION SCALE) (AND TIMER (MOUSESTATE (OR LEFT MIDDLE)) (TIMEREXPIRED? TIMER) (RETFROM 'SKETCHW.REPAINTFN1 'STOPPED]) (SKETCHW.SCROLLFN [LAMBDA (SKW XDELTA YDELTA CONTINUOUSFLG) (* rrb "11-Jul-86 15:51") (* scroll function for a sketch window. It must check to see which elements  need to get added and deleted from the ones currently viewed as a result of the  scrolling. Also if an element gets added, the clipping region must be expanded  because part of the display of the object may be in the already visible part of  the window.) (PROG ([SKETCH (fetch (SKETCH SKETCHELTS) of (INSURE.SKETCH (SKETCH.FROM.VIEWER SKW] (NOWREG (DSPCLIPPINGREGION NIL SKW)) NEWREGION NEWLOCALREGION INNEW? NEWONES LOCALELT SCALE) (* clear the caret.) (SKED.CLEAR.SELECTION SKW) [COND (CONTINUOUSFLG (* set XDELTA and YDELTA for  continuous scrolling) [COND ((AND XDELTA (NEQ XDELTA 0)) (COND ((IGREATERP XDELTA 0) (SETQ XDELTA 12)) (T (SETQ XDELTA -12] (COND ((AND YDELTA (NEQ YDELTA 0)) (COND ((IGREATERP YDELTA 0) (SETQ YDELTA 12)) (T (SETQ YDELTA -12] [SETQ NEWREGION (UNSCALE.REGION (SETQ NEWLOCALREGION (CREATEREGION (DIFFERENCE (fetch (REGION LEFT) of NOWREG) (COND (XDELTA) (0))) (DIFFERENCE (fetch (REGION BOTTOM) of NOWREG) (COND (YDELTA) (0))) (fetch (REGION WIDTH) of NOWREG) (fetch (REGION HEIGHT) of NOWREG))) (SETQ SCALE (VIEWER.SCALE SKW] (* update the current image to contain the things that will be there after the  scroll, then scroll.) [for GELT in SKETCH do (SETQ INNEW? (SK.INSIDE.REGION GELT NEWREGION)) (COND [(SETQ LOCALELT (SK.LOCAL.ELT.FROM.GLOBALPART GELT SKW)) (* if it is not supposed to be in the new region, remove it.) (OR INNEW? (COND ((REGIONSINTERSECTP NEWLOCALREGION (SK.ITEM.REGION LOCALELT)) (* part of image may overlap the part of sketch that is still showing) (SK.ERASE.AND.DELETE.ITEM LOCALELT SKW)) (T (SK.DELETE.ITEM LOCALELT SKW] (INNEW? (* just came in) (SETQ NEWONES (CONS GELT NEWONES] (SCROLLBYREPAINTFN SKW XDELTA YDELTA) (SKETCHW.FIG.CHANGED SKW) (SK.UPDATE.REGION.VIEWED SKW) (for GELT in NEWONES do (SKETCH.ADD.AND.DISPLAY1 GELT SKW SCALE]) (SKETCHW.RESHAPEFN [LAMBDA (SKW OLDIMAGE IMAGEREGION OLDSCREENREGION) (* rrb "11-Jul-86 15:51") (* reshape function for a sketch window.  It must check to see which elements need to get added and deleted from the ones  currently viewed as a result of the reshaping.) (PROG ([SKETCH (fetch (SKETCH SKETCHELTS) of (INSURE.SKETCH (SKETCH.FROM.VIEWER SKW] (NOWREG (DSPCLIPPINGREGION NIL SKW)) NEWREGION NEWLOCALREGION INNEW? NEWONES LOCALELT SCALE) (* clear the caret.) (SKED.CLEAR.SELECTION SKW) (RESHAPEBYREPAINTFN SKW OLDIMAGE IMAGEREGION OLDSCREENREGION) [SETQ NEWREGION (UNSCALE.REGION (SETQ NEWLOCALREGION (DSPCLIPPINGREGION NIL SKW)) (SETQ SCALE (VIEWER.SCALE SKW] (* update the current image to contain the things that will be there after the  scroll, then scroll.) [for GELT in SKETCH do (SETQ INNEW? (SK.INSIDE.REGION GELT NEWREGION)) (COND [(SETQ LOCALELT (SK.LOCAL.ELT.FROM.GLOBALPART GELT SKW)) (* if it is not supposed to be in the new region, remove it.) (OR INNEW? (COND ((REGIONSINTERSECTP NEWLOCALREGION (SK.ITEM.REGION LOCALELT)) (* part of image may overlap the part of sketch that is still showing) (SK.ERASE.AND.DELETE.ITEM LOCALELT SKW)) (T (SK.DELETE.ITEM LOCALELT SKW] (INNEW? (* just came in) (SETQ NEWONES (CONS GELT NEWONES] (SKETCHW.FIG.CHANGED SKW) (SK.UPDATE.REGION.VIEWED SKW) (for GELT in NEWONES do (SKETCH.ADD.AND.DISPLAY1 GELT SKW SCALE]) (SK.UPDATE.EVENT.SELECTION [LAMBDA (HOTSPOTCACHE X1 Y1 X2 Y2 SCALE WINDOW COPYMODE DELETEMODE) (* rrb "31-Jan-85 11:35") (* * internal function to SK.COPY.BUTTONEVENTFN that determines the elements  within the given bounds and selects or deselects them.) (PROG (SELITEMS) (RETURN (COND ((LASTMOUSESTATE UP) (* don't do anything with button up.) NIL) ((SETQ SELITEMS (SK.LOCAL.ITEMS.IN.REGION HOTSPOTCACHE (MIN X1 X2) (MIN Y1 Y2) (MAX X1 X2) (MAX Y1 Y2))) (* OLD CODE (SETQ SELITEMS  (SK.LOCAL.ITEMS.IN.REGION HOTSPOTCACHE  (REGION.FROM.COORDINATES X1 Y1 X2 Y2)  SCALE))) (COND [(LASTMOUSESTATE (OR (ONLY LEFT) (ONLY MIDDLE)))(* left or middle only selects.) (for SELITEM in SELITEMS do (SK.ADD.SELECTION SELITEM WINDOW (SK.BUTTONEVENT.MARK COPYMODE DELETEMODE ] (T (* anything but left only should cause  deselect.) (for SELITEM in SELITEMS do (SK.REMOVE.SELECTION SELITEM WINDOW (SK.BUTTONEVENT.MARK COPYMODE DELETEMODE]) (LIGHTGRAYWINDOW [LAMBDA (WINDOW) (* rrb "28-Jun-84 10:27") (DSPFILL NIL 1 'INVERT WINDOW) WINDOW]) (SK.ADD.SPACES [LAMBDA (STRLST) (* rrb "19-Jul-85 15:11") (* adds eols between the elements of  STRLST) (for STR in STRLST join (COND ((EQUAL STR "") NIL) ((EQ (NTHCHARCODE STR -1) (CHARCODE EOL)) (* if it already ends in CR, don't add  one.) (LIST STR)) (T (LIST STR " "]) (SK.SKETCH.MENU [LAMBDA (SKW) (* rrb "12-Sep-85 11:50") (* brings up the normal sketch command  menu.) (SK.MIDDLE.TITLEFN SKW T]) (SK.CHECK.IMAGEOBJ.WHENDELETEDFN [LAMBDA (GELT SKETCHW) (* rrb "19-Oct-85 17:10") (* check to see if a when deleted function needs to be applied and applies it.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) (SKIMAGEOBJ (* deleting an image object apply  WHENDELETEDFN) (SK.APPLY.IMAGEOBJ.WHENDELETEDFN GELT SKETCHW)) (GROUP (for GELT in (fetch (GROUP LISTOFGLOBALELTS) of GELT) do (  SK.CHECK.IMAGEOBJ.WHENDELETEDFN GELT SKETCHW))) NIL]) (SK.APPLY.IMAGEOBJ.WHENDELETEDFN [LAMBDA (GELT SKETCHW) (* rrb "30-Jul-85 15:35") (* applies the when deleted function  for an image object.) (PROG (IMAGEOBJ FN) (COND ((AND (SETQ FN (IMAGEOBJPROP (SETQ IMAGEOBJ (fetch (SKIMAGEOBJ SKIMAGEOBJ) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) 'WHENDELETEDFN)) (NEQ FN 'NILL)) (* documentation calls for passing text streams as well but there aren't any.) (APPLY* FN IMAGEOBJ SKETCHW]) (SK.RETURN.TTY [LAMBDA (W) (* rrb "29-Aug-85 11:09") (* gives up the tty when the window is  shrunken.) (AND (TTY.PROCESSP (WINDOWPROP W 'PROCESS)) (TTY.PROCESS T]) (SK.TAKE.TTY [LAMBDA (W) (* rrb "29-Aug-85 11:10") (* takes the tty when the window is  expanded) (TTY.PROCESS (WINDOWPROP W 'PROCESS]) ) (* ; "fns for dealing with the sketch menu") (DEFINEQ (SKETCH.COMMANDMENU [LAMBDA (ITEMS TITLE) (* rrb "14-Jul-86 13:43") (create MENU ITEMS _ ITEMS CENTERFLG _ T WHENSELECTEDFN _ (FUNCTION SKETCHW.SELECTIONFN) MENUFONT _ (SK.FONTNAMELIST (FONTCREATE BOLDFONT)) TITLE _ TITLE]) (SKETCH.COMMANDMENU.ITEMS [LAMBDA (ADDFIXITEM ELEMENTTYPES VIEWER) (* rrb "24-Sep-86 18:11") (* returns a list of the items that are in the sketch command menu.) (APPEND '[(Delete SK.DELETE.ELT "Deletes one or more elements from the sketch." (SUBITEMS ("Delete element(s)" SK.DELETE.ELT "Deletes one or more elements from the sketch.") ("Delete point" SK.DELETE.KNOT "Deletes a control point from a wire or curve."] '[(Move SK.APPLY.DEFAULT.MOVE "Moves a control point, or one or more elements." (SUBITEMS (Move% point SK.MOVE.ELEMENT.POINT "Moves one of the control points.") ("Move points" SK.MOVE.POINTS "Moves a collection of control points.") ("Move elements" SK.MOVE.ELT "Moves one or more elements of the sketch.") ("Two pt transform" SK.TWO.PT.TRANSFORM.ELTS "Moves one or more sketch elements with a two point transformation." ) ("Three pt transform" SK.THREE.PT.TRANSFORM.ELTS "Moves one or more sketch elements with a three point transformation." ) ("Set MOVE command mode" SK.SET.MOVE.MODE "changes whether the MOVE command applies to points or elements." (SUBITEMS (Points SK.SET.MOVE.MODE.POINTS "Top level MOVE command will be the same as MOVE POINTS command." ) (Elements SK.SET.MOVE.MODE.ELEMENTS "Top level MOVE command will be the same as MOVE ELEMENTS command." ) (Combined SK.SET.MOVE.MODE.COMBINED "MOVE command will move points if a single point is clicked; elements otherwise" ] '[(Copy SK.COPY.ELT "Copies a piece of the sketch." (SUBITEMS ("Copy elements" SK.COPY.ELT "copies one or more elements of the sketch." ) ("Copy w/2 pt trans" SK.COPY.AND.TWO.PT.TRANSFORM.ELTS "Copies one or more sketch elements with a two point transformation." ) ("Copy w/3 pt trans" SK.COPY.AND.THREE.PT.TRANSFORM.ELTS "Copies one or more sketch elements with a three point transformation." ] '[(Align SK.ALIGN.POINTS.LEFT "Aligns a collection of points with the leftmost one." (SUBITEMS ("Align Left" SK.ALIGN.POINTS.LEFT "Aligns a collection of points with the leftmost one.") ("Align Right" SK.ALIGN.POINTS.RIGHT "Aligns a collection of points with the rightmost one.") ("Align Top" SK.ALIGN.POINTS.TOP "Aligns a collection of points with the topmost one.") ("Align Bottom" SK.ALIGN.POINTS.BOTTOM "Aligns a collection of points with the bottommost one.") ("Move onto grid" SK.PUT.ELTS.ON.GRID "Moves control points to nearest grid point.") ("Space evenly in X" SK.EVEN.SPACE.POINTS.IN.X "Moves points so that they are evenly spaced between the leftmost and rightmost." ) ("Space evenly in Y" SK.EVEN.SPACE.POINTS.IN.Y "Moves points so that they are evenly spaced between the topmost and bottommost." ] '((Change SK.CHANGE.ELT "Changes a property of a piece or collection of pieces.")) [AND (GETD 'SK.SEL.AND.SHOW.ANNOTE) (GETD 'NCP.CardFromWindow) (NCP.CardFromWindow VIEWER) '((Annotations SK.SEL.AND.SHOW.ANNOTE "Manipulates the annotations from a selected element." (SUBITEMS (Add% Annotation SK.SEL.AND.ADD.ANNOTE "Adds an annotation to an element.") (Delete% Annotation SK.SEL.AND.DELETE.ANNOTE "Deletes the annotation from an element.") (Show% Annotation SK.SEL.AND.SHOW.ANNOTE "Shows the annotation of an element."] (for ELEMENT in (COND ((EQ ELEMENTTYPES T) SKETCH.ELEMENT.TYPE.NAMES) (T ELEMENTTYPES)) 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))) [AND (GETD 'SK.SEL.AND.SHOW.ANNOTE) '((Link SK.ADD.ANNOTATION "Adds an annotation object."] [AND FILLINGMODEFLG '(("Bury" SK.SEND.TO.BOTTOM "will put selected elements on the bottom of the display stack." (SUBITEMS ("Send to bottom" SK.SEND.TO.BOTTOM "same as BURY, puts selected elements on the bottom of the display stack." ) ("Bring to top" SK.BRING.TO.TOP "will cause selected elements to be displayed on top of ones now covering it." ) ("Reverse order" SK.SWITCH.PRIORITIES "reorders the display of elements. Selecting 2 will switch them." ] '[(Group SK.GROUP.ELTS "groups a collection of elements into a single unit." (SUBITEMS ("Move group control point" SK.MOVE.GROUP.CONTROL.PT "moves the control point of a group without moving the group.") (Group SK.GROUP.ELTS "groups a collection of elements into a single unit." ) (Freeze SK.FREEZE.ELTS "freezes elements so that they can not be moved, changed, copied or deleted." ] '[(UnGroup SK.UNGROUP.ELT "replaces a group element by its constituents." (SUBITEMS (UnGroup SK.UNGROUP.ELT "replaces a group element by its constituents." ) (UnFreeze SK.UNFREEZE.ELT "unprotects an element so it can be moved, changed, copied or deleted." ] '[(Undo SK.UNDO.LAST "undoes the previous event. Or the latest one that hasn't been undone." (SUBITEMS (?Undo SK.SEL.AND.UNDO "allows selection of an event to undo.") (Undo SK.UNDO.LAST "undoes the previous event. Or the latest one that hasn't been undone." ] '[(Defaults SKETCH.SET.A.DEFAULT "Changes one of the default characteristics." (SUBITEMS (Line SKETCH.SET.BRUSH.SIZE "Sets the characteristics of the default brush." (SUBITEMS (Size SKETCH.SET.BRUSH.SIZE "Sets the size of the default brush") (Shape SKETCH.SET.BRUSH.SHAPE "Sets the shape of the default brush") (Add% arrowhead SK.SET.LINE.ARROWHEAD "Makes it so that new lines automatically have Arrowheads." ) ("Mouse line specs" SK.SET.LINE.LENGTH.MODE "Sets whether the lines drawn with the middle mouse button connect to each other." ))) (Arrowhead SK.SET.ARROWHEAD.LENGTH "Sets the characteristics of the default arrowhead." (SUBITEMS ("set Size of default arrowhead" SK.SET.ARROWHEAD.LENGTH) ("set Angle of default arrowhead" SK.SET.ARROWHEAD.ANGLE) ("set Type of default arrowhead" SK.SET.ARROWHEAD.TYPE) ("default Add arrowheads" SK.SET.LINE.ARROWHEAD "Makes it so that new lines automatically have Arrowheads." ))) (Text SK.SET.TEXT.SIZE "Sets the size of newly added text." (SUBITEMS ("Font size" SK.SET.TEXT.SIZE "Sets the size of newly added text.") ("Font family" SK.SET.TEXT.FONT "Sets the font family of newly added text.") ("Horizontal justification" SK.SET.TEXT.HORIZ.ALIGN "Sets the horizontal justification mode of new text.") ("Vertical justification" SK.SET.TEXT.VERT.ALIGN "Sets the vertical justification of new text.") ("Bold and/or italic" SK.SET.TEXT.LOOKS "Sets the bold and italic look of new text."))) (Text% Box SK.SET.TEXTBOX.HORIZ.ALIGN "Sets the alignment of text within new text boxes." (SUBITEMS ("Horizontal justification" SK.SET.TEXTBOX.HORIZ.ALIGN "Sets the horizontal alignment of text within new text boxes." ) ("Vertical justification" SK.SET.TEXTBOX.VERT.ALIGN "Sets the vertical alignment of text within new text boxes." ))) (Arc SK.SET.ARC.DIRECTION "Sets the direction arcs go around their circle." (SUBITEMS ("Clockwise" SK.SET.ARC.DIRECTION.CW "Makes new arcs go around in the clockwise direction" ) ("Counterclockwise" SK.SET.ARC.DIRECTION.CCW "Makes new arcs go around in the counterclockwise direction" ))) ("Input scale" SK.SET.INPUT.SCALE "Sets the scale for newly added lines and text." (SUBITEMS ("Read new input scale" SK.SET.INPUT.SCALE "Reads a new input scale.") ("Make input scale current" SK.SET.INPUT.SCALE.CURRENT "makes the input scale be the scale of the current view." ))) (Feedback SK.SET.FEEDBACK.MODE "Controls the amount of feedback when adding new curves, circles, etc." (SUBITEMS ("Points only" SK.SET.FEEDBACK.POINT "Only the control points will be shown when entering elements." ) ("Fast figures" SK.SET.FEEDBACK.VERBOSE "Wires, circles and ellipses are shown while they are being entered." ) ("All figures" SK.SET.FEEDBACK.ALWAYS "Most elements are shown while they are being entered. This will be slow for arcs and curves."] '[(Grid SK.SET.GRID "Flips between using the grid and not using the grid." (SUBITEMS (|Turn grid ON| SK.TURN.GRID.ON "turns on a grid. Only pts on the grid can be selected.") (|Turn grid OFF| SK.TURN.GRID.OFF "turns off the grid. Any point can be selected.") (LARGER% Grid SK.MAKE.GRID.LARGER "doubles the distance between the grid points.") (smaller% Grid SK.MAKE.GRID.SMALLER "halves the distance between the grid points.") ("Display grid" SK.DISPLAY.GRID "XORs a point at each grid point. If grid is visible, this will erase it." ) ("Remove grid display" SK.TAKE.DOWN.GRID "XORs a point at each grid point. If grid is visible, this will erase it." ] '[("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 to window" SK.FRAME.IT "moves so that the entire sketch just fits in the window" (SUBITEMS ("Fit to window" SK.FRAME.IT "moves so that the entire sketch just fits in the window" ) ("Fit window to sketch" SK.FRAME.WINDOW.TO.SKETCH "reshapes the window so that the entire sketch just fits" ))) ("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 SK.HARDCOPYIMAGEW "sends a copy of the current window contents on the default printer." (SUBITEMS ("To a file" SK.HARDCOPYIMAGEW.TOFILE "Puts image on a file; prompts for filename and format") ("To a printer" SK.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" SK.LIST.IMAGE.ON.FILE "Sends the image of the whole sketch at the current scale on a file." ) ("To a printer" SK.LIST.IMAGE "Sends the image of the whole sketch at the current scale to the printer." ))) (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."] '((Put SK.PUT.ON.FILE "saves this sketch on a file")) '[(Get SK.GET.FROM.FILE "gets a sketch from a file." (SUBITEMS (Get SK.GET.FROM.FILE "gets a sketch from a file." ) (Include SK.INCLUDE.FILE "adds the contents of a file to the existing sketch." ] [AND ADDFIXITEM '((Fix% Menu SK.FIX.MENU "leaves up the menu of sketch operations."] (AND (EQUAL (USERNAME) "BURTON.PA") '((inspect INSPECT.SKETCH "Calls the Inspector on the figure data structures."]) (CREATE.SKETCHW.COMMANDMENU [LAMBDA (MENUTITLE ADDFIXITEM ELEMENTTYPES VIEWER) (* rrb " 6-May-86 15:22") (* returns the control menu for a  figure window.) (SKETCH.COMMANDMENU (SKETCH.COMMANDMENU.ITEMS ADDFIXITEM ELEMENTTYPES VIEWER) MENUTITLE]) (SKETCHW.SELECTIONFN [LAMBDA (ITEM MENU) (* rrb "31-Jan-86 11:34") (* calls the function appropriate for the item selected from the command menu  associated with a figure window.) (PROG [(SKW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW] (RETURN (RESETLST (COND ((OBTAIN.MONITORLOCK (SKETCH.MONITORLOCK SKW) T T) (* clear the prompt window if there is  one.) (CLOSEPROMPTWINDOW SKW) (* reset the line being drawn if there  is one.) (RESET.LINE.BEING.INPUT SKW) (SK.APPLY.MENU.COMMAND (CADR ITEM) SKW)) (T (STATUSPRINT SKW " " "Sketch operation in progress. Please wait."]) (SKETCH.MONITORLOCK [LAMBDA (VIEWER) (* rrb "31-Jan-86 10:20") (* returns the monitorlock for a  sketch) (OR (WINDOWPROP VIEWER 'MONITORLOCK) (PROG [(LOCK (CREATE.MONITORLOCK (GENSYM "Sketch"] (WINDOWPROP VIEWER 'MONITORLOCK LOCK) (RETURN LOCK]) (SK.EVAL.AS.PROCESS [LAMBDA (FORM VIEWER) (* rrb "31-Jan-86 11:23") (* evals a form that grabs the sketch lock on its viewer in a process.) (COND ((THIS.PROCESS) (ADD.PROCESS (LIST 'SK.EVAL.WITH.LOCK (KWOTE FORM) (KWOTE VIEWER)) 'RESTARTABLE 'NO)) (T (* processes aren't on, don't bother  with monitor locks.) (\EVAL FORM]) (SK.EVAL.WITH.LOCK [LAMBDA (FORM VIEWER) (* rrb "31-Jan-86 11:22") (* evals FORM in a context where it has the lock on VIEWER) (WITH.MONITOR (SKETCH.MONITORLOCK VIEWER) (EVAL FORM]) ) (DEFINEQ (SK.FIX.MENU [LAMBDA (SKETCHW DONTOPENFLG) (* rrb "23-Sep-86 17:59") (* attaches the menu on the right side of the viewer.) (PROG (MENUW) (OR (SETQ MENUW (SK.INSURE.HAS.MENU SKETCHW)) (RETURN)) (* clear the popup menu cache.) (WINDOWPROP SKETCHW 'SKETCHPOPUPMENUCACHE NIL) (WINDOWPROP MENUW 'MINSIZE (CONS [BITMAPWIDTH (UPDATE/MENU/IMAGE (CAR (WINDOWPROP MENUW 'MENU] 20)) (COND ((NOT (MEMB MENUW (ATTACHEDWINDOWS SKETCHW))) (ATTACHWINDOW MENUW SKETCHW 'RIGHT 'TOP 'LOCALCLOSE) (WINDOWADDPROP MENUW 'CLOSEFN (FUNCTION DETACHWINDOW)) (WINDOWADDPROP MENUW 'CLOSEFN (FUNCTION SK.CLEAR.POPUP.MENU) T) (OR DONTOPENFLG (OPENW MENUW]) (SK.SET.UP.MENUS [LAMBDA (SKETCHW DONTOPENFLG MENUSPEC) (* rrb "23-Sep-86 17:59") (* attached the sketch menu to the  window.) (PROG (FIXEDMENUW POPUPMENUW FIXIT?) (COND ((NULL MENUSPEC) (* mark window so both menus will come up if needed.) (SETQ FIXEDMENUW (SETQ POPUPMENUW T))) ((type? MENU MENUSPEC) (* put the given menu as the fixed one and establish the standard one as the  SKETCHPOPUPMENU) (SETQ FIXEDMENUW (MENUWINDOW MENUSPEC T)) (SETQ POPUPMENUW T) (SETQ FIXIT? T)) [(LISTP MENUSPEC) (SETQ FIXIT? (CADDR MENUSPEC)) [SETQ FIXEDMENUW (SELECTQ (CAR MENUSPEC) ((T NIL) (CAR MENUSPEC)) (COND ((type? MENU (CAR MENUSPEC)) (MENUWINDOW (CAR MENUSPEC) T)) (T (\ILLEGAL.ARG (CAR MENUSPEC] (SETQ POPUPMENUW (SELECTQ (CADR MENUSPEC) ((T NIL) (CADR MENUSPEC)) (COND ((type? MENU (CADR MENUSPEC)) (MENUWINDOW (CADR MENUSPEC) T)) (T (\ILLEGAL.ARG (CADR MENUSPEC] (T (* default is to bring up the standard  menu) (SETQ FIXEDMENUW (SETQ POPUPMENUW T)) (SETQ FIXIT? T))) (* clear the popup menu cache.) (WINDOWPROP SKETCHW 'SKETCHFIXEDMENU FIXEDMENUW) (WINDOWPROP SKETCHW 'SKETCHPOPUPMENU POPUPMENUW) (AND FIXIT? (SK.FIX.MENU SKETCHW DONTOPENFLG]) (SK.INSURE.HAS.MENU [LAMBDA (SKETCHW) (* rrb "23-Sep-86 17:59") (* makes sure a sketch window has a  menu.) (PROG [(FIXEDMENU (WINDOWPROP SKETCHW 'SKETCHFIXEDMENU] [COND ((EQ (WINDOWPROP SKETCHW 'SKETCHFIXEDMENU) T) (* no fixed menu yet but wants standard one, create it) (WINDOWPROP SKETCHW 'SKETCHFIXEDMENU (SETQ FIXEDMENU (SK.CREATE.STANDARD.MENU SKETCHW] (RETURN FIXEDMENU]) (SK.CREATE.STANDARD.MENU [LAMBDA (VIEWER) (* rrb "23-Sep-86 17:52") (* creates the standard sketch viewer  fixed menu window.) (RESETFORM (CURSOR WAITINGCURSOR) (MENUWINDOW (CREATE.SKETCHW.COMMANDMENU NIL NIL T VIEWER) T]) (SK.ADD.ITEM.TO.MENU [LAMBDA (OLDMENU NEWITEM) (* rrb "23-Sep-86 09:53") (* returns a menu that is like OLDMENU but has one additional item NEWITEM) (* clober enough fields to get the menu to redraw itself correctly.) (create MENU using OLDMENU ITEMS _ (APPEND (fetch (MENU ITEMS) of OLDMENU) (LIST NEWITEM)) MENUCOLUMNS _ NIL MENUROWS _ NIL IMAGE _ NIL MENUGRID _ (create REGION LEFT _ 0 BOTTOM _ 0]) (SK.GET.VIEWER.POPUP.MENU [LAMBDA (SKETCHW) (* rrb "24-Sep-86 10:31") (* gets the popup menu for a viewer. If the sketch menu is open, it creates a  standard one. If the sketch menu isn't open, it adds the fix menu item to it  and pops it up. It is cleared each time the menu is fixed.) (OR (WINDOWPROP SKETCHW 'SKETCHPOPUPMENUCACHE) (PROG [(SKETCHMENU (WINDOWPROP SKETCHW 'SKETCHFIXEDMENU] [COND [(OR (NULL SKETCHMENU) (OPENWP SKETCHMENU)) (* window doesn't want a fixed menu or its fixed menu is already open, check  for a popup one) (COND ((EQ (SETQ SKETCHMENU (WINDOWPROP SKETCHW 'SKETCHPOPUPMENU)) T) (WINDOWPROP SKETCHW 'SKETCHPOPUPMENU (SETQ SKETCHMENU (SK.CREATE.STANDARD.MENU SKETCHW] (T (* use the fixed menu with an item added to fix the menu.) [COND ((EQ SKETCHMENU T) (* no fixed menu yet but wants standard one, create it) (WINDOWPROP SKETCHW 'SKETCHFIXEDMENU (SETQ SKETCHMENU (  SK.CREATE.STANDARD.MENU SKETCHW] (SETQ SKETCHMENU (MENUWINDOW (SK.ADD.ITEM.TO.MENU (CAR (WINDOWPROP SKETCHMENU 'MENU)) '(Fix% Menu SK.FIX.MENU "leaves up the menu of sketch operations." )) T] (WINDOWPROP SKETCHW 'SKETCHPOPUPMENUCACHE SKETCHMENU) (RETURN SKETCHMENU]) (SK.CLEAR.POPUP.MENU [LAMBDA (MENUW) (* rrb "24-Sep-86 10:34") (* clears the cache of pop up window so that the fixed menu will be used if the  user middle buttons.) (PROG NIL (WINDOWPROP (OR (MAINWINDOW MENUW) (RETURN)) 'SKETCHPOPUPMENUCACHE NIL]) ) (* ; "fns for dealing with sketch structures") (DEFINEQ (SKETCH.CREATE [LAMBDA ARGS (* rrb " 6-Nov-85 11:16") (PROG [(SKETCH (create SKETCH SKETCHNAME _ (AND (GREATERP ARGS 0) (ARG ARGS 1] (PUTSKETCHPROP SKETCH 'SKETCHCONTEXT (CREATE.DEFAULT.SKETCH.CONTEXT)) (PUTSKETCHPROP SKETCH 'VERSION SKETCH.VERSION) (* pick out the props that are  context,) [COND ((GREATERP ARGS 1) (for I from 2 to ARGS by 2 do (PUTSKETCHPROP SKETCH (ARG ARGS I) (ARG ARGS (ADD1 I] (RETURN SKETCH]) (GETSKETCHPROP [LAMBDA (SKETCH PROPERTY) (* rrb " 3-Mar-86 14:37") (* retrieves the property of a sketch) (PROG ((SKETCH (INSURE.SKETCH SKETCH)) SKETCHCONTEXT) (SETQ SKETCHCONTEXT (LISTGET (fetch (SKETCH SKETCHPROPS) of SKETCH) 'SKETCHCONTEXT)) (RETURN (SELECTQ PROPERTY (BRUSH (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT)) (SHAPE (fetch (BRUSH BRUSHSHAPE) of (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT))) (SIZE (fetch (BRUSH BRUSHSIZE) of (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT))) (COLOR (fetch (BRUSH BRUSHCOLOR) of (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT))) (FONT (fetch (SKETCHCONTEXT SKETCHFONT) of SKETCHCONTEXT)) (TEXTALIGNMENT (fetch (SKETCHCONTEXT SKETCHTEXTALIGNMENT) of SKETCHCONTEXT)) (ARROWHEAD (fetch (SKETCHCONTEXT SKETCHARROWHEAD) of SKETCHCONTEXT)) (DASHING (fetch (SKETCHCONTEXT SKETCHDASHING) of SKETCHCONTEXT)) (USEARROWHEAD (fetch (SKETCHCONTEXT SKETCHUSEARROWHEAD) of SKETCHCONTEXT)) (DRAWINGMODE (OR (fetch (SKETCHCONTEXT SKETCHDRAWINGMODE) of SKETCHCONTEXT) 'REPLACE)) (TEXTBOXALIGNMENT (fetch (SKETCHCONTEXT SKETCHTEXTBOXALIGNMENT) of SKETCHCONTEXT)) (TEXTURE (fetch (SKFILLING FILLING.COLOR) of (fetch (SKETCHCONTEXT SKETCHFILLING) of SKETCHCONTEXT))) ((FILLINGCOLOR BACKCOLOR) (fetch (SKFILLING FILLING.TEXTURE) of (fetch (SKETCHCONTEXT SKETCHFILLING) of SKETCHCONTEXT))) (LINEMODE (fetch (SKETCHCONTEXT SKETCHLINEMODE) of SKETCHCONTEXT)) (ARCDIRECTION (fetch (SKETCHCONTEXT SKETCHARCDIRECTION) of SKETCHCONTEXT)) (MOVEMODE (fetch (SKETCHCONTEXT SKETCHMOVEMODE) of SKETCHCONTEXT)) (ELEMENTS (fetch (SKETCH SKETCHELTS) of SKETCH)) (NAME (fetch (SKETCH SKETCHNAME) of SKETCH)) (LISTGET (fetch (SKETCH SKETCHPROPS) of SKETCH) PROPERTY]) (PUTSKETCHPROP [LAMBDA (SKETCH PROPERTY VALUE) (* rrb " 3-Mar-86 13:58") (* stores a property on a sketch Returns VALUE.  Knows about the form of a sketch and does value checking  (or should.)) (PROG ((SKETCH (INSURE.SKETCH SKETCH)) SKETCHCONTEXT PLIST) (SETQ PLIST (fetch (SKETCH SKETCHPROPS) of SKETCH)) (SETQ SKETCHCONTEXT (LISTGET (fetch (SKETCH SKETCHPROPS) of SKETCH) 'SKETCHCONTEXT)) [SELECTQ PROPERTY (BRUSH (replace (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT with VALUE)) (SHAPE (replace (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT with (create BRUSH using (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT) BRUSHSHAPE _ VALUE))) (SIZE (replace (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT with (create BRUSH using (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT) BRUSHSIZE _ VALUE))) (COLOR (replace (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT with (create BRUSH using (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT) BRUSHCOLOR _ VALUE))) (FONT (replace (SKETCHCONTEXT SKETCHFONT) of SKETCHCONTEXT with VALUE)) (TEXTALIGNMENT (replace (SKETCHCONTEXT SKETCHTEXTALIGNMENT) of SKETCHCONTEXT with VALUE)) (ARROWHEAD (replace (SKETCHCONTEXT SKETCHARROWHEAD) of SKETCHCONTEXT with VALUE)) (DASHING (replace (SKETCHCONTEXT SKETCHDASHING) of SKETCHCONTEXT with VALUE)) (USEARROWHEAD (replace (SKETCHCONTEXT SKETCHUSEARROWHEAD) of SKETCHCONTEXT with VALUE)) (DRAWINGMODE (replace (SKETCHCONTEXT SKETCHDRAWINGMODE) of SKETCHCONTEXT with VALUE)) (TEXTBOXALIGNMENT (replace (SKETCHCONTEXT SKETCHTEXTBOXALIGNMENT) of SKETCHCONTEXT with VALUE)) (TEXTURE (replace (SKETCHCONTEXT SKETCHFILLING) of SKETCHCONTEXT with (create SKFILLING using (fetch (SKETCHCONTEXT SKETCHFILLING) of SKETCHCONTEXT) FILLING.TEXTURE _ VALUE))) ((BACKCOLOR FILLINGCOLOR) (replace (SKETCHCONTEXT SKETCHFILLING) of SKETCHCONTEXT with (create SKFILLING using (fetch (SKETCHCONTEXT SKETCHFILLING) of SKETCHCONTEXT ) FILLING.COLOR _ VALUE))) (LINEMODE (replace (SKETCHCONTEXT SKETCHLINEMODE) of SKETCHCONTEXT with VALUE)) (ARCDIRECTION (replace (SKETCHCONTEXT SKETCHARCDIRECTION) of SKETCHCONTEXT with VALUE)) (MOVEMODE (replace (SKETCHCONTEXT SKETCHMOVEMODE) of SKETCHCONTEXT with VALUE)) (ELEMENTS (replace (SKETCH SKETCHTCELL) of SKETCH with (CONS VALUE (LAST VALUE)))) (NAME (replace (SKETCH SKETCHNAME) of SKETCH with VALUE)) (COND (PLIST (LISTPUT PLIST PROPERTY VALUE)) (T (replace (SKETCH SKETCHPROPS) of SKETCH with (LIST PROPERTY VALUE] (RETURN VALUE]) (CREATE.DEFAULT.SKETCH.CONTEXT [LAMBDA NIL (* rrb "23-Sep-86 10:40") (* returns a default sketch context) (create SKETCHCONTEXT SKETCHBRUSH _ SK.DEFAULT.BRUSH SKETCHFONT _ [OR SK.DEFAULT.FONT (SK.FONT.LIST (DEFAULTFONT 'DISPLAY] SKETCHTEXTALIGNMENT _ SK.DEFAULT.TEXT.ALIGNMENT SKETCHARROWHEAD _ (create ARROWHEAD ARROWTYPE _ SK.DEFAULT.ARROW.TYPE ARROWANGLE _ SK.DEFAULT.ARROW.ANGLE ARROWLENGTH _ SK.DEFAULT.ARROW.LENGTH) SKETCHDASHING _ SK.DEFAULT.DASHING SKETCHUSEARROWHEAD _ NIL SKETCHTEXTBOXALIGNMENT _ SK.DEFAULT.TEXTBOX.ALIGNMENT SKETCHFILLING _ (SK.CREATE.DEFAULT.FILLING) SKETCHLINEMODE _ T SKETCHINPUTSCALE _ 1 SKETCHDRAWINGMODE _ SK.DEFAULT.OPERATION]) ) (PUTPROPS SKETCH.CREATE ARGNAMES (NIL (NAME . DEFAULTS&VALUES) . U)) (* ; "fns for implementing copy and delete functions under keyboard control.") (DEFINEQ (SK.COPY.BUTTONEVENTFN [LAMBDA (WINDOW) (* rrb "11-Jul-86 15:51") (* * handles the button event when a copy key and/or the delete is held down.  allows the user to select a group of the sketch elements from the sketch  WINDOW. This is very similar to SK.SELECT.MULTIPLE.ITEMS) (* the selection protocol is left to add, right to delete.  Multiple clicking in the same place upscales for both select and deselect.  Sweeping will select or deselect all of the items in the swept out area.) (COND ([AND (TTY.PROCESSP (WINDOWPROP WINDOW 'PROCESS)) (OR (.MOVEKEYDOWNP.) (AND (.COPYKEYDOWNP.) (.DELETEKEYDOWNP.] (* this is going to be a move command.) (SELECTQ (fetch (SKETCHCONTEXT SKETCHMOVEMODE) of (WINDOWPROP WINDOW 'SKETCHCONTEXT)) (POINTS (SK.SEL.AND.MOVE.POINTS WINDOW)) (SK.SEL.AND.MOVE WINDOW))) ((LASTMOUSESTATE (NOT UP)) (PROG ((COPYMODE (OR (.COPYKEYDOWNP.) (.MOVEKEYDOWNP.))) [DELETEMODE (AND (TTY.PROCESSP (WINDOWPROP WINDOW 'PROCESS)) (OR (.DELETEKEYDOWNP.) (.MOVEKEYDOWNP.] HOTSPOTCACHE (SCALE (VIEWER.SCALE WINDOW)) OLDX ORIGX NEWX NEWY OLDY ORIGY MOVEDMUCHFLG SELITEMS RETURNVAL PREVMOUSEBUTTONS NOW MIDDLEONLYFLG OPERATION) [SETQ OPERATION (COND [COPYMODE (COND [(TTY.PROCESSP (WINDOWPROP WINDOW 'PROCESS)) (* this is not a copy select operation) (COND (DELETEMODE 'MOVE) (T 'COPY] (T 'COPYSELECT] (DELETEMODE 'DELETE) (T (* keys aren't still down.) (RETURN] (* create the cache for the elements that allow the current operation.) (SETQ HOTSPOTCACHE (SK.HOTSPOT.CACHE.FOR.OPERATION WINDOW OPERATION)) (COND ((NOT (SK.HAS.SOME.HOTSPOTS HOTSPOTCACHE)) (* no items don't do anything.) (RETURN))) (TOTOPW WINDOW) (SK.PUT.MARKS.UP WINDOW HOTSPOTCACHE) [STATUSPRINT WINDOW " " "Select elements to " (COND [COPYMODE (COND (DELETEMODE 'MOVE) (T 'COPY] (DELETEMODE 'DELETE] (* no selections have been made at  this point.) STARTOVERLP (GETMOUSESTATE) (COND ((AND (LASTMOUSESTATE UP) (SK.BUTTONEVENT.OVERP COPYMODE DELETEMODE)) (SK.TAKE.MARKS.DOWN WINDOW HOTSPOTCACHE) (RETURN))) (* MIDDLEONLYFLG is used to note case of picking characters out of a sketch.) (SETQ MIDDLEONLYFLG (LASTMOUSESTATE (ONLY MIDDLE))) SELECTLP (GETMOUSESTATE) (COND ((SK.BUTTONEVENT.OVERP COPYMODE DELETEMODE) (* user let up copy key. Put sketch into input buffer.) (SETQ RETURNVAL (WINDOWPROP WINDOW 'SKETCH.SELECTIONS)) (GO EXIT)) ([AND (LASTMOUSESTATE (NOT UP)) (OR (NOT (INSIDEP (WINDOWPROP WINDOW 'REGION) LASTMOUSEX LASTMOUSEY)) (NOT (SK.BUTTONEVENT.SAME.KEYS COPYMODE DELETEMODE] (* if a button is down, and either the keystate is different from entry or the  cursor is out of the window, stop this event.) (SETQ RETURNVAL NIL) (GO EXIT))) (* cursor is still inside or buttons are up, leave sketch selected.) (SETQ NEWY (LASTMOUSEY WINDOW)) (SETQ NEWX (LASTMOUSEX WINDOW)) (COND ((NEQ PREVMOUSEBUTTONS LASTMOUSEBUTTONS) (* a button has gone up or down, mark this as the origin of a new box to sweep.) (SETQ ORIGX NEWX) (SETQ ORIGY NEWY) (COND [(AND (EQ PREVMOUSEBUTTONS 0) (NULL MOVEDMUCHFLG) NOW) (* user double clicked and an element  was selected.) (SETQ NOW) (COND [[OR (AND (LASTMOUSESTATE (ONLY LEFT)) (NOT (SETQ MIDDLEONLYFLG))) (AND MIDDLEONLYFLG (LASTMOUSESTATE (ONLY MIDDLE] (* select the whole document.) (for SELITEM in (LOCALSPECS.FROM.VIEWER WINDOW) do (SK.ADD.SELECTION SELITEM WINDOW (SK.BUTTONEVENT.MARK COPYMODE DELETEMODE] (T (* thing selected is a the whole sketch, clear everything and start over.) (for SELITEM in (LOCALSPECS.FROM.VIEWER WINDOW) do (SK.REMOVE.SELECTION SELITEM WINDOW (SK.BUTTONEVENT.MARK COPYMODE DELETEMODE))) (* set PREVMOUSEBUTTONS to cause  reinitialization.) (SETQ PREVMOUSEBUTTONS) (GO STARTOVERLP] [(LASTMOUSESTATE (NOT UP)) (* add or delete the element if any that the point is in.  This uses a different method which takes into account the size of the selection  knots which the area sweep doesn't.) (COND ((SETQ NOW (IN.SKETCH.ELT? HOTSPOTCACHE (create POSITION XCOORD _ NEWX YCOORD _ NEWY))) (COND ([OR (AND (LASTMOUSESTATE (ONLY LEFT)) (NOT (SETQ MIDDLEONLYFLG))) (AND MIDDLEONLYFLG (LASTMOUSESTATE (ONLY MIDDLE] (* left or middle selects.) (SK.ADD.SELECTION NOW WINDOW (SK.BUTTONEVENT.MARK COPYMODE DELETEMODE)) ) ((LASTMOUSESTATE RIGHT) (* right cause deselect.) (SK.REMOVE.SELECTION NOW WINDOW (SK.BUTTONEVENT.MARK COPYMODE DELETEMODE] (T (SETQ MOVEDMUCHFLG))) (SETQ PREVMOUSEBUTTONS LASTMOUSEBUTTONS)) ((COND (MOVEDMUCHFLG (OR (NEQ OLDX NEWX) (NEQ OLDY NEWY))) ((OR (IGREATERP (IABS (IDIFFERENCE ORIGX NEWX)) SK.NO.MOVE.DISTANCE) (IGREATERP (IABS (IDIFFERENCE ORIGY NEWY)) SK.NO.MOVE.DISTANCE)) (* make the first pick move further so that it is easier to multiple click.) (SETQ MOVEDMUCHFLG T))) (* cursor has moved more than the minimum amount since last noticed.) (* add or delete any with in the swept out area.) (SK.UPDATE.EVENT.SELECTION HOTSPOTCACHE ORIGX ORIGY NEWX NEWY SCALE WINDOW COPYMODE DELETEMODE))) (SETQ OLDX NEWX) (SETQ OLDY NEWY) (GO SELECTLP) EXIT (* clear the selections from the  window.) (for SEL in (WINDOWPROP WINDOW 'SKETCH.SELECTIONS) do (SK.REMOVE.SELECTION SEL WINDOW (SK.BUTTONEVENT.MARK COPYMODE DELETEMODE))) (SK.TAKE.MARKS.DOWN WINDOW HOTSPOTCACHE) (CLOSEPROMPTWINDOW WINDOW) (* if middle was the only button used to select, return only the text  characters.) (RETURN (AND RETURNVAL (COND [(TTY.PROCESSP (WINDOWPROP WINDOW 'PROCESS)) (* the results will be going to this  same window) (COND ((AND COPYMODE DELETEMODE) (* move the elements) (SK.MOVE.ELEMENTS RETURNVAL WINDOW)) [COPYMODE (* copy them) (COND (MIDDLEONLYFLG (* if middle only, just get the  characters.) (COPYINSERT (SK.BUILD.IMAGEOBJ RETURNVAL WINDOW T))) (T (SK.COPY.ELEMENTS RETURNVAL WINDOW] (DELETEMODE (* delete them) (SK.DELETE.ELEMENT RETURNVAL WINDOW] (T (COPYINSERT (SK.BUILD.IMAGEOBJ RETURNVAL WINDOW MIDDLEONLYFLG]) (SK.BUTTONEVENT.MARK [LAMBDA (COPYFLG DELETEFLG) (* rrb "29-Dec-84 19:02") (* returns the mark that should be put on the points when they are selected.) (COND (DELETEFLG (COND (COPYFLG MOVESELECTIONMARK) (T DELETESELECTIONMARK))) (T COPYSELECTIONMARK]) (SK.BUILD.IMAGEOBJ [LAMBDA (SCRELTS SKW CHARSONLYFLG) (* ; "Edited 20-Jun-92 15:28 by rmk:") (* builds an imageobj from the list  of screen elements.) (COND [CHARSONLYFLG (* return only the text characters.) (PROG ((TEXTELTS (bind GELT for LOCALSKELT in SCRELTS join (SELECTQ (fetch (GLOBALPART GTYPE) of (SETQ GELT (fetch (SCREENELT GLOBALPART) of LOCALSKELT))) (TEXT (LIST (LIST (fetch (TEXT LOCATIONLATLON) of (SETQ GELT (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GELT))) GELT))) (TEXTBOX (LIST (LIST (SK.TEXTBOX.TEXT.POSITION (SETQ GELT (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GELT))) GELT))) (SKIMAGEOBJ (* grab the imageobj too.) (LIST (LIST (create POSITION XCOORD _ [fetch (REGION LEFT) of (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION ) of (SETQ GELT (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GELT] YCOORD _ (fetch (REGION BOTTOM) of (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION ) of GELT))) GELT))) NIL))) CHARSLST) (* sort according to top from the  left.) [SORT TEXTELTS (FUNCTION (LAMBDA (A B) (COND [(GREATERP (fetch (POSITION YCOORD) of (SETQ A (CAR A))) (fetch (POSITION YCOORD) of (SETQ B (CAR B] ((EQUAL (fetch (POSITION YCOORD) of A) (fetch (POSITION YCOORD) of B)) (LESSP (fetch (POSITION XCOORD) of A) (fetch (POSITION XCOORD) of B] (RETURN (COND ((EQUAL [CAR (LAST (SETQ CHARSLST (for TEXTELT in TEXTELTS join (* collect relevant parts.) (COND [(EQ 'SKIMAGEOBJ (fetch ( INDIVIDUALGLOBALPART GTYPE) of (CADR TEXTELT))) (* copy image object so that copyfn is called.  This also copies the part of the image object that are sketch relevent  unnecessarily but it keeps copyfn call in one place.) (LIST (COPY.IMAGE.OBJECT (fetch (SKIMAGEOBJ SKIMAGEOBJ) of (CADR TEXTELT] (T (SK.ADD.SPACES (fetch (TEXT LISTOFCHARACTERS ) of (CADR TEXTELT ] " ") (* strip off the trailing EOL that  was added.) (BUTLAST CHARSLST)) (T CHARSLST] [(AND (NOT (CDR SCRELTS)) (EQ (fetch (GLOBALPART GTYPE) of (fetch (SCREENELT GLOBALPART) of (CAR SCRELTS))) 'SKIMAGEOBJ)) (* ;; "RMK: singelton imageobject. Return an unencapsulated copy of it. Don't need to worry about sketch transformations that might have applied, since they don't affect imageobjects.") (COPY.IMAGE.OBJECT (fetch (SKIMAGEOBJ SKIMAGEOBJ) of (FETCH (GLOBALPART INDIVIDUALGLOBALPART ) OF (fetch (SCREENELT GLOBALPART ) of (CAR SCRELTS ] (T (* return a sketch image object. The sketch is translated to bring its lower  left coordinate to 0,0 so that when it is put in a document it is in a  canonical place. Maybe don't need to do this anymore.) (SKETCH.IMAGEOBJ [create SKETCH using (INSURE.SKETCH SKW) SKETCHNAME _ NIL SKETCHELTS _ (SK.SORT.GELTS.BY.PRIORITY (bind GELT for LOCALSKELT in SCRELTS collect (COND ((EQ (fetch (GLOBALPART GTYPE) of (SETQ GELT (fetch (SCREENELT GLOBALPART) of LOCALSKELT ))) 'SKIMAGEOBJ) (* apply copy fn) (SK.COPY.IMAGEOBJ GELT)) (T (COPY GELT] (SK.GLOBAL.REGION.OF.LOCAL.ELEMENTS SCRELTS (VIEWER.SCALE SKW)) (VIEWER.SCALE SKW) (SK.GRIDFACTOR SKW]) (SK.BUTTONEVENT.OVERP [LAMBDA (COPYMODE DELETEMODE) (* rrb " 1-Feb-85 18:39") (* determines if this button event is over by looking at the keys that are held  down. COPYMODE and DELETEMODE indicate the keystate at the entry point.) (COND [DELETEMODE (AND (NOT (OR (.DELETEKEYDOWNP.) (.MOVEKEYDOWNP.))) (OR (NULL COPYMODE) (NULL (OR (.COPYKEYDOWNP.) (.MOVEKEYDOWNP.] (COPYMODE (NULL (.COPYKEYDOWNP.]) (SK.BUTTONEVENT.SAME.KEYS [LAMBDA (COPYMODE DELETEMODE) (* rrb " 1-Feb-85 18:39") (* determines if the same keys are held down now as were held down at the  start. If not, the event will be stopped.  COPYMODE and DELETEMODE indicate the keystate at the entry point.) (COND [DELETEMODE (AND (OR (.DELETEKEYDOWNP.) (.MOVEKEYDOWNP.)) (EQ COPYMODE (OR (.COPYKEYDOWNP.) (.MOVEKEYDOWNP.] (COPYMODE (* if we are not in delete mode, ignore the state of the delete key.) (.COPYKEYDOWNP.]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS .DELETEKEYDOWNP. MACRO [NIL (OR (KEYDOWNP 'CTRL) (KEYDOWNP 'DELETE]) (PUTPROPS .MOVEKEYDOWNP. MACRO (NIL (KEYDOWNP 'MOVE))) ) (* ; "fns for implementing the CHANGE command.") (DEFINEQ (SK.SEL.AND.CHANGE [LAMBDA (W) (* rrb "10-Dec-85 17:07") (* allows the user to select some elements and changes them.) (SK.CHANGE.THING (SK.SELECT.MULTIPLE.ITEMS W T NIL 'CHANGE) W]) (SK.CHECK.WHENCHANGEDFN [LAMBDA (VIEWER GELT PROPERTY NEWVALUE OLDVALUE) (* rrb " 3-Jan-86 18:36") (* checks if the sketch has a whenchange fn and if so, calls it and interprets  the result. Returns NIL if the change shouldn't be made.) (PROG ((SKETCH (INSURE.SKETCH VIEWER)) RESULT WHENCHANGEDFN) (COND ([NULL (SETQ WHENCHANGEDFN (GETSKETCHPROP SKETCH 'WHENCHANGEDFN] (RETURN GELT))) (SETQ RESULT (APPLY* WHENCHANGEDFN VIEWER GELT PROPERTY NEWVALUE OLDVALUE)) (COND ((EQ RESULT 'DON'T) (RETURN NIL)) (T (RETURN GELT]) (SK.CHECK.PRECHANGEFN [LAMBDA (VIEWER SCRELT CHANGESPEC) (* rrb "27-Jun-86 15:51") (* checks if the sketch has a prechange fn and if so, calls it and interprets  the result. Returns NIL if the change shouldn't be made.) (PROG ((SKETCH (INSURE.SKETCH VIEWER)) PRECHANGEFN) (COND ((SETQ PRECHANGEFN (GETSKETCHPROP SKETCH 'PRECHANGEFN)) (RETURN (APPLY* PRECHANGEFN VIEWER (fetch (SCREENELT GLOBALPART) of SCRELT) CHANGESPEC]) (SK.CHANGE.ELT [LAMBDA (W) (* rrb "31-Jan-86 10:46") (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.CHANGE (KWOTE W)) W]) (SK.CHANGE.THING [LAMBDA (ELTSTOCHANGE W) (* rrb " 6-Jan-85 19:23") (* ELTSTOCHANGE is a sketch element that was selected for a CHANGE operation.) (* Change according to the first one  on the list) (PROG (FIRSTTYPE READCHANGEFN) (* find the first thing that has a  change function.) (OR (for ELT in ELTSTOCHANGE when (AND [SETQ READCHANGEFN (SK.READCHANGEFN (SETQ FIRSTTYPE (fetch (SCREENELT GTYPE) of ELT] (NEQ READCHANGEFN 'NILL)) do (RETURN T)) (RETURN)) (RETURN (SK.APPLY.CHANGE.COMMAND (SK.CHANGEFN FIRSTTYPE) (APPLY* READCHANGEFN W ELTSTOCHANGE) ELTSTOCHANGE W]) (SKETCH.CHANGE.ELEMENTS [LAMBDA (ELEMENTS CHANGESPECS SKETCHTOUPDATE ADDHISTORY?) (* rrb " 2-Oct-86 16:38") (* Changes the elements ELEMENTS according to the change specifications  CHANGESPECs. If SKETCHTOUPDATE is a viewer or a sketch.  it will be updated. If ADDHISTORY is non-NIL, the changes will be added to the  history list of SKETCHTOUPDATE which should be a viewer.  CHANGESPECs can be a list of the line, brush, text or arc properties, e.g.  ((TEXT BOLD) (SIZE LARGER) (DASHING (3 1 2 1))%.  The changes will be applied to any elements for which they make sense.)) (PROG ((VIEWER (SK.VIEWER.FROM.SKETCH.ARG SKETCHTOUPDATE)) RESULT) (RETURN (SK.DO.AND.RECORD.CHANGES (for ELEMENT in ELEMENTS when (SETQ RESULT (SK.DO.CHANGESPECS ELEMENT CHANGESPECS VIEWER)) collect RESULT) VIEWER NIL NIL (NULL ADDHISTORY?]) (SK.APPLY.SINGLE.CHANGEFN [LAMBDA (GELEMENT CHANGEFN CHANGESPEC VIEWER) (* rrb " 2-Oct-86 10:49") (* applies a single change to an element.  It returns a change structure that contains the old and new elements.) (COND ((EQ (fetch (GLOBALPART GTYPE) of GELEMENT) 'GROUP) (* handle a group by propagating it) (SK.GROUP.CHANGEFN GELEMENT CHANGEFN CHANGESPEC VIEWER)) (T (APPLY* CHANGEFN GELEMENT CHANGESPEC VIEWER]) (SK.DO.CHANGESPECS [LAMBDA (ELEMENT CHANGESPECS VIEWER) (* rrb " 2-Oct-86 16:31") (* returns a change structure that is the combined effects of applying all  CHANGESPECS to ELEMENT.) (* for now, pretty kludgy) (PROG (NEWELEMENT) (COND ((NULL CHANGESPECS) NIL)) (for CHANGESPEC in CHANGESPECS do (SETQ NEWELEMENT (OR (SK.DO.CHANGESPEC1 (COND (NEWELEMENT (fetch (SKHISTORYCHANGESPEC NEWELT) of NEWELEMENT )) (T (* before one of the change specs applies, use the original element.) ELEMENT)) CHANGESPEC VIEWER) NEWELEMENT))) (RETURN (AND NEWELEMENT (create SKHISTORYCHANGESPEC OLDELT _ ELEMENT NEWELT _ (fetch (SKHISTORYCHANGESPEC NEWELT) of NEWELEMENT) PROPERTY _ CHANGESPECS]) (SK.VIEWER.FROM.SKETCH.ARG [LAMBDA (SKETCH) (* rrb " 2-Oct-86 10:57") (* returns the viewer that changes should be reflected in when SKETCH is passed  in as a sketch argument.) (COND ((NULL SKETCH) NIL) ((WINDOWP SKETCH)) ((SETQ SKETCH (INSURE.SKETCH SKETCH)) (CAR (ALL.SKETCH.VIEWERS SKETCH]) (SK.DO.CHANGESPEC1 [LAMBDA (ELEMENT CHANGESPEC VIEWER) (* rrb "23-Oct-86 14:21") (* applies a single change spec to a  single element.) (PROG (CHANGEASPECTFN (CHANGEHOW (CADR CHANGESPEC))) (OR (SETQ CHANGEASPECTFN (SELECTQ (CAR CHANGESPEC) (SIZE (FUNCTION SK.CHANGE.BRUSH.SIZE)) (SHAPE (FUNCTION SK.CHANGE.BRUSH.SHAPE)) (ARROW (FUNCTION SK.CHANGE.ARROWHEAD)) (FILLING (FUNCTION SK.CHANGE.FILLING)) (DASHING (FUNCTION SK.CHANGE.DASHING)) (ANGLE (FUNCTION SK.CHANGE.ANGLE)) (DIRECTION (FUNCTION SK.CHANGE.ARC.DIRECTION)) ((TEXT NEWFONT SETSIZE SAME FAMILY&SIZE) (SETQ CHANGEHOW CHANGESPEC) (FUNCTION SK.CHANGE.TEXT)) (ADDPOINT (* handle this specially because it shouldn't go inside of a group element.) (RETURN (SK.ADD.KNOT.TO.ELEMENT ELEMENT CHANGEHOW))) (BRUSHCOLOR (FUNCTION SK.CHANGE.BRUSH.COLOR)) (FILLINGCOLOR (FUNCTION SK.CHANGE.FILLING.COLOR)) (FILLINGMODE (FUNCTION SK.CHANGE.FILLING.MODE)) NIL)) (RETURN)) (RETURN (SK.APPLY.SINGLE.CHANGEFN ELEMENT CHANGEASPECTFN CHANGEHOW VIEWER]) (SK.CHANGEFN [LAMBDA (ELEMENTTYPE) (* rrb " 8-Jan-86 17:15") (* returns the changefn for an element. The only one that isnt  SK.ELEMENTS.CHANGEFN is image objects.) (* the changefn should return a list  of SKHISTORYCHANGESPEC instances.) (OR (fetch (SKETCHTYPE CHANGEFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE)) (FUNCTION SK.DEFAULT.CHANGEFN]) (SK.READCHANGEFN [LAMBDA (ELEMENTTYPE) (* rrb " 6-Jan-85 18:29") (* used to be (OR & (FUNCTION SK.DEFAULT.CHANGEFN)) If this really isn't  necessary, clean out SK.DEFAULT.CHANGEFN and all the things only it calls.  If it is necessary, update it to include a readchangefn.) (fetch (SKETCHTYPE READCHANGEFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) (SK.DEFAULT.CHANGEFN [LAMBDA (SCRNELT W FIELD) (* rrb "14-May-84 15:57") (PROG ([FIELD (OR FIELD (SK.MENU.AND.RETURN.FIELD (fetch (SCREENELT GTYPE) of SCRNELT] (INDVELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of SCRNELT)) (NOSETVALUE "str") CURRENTVAL NEWPROPVALUE FIELDNAME) (COND ((NULL FIELD) (STATUSPRINT W "That element doesn't have any changeable parts.") (RETURN NIL))) (SETQ CURRENTVAL (RECORDACCESS (SETQ FIELDNAME (COND ((LISTP FIELD) (CAR FIELD)) (T FIELD))) INDVELT (RECLOOK (fetch (SCREENELT GTYPE) of SCRNELT)) 'FETCH)) [COND ((LISTP FIELD) (* cadr is queryfunction which can do special input and return value checking.) (SETQ NEWPROPVALUE (APPLY* (CADR FIELD) SCRNELT FIELD W NOSETVALUE))) (T (* have NIL returned be no change.) (SETQ NEWPROPVALUE (OR (READ.FUNCTION [CONCAT "Enter new " (MKSTRING FIELD) " value. Current value is " (MKSTRING (RECORDACCESS FIELD INDVELT (RECLOOK (fetch (SCREENELT GTYPE) of SCRNELT)) 'FETCH] W) NOSETVALUE] (OR (EQ NEWPROPVALUE NOSETVALUE) (RECORDACCESS FIELDNAME INDVELT (RECLOOK (fetch (SCREENELT GTYPE) of SCRNELT)) 'REPLACE (EVAL NEWPROPVALUE))) (RETURN (fetch (SCREENELT GLOBALPART) of SCRNELT]) (CHANGEABLEFIELDITEMS [LAMBDA (ELEMENTTYPE) (* rrb "11-May-84 15:49") (* returns the list of fields that element type allows to change.  Each field should be of the form (FIELDNAMELABEL  (QUOTE (FIELDNAME QUERYFN)) "helpstring") -  QUERYFN should be a function of four args%: the screen element being changed,  the "field" returned from this function, the window the sketch is being  displayed in, and a value to be returned if no change should be made.) (GETPROP ELEMENTTYPE 'CHANGEABLEFIELDITEMS]) (SK.APPLY.CHANGE.COMMAND [LAMBDA (CHANGEFN COMMAND SCRELTS SKW) (* rrb "24-Sep-86 16:23") (* applies a change command to the relevant elements in SCRELTS.) (AND COMMAND (SK.DO.AND.RECORD.CHANGES (bind ELTCHANGE for SCRELT in SCRELTS when (SETQ ELTCHANGE (SK.APPLY.CHANGE.COMMAND1 CHANGEFN COMMAND SCRELT SKW)) collect ELTCHANGE) SKW]) (SK.DO.AND.RECORD.CHANGES [LAMBDA (LSTOFCHANGESPECS VIEWER DONTUPDATEPRIORITYFLG DONTDISPLAYFLG DONTHISTORYFLG) (* rrb " 2-Oct-86 16:22") (* accepts a list of change specs and actually updates the sketch, viewer and  history list.) (COND (LSTOFCHANGESPECS [SETQ LSTOFCHANGESPEC (COND (DONTUPDATEPRIORITYFLG (* priority of new ones won't change,  order by them.) (SORT.CHANGESPECS.BY.NEW.PRIORITY LSTOFCHANGESPECS)) (T (* order so that new priorities are assigned in the same relative order as the  old ones.) (SORT.CHANGESPECS.BY.OLD.PRIORITY LSTOFCHANGESPECS] (SK.UPDATE.ELEMENTS LSTOFCHANGESPECS VIEWER DONTUPDATEPRIORITYFLG DONTDISPLAYFLG) (OR DONTHISTORYFLG (SK.ADD.HISTEVENT 'CHANGE LSTOFCHANGESPECS VIEWER)) T]) (SK.APPLY.CHANGE.COMMAND1 [LAMBDA (CHANGEFN COMMAND SCRELT VIEWER) (* rrb "27-Jun-86 15:48") (* applies a change command to a single screen element.  Does the prechangefn and whenchangefn checks.) (PROG (FNRESULT CHANGES) (COND ((EQ (SETQ FNRESULT (SK.CHECK.PRECHANGEFN VIEWER SCRELT COMMAND)) 'DON'T) (RETURN NIL)) ((LISTP FNRESULT) (* result was a different change  specification.) (SETQ COMMAND FNRESULT))) (* code was written to take a list but since prechangefn can change things at  the elements level, every element is done individually.) (OR (SETQ CHANGES (APPLY* CHANGEFN (LIST SCRELT) VIEWER COMMAND)) (RETURN)) (SETQ CHANGES (CAR CHANGES)) (RETURN (AND (SK.CHECK.WHENCHANGEDFN VIEWER (fetch (SKHISTORYCHANGESPEC OLDELT) of CHANGES) (fetch (SKHISTORYCHANGESPEC PROPERTY) of CHANGES) (fetch (SKHISTORYCHANGESPEC NEWVALUE) of CHANGES) (fetch (SKHISTORYCHANGESPEC OLDVALUE) of CHANGES)) CHANGES]) (SK.ELEMENTS.CHANGEFN [LAMBDA (SCRELTS SKW HOW) (* rrb " 2-Oct-86 16:18") (* changefn for many sketch elements.) (PROG (CHANGEASPECTFN (CHANGEHOW (CADR HOW))) (OR (SETQ CHANGEASPECTFN (SELECTQ (CAR HOW) (SIZE (FUNCTION SK.CHANGE.BRUSH.SIZE)) (SHAPE (FUNCTION SK.CHANGE.BRUSH.SHAPE)) (ARROW (FUNCTION SK.CHANGE.ARROWHEAD)) (FILLING (FUNCTION SK.CHANGE.FILLING)) (DASHING (FUNCTION SK.CHANGE.DASHING)) (ANGLE (FUNCTION SK.CHANGE.ANGLE)) (DIRECTION (FUNCTION SK.CHANGE.ARC.DIRECTION)) ((TEXT NEWFONT SETSIZE SAME FAMILY&SIZE) (SETQ CHANGEHOW HOW) (FUNCTION SK.CHANGE.TEXT)) (ADDPOINT (* handle this specially because it only works on the first element.) (RETURN (LIST (SK.ADD.KNOT.TO.ELEMENT (fetch (SCREENELT GLOBALPART) of (CAR SCRELTS)) CHANGEHOW)))) (BRUSHCOLOR (FUNCTION SK.CHANGE.BRUSH.COLOR)) (FILLINGCOLOR (FUNCTION SK.CHANGE.FILLING.COLOR)) (FILLINGMODE (FUNCTION SK.CHANGE.FILLING.MODE)) NIL)) (RETURN)) (RETURN (for SCRELT in SCRELTS collect (SK.APPLY.SINGLE.CHANGEFN (fetch (SCREENELT GLOBALPART) of SCRELT) CHANGEASPECTFN CHANGEHOW SKW]) (READ.POINT.TO.ADD [LAMBDA (SCRELT SKVIEWER) (* rrb "20-May-86 10:52") (* asks where a point should be added and where it should be.  Return a list (AfterPt NewPt)) (PROG (AFTERPT NEWPT) (STATUSPRINT SKVIEWER "Select the point that the new point should follow.") (OR (SETQ AFTERPT (SK.SELECT.ITEM SKVIEWER NIL (LIST SCRELT))) (PROGN (CLOSEPROMPTWINDOW SKVIEWER) (RETURN))) (STATUSPRINT SKVIEWER "Indicate where the new point should be.") (SETQ NEWPT (SK.READ.POINT.WITH.FEEDBACK SKVIEWER POINTREADINGCURSOR NIL NIL NIL NIL SKETCH.USE.POSITION.PAD)) (CLOSEPROMPTWINDOW SKVIEWER) (AND NEWPT (RETURN (LIST (GLOBAL.KNOT.FROM.LOCAL AFTERPT SCRELT) (SK.MAP.INPUT.PT.TO.GLOBAL NEWPT SKVIEWER]) (GLOBAL.KNOT.FROM.LOCAL [LAMBDA (LOCALKNOT SCRELT) (* rrb "20-Nov-85 11:05") (* returns the global knot that corresponds to a local one.) (for LKNOT in (fetch (SCREENELT HOTSPOTS) of SCRELT) as GKNOT in (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of SCRELT) 'DATA) when (EQUAL LKNOT LOCALKNOT) do (RETURN GKNOT]) (SK.ADD.KNOT.TO.ELEMENT [LAMBDA (GELTWITHKNOTS PTS) (* rrb "16-Jan-86 12:23") (* adds a point to a knot element. The point  (CADR PTS) is added after (CAR PTS)) (PROG ((OLDKNOTS (GETSKETCHELEMENTPROP GELTWITHKNOTS 'DATA)) NEWKNOTS) [SETQ NEWKNOTS (for KNOT in OLDKNOTS join (COND ((EQUAL KNOT (CAR PTS)) (LIST KNOT (CADR PTS))) (T (LIST KNOT] (RETURN (create SKHISTORYCHANGESPEC NEWELT _ (SK.CHANGE.ELEMENT.KNOTS GELTWITHKNOTS NEWKNOTS) OLDELT _ GELTWITHKNOTS PROPERTY _ 'DATA NEWVALUE _ NEWKNOTS OLDVALUE _ OLDKNOTS]) (SK.GROUP.CHANGEFN [LAMBDA (GROUPELT CHANGEASPECTFN CHANGEHOW SKW) (* rrb "10-Jan-86 12:15") (* maps a change function through all the elements of a group and returns a  change spec event if it takes on any of them.) (PROG (NEWELT) (SETQ NEWELT (SK.GROUP.CHANGEFN1 GROUPELT CHANGEASPECTFN CHANGEHOW SKW)) (OR NEWELT (RETURN)) (RETURN (create SKHISTORYCHANGESPEC NEWELT _ NEWELT OLDELT _ GROUPELT PROPERTY _ 'DATA NEWVALUE _ (fetch (GROUP LISTOFGLOBALELTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of NEWELT)) OLDVALUE _ (fetch (GROUP LISTOFGLOBALELTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GROUPELT]) (SK.GROUP.CHANGEFN1 [LAMBDA (GROUPELT CHANGEASPECTFN CHANGEHOW SKW) (* rrb "27-Jun-86 16:19") (* maps a change function through all the elements of a group and returns a new  element if it takes on any of them.) (PROG ((OLDSUBELTS (fetch (GROUP LISTOFGLOBALELTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GROUPELT))) NEWSUBELTS NEWELT CHANGEDFLG) [SETQ NEWSUBELTS (for SUBELT in OLDSUBELTS collect (COND ([SETQ NEWELT (COND ((EQ (fetch (GLOBALPART GTYPE) of SUBELT) 'GROUP) (* handle a group by propagating it) (SK.GROUP.CHANGEFN1 SUBELT CHANGEASPECTFN CHANGEHOW SKW)) (T (* individual change functions return a change spec event, pull the new element  out of it. This throws aways a lot of information about what was changed but I  don't know any good way to save it so that it can be passed on undoing so don't  save it.) (fetch (SKHISTORYCHANGESPEC NEWELT) of (APPLY* CHANGEASPECTFN SUBELT CHANGEHOW SKW] (SETQ CHANGEDFLG T) NEWELT] (OR CHANGEDFLG (RETURN)) [SETQ NEWSUBELTS (for OLDSUBELT in OLDSUBELTS as NEWSUBELT in NEWSUBELTS collect (* copy any unchanged elements so that user programs don't have to worry about  them.) (OR NEWSUBELT (SK.COPY.GLOBAL.ELEMENT OLDSUBELT] (RETURN (SK.UPDATE.GROUP.AFTER.CHANGE (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART ) of GROUPELT) INDIVIDUALGLOBALPART _ (create GROUP using (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GROUPELT) LISTOFGLOBALELTS _ NEWSUBELTS]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD SKHISTORYCHANGESPEC (OLDELT NEWELT PROPERTY NEWVALUE OLDVALUE)) ) ) (* ; "fns for adding elements") (DEFINEQ (ADD.ELEMENT.TO.SKETCH [LAMBDA (GELT SKETCH) (* rrb "23-Jun-87 13:29") (* changes the global sketch) (PROG [(REALSKETCH (INSURE.SKETCH SKETCH)) (ELTPRI (\GETSKETCHELEMENTPROP1 GELT 'PRI] [COND ((EQ (fetch (GLOBALPART GTYPE) of GELT) 'SKIMAGEOBJ) (* call the wheninsertedfn for this imageobj if there is one.) (PROG ((IMOBJ (fetch (SKIMAGEOBJ SKIMAGEOBJ) of (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GELT))) DATUM) (COND ((AND (SETQ DATUM (IMAGEOBJPROP IMOBJ 'WHENINSERTEDFN)) (NEQ DATUM 'NILL)) (* call the image objects insertfn.) (APPLY* DATUM IMOBJ (SK.VIEWER.FROM.SKETCH.ARG SKETCH) NIL SKETCH))) (RETURN] (COND ((NULL ELTPRI) (* give the element a priority and put it at the end) (SK.SET.ELEMENT.PRIORITY GELT (SK.POP.NEXT.PRIORITY REALSKETCH)) (TCONC (fetch (SKETCH SKETCHTCELL) of REALSKETCH) GELT)) (T (SK.ADD.PRIORITY.ELEMENT.TO.SKETCH SKETCH GELT ELTPRI))) (SK.MARK.DIRTY REALSKETCH]) (ADD.SKETCH.VIEWER [LAMBDA (SKETCH VIEWER) (* rrb " 8-APR-83 17:56") (* adds VIEWER as a viewer of SKETCH.) (PROG (VIEWERS) (COND ((SETQ VIEWERS (ALL.SKETCH.VIEWERS SKETCH)) (* already has at least one viewer) (OR (FMEMB VIEWER VIEWERS) (NCONC1 VIEWERS VIEWER))) (T (* doesn't have any viewers yet.) (SETQ ALL.SKETCHES (CONS (LIST SKETCH VIEWER) ALL.SKETCHES]) (REMOVE.SKETCH.VIEWER [LAMBDA (SKETCH VIEWER) (* rrb "26-Apr-85 16:56") (* removes VIEWER as a viewer of  SKETCH.) (PROG (VIEWERS) (COND ((SETQ VIEWERS (VIEWER.BUCKET SKETCH)) (* remove it from the list.) (COND ((NULL (CDR (DREMOVE VIEWER VIEWERS))) (* deleted the last viewer.) (SETQ ALL.SKETCHES (REMOVE VIEWERS ALL.SKETCHES]) (ALL.SKETCH.VIEWERS [LAMBDA (SKETCH) (* rrb " 8-APR-83 14:20") (* returns the list of all active viewers of a sketch) (CDR (VIEWER.BUCKET SKETCH]) (SKETCH.ALL.VIEWERS [LAMBDA (SKETCH) (* returns all of the viewers onto a  sketch.) (ALL.SKETCH.VIEWERS (INSURE.SKETCH SKETCH]) (VIEWER.BUCKET [LAMBDA (SKETCH) (* rrb " 8-APR-83 14:20") (FASSOC SKETCH ALL.SKETCHES]) (ELT.INSIDE.REGION? [LAMBDA (GLOBALPART WORLDREG) (* rrb " 4-AUG-83 14:51") (* determines if any part of an element is inside the region WORLDREG) (APPLY* (SK.INSIDEFN (fetch (GLOBALPART GTYPE) of GLOBALPART)) GLOBALPART WORLDREG]) (ELT.INSIDE.SKWP [LAMBDA (GLOBALPART SKETCHW) (* rrb "25-Nov-85 17:46") (* determines if a global element is in the world region of a map window.) (ELT.INSIDE.REGION? GLOBALPART (SKETCH.REGION.VIEWED SKETCHW]) (SCALE.FROM.SKW [LAMBDA (WINDOW) (* rrb "11-MAR-83 11:52") (* gets the scale of a sketch window.) (WINDOWPROP WINDOW 'SCALE]) (SK.ADDELT.TO.WINDOW [LAMBDA (PELT SKETCHW) (* rrb "10-Mar-86 14:56") (* adds a picture element to a sketch window.  Returns the element that was added.) (COND (PELT (SK.ADD.PRIORITY.LOCAL.ELEMENT.TO.SKETCH (WINDOWPROP SKETCHW 'SKETCHSPECS) PELT) [PROG ((CACHE (SK.HOTSPOT.CACHE SKETCHW))) (COND (CACHE (* if there is a cache, adding an element will change it) (SK.ADD.HOTSPOTS.TO.CACHE1 PELT CACHE)) (T (* if this is the first, must set the window property too.) (SK.SET.HOTSPOT.CACHE SKETCHW (SK.ADD.HOTSPOTS.TO.CACHE1 PELT CACHE] PELT]) (SK.CALC.REGION.VIEWED [LAMBDA (WINDOW SCALE) (* rrb "29-APR-83 08:37") (* returns the region of the sketch  visible in window.) (UNSCALE.REGION (DSPCLIPPINGREGION NIL WINDOW) SCALE]) (SK.DRAWFIGURE [LAMBDA (SCREENELT STREAM REGION SCALE) (* rrb "30-Aug-84 14:31") (* draws an element of a sketch in a window.  Makes sure the scale of the current drawing is with in the limits of the  element. Returns SCREENELT) (PROG (GLOBALPART) [COND ([AND (NUMBERP SCALE) (OR [LESSP SCALE (fetch (COMMONGLOBALPART MINSCALE) of (SETQ GLOBALPART (fetch (SCREENELT COMMONGLOBALPART ) of SCREENELT] (GREATERP SCALE (fetch (COMMONGLOBALPART MAXSCALE) of GLOBALPART] (* scale is out of bounds, don't draw  it.) NIL) (T (SK.DRAWFIGURE1 SCREENELT STREAM (OR REGION (DSPCLIPPINGREGION NIL STREAM] (RETURN SCREENELT]) (SK.DRAWFIGURE1 [LAMBDA (ELT SKW REGION) (* rrb "14-Sep-84 16:59") (* displays a sketch element in a  window) (APPLY* (SK.DRAWFN (fetch (SCREENELT GTYPE) of ELT)) ELT SKW REGION]) (SK.LOCAL.FROM.GLOBAL [LAMBDA (GELT SKSTREAM SCALE) (* rrb "11-Jul-86 15:56") (* returns the element instance of the global element GELT expanded into the  window SKW.) (* SKSTREAM can be deleted from call once TEXT.EXPANDFN no longer needs to  distinquish INTERPRESS stream from windows.) (PROG ((SCRELT (APPLY* (SK.EXPANDFN (fetch (GLOBALPART GTYPE) of GELT)) GELT (OR (NUMBERP SCALE) (VIEWER.SCALE SKSTREAM)) SKSTREAM)) ACTIVEREGION) (* do the ACTIVEREGION which is common  to all elements.) [AND SCRELT (SETQ ACTIVEREGION (GETSKETCHELEMENTPROP GELT 'ACTIVEREGION)) (replace (LOCALPART LOCALHOTREGION) of (fetch (SCREENELT LOCALPART) of SCRELT) with (SK.SCALE.REGION ACTIVEREGION (OR (NUMBERP SCALE) (VIEWER.SCALE SKSTREAM] (RETURN SCRELT]) (SKETCH.REGION.VIEWED [LAMBDA (VIEWER NEWREGION) (* rrb "23-Apr-87 12:20") (* returns the region in sketch coordinates of the area visible in SKETCHW.) (COND [(IMAGEOBJP VIEWER) (* it is a sketch image object) (PROG ([SK? (LISTP (IMAGEOBJPROP VIEWER 'OBJECTDATUM] NEWVIEW) (COND [(type? SKETCH (FETCH (SKETCHIMAGEOBJ SKIO.SKETCH) OF SK?)) (RETURN (PROG1 (fetch (SKETCHIMAGEOBJ SKIO.REGION) of SK?) (COND (NEWREGION (COND ((REGIONP NEWREGION) (replace (SKETCHIMAGEOBJ SKIO.REGION) of SK? with NEWREGION)) ((SETQ NEWVIEW (SKETCH.VIEW.FROM.NAME NEWREGION VIEWER)) (replace (SKETCHIMAGEOBJ SKIO.REGION) of SK? with NEWVIEW)) ((EQ NEWREGION 'HOME) (* change scale to 1.0 and set lower left of region viewed to  (0,0)%.) NIL) (T (* HOME and named views aren't supported for image object sketches.) (\ILLEGAL.ARG NEWREGION] (T (ERROR "not a sketch image object" VIEWER] [(WINDOWP VIEWER) (PROG1 (WINDOWPROP VIEWER 'REGION.VIEWED) (COND (NEWREGION (PROG (NEWVIEW) (RETURN (COND ((REGIONP NEWREGION) (SKETCH.GLOBAL.REGION.ZOOM VIEWER NEWREGION)) ((EQ NEWREGION 'HOME) (SKETCH.HOME VIEWER)) ((SETQ NEWVIEW (SKETCH.VIEW.FROM.NAME NEWREGION VIEWER)) (SK.MOVE.TO.VIEW VIEWER NEWVIEW)) (T (\ILLEGAL.ARG NEWREGION] (T (\ILLEGAL.ARG VIEWER]) (SKETCH.VIEW.FROM.NAME [LAMBDA (VIEWNAME SKETCHW) (* rrb "25-Nov-85 17:55") (* returns the view structure for a view given its name.) (for SAVEDVIEW in (GETSKETCHPROP (INSURE.SKETCH SKETCHW) 'VIEWS) when (EQUAL VIEWNAME (fetch (SKETCHVIEW VIEWNAME) of SAVEDVIEW)) do (RETURN SAVEDVIEW]) (SK.UPDATE.REGION.VIEWED [LAMBDA (SKW) (* rrb "11-Jul-86 15:51") (* updates the REGION.VIEWED property  of a window.) (WINDOWPROP SKW 'REGION.VIEWED (SK.CALC.REGION.VIEWED SKW (VIEWER.SCALE SKW]) (SKETCH.ADD.AND.DISPLAY [LAMBDA (GELT SKETCHW DONTCLEARCURSOR) (* rrb "14-Nov-84 17:12") (* adds a new element to a sketch window and handles propagation to all other  figure windows) (COND (GELT (SK.ADD.HISTEVENT 'ADD (LIST GELT) SKETCHW) (SK.ADD.ELEMENT GELT SKETCHW DONTCLEARCURSOR]) (SKETCH.ADD.AND.DISPLAY1 [LAMBDA (GELT SKETCHW SCALE NODISPLAYFLG) (* rrb "11-Jul-86 15:51") (* displays a sketch element and adds it to the window.) (COND (GELT (COND (NODISPLAYFLG (SK.ADD.ITEM GELT SKETCHW)) (T (SK.DRAWFIGURE (SK.ADD.ITEM GELT SKETCHW) SKETCHW NIL (OR SCALE (VIEWER.SCALE SKETCHW]) (SK.ADD.ITEM [LAMBDA (GELT SKETCHW) (* rrb "10-APR-83 13:38") (* adds a global element to a window. Returns the local element that was  actually added.) (SK.ADDELT.TO.WINDOW (SK.LOCAL.FROM.GLOBAL GELT SKETCHW) SKETCHW]) (SKETCHW.ADD.INSTANCE [LAMBDA (TYPE SKW) (* rrb "14-Nov-84 17:08") (* reads an instance of type TYPE from the user and displays it in SKW.) (PROG ((ELT (SK.INPUT TYPE SKW))) (AND ELT (SKETCH.ADD.AND.DISPLAY ELT SKW)) (RETURN ELT]) ) (* ; "fns for deleting things") (DEFINEQ (SK.SEL.AND.DELETE [LAMBDA (W) (* rrb "10-Dec-85 17:08") (* lets the user select elements and  deletes them) (SK.DELETE.ELEMENT (SK.SELECT.MULTIPLE.ITEMS W T NIL 'DELETE) W]) (SK.ERASE.AND.DELETE.ITEM [LAMBDA (SELELT SKW NODISPLAYFLG) (* rrb "30-Jul-85 15:36") (* removes a sketch element from a  viewer.) (COND (SELELT (OR NODISPLAYFLG (SK.ERASE.ELT SELELT SKW)) (SK.DELETE.ITEM SELELT SKW]) (REMOVE.ELEMENT.FROM.SKETCH [LAMBDA (GELT SKETCH INSIDEGROUPFLG) (* rrb "26-Sep-86 13:24") (* changes the global sketch Returns the element or the group element  containing the element if the element was found in the sketch.  If INSIDEGROUPFLG is T, it will go inside of groups.) (PROG ((SKETCHDATA (INSURE.SKETCH SKETCH))) (COND ((DELFROMTCONC (fetch (SKETCH SKETCHTCELL) of SKETCHDATA) GELT) (SK.MARK.DIRTY SKETCH) (RETURN T)) [INSIDEGROUPFLG (RETURN (for ELT on (fetch (SKETCH SKETCHELTS) of SKETCHDATA) do (* look inside groups) (COND ((DELFROMGROUPELT GELT ELT) (SK.MARK.DIRTY SKETCH) (RETURN ELT] (T (RETURN NIL]) (SK.DELETE.ELEMENT [LAMBDA (ELTSTODEL SKETCHW ELTSFORHISTORY) (* rrb "30-Dec-85 16:19") (* deletes a list of element to a sketch window and handles propagation to all  other figure windows) (SKED.CLEAR.SELECTION SKETCHW) (AND ELTSTODEL (SK.DELETE.ELEMENT2 (for SCRELT in ELTSTODEL collect (fetch (SCREENELT GLOBALPART) of SCRELT)) SKETCHW ELTSFORHISTORY]) (SK.DELETE.ELEMENT2 [LAMBDA (GELTSTODEL SKETCHW ELTSFORHISTORY) (* rrb "30-Dec-85 16:18") (* deletes a list of global elements and adds it to the history list depending  upon ELTSFORHISTORY) (PROG (DELETEDELTS) (SETQ DELETEDELTS (SK.CHECK.WHENDELETEDFN SKETCHW GELTSTODEL)) (OR DELETEDELTS (RETURN)) (OR (EQ ELTSFORHISTORY 'DON'T) (SK.ADD.HISTEVENT 'DELETE (OR ELTSFORHISTORY DELETEDELTS) SKETCHW)) (for GELT in DELETEDELTS do (SK.DELETE.ELEMENT1 GELT SKETCHW)) (RETURN DELETEDELTS]) (SK.DELETE.KNOT [LAMBDA (W) (* rrb "31-Jan-86 10:47") (* lets the user select a knot in a curve or wire and deletes it.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.DELETE.KNOT (KWOTE W)) W]) (SK.SEL.AND.DELETE.KNOT [LAMBDA (W) (* rrb "10-Dec-85 17:03") (* lets the user select a knot and  deletes it.) (PROG [(KNOTELTS (SUBSET (LOCALSPECS.FROM.VIEWER W) (FUNCTION (LAMBDA (SCRELT) (AND (MEMB (fetch (SCREENELT GTYPE) of SCRELT) '(WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE)) (NOT (SK.ELEMENT.PROTECTED? (fetch (SCREENELT GTYPE) of SCRELT) 'CHANGE] (COND ((NULL KNOTELTS) (STATUSPRINT W "There are no curve or wire elements to delete points from.") (RETURN))) (SK.DELETE.ELEMENT.KNOT (SK.SELECT.ITEM W NIL KNOTELTS) KNOTELTS W]) (SK.DELETE.ELEMENT.KNOT [LAMBDA (LOCALKNOT SCRELTS SKW) (* rrb " 9-Jan-86 19:45") (* deletes a knot from a curve or wire  element.) (SKED.CLEAR.SELECTION SKW) (COND ((NULL LOCALKNOT)) ([OR (POSITIONP LOCALKNOT) (AND (NULL (CDR LOCALKNOT)) (POSITIONP (CAR LOCALKNOT)) (SETQ LOCALKNOT (CAR LOCALKNOT] (PROG ((SCREENELT (for SKELT in SCRELTS when (MEMBER LOCALKNOT (fetch (SCREENELT HOTSPOTS) of SKELT)) do (RETURN SKELT))) LOCALKNOTS GLOBALKNOT GLOBALKNOTS NEWKNOTS NEWELT CHANGES GLOBALPART) (COND ((NULL SCREENELT) (RETURN NIL))) (SETQ GLOBALPART (fetch (SCREENELT GLOBALPART) of SCREENELT)) (SETQ GLOBALKNOT (for LKNOT in (SETQ LOCALKNOTS (fetch (SCREENELT HOTSPOTS) of SCREENELT)) as GKNOT in (SETQ GLOBALKNOTS (GETSKETCHELEMENTPROP GLOBALPART 'DATA)) when (EQUAL LKNOT LOCALKNOT) do (RETURN GKNOT))) (OR (SK.CHECK.WHENPOINTDELETEDFN SKW SCREENELT GLOBALKNOT) (RETURN)) (RETURN (COND [(SETQ NEWKNOTS (REMOVE GLOBALKNOT GLOBALKNOTS)) (* change the knots and update the  element) (COND ((SETQ NEWELT (SK.CHANGE.ELEMENT.KNOTS GLOBALPART NEWKNOTS)) (* call the when changed fn) (OR (SK.CHECK.WHENCHANGEDFN SKW GLOBALPART 'DATA NEWKNOTS GLOBALKNOTS) (RETURN)) (* make history entry and update  screen) (SK.UPDATE.ELEMENTS (SETQ CHANGES (CONS (create SKHISTORYCHANGESPEC NEWELT _ NEWELT OLDELT _ GLOBALPART PROPERTY _ 'DATA NEWVALUE _ NEWKNOTS OLDVALUE _ GLOBALKNOTS))) SKW) (SK.ADD.HISTEVENT 'CHANGE CHANGES SKW] (T (* delete the whole element.) (SK.DELETE.ELEMENT (CONS SCREENELT) SKW]) (SK.CHECK.WHENDELETEDFN [LAMBDA (VIEWER GELTS) (* rrb "30-Dec-85 16:15") (* checks if the sketch has a when deleted fn and if so, creates the list of  global elements and interprets the result.  Returns a list of the elements that should be deleted.) (PROG ((SKETCH (INSURE.SKETCH VIEWER)) RESULT DELETEFN) (COND ([NULL (SETQ DELETEFN (GETSKETCHPROP SKETCH 'WHENDELETEDFN] (RETURN GELTS))) (SETQ RESULT (APPLY* DELETEFN VIEWER GELTS)) (COND ((EQ RESULT 'DON'T) (RETURN NIL)) ((LISTP RESULT) (RETURN RESULT)) (T (RETURN GELTS]) (SK.CHECK.PREEDITFN [LAMBDA (VIEWER OLDELT) (* rrb " 9-Dec-85 11:52") (* checks if the sketch has a preedit fn and if so, calls it) (PROG ((SKETCH (INSURE.SKETCH VIEWER)) PREEDITFN) (COND ([NULL (SETQ PREEDITFN (GETSKETCHPROP SKETCH 'PREEDITFN] (RETURN T))) (RETURN (NEQ (APPLY* PREEDITFN VIEWER OLDELT) 'DON'T]) (SK.CHECK.END.INITIAL.EDIT [LAMBDA (VIEWER NEWELT) (* rrb "15-Jan-86 15:20") (* called when the edit of a newly created text element is ended.  Calls the when changed fn.) (SK.CHECK.WHENCHANGEDFN VIEWER NEWELT 'DATA NIL (fetch (TEXT LISTOFCHARACTERS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWELT]) (SK.CHECK.WHENPOINTDELETEDFN [LAMBDA (VIEWER SCRELT CONTROLPOINT) (* rrb " 3-Jan-86 15:32") (* checks if the sketch has a prechange fn and if so, calls it and interprets  the result. Returns NIL if the point should not be deleted.) (PROG ((SKETCH (INSURE.SKETCH VIEWER)) RESULT PRECHANGEFN) (COND ([NULL (SETQ PRECHANGEFN (GETSKETCHPROP SKETCH 'PRECHANGEFN] (RETURN SCRELT))) (SETQ RESULT (APPLY* PRECHANGEFN VIEWER (LIST (fetch (SCREENELT GLOBALPART) of SCRELT)) (LIST 'DELETEPOINT CONTROLPOINT))) (COND ((EQ RESULT 'DON'T) (RETURN NIL)) (T (RETURN SCRELT]) (SK.ERASE.ELT [LAMBDA (ELT WINDOW REGION) (* rrb "30-Aug-86 15:08") (* erases a sketch element) (DSPOPERATION 'ERASE WINDOW) (SK.DRAWFIGURE ELT WINDOW REGION (VIEWER.SCALE WINDOW)) (DSPOPERATION 'PAINT WINDOW]) (SK.DELETE.ELT [LAMBDA (W) (* rrb "31-Jan-86 10:48") (* lets the user select an element and  deletes it.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.DELETE (KWOTE W)) W]) (SK.DELETE.ITEM [LAMBDA (ELT SKETCHW) (* rrb "12-May-85 18:10") (* deletes an element from a window) (COND (ELT (DELFROMTCONC (WINDOWPROP SKETCHW 'SKETCHSPECS) ELT) (SK.REMOVE.HOTSPOTS.FROM.CACHE1 ELT (SK.HOTSPOT.CACHE SKETCHW)) ELT]) (DELFROMTCONC [LAMBDA (TCONCCELL ELEMENT) (* rrb "26-Sep-86 13:24") (* deletes an element from a TCONC cell list.  Returns T if the element was deleted, NIL if it wasn't a member.) (COND ((EQ ELEMENT (CAAR TCONCCELL)) (* first element) [COND ((EQLENGTH (CAR TCONCCELL) 1) (* only one element) (RPLACA TCONCCELL NIL) (RPLACD TCONCCELL NIL)) (T (* remove first element.) (RPLACA TCONCCELL (CDAR TCONCCELL] T) ((EQ ELEMENT (CADR TCONCCELL)) (* elt to delete is the last one on the list, do special case.) (for TAIL on (CAR TCONCCELL) when (EQ (CDR TAIL) (CDR TCONCCELL)) do (* update the TCONC last entry) (RPLACD TCONCCELL TAIL) (* remove the last element) (RPLACD TAIL NIL) (RETURN)) T) (T (for TAIL on (CAR TCONCCELL) when (EQ ELEMENT (CADR TAIL)) do (RPLACD TAIL (CDDR TAIL)) (RETURN T) finally (RETURN NIL]) ) (* ; "fns for copying stuff") (DEFINEQ (SK.COPY.ELT [LAMBDA (W) (* rrb "31-Jan-86 10:49") (* lets the user select an element and  copies it.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.COPY (KWOTE W)) W]) (SK.SEL.AND.COPY [LAMBDA (W) (* rrb "10-Dec-85 17:08") (* lets the user select elements and  copies them.) (SK.COPY.ELEMENTS (SK.SELECT.MULTIPLE.ITEMS W T NIL 'COPY) W]) (SK.COPY.ELEMENTS [LAMBDA (SCRELTS SKW) (* rrb " 1-Oct-86 19:12") (* create a bitmap of the thing being moved and get its new position.  Then translate all the pieces.) (AND SCRELTS (PROG (FIGINFO FIRSTHOTSPOT GHOTSPOT LOWLFT NEWGPOS DELTAPOS NEWELTS COPYFN SKETCH COPYARGS COPYPLACEDYETFLG) (* call PRECOPYFN.) [AND (SETQ COPYFN (GETSKETCHPROP (SETQ SKETCH (INSURE.SKETCH SKW)) 'PRECOPYFN)) (SETQ DELTAPOS (APPLY* COPYFN SKW (SETQ COPYARGS (  SK.GLOBAL.FROM.LOCAL.ELEMENTS SCRELTS] [COND ((EQ DELTAPOS 'DON'T) (RETURN)) ((POSITIONP DELTAPOS) (* PRECOPYFN returned a position, don't bother to check for multiple copies.) (* value returned is the delta by which to move the point.  Set up new position) (RETURN (SK.ADD.COPY.OF.ELEMENTS SKW SCRELTS (OR COPYARGS (SETQ COPYARGS (  SK.GLOBAL.FROM.LOCAL.ELEMENTS SCRELTS))) DELTAPOS] (* read new position from the user) (SETQ FIGINFO (SK.FIGUREIMAGE SCRELTS (DSPCLIPPINGREGION NIL SKW))) (SETQ LOWLFT (fetch (SKFIGUREIMAGE SKFIGURE.LOWERLEFT) of FIGINFO)) [SETQ FIRSTHOTSPOT (CAR (fetch (SCREENELT HOTSPOTS) of (CAR SCRELTS] (SETQ GHOTSPOT (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of (CAR SCRELTS)) 'POSITION)) (* move the image by the first hotspot of the first element chosen.  This will align the image on the grid correctly.) PLACECOPYLP (COND ((SETQ NEWGPOS (SK.MAP.INPUT.PT.TO.GLOBAL [GET.BITMAP.POSITION SKW (fetch (SKFIGUREIMAGE SKFIGURE.BITMAP) of FIGINFO) 'PAINT "move the figure into place and press the left button." (FIXR (DIFFERENCE (fetch (POSITION XCOORD) of LOWLFT) (fetch (POSITION XCOORD) of FIRSTHOTSPOT ))) (FIXR (DIFFERENCE (fetch (POSITION YCOORD) of LOWLFT) (fetch (POSITION YCOORD) of FIRSTHOTSPOT ] SKW)) (CLOSEPROMPTWINDOW SKW)) (COPYPLACEDYETFLG (* already one copy down, close prompt window so user knows copy mode is over.) (CLOSEPROMPTWINDOW SKW) (RETURN NIL)) (T (STATUSPRINT SKW "Position was outside the window. Copy not placed.") (RETURN NIL))) [SETQ DELTAPOS (create POSITION XCOORD _ (DIFFERENCE (fetch (POSITION XCOORD) of NEWGPOS) (fetch (POSITION XCOORD) of GHOTSPOT)) YCOORD _ (DIFFERENCE (fetch (POSITION YCOORD) of NEWGPOS) (fetch (POSITION YCOORD) of GHOTSPOT] (SK.ADD.COPY.OF.ELEMENTS SKW SCRELTS (OR COPYARGS (SETQ COPYARGS (  SK.GLOBAL.FROM.LOCAL.ELEMENTS SCRELTS))) DELTAPOS) (COND ((.COPYKEYDOWNP.) (SETQ COPYPLACEDYETFLG T) (GO PLACECOPYLP)) (T (CLOSEPROMPTWINDOW SKW]) (SK.ADD.COPY.OF.ELEMENTS [LAMBDA (VIEWER SCRELEMENTS GLOBALELEMENTS NEWPOSDELTA) (* rrb " 1-Oct-86 19:13") (* internal function for copying elements.  Adds a copy of SCRELEMENTS moved by NEWPOSDELTA to VIEWER and calls the copyfn.) (PROG (SKETCH NEWELTS COPYFN X) (AND (SETQ COPYFN (GETSKETCHPROP (SETQ SKETCH (INSURE.SKETCH VIEWER)) 'WHENCOPIEDFN)) (SETQ X (APPLY* COPYFN VIEWER GLOBALELEMENTS NEWPOSDELTA))) (COND ((EQ X 'DON'T) (RETURN)) ((POSITIONP X) (* value returned is the position to put the copy.  Set up new position) (SETQ NEWPOSDELTA X))) [SETQ NEWELTS (SK.SORT.GELTS.BY.PRIORITY (COND ((AND (LISTP X) (EVERY X (FUNCTION GLOBALELEMENTP))) (* value returns was a list of new  global elements.) X) (T (MAPCOLLECTSKETCHSPECS SCRELEMENTS (FUNCTION SK.COPY.ITEM) NEWPOSDELTA VIEWER] (* add new elements to history list.) (SK.ADD.ELEMENTS NEWELTS VIEWER) (SK.ADD.HISTEVENT 'COPY NEWELTS VIEWER]) (SK.GLOBAL.FROM.LOCAL.ELEMENTS [LAMBDA (SCRELTS) (* returns the global elements from a list of screen elements) (for SCRELT in SCRELTS collect (fetch (SCREENELT GLOBALPART) of SCRELT]) (SK.COPY.ITEM [LAMBDA (SELELT GLOBALDELTAPOS W) (* rrb "24-Jun-87 15:12") (* SELELT is a sketch element that was selected for a copy operation.  GLOBALDELTAPOS is the amount the new item is to be offset from the old.) (PROG ((OLDGLOBAL (fetch (SCREENELT GLOBALPART) of SELELT))) [COND ((EQ (fetch (GLOBALPART GTYPE) of OLDGLOBAL) 'SKIMAGEOBJ) (* copying an image obj. Don't call its when copied fn.  was changed to call the WHENINSERTEDFN instead when it acutally gets  inserted.) (SETQ OLDGLOBAL (SK.COPY.IMAGEOBJ OLDGLOBAL W] (RETURN (SK.TRANSLATE.GLOBALPART OLDGLOBAL GLOBALDELTAPOS]) (SK.INSERT.SKETCH [LAMBDA (W SKETCH REGION SCALE) (* rrb "30-Sep-86 18:29") (* * inserts the sketch SKETCH into the sketch window W.  Called by the copy insert function for sketch windows.) (AND SKETCH (PROG (LOCALSCRELTS FIGINFO FIRSTHOTSPOT LOWLFT NEWPOS WINDOWSCALE NEWELTS) (* map inserted elements into new  coordinate space.) [COND ([NOT (EQUAL SCALE (SETQ WINDOWSCALE (VIEWER.SCALE W] (* change the scale of the sketch and  the region.) [SETQ SKETCH (create SKETCH using SKETCH SKETCHELTS _ (SK.TRANSFORM.GLOBAL.ELEMENTS (fetch (SKETCH SKETCHELTS) of SKETCH) (FUNCTION SK.SCALE.POSITION.INTO.VIEWER.EXACT) (QUOTIENT SCALE WINDOWSCALE] (SETQ REGION (SK.SCALE.REGION REGION (QUOTIENT SCALE WINDOWSCALE] (OR (SETQ LOCALSCRELTS (MAKE.LOCAL.SKETCH SKETCH NIL WINDOWSCALE W T)) (RETURN)) (SETQ FIGINFO (SK.FIGUREIMAGE LOCALSCRELTS REGION)) [SETQ FIRSTHOTSPOT (CAR (fetch (SCREENELT HOTSPOTS) of (CAR LOCALSCRELTS] (SETQ LOWLFT (fetch (SKFIGUREIMAGE SKFIGURE.LOWERLEFT) of FIGINFO)) (* move the image by the first hotspot of the first element chosen.  This will align the image on the grid correctly.) (COND ([SETQ NEWPOS (fetch (INPUTPT INPUT.POSITION) of (GET.BITMAP.POSITION W (fetch (SKFIGUREIMAGE SKFIGURE.BITMAP) of FIGINFO) 'PAINT "move the figure into place and press the left button." (IDIFFERENCE (fetch (POSITION XCOORD) of LOWLFT) (fetch (POSITION XCOORD) of FIRSTHOTSPOT)) (IDIFFERENCE (fetch (POSITION YCOORD) of LOWLFT) (fetch (POSITION YCOORD) of FIRSTHOTSPOT] (CLOSEPROMPTWINDOW W)) (T (STATUSPRINT W " " "Position was outside the window. Copy not placed.") (RETURN NIL))) (SETQ NEWELTS (MAPCOLLECTSKETCHSPECS LOCALSCRELTS (FUNCTION SK.COPY.ITEM) (SK.MAP.FROM.WINDOW.TO.NEAREST.GRID (create POSITION XCOORD _ (IDIFFERENCE (fetch (POSITION XCOORD) of NEWPOS) (fetch (POSITION XCOORD) of FIRSTHOTSPOT)) YCOORD _ (IDIFFERENCE (fetch (POSITION YCOORD) of NEWPOS) (fetch (POSITION YCOORD) of FIRSTHOTSPOT))) WINDOWSCALE) W)) (SK.ADD.ELEMENTS NEWELTS W) (SK.ADD.HISTEVENT 'COPY NEWELTS W) (RETURN NEWELTS]) ) (* ; "fns for moving things.") (DEFINEQ (SK.MOVE.ELT [LAMBDA (W) (* rrb "31-Jan-86 10:49") (* lets the user select one or more elements and move them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.MOVE (KWOTE W)) W]) (SK.MOVE.ELT.OR.PT [LAMBDA (W) (* rrb "31-Jan-86 10:49") (* lets the user select one or more elements and move them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.MOVE (KWOTE W) T) W]) (SK.APPLY.DEFAULT.MOVE [LAMBDA (W) (* rrb " 2-Jun-85 12:52") (* applies the default move mode which can be either points, elements or both.) (SELECTQ (fetch (SKETCHCONTEXT SKETCHMOVEMODE) of (WINDOWPROP W 'SKETCHCONTEXT)) (POINTS (SK.MOVE.POINTS W)) (ELEMENTS (SK.MOVE.ELT W)) (SK.MOVE.ELT.OR.PT W]) (SK.SEL.AND.MOVE [LAMBDA (W PTFLG) (* rrb "10-Dec-85 17:06") (* lets the user select either a control point or one or more elements and move  them.) (SK.MOVE.ELEMENTS [COND ((EQ PTFLG 'ONLY) (SK.SELECT.ITEM W NIL NIL 'MOVE)) (T (SK.SELECT.MULTIPLE.ITEMS W (NULL PTFLG) NIL 'MOVE] W]) (SK.MOVE.ELEMENTS [LAMBDA (SCRELTS SKW) (* rrb "11-Jul-86 15:51") (SKED.CLEAR.SELECTION SKW) (COND ((NULL SCRELTS)) [[OR (POSITIONP SCRELTS) (AND (NULL (CDR SCRELTS)) (POSITIONP (CAR SCRELTS)) (SETQ SCRELTS (CAR SCRELTS] (* user selected a point, move just  that point.) (PROG ((SKETCHELTS (SK.ELTS.FROM.HOTSPOT SCRELTS (SK.HOTSPOT.CACHE SKW))) SKETCHELT OTHERHOTSPOTS NEWPOS MOVEFN GDELTAPOS X MOVEARGS SKETCH) (COND ((NULL SKETCHELTS) (RETURN NIL)) ([NULL (SETQ SKETCHELT (for SCRELT in SKETCHELTS when (NOT (SK.ELEMENT.PROTECTED? (fetch (SCREENELT GLOBALPART) of SCRELT) 'MOVE)) do (RETURN SCRELT] (* only protected elements at this point, shouldn't happen but don't cause an  error.) (RETURN NIL))) [COND ([NULL (SETQ OTHERHOTSPOTS (REMOVE SCRELTS (fetch (SCREENELT HOTSPOTS) of SKETCHELT] (* only one control point, move it with the move element function.) (RETURN (SK.MOVE.ELEMENTS (LIST SKETCHELT) SKW] (* call sketch premovefn if given.) [AND (SETQ MOVEFN (GETSKETCHPROP (SETQ SKETCH (INSURE.SKETCH SKW)) 'PREMOVEFN)) (SETQ GDELTAPOS (APPLY* MOVEFN SKW (SETQ MOVEARGS (SK.MAKE.ELEMENT.MOVE.ARG SKETCHELT SCRELTS] [COND ((EQ GDELTAPOS 'DON'T) (RETURN)) ((POSITIONP GDELTAPOS) (* value returned is the delta by which to move the point.  Set up new position) NIL) (T (* read new position from the user) (for PT in OTHERHOTSPOTS do (MARKPOINT PT SKW OTHERCONTROLPOINTMARK)) (CURSORPOSITION SCRELTS SKW) (SETQ NEWPOS (SK.READ.POINT.WITH.FEEDBACK SKW NIL NIL NIL NIL NIL SKETCH.USE.POSITION.PAD)) (for PT in OTHERHOTSPOTS do (MARKPOINT PT SKW OTHERCONTROLPOINTMARK)) (* if user selected outside, don't  move anything.) (OR NEWPOS (RETURN NIL)) (* calculate the delta that the  selected point moves.) (SETQ GDELTAPOS (SK.MAP.FROM.WINDOW.TO.NEAREST.GRID (create POSITION XCOORD _ (IDIFFERENCE (fetch (POSITION XCOORD) of (fetch (INPUTPT INPUT.POSITION) of NEWPOS)) (fetch (POSITION XCOORD) of SCRELTS)) YCOORD _ (IDIFFERENCE (fetch (POSITION YCOORD) of (fetch (INPUTPT INPUT.POSITION) of NEWPOS)) (fetch (POSITION YCOORD) of SCRELTS))) (VIEWER.SCALE SKW] (AND (SETQ MOVEFN (GETSKETCHPROP SKETCH 'WHENMOVEDFN)) (SETQ X (APPLY* MOVEFN SKW (OR MOVEARGS (SK.MAKE.ELEMENT.MOVE.ARG SKETCHELT SCRELTS)) GDELTAPOS))) (COND ((EQ X 'DON'T) (RETURN)) ((POSITIONP X) (* value returned is the delta by which to move the point.  Set up new position) (SETQ GDELTAPOS X))) (RETURN (SK.MOVE.THING SKETCHELT SCRELTS GDELTAPOS SKW] (T (* create a bitmap of the thing being moved and get its new position.  Then translate all the pieces.) (PROG (FIGINFO FIRSTHOTSPOT NEWPOS LOWLFT IMAGEPOSX IMAGEPOSY IMAGEBM DELTAPOS CHANGES MOVEFN X GDELTAPOS) [AND (SETQ MOVEFN (GETSKETCHPROP (INSURE.SKETCH SKW) 'PREMOVEFN)) (SETQ GDELTAPOS (APPLY* MOVEFN SKW (SK.MAKE.ELEMENTS.MOVE.ARG SCRELTS] [COND ((EQ GDELTAPOS 'DON'T) (RETURN)) ((POSITIONP GDELTAPOS) (* value returned is the delta by which to move the point.  Set up new position) NIL) (T (* read new position from the user) (SETQ FIGINFO (SK.FIGUREIMAGE SCRELTS (DSPCLIPPINGREGION NIL SKW))) [SETQ FIRSTHOTSPOT (CAR (fetch (SCREENELT HOTSPOTS) of (CAR SCRELTS] (SETQ IMAGEBM (fetch (SKFIGUREIMAGE SKFIGURE.BITMAP) of FIGINFO)) (SETQ LOWLFT (fetch (SKFIGUREIMAGE SKFIGURE.LOWERLEFT) of FIGINFO)) (* move the image by the first hotspot of the first element chosen.  This will align the image on the grid correctly.) (SETQ IMAGEPOSX (fetch (POSITION XCOORD) of LOWLFT)) (SETQ IMAGEPOSY (fetch (POSITION YCOORD) of LOWLFT)) (* put the cursor on the hot spot) (CURSORPOSITION FIRSTHOTSPOT SKW) (COND ([NULL (ERSETQ (PROGN (SK.SHOW.FIG.FROM.INFO IMAGEBM IMAGEPOSX IMAGEPOSY 'ERASE SKW) (SETQ NEWPOS (fetch (INPUTPT INPUT.POSITION) of (GET.BITMAP.POSITION SKW IMAGEBM 'PAINT "Move image to its new position." (IDIFFERENCE IMAGEPOSX (fetch (POSITION XCOORD) of FIRSTHOTSPOT)) (IDIFFERENCE IMAGEPOSY (fetch (POSITION YCOORD) of FIRSTHOTSPOT] (* error happened, repaint the image.) (SK.SHOW.FIG.FROM.INFO IMAGEBM IMAGEPOSX IMAGEPOSY 'PAINT SKW) (CLOSEPROMPTWINDOW SKW) (ERROR!)) ((NULL NEWPOS) (SK.SHOW.FIG.FROM.INFO IMAGEBM IMAGEPOSX IMAGEPOSY 'PAINT SKW) (STATUSPRINT SKW "Position was outside the window, copy not placed.") (RETURN NIL))) (* GET.BITMAP.POSITION returns the position that the cursor was in which is the  position of the first hotspot.) (* calculate the delta that the  selected point moves.) (SETQ GDELTAPOS (SK.MAP.FROM.WINDOW.TO.NEAREST.GRID [SETQ DELTAPOS (create POSITION XCOORD _ (IDIFFERENCE (fetch (POSITION XCOORD) of NEWPOS) (fetch (POSITION XCOORD) of FIRSTHOTSPOT)) YCOORD _ (IDIFFERENCE (fetch (POSITION YCOORD) of NEWPOS) (fetch (POSITION YCOORD) of FIRSTHOTSPOT] (VIEWER.SCALE SKW] (SKETCH.MOVE.ELEMENTS (for ELT in SCRELTS collect (fetch (SCREENELT GLOBALPART) of ELT)) GDELTAPOS SKW T) (* I started noticing cases where the image was a point off on some lines and  where the texture alignment was off so I removed this  (COND ((AND DELTAPOS (NOT (POSITIONP X)))  (* If the user was asked for a new position and the movefn didn't change it,  redraw the image in case any of it was erased by the calls to SK.TRANSLATE.ITEM)  (SK.SHOW.FIG.FROM.INFO IMAGEBM (IPLUS IMAGEPOSX  (fetch (POSITION XCOORD) of DELTAPOS)) (IPLUS IMAGEPOSY  (fetch (POSITION YCOORD) of DELTAPOS)) (QUOTE PAINT) SKW)))) (CLOSEPROMPTWINDOW SKW]) (SKETCH.MOVE.ELEMENTS [LAMBDA (ELEMENTS DELTA SKETCHTOUPDATE ADDHISTORY?) (* rrb " 2-Oct-86 11:09") (* moves the elements ELEMENTS by the amount of position DELTA  (XCOORD gives x amount, YCOORD gives y delta) and updates the viewers on  SKETCHTOUPDATE if it is given.) (PROG (X MOVEFN NEWGLOBALS SKETCH GDELTAPOS VIEWER) (OR (POSITIONP DELTA) (\ILLEGAL.ARG DELTA)) (AND SKETCHTOUPDATE (SETQ SKETCH (INSURE.SKETCH SKETCHTOUPDATE)) (SETQ VIEWER (SK.VIEWER.FROM.SKETCH.ARG SKETCHTOUPDATE))) (COND [[AND SKETCH (SETQ MOVEFN (GETSKETCHPROP SKETCH 'WHENMOVEDFN] (* call the WHENMOVEDFN if any Pass the thing the user passed in if you can't  find a viewer.) (COND ((EQ (SETQ X (APPLY* MOVEFN VIEWER (for ELT in ELEMENTS collect (CONS T ELT)) DELTA)) 'DON'T) (RETURN)) ((POSITIONP X) (* value returned is the delta by which to move the point.  Set up new position) (SETQ GDELTAPOS X)) (T (SETQ GDELTAPOS DELTA] (T (SETQ GDELTAPOS DELTA))) (SETQ NEWGLOBALS (MAPGLOBALSKETCHSPECS (SK.SORT.GELTS.BY.PRIORITY ELEMENTS) (FUNCTION SK.TRANSLATE.ELEMENT) GDELTAPOS VIEWER)) (AND ADDHISTORY? (SK.ADD.HISTEVENT 'MOVE (for NEWG in NEWGLOBALS as OLDG in ELEMENTS when NEWG collect (LIST OLDG NEWG GDELTAPOS)) VIEWER)) (RETURN NEWGLOBALS]) (SKETCH.COPY.ELEMENTS [LAMBDA (ELEMENTS SKETCHTOUPDATE DELTA ADDHISTORY?) (* rrb "15-Dec-86 15:58") (* copies the elements ELEMENTS moving them by the amount of position DELTA  (XCOORD gives x amount, YCOORD gives y delta) and updates the viewers on  SKETCHTOUPDATE if it is given.) (PROG (X COPYFN NEWGLOBALS SKETCH GDELTAPOS VIEWER) (COND ((NULL DELTA) (SETQ DELTA (CREATEPOSITION 0 0))) ((POSITIONP DELTA)) (T (\ILLEGAL.ARG DELTA))) (AND SKETCHTOUPDATE (SETQ SKETCH (INSURE.SKETCH SKETCHTOUPDATE)) (SETQ VIEWER (SK.VIEWER.FROM.SKETCH.ARG SKETCHTOUPDATE))) (COND [[AND SKETCH (SETQ COPYFN (GETSKETCHPROP SKETCH 'WHENCOPIEDFN] (* call the WHENCOPIEFN if any Pass the thing the user passed in if you can't  find a viewer.) (COND ((EQ (SETQ X (APPLY* COPYFN VIEWER ELEMENTS DELTA)) 'DON'T) (RETURN)) ((POSITIONP X) (* value returned is the delta by which to move the point.  Set up new position) (SETQ GDELTAPOS X)) (T (SETQ GDELTAPOS DELTA] (T (SETQ GDELTAPOS DELTA))) (SETQ NEWGLOBALS (MAPGLOBALSKETCHSPECS ELEMENTS (FUNCTION \SKETCH.COPY.ELEMENT) GDELTAPOS VIEWER)) (AND SKETCH (for ELT in NEWGLOBALS do (SK.SET.ELEMENT.PRIORITY ELT NIL) (SKETCH.ADD.ELEMENT ELT SKETCHTOUPDATE))) (AND ADDHISTORY? VIEWER (SK.ADD.HISTEVENT 'COPY (for NEWG in NEWGLOBALS as OLDG in ELEMENTS when NEWG collect (LIST OLDG NEWG)) VIEWER)) (RETURN NEWGLOBALS]) (\SKETCH.COPY.ELEMENT [LAMBDA (GLOBALELEMENT GLOBALDELTAPOS W) (* rrb "24-Jun-87 15:05") (* SELELT is a sketch element that was selected for a copy operation.  GLOBALDELTAPOS is the amount the new item is to be offset from the old.) (COND ((EQ (fetch (GLOBALPART GTYPE) of GLOBALELEMENT) 'SKIMAGEOBJ) (* copying an image obj.  Calls its when copied fn.) (SK.TRANSLATE.GLOBALPART (SK.COPY.IMAGEOBJ GLOBALELEMENT W) GLOBALDELTAPOS)) (T (SK.TRANSLATE.GLOBALPART GLOBALELEMENT GLOBALDELTAPOS]) (SK.TRANSLATE.ELEMENT [LAMBDA (GELT GLOBALDELTAPOS W) (* rrb "25-Sep-86 15:16") (* * GELT is a sketch element to be moved.  GLOBALDELTAPOS is the amount the item is to be translated.) (PROG (NEWGLOBAL) (COND ((SETQ NEWGLOBAL (SK.TRANSLATE.GLOBALPART GELT GLOBALDELTAPOS)) (AND W (SK.UPDATE.ELEMENT GELT NEWGLOBAL W T T)) (RETURN NEWGLOBAL]) (SK.COPY.GLOBAL.ELEMENT [LAMBDA (GLOBALELT) (* returns a copy of a global element.) (SK.TRANSLATE.GLOBALPART GLOBALELT (CREATEPOSITION 0 0) T]) (SK.MAKE.ELEMENT.MOVE.ARG [LAMBDA (SCRELT SELPOS) (* rrb " 5-Nov-85 14:35") (* makes an argument structure that is suitable to be passed to the sketch  movefn. This is a list whose CAR is a list of the numbers of the control points  being moved and whose CDR is the global sketch element.) (CONS (CONS (for I from 1 as PT in (fetch (SCREENELT HOTSPOTS) of SCRELT) when (EQUAL PT SELPOS) do (RETURN I))) (fetch (SCREENELT GLOBALPART) of SCRELT]) (SK.MAKE.ELEMENTS.MOVE.ARG [LAMBDA (SCRELTS) (* rrb " 5-Nov-85 14:34") (* makes an argument structure that is suitable to be passed to the sketch  movefn. This is a list whose CAR is a list of the numbers of the control points  being moved which is in this case T and whose CDR is the global sketch element.) (CONS T (for SCRELT in SCRELTS collect (fetch (SCREENELT GLOBALPART) of SCRELT]) (SK.MAKE.POINTS.AND.ELEMENTS.MOVE.ARG [LAMBDA (SCRELTS SELPTS) (* rrb "21-Jan-86 17:38") (* makes an argument structure that is suitable to be passed to the sketch  movefn. This is a list of lists each of whose CAR is a list of the numbers of  the control points being moved and whose CDR is the global sketch element.) (for SCRELT in SCRELTS collect (CONS (bind NOTALL for I from 1 as PT in (fetch (SCREENELT HOTSPOTS) of SCRELT) when (COND ((MEMBER PT SELPTS)) (T (SETQ NOTALL T) NIL)) collect I finally (OR NOTALL (RETURN T))) (fetch (SCREENELT GLOBALPART) of SCRELT]) (SK.SHOW.FIG.FROM.INFO [LAMBDA (IMAGEBM XOFFSET YOFFSET OPERATION WINDOW) (* rrb "14-Nov-84 14:20") (* puts a bitmap onto the sketch  window.) (BITBLT IMAGEBM 0 0 WINDOW XOFFSET YOFFSET NIL NIL 'INPUT OPERATION]) (SK.MOVE.THING [LAMBDA (SKETCHELT LOCALPT GDELTAPOS SKW) (* rrb "27-Jun-86 14:04") (* moves a control point in a sketch  element.) (PROG (OLDGLOBAL NEWGLOBAL) (* calculate the delta that the  selected point moves.) (SETQ NEWGLOBAL (SK.TRANSLATE.POINTS (LIST LOCALPT) GDELTAPOS SKETCHELT SKW)) (* moving a piece of an element.) (SK.UPDATE.ELEMENT (SETQ OLDGLOBAL (fetch (SCREENELT GLOBALPART) of SKETCHELT)) NEWGLOBAL SKW) (SK.ADD.HISTEVENT 'MOVE (LIST (LIST OLDGLOBAL NEWGLOBAL GDELTAPOS)) SKW) (RETURN NEWGLOBAL]) (UPDATE.ELEMENT.IN.SKETCH [LAMBDA (OLDGELT NEWGELT SKETCH SKW DONTUPDATEPRIORITYFLG) (* rrb "26-Sep-86 13:35") (* changes the global sketch) (* returns NIL if the old global sketch element is not found in SKETCH.  This can happen if things are undone out of order.) (PROG ((SKETCHSTRUCTURE (INSURE.SKETCH SKETCH)) SKETCHELEMENTS) (* if old and new are the same, the change was done destructively;  otherwise clobber the new one in.) [COND ((EQ OLDGELT NEWGELT)) ((OR (NULL DONTUPDATEPRIORITYFLG) (EQ (SK.ELEMENT.PRIORITY OLDGELT) (SK.ELEMENT.PRIORITY NEWGELT))) (* same priorities so just clobber the old elements place in the list with the  new one.) (OR (for GELTTAIL on (fetch (SKETCH SKETCHELTS) of SKETCHSTRUCTURE) when (EQ (CAR GELTTAIL) OLDGELT) do [OR DONTUPDATEPRIORITYFLG (SK.SET.ELEMENT.PRIORITY NEWGELT (SK.ELEMENT.PRIORITY (CAR GELTTAIL] (RPLACA GELTTAIL NEWGELT) (RETURN T)) (RETURN))) (T (* priority has changed so order of this element in the list may need to be  changed.) (REMOVE.ELEMENT.FROM.SKETCH OLDGELT SKETCHSTRUCTURE) (SK.ADD.PRIORITY.ELEMENT.TO.SKETCH SKETCHSTRUCTURE NEWGELT (SK.ELEMENT.PRIORITY NEWGELT] (SK.MARK.DIRTY SKETCH) (RETURN T]) (SK.UPDATE.ELEMENT [LAMBDA (OLDGLOBAL NEWGLOBAL SKETCHW REDRAWIFSAMEFLG DONTUPDATEPRIORITYFLG DONTDISPLAYFLG) (* rrb "24-Sep-86 17:32") (* replaces an old element with a new one.  The global part of the old one may be the same as the new global part.  This also handles propagation to other windows that have the same figure  displayed.) (PROG ((SKETCH (SKETCH.FROM.VIEWER SKETCHW)) UPDATEDELT) (* update the element in the sketch first.  If this returns NIL, the element was not found in the sketch.) (OR (UPDATE.ELEMENT.IN.SKETCH OLDGLOBAL NEWGLOBAL SKETCH SKETCHW DONTUPDATEPRIORITYFLG) (RETURN NIL)) (* do the window that the interaction  occurred in first.) (SETQ UPDATEDELT (SK.UPDATE.ELEMENT1 OLDGLOBAL NEWGLOBAL SKETCHW REDRAWIFSAMEFLG DONTDISPLAYFLG)) (* propagate to other windows.) (for SKW in (ALL.SKETCH.VIEWERS SKETCH) when (NEQ SKW SKETCHW) do (* the position may have changed which means that it may have moved in or out  of a viewer.) (SK.UPDATE.ELEMENT1 OLDGLOBAL NEWGLOBAL SKW REDRAWIFSAMEFLG DONTDISPLAYFLG)) (RETURN UPDATEDELT]) (SK.UPDATE.ELEMENTS [LAMBDA (CHANGEEVENTS WINDOW DONTUPDATEPRIORITYFLG DONTDISPLAYFLG) (* rrb "24-Sep-86 17:32") (* replaces the global parts of a list of change events and handles updating  the screen.) (for CHANGEEVENT in CHANGEEVENTS do (SK.UPDATE.ELEMENT (fetch (SKHISTORYCHANGESPEC OLDELT) of CHANGEEVENT) (fetch (SKHISTORYCHANGESPEC NEWELT) of CHANGEEVENT) WINDOW NIL DONTUPDATEPRIORITYFLG DONTDISPLAYFLG]) (SK.UPDATE.ELEMENT1 [LAMBDA (OLDGELT NEWGELT SKETCHW REDRAWIFSAME DONTDISPLAYFLG) (* rrb "24-Sep-86 17:32") (* determines what action is needed wrt the viewer SKETCHW when the element  OLDGELT is updated to NEWGELT. This works only in the given window.) (PROG (LOCALELT UPDATEFN NEWLOCAL) (COND [(SETQ LOCALELT (SK.LOCAL.ELT.FROM.GLOBALPART OLDGELT SKETCHW)) (COND (DONTDISPLAYFLG (* just do the update in the datastructure, don't change the display) (SK.DELETE.ITEM LOCALELT SKETCHW) (RETURN (SK.ADD.ITEM NEWGELT SKETCHW))) ((EQ (SKETCH.ELEMENT.TYPE OLDGELT) 'SKIMAGEOBJ) (* handle imageobject case specially because changes are often in internal  structure) (SK.DELETE.ITEM LOCALELT SKETCHW) (* erase the old image region because often the internal parts of the image  object have been clobbered making it impossible to erase by redrawing) (DSPFILL (fetch (LOCALSKIMAGEOBJ SKIMOBJLOCALREGION) of (fetch (SCREENELT LOCALPART ) of LOCALELT)) WHITESHADE 'REPLACE SKETCHW) (RETURN (SKETCH.ADD.AND.DISPLAY1 NEWGELT SKETCHW))) [[AND (EQUAL OLDGELT NEWGELT) (NOT (MEMB (fetch (GLOBALPART GTYPE) of OLDGELT) '(TEXT TEXTBOX] (* text and textbox are special because interactive editing reuses the same  element after the first character but they need to use updatefns for speed.) (* replacing something by something else that is identical.  Check here because add will not add something that is already there and  updatefn may call add first.) (COND (REDRAWIFSAME (* this entry is used from the WB.BUTTON.HANDLER and deals with image objects  which we have no control over whether they give us something new or not.) (SK.ERASE.AND.DELETE.ITEM LOCALELT SKETCHW)) (T (SK.DELETE.ITEM LOCALELT SKETCHW) (RETURN (SK.ADD.ITEM NEWGELT SKETCHW] ((AND (SETQ UPDATEFN (SK.UPDATEFN (fetch (GLOBALPART GTYPE) of NEWGELT))) (SETQ NEWLOCAL (APPLY* UPDATEFN LOCALELT NEWGELT SKETCHW))) (* if the old one is visible and the element has an updatefn, use it to update  the display. Then delete the old one. The updatefn should have added the new  one.) (SK.DELETE.ITEM LOCALELT SKETCHW) (RETURN NEWLOCAL)) (T (* if this type doesn't have a updatefn or it returned NIL, do the erase and  redraw method.) (SK.ERASE.AND.DELETE.ITEM LOCALELT SKETCHW] ((NOT (MEMB NEWGELT (SKETCH.ELEMENTS.OF.SKETCH SKETCHW))) (* this element isn't a member of this  sketch, quit) (RETURN))) (RETURN (COND ((ELT.INSIDE.SKWP NEWGELT SKETCHW) (SKETCH.ADD.AND.DISPLAY1 NEWGELT SKETCHW]) (SK.MOVE.ELEMENT.POINT [LAMBDA (W) (* rrb "31-Jan-86 10:50") (* lets the user select an element and  move it.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.MOVE (KWOTE W) ''ONLY) W]) ) (* ; "fns for moving points or a collection of pts.") (DEFINEQ (SK.MOVE.POINTS [LAMBDA (W) (* rrb "31-Jan-86 10:50") (* lets the user select a collection of points and move them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.MOVE.POINTS (KWOTE W)) W]) (SK.SEL.AND.MOVE.POINTS [LAMBDA (W) (* rrb "17-Oct-85 11:11") (* * lets the user select a collection of control point and moves them.) (SK.DO.MOVE.ELEMENT.POINTS (SK.SELECT.MULTIPLE.POINTS W) W]) (SK.DO.MOVE.ELEMENT.POINTS [LAMBDA (SCRPTS SKW) (* rrb "30-Sep-86 18:33") (* moves a collection of points) (SKED.CLEAR.SELECTION SKW) (AND SCRPTS (PROG ((SCRELTS (SK.ELTS.CONTAINING.PTS SCRPTS SKW)) NONMOVEDHOTSPOTS ONEPTELTS FIGINFO FIRSTHOTSPOT NEWPOS LOWLFT IMAGEPOSX IMAGEPOSY IMAGEBM DELTAPOS NEWGLOBALS CHANGES MOVEFN X MOVEARGS SKETCH GDELTAPOS) [AND (SETQ MOVEFN (GETSKETCHPROP (SETQ SKETCH (INSURE.SKETCH SKW)) 'PREMOVEFN)) (SETQ GDELTAPOS (APPLY* MOVEFN SKW (SETQ MOVEARGS (  SK.MAKE.POINTS.AND.ELEMENTS.MOVE.ARG SCRELTS SCRPTS] (COND ((EQ GDELTAPOS 'DON'T) (RETURN)) ((POSITIONP GDELTAPOS) (* value returned is the delta by which to move the point.  Set up new position) NIL) (T (* read new position from the user) (* create a bitmap of all of the elements that have any point being moved and  get its new position. Use only the region that contains the points.  points plus a boarder to catch the lines of a box as large as the region.) (SETQ NONMOVEDHOTSPOTS (SK.HOTSPOTS.NOT.ON.LIST SCRPTS SCRELTS)) [SETQ ONEPTELTS (SUBSET SCRELTS (FUNCTION (LAMBDA (ELT) (EQ (LENGTH (fetch (LOCALPART HOTSPOTS) of (fetch (SCREENELT LOCALPART) of ELT))) 1] (SETQ FIGINFO (SK.FIGUREIMAGE SCRELTS NIL (INCREASEREGION (COND (ONEPTELTS (* include the regions of any elements that only have one control point.  This picks up text and groups whose image is much larger than the point.) (SK.UNIONREGIONS (REGION.CONTAINING.PTS SCRPTS) (  SK.LOCAL.REGION.OF.LOCAL.ELEMENTS ONEPTELTS))) (T (REGION.CONTAINING.PTS SCRPTS)) ) 4))) (SETQ FIRSTHOTSPOT (CAR SCRPTS)) (SETQ LOWLFT (fetch (SKFIGUREIMAGE SKFIGURE.LOWERLEFT) of FIGINFO)) (SETQ IMAGEBM (fetch (SKFIGUREIMAGE SKFIGURE.BITMAP) of FIGINFO)) (* move the image by the first hotspot of the first element chosen.  This will align the image on the grid correctly.) (SETQ IMAGEPOSX (fetch (POSITION XCOORD) of LOWLFT)) (SETQ IMAGEPOSY (fetch (POSITION YCOORD) of LOWLFT)) (* put the cursor on the hot spot) (CURSORPOSITION FIRSTHOTSPOT SKW) (COND ([NULL (ERSETQ (PROGN (SK.SHOW.FIG.FROM.INFO IMAGEBM IMAGEPOSX IMAGEPOSY 'ERASE SKW) (for PT in NONMOVEDHOTSPOTS do (MARKPOINT PT SKW OTHERCONTROLPOINTMARK)) (SETQ NEWPOS (fetch (INPUTPT INPUT.POSITION) of (GET.BITMAP.POSITION SKW IMAGEBM 'PAINT "Move image to its new position." (IDIFFERENCE IMAGEPOSX (fetch (POSITION XCOORD) of FIRSTHOTSPOT)) (IDIFFERENCE IMAGEPOSY (fetch (POSITION YCOORD) of FIRSTHOTSPOT] (* error happened, repaint the image.) (SK.SHOW.FIG.FROM.INFO IMAGEBM IMAGEPOSX IMAGEPOSY 'PAINT SKW) (for PT in NONMOVEDHOTSPOTS do (MARKPOINT PT SKW OTHERCONTROLPOINTMARK)) (CLOSEPROMPTWINDOW SKW) (ERROR!)) ((NULL NEWPOS) (SK.SHOW.FIG.FROM.INFO IMAGEBM IMAGEPOSX IMAGEPOSY 'PAINT SKW) (for PT in NONMOVEDHOTSPOTS do (MARKPOINT PT SKW OTHERCONTROLPOINTMARK)) (STATUSPRINT SKW "Position was outside the window, copy not placed.") (RETURN NIL))) (* GET.BITMAP.POSITION returns the position that the cursor was in which is the  position of the first hotspot.) (for PT in NONMOVEDHOTSPOTS do (MARKPOINT PT SKW OTHERCONTROLPOINTMARK)) (SETQ GDELTAPOS (SK.MAP.FROM.WINDOW.TO.NEAREST.GRID (create POSITION XCOORD _ (IDIFFERENCE (fetch (POSITION XCOORD) of NEWPOS) (fetch (POSITION XCOORD) of FIRSTHOTSPOT )) YCOORD _ (IDIFFERENCE (fetch (POSITION YCOORD) of NEWPOS) (fetch (POSITION YCOORD) of FIRSTHOTSPOT ))) (VIEWER.SCALE SKW))) (* calculate the delta that the  selected point moves.) )) (AND (SETQ MOVEFN (GETSKETCHPROP SKETCH 'WHENMOVEDFN)) (SETQ X (APPLY* MOVEFN SKW (OR MOVEARGS (SK.MAKE.ELEMENTS.MOVE.ARG SCRELTS)) GDELTAPOS))) (COND ((EQ X 'DON'T) (RETURN)) ((POSITIONP X) (* value returned is the delta by which to move the point.  Set up new position) (SETQ GDELTAPOS X))) (SETQ NEWGLOBALS (MAPCOLLECTSKETCHSPECS SCRELTS (FUNCTION SK.MOVE.ITEM.POINTS) GDELTAPOS SKW SCRPTS)) (SK.ADD.HISTEVENT 'MOVE (for NEWG in NEWGLOBALS as OLDG in SCRELTS when NEWG collect (LIST (fetch (SCREENELT GLOBALPART) of OLDG) NEWG)) SKW) (CLOSEPROMPTWINDOW SKW]) (SK.MOVE.ITEM.POINTS [LAMBDA (SELELT GLOBALDELTAPOS W LOCALPTS) (* rrb "11-Jul-85 13:44") (* SELELT is a sketch element at least one of whose points was selected for a  translate operation. GLOBALDELTAPOS is the amount the item is to be translated.  LOCALPTS is the list of points that was selected.  This function moves any of those that belong to SELELT and return the new  global. If all of SELELT points are on LOCALPTS this is a SK.TRANSLATE.ITEM.) (PROG ((ELTHOTSPOTS (fetch (LOCALPART HOTSPOTS) of (fetch (SCREENELT LOCALPART) of SELELT))) MOVEDPTS NEWGLOBAL OLDGLOBAL NEWSCREENELT) (* this shouldn't happen but don't cause an error if it does.) (OR (SETQ MOVEDPTS (INTERSECTION ELTHOTSPOTS LOCALPTS)) (RETURN)) (* map the difference point onto a grid location that would have the same  screen distance but will leave things on a power of two.) (SETQ OLDGLOBAL (fetch (SCREENELT GLOBALPART) of SELELT)) (COND ((EQ (LENGTH MOVEDPTS) (LENGTH ELTHOTSPOTS)) (* all of its hot spots have been moved, just translate it) (OR (SETQ NEWGLOBAL (SK.TRANSLATE.GLOBALPART OLDGLOBAL GLOBALDELTAPOS W)) (RETURN NIL))) ((SETQ NEWGLOBAL (SK.TRANSLATE.POINTS MOVEDPTS GLOBALDELTAPOS SELELT W))) (T (RETURN NIL))) (SK.UPDATE.ELEMENT OLDGLOBAL NEWGLOBAL W T) (RETURN NEWGLOBAL]) (SK.TRANSLATEPTSFN [LAMBDA (ELEMENTTYPE) (* rrb " 5-May-85 16:25") (* goes from an element type name to  its EXPANDFN) (fetch (SKETCHTYPE TRANSLATEPTSFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) (SK.TRANSLATE.POINTS [LAMBDA (SELPTS GLOBALDELTA SKETCHELT W) (* rrb " 6-May-86 11:01") (* moves the selected points by a  global amount.) (AND SKETCHELT (PROG ((NEWGLOBAL (APPLY* (SK.TRANSLATEPTSFN (fetch (SCREENELT GTYPE) of SKETCHELT )) SKETCHELT SELPTS GLOBALDELTA W))) (* copy the elements property list.) (SK.COPY.ELEMENT.PROPERTY.LIST NEWGLOBAL (fetch (SCREENELT GLOBALPART) of SKETCHELT)) (RETURN NEWGLOBAL]) (SK.SELECT.MULTIPLE.POINTS [LAMBDA (SKW) (* rrb "10-Dec-85 16:41") (* * allows the user to select a collection of control points.) (PROG ((INTERIOR (DSPCLIPPINGREGION NIL SKW)) SELECTABLEITEMS HOTSPOTCACHE NOW OLDX ORIGX NEWX NEWY OLDY ORIGY SELPTS PREVMOUSEBUTTONS MOUSEINSIDE?) (COND [(SK.HAS.SOME.HOTSPOTS (SETQ HOTSPOTCACHE (SK.HOTSPOT.CACHE.FOR.OPERATION SKW 'MOVE] (T (* no items, don't do anything.) (RETURN))) (TOTOPW SKW) (SK.PUT.MARKS.UP SKW HOTSPOTCACHE) (until (MOUSESTATE (NOT UP))) (COND ((INSIDEP INTERIOR (LASTMOUSEX SKW) (LASTMOUSEY SKW))) (T (* first press was outside of the window, don't select anything.) (SK.TAKE.MARKS.DOWN SKW HOTSPOTCACHE) (RETURN))) SELECTLP (COND ((MOUSESTATE UP) (GO SHIFTDOWNLP))) (* this label provides an entry for the code that tests if the shift key is  down.) SELAFTERTEST (SETQ NEWY (LASTMOUSEY SKW)) (SETQ NEWX (LASTMOUSEX SKW)) [COND [(NOT MOUSEINSIDE?) (* mouse is outside, don't do anything other than wait for it to come back in.  If the user has let up all buttons, the branch to SELECTEXIT will have been  taken.) (COND ((INSIDEP INTERIOR NEWX NEWY) (SETQ MOUSEINSIDE? T) (* restore the saved selected items.) (for ELT in SELPTS do (SK.ADD.PT.SELECTION ELT SKW] ((NOT (INSIDEP INTERIOR NEWX NEWY)) (* mouse just went outside, remove selections but save them in case mouse comes  back in.) (SETQ MOUSEINSIDE? NIL) (SETQ SELPTS (WINDOWPROP SKW 'SKETCH.SELECTIONS)) (for ELT in SELPTS do (SK.REMOVE.PT.SELECTION ELT SKW))) [(NEQ PREVMOUSEBUTTONS LASTMOUSEBUTTONS) (* another button has gone down, mark this as the origin of a new box to sweep.) (SETQ PREVMOUSEBUTTONS LASTMOUSEBUTTONS) (SETQ ORIGX (LASTMOUSEX SKW)) (SETQ ORIGY (LASTMOUSEY SKW)) (* add or delete the element that the button press occurred on if any.) (AND (SETQ NOW (IN.SKETCH.ELT? HOTSPOTCACHE (create POSITION XCOORD _ NEWX YCOORD _ NEWY) T)) (COND ((LASTMOUSESTATE (ONLY LEFT)) (* add selection.) (SK.ADD.PT.SELECTION NOW SKW)) ((LASTMOUSESTATE RIGHT) (* remove selection.) (SK.REMOVE.PT.SELECTION NOW SKW] ([AND (OR (NEQ NEWX OLDX) (NEQ NEWY OLDY)) (SETQ SELPTS (SK.CONTROL.POINTS.IN.REGION HOTSPOTCACHE (MIN ORIGX NEWX) (MIN ORIGY NEWY) (MAX ORIGX NEWX) (MAX ORIGY NEWY] (* add or delete any with in the swept out area.) (COND ((LASTMOUSESTATE (ONLY LEFT)) (* left only selects.) (for SELPT in SELPTS do (SK.ADD.PT.SELECTION SELPT SKW))) ((LASTMOUSESTATE RIGHT) (* right cause deselect.) (for SELPT in SELPTS do (SK.REMOVE.PT.SELECTION SELPT SKW] (SETQ OLDX NEWX) (SETQ OLDY NEWY) (GO SELECTLP) SHIFTDOWNLP (COND ((MOUSESTATE (NOT UP)) (* button went down again, initialize the button state and click position.) (SETQ PREVMOUSEBUTTONS NIL) (GO SELAFTERTEST)) ((.SHIFTKEYDOWNP.) [COND [(NOT MOUSEINSIDE?) (* mouse is outside%: if it comes back in, mark the selections.) (COND ((INSIDEP INTERIOR (LASTMOUSEX SKW) (LASTMOUSEY SKW)) (SETQ MOUSEINSIDE? T) (* restore the saved selected items.) (for ELT in SELPTS do (SK.ADD.PT.SELECTION ELT SKW] ((NOT (INSIDEP INTERIOR (LASTMOUSEX SKW) (LASTMOUSEY SKW))) (* mouse just went outside, remove  marks but keep selections) (SETQ MOUSEINSIDE? NIL) (SETQ SELPTS (WINDOWPROP SKW 'SKETCH.SELECTIONS)) (for ELT in SELPTS do (SK.REMOVE.PT.SELECTION ELT SKW] (GO SHIFTDOWNLP))) (SETQ SELPTS (WINDOWPROP SKW 'SKETCH.SELECTIONS)) (for SEL in SELPTS do (SK.REMOVE.PT.SELECTION SEL SKW)) (SK.TAKE.MARKS.DOWN SKW HOTSPOTCACHE) (RETURN SELPTS]) (SK.CONTROL.POINTS.IN.REGION [LAMBDA (HOTSPOTCACHE LEFT BOTTOM RIGHT TOP) (* rrb " 6-May-85 16:22") (* * returns a list of the control points that are within LOCALREGION) (PROG ((RLEFT (DIFFERENCE LEFT SK.POINT.WIDTH)) (RBOTTOM (DIFFERENCE BOTTOM SK.POINT.WIDTH)) (RRIGHT (PLUS RIGHT SK.POINT.WIDTH)) (RTOP (PLUS TOP SK.POINT.WIDTH)) ELTS) [for YBUCKET in HOTSPOTCACHE when (ILEQ (CAR YBUCKET) RTOP) do (COND ((ILESSP (CAR YBUCKET) RBOTTOM) (* stop when Y gets too small.) (RETURN))) (for XBUCKET in (CDR YBUCKET) when (ILEQ (CAR XBUCKET) RRIGHT) do (COND ((ILESSP (CAR XBUCKET) RLEFT) (* stop when X gets too small.) (RETURN))) (* collect the points if there are any elements cached there.) (AND (CDR XBUCKET) (SETQ ELTS (SK.ADD.POINT ELTS (CAR XBUCKET) (CAR YBUCKET] (RETURN ELTS]) (SK.ADD.PT.SELECTION [LAMBDA (PT WINDOW MARKBM) (* rrb " 9-May-85 10:18") (* adds an item to the selection list  of WINDOW.) (COND ([NOT (MEMBER PT (WINDOWPROP WINDOW 'SKETCH.SELECTIONS] (MARKPOINT PT WINDOW MARKBM) (WINDOWADDPROP WINDOW 'SKETCH.SELECTIONS PT]) (SK.REMOVE.PT.SELECTION [LAMBDA (PT WINDOW MARKBM) (* rrb " 9-May-85 10:22") (* removes an item from the selection  list of WINDOW.) (COND ((MEMBER PT (WINDOWPROP WINDOW 'SKETCH.SELECTIONS)) (MARKPOINT PT WINDOW MARKBM) (* used to call WINDOWDELPROP but it has a bug that it only removes EQ things.) (WINDOWPROP WINDOW 'SKETCH.SELECTIONS (REMOVE PT (WINDOWPROP WINDOW 'SKETCH.SELECTIONS]) (SK.ADD.POINT [LAMBDA (PTLST X Y) (* rrb " 6-May-85 16:22") (* add the point X Y to PTLST unless it is already a member.) (COND ((for PT in PTLST thereis (AND (EQ (fetch (POSITION XCOORD) of PT) X) (EQ (fetch (POSITION YCOORD) of PT) Y))) PTLST) (T (CONS (create POSITION XCOORD _ X YCOORD _ Y) PTLST]) (SK.ELTS.CONTAINING.PTS [LAMBDA (PTLST SKW) (* rrb " 4-May-85 15:38") (* returns the list of elements that have any points on PTLST.) (bind (HOTSPOTCACHE _ (SK.HOTSPOT.CACHE SKW)) ELTS for POS in PTLST do (SETQ ELTS (UNION (SK.ELTS.FROM.HOTSPOT POS HOTSPOTCACHE) ELTS)) finally (* reverse them so the first selected pt has its element first.) (RETURN (REVERSE ELTS]) (SK.HOTSPOTS.NOT.ON.LIST [LAMBDA (PTLST ELTS) (* rrb "19-Jul-85 13:18") (* returns a list of the hot spots on any of ELTS that aren't on PTLST.) (bind OTHERHOTSPOTS for ELT in ELTS do [for HOTSPOT in (fetch (SCREENELT HOTSPOTS) of ELT) do (OR (MEMBER HOTSPOT PTLST) (MEMBER HOTSPOT OTHERHOTSPOTS) (SETQ OTHERHOTSPOTS (CONS HOTSPOT OTHERHOTSPOTS] finally (RETURN OTHERHOTSPOTS]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS .SHIFTKEYDOWNP. MACRO [NIL (OR (KEYDOWNP 'LSHIFT) (KEYDOWNP 'RSHIFT]) ) (DEFINEQ (SK.SET.MOVE.MODE [LAMBDA (SKW NEWMODE) (* rrb " 2-Jun-85 12:52") (* * reads a value of move command mode and makes it the default) (PROG [(LOCALNEWMODE (OR NEWMODE (READMOVEMODE] (RETURN (AND LOCALNEWMODE (replace (SKETCHCONTEXT SKETCHMOVEMODE) of (WINDOWPROP SKW 'SKETCHCONTEXT) with (SELECTQ NEWMODE ((POINTS ELEMENTS) NEWMODE) NIL]) (SK.SET.MOVE.MODE.POINTS [LAMBDA (SKW) (* rrb " 2-Jun-85 12:47") (* sets the default to move mode to  points.) (SK.SET.MOVE.MODE SKW 'POINTS]) (SK.SET.MOVE.MODE.ELEMENTS [LAMBDA (SKW) (* rrb " 2-Jun-85 12:48") (* sets the default to move mode to  elements) (SK.SET.MOVE.MODE SKW 'ELEMENTS]) (SK.SET.MOVE.MODE.COMBINED [LAMBDA (SKW) (* rrb " 2-Jun-85 12:49") (* sets the default to move mode to  combined move.) (SK.SET.MOVE.MODE SKW 'COMBINED]) (READMOVEMODE [LAMBDA (MENUTITLE) (* rrb " 6-Nov-85 09:54") (* interacts to get whether move mode should be points, elements or both.) (\CURSOR.IN.MIDDLE.MENU (create MENU TITLE _ (OR MENUTITLE "Top level MOVE command should apply to?") ITEMS _ '((Points 'POINTS "Top level MOVE command will be the same as MOVE POINTS command." ) (Elements 'ELEMENTS "Top level MOVE command will be the same as MOVE ELEMENTS command." ) (Combined 'COMBINED "MOVE command will move points if a single point is clicked; elements otherwise" )) CENTERFLG _ T]) ) (DEFINEQ (SK.ALIGN.POINTS [LAMBDA (W) (* rrb "31-Jan-86 10:50") (* lets the user select a collection of points and aligns them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.MOVE.POINTS (KWOTE W)) W]) (SK.SEL.AND.ALIGN.POINTS [LAMBDA (ALIGNHOW W) (* rrb "22-Jan-86 14:57") (* * lets the user select a collection of control point and aligns them.) (SK.DO.ALIGN.POINTS (SK.SELECT.MULTIPLE.POINTS W) ALIGNHOW W]) (SK.ALIGN.POINTS.LEFT [LAMBDA (W) (* rrb "31-Jan-86 10:51") (* lets the user select a collection of points and aligns them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.ALIGN.POINTS ''LEFT (KWOTE W)) W]) (SK.ALIGN.POINTS.RIGHT [LAMBDA (W) (* rrb "31-Jan-86 10:51") (* lets the user select a collection of points and aligns them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.ALIGN.POINTS ''RIGHT (KWOTE W)) W]) (SK.ALIGN.POINTS.TOP [LAMBDA (W) (* rrb "31-Jan-86 10:57") (* lets the user select a collection of points and aligns them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.ALIGN.POINTS ''TOP (KWOTE W)) W]) (SK.ALIGN.POINTS.BOTTOM [LAMBDA (W) (* rrb "31-Jan-86 10:58") (* lets the user select a collection of points and aligns them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.ALIGN.POINTS ''BOTTOM (KWOTE W)) W]) (SK.EVEN.SPACE.POINTS.IN.X [LAMBDA (W) (* rrb "31-Jan-86 10:58") (* lets the user select a collection of points and spaces them evenly in X) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.ALIGN.POINTS ''EVENX (KWOTE W)) W]) (SK.EVEN.SPACE.POINTS.IN.Y [LAMBDA (W) (* rrb "31-Jan-86 10:58") (* lets the user select a collection of points and spaces them evenly in Y) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.ALIGN.POINTS ''EVENY (KWOTE W)) W]) (SK.DO.ALIGN.POINTS [LAMBDA (SCRPTS ALIGNHOW SKW) (* rrb "12-Sep-86 18:28") (* * aligns a collection of points according to ALIGNHOW which can be LEFT  RIGHT TOP BOTTOM EVENX or EVENY) (SKED.CLEAR.SELECTION SKW) (* if there isn't at least two points, don't do anything.) (AND (CDR SCRPTS) (PROG ((SELECTEDPTSTRUC (SK.GET.SELECTED.ELEMENT.STRUCTURE SCRPTS SKW)) MOSTSELBUCK LEASTSELBUCK DIMENSION LEAST MOST PREMOVEFN X NEWGLOBALS) (AND (SETQ PREMOVEFN (GETSKETCHPROP (INSURE.SKETCH SKW) 'PREMOVEFN)) (EQ (APPLY* PREMOVEFN SKW (SK.MAKE.POINTS.AND.ELEMENTS.MOVE.ARG (  SK.ELTS.CONTAINING.PTS SCRPTS SKW) SCRPTS) ALIGNHOW) 'DON'T) (RETURN)) (SETQ MOSTSELBUCK (CAR SELECTEDPTSTRUC)) (SETQ LEASTSELBUCK (CAR SELECTEDPTSTRUC)) (* find the dimension of interest and do some error checking.) (SETQ DIMENSION (SELECTQ ALIGNHOW ((LEFT RIGHT) 'HORIZONTAL) ((TOP BOTTOM) 'VERTICAL) (EVENX (OR (CDDR SCRPTS) (RETURN)) 'HORIZONTAL) (EVENY (OR (CDDR SCRPTS) (RETURN)) 'VERTICAL) (SHOULDNT))) (* calculate the extreme points.) [COND [(EQ DIMENSION 'HORIZONTAL) (for PT in (CDR SELECTEDPTSTRUC) do (COND ((GREATERP (fetch (POSITION XCOORD) of (CAR PT)) (fetch (POSITION XCOORD) of (CAR MOSTSELBUCK))) (SETQ MOSTSELBUCK PT)) ((LESSP (fetch (POSITION XCOORD) of (CAR PT)) (fetch (POSITION XCOORD) of (CAR LEASTSELBUCK))) (SETQ LEASTSELBUCK PT] (T (for PT in (CDR SELECTEDPTSTRUC) do (COND ((GREATERP (fetch (POSITION YCOORD) of (CAR PT)) (fetch (POSITION YCOORD) of (CAR MOSTSELBUCK))) (SETQ MOSTSELBUCK PT)) ((LESSP (fetch (POSITION YCOORD) of (CAR PT)) (fetch (POSITION YCOORD) of (CAR LEASTSELBUCK))) (SETQ LEASTSELBUCK PT] (* find the extreme dimensions in  global space) (SELECTQ DIMENSION (HORIZONTAL (SETQ LEAST (fetch (POSITION XCOORD) of (CAADR LEASTSELBUCK))) [for GELTSTR in (CDDR LEASTSELBUCK) when (LESSP (fetch (POSITION XCOORD) of (CAR GELTSTR)) LEAST) do (SETQ LEAST (fetch (POSITION XCOORD) of (CAR GELTSTR] (SETQ MOST (fetch (POSITION XCOORD) of (CAADR MOSTSELBUCK))) [for GELTSTR in (CDDR MOSTSELBUCK) when (GREATERP (fetch (POSITION XCOORD) of (CAR GELTSTR)) MOST) do (SETQ MOST (fetch (POSITION XCOORD) of (CAR GELTSTR]) (VERTICAL (SETQ LEAST (fetch (POSITION YCOORD) of (CAADR LEASTSELBUCK))) [for GELTSTR in (CDDR LEASTSELBUCK) when (LESSP (fetch (POSITION YCOORD) of (CAR GELTSTR)) LEAST) do (SETQ LEAST (fetch (POSITION YCOORD) of (CAR GELTSTR] (SETQ MOST (fetch (POSITION YCOORD) of (CAADR MOSTSELBUCK))) [for GELTSTR in (CDDR MOSTSELBUCK) when (GREATERP (fetch (POSITION YCOORD) of (CAR GELTSTR)) MOST) do (SETQ MOST (fetch (POSITION YCOORD) of (CAR GELTSTR]) NIL) (* move the individual elements) (SETQ NEWGLOBALS (SELECTQ ALIGNHOW ((LEFT BOTTOM) (for SELBUCK in SELECTEDPTSTRUC join (* apply the movement to each selected  element) (SK.DO.ALIGN.SETVALUE SELBUCK LEAST DIMENSION SKW))) ((RIGHT TOP) (for SELBUCK in SELECTEDPTSTRUC join (* apply the movement to each selected  element) (SK.DO.ALIGN.SETVALUE SELBUCK MOST DIMENSION SKW))) ((EVENX EVENY) (for SELBUCK in [SORT SELECTEDPTSTRUC (COND [(EQ DIMENSION 'HORIZONTAL) (* sort the selected points) (FUNCTION (LAMBDA (A B) (OR (LESSP (fetch (POSITION XCOORD) of (CAR A)) (fetch (POSITION XCOORD) of (CAR B))) (AND (EQUAL (fetch (POSITION XCOORD) of (CAR A)) (fetch (POSITION XCOORD) of (CAR B))) (LESSP (fetch (POSITION YCOORD) of (CAR A)) (fetch (POSITION YCOORD) of (CAR B] (T (FUNCTION (LAMBDA (A B) (OR (LESSP (fetch (POSITION YCOORD) of (CAR A)) (fetch (POSITION YCOORD) of (CAR B))) (AND (EQUAL (fetch (POSITION YCOORD) of (CAR A)) (fetch (POSITION YCOORD) of (CAR B))) (LESSP (fetch (POSITION XCOORD) of (CAR A)) (fetch (POSITION XCOORD) of (CAR B] as VALUE from LEAST to MOST by (FQUOTIENT (DIFFERENCE MOST LEAST) (SUB1 (LENGTH SELECTEDPTSTRUC))) join (* apply the movement to each selected  element) (SK.DO.ALIGN.SETVALUE SELBUCK VALUE DIMENSION SKW))) NIL)) (AND NEWGLOBALS (SK.ADD.HISTEVENT 'MOVE NEWGLOBALS SKW)) (CLOSEPROMPTWINDOW SKW]) (SK.NTH.CONTROL.POINT [LAMBDA (ELEMENT N) (* returns the nth control point of  ELEMENT.) (SELECTQ N (1 (GETSKETCHELEMENTPROP ELEMENT 'POSITION)) (2 (GETSKETCHELEMENTPROP ELEMENT '2NDCONTROLPT)) (3 (GETSKETCHELEMENTPROP ELEMENT '3RDCONTROLPT)) (CAR (NTH (GETSKETCHELEMENTPROP ELEMENT 'DATA) N]) (SK.GET.SELECTED.ELEMENT.STRUCTURE [LAMBDA (SELPTS SKW) (* rrb "22-Jan-86 14:58") (* returns a list of the points and elements that each selected point on SELPTS  corresponds to. Returns a list of lists of the form  (SELPT (GPT1 GELT1) |...| (GPTn GELTn))) (bind (HOTSPOTCACHE _ (SK.HOTSPOT.CACHE SKW)) for POS in SELPTS collect (CONS POS (for ELT in (SK.ELTS.FROM.HOTSPOT POS HOTSPOTCACHE) collect (LIST (SK.CORRESPONDING.CONTROL.PT POS ELT) ELT]) (SK.CORRESPONDING.CONTROL.PT [LAMBDA (SELPT SCRELEMENT) (* rrb "22-Jan-86 14:59") (* returns the global control point of an element that corresponds to the  screen point SELPT.) (for I from 1 as PT in (fetch (SCREENELT HOTSPOTS) of SCRELEMENT) when (EQUAL PT SELPT) do (RETURN (OR (SK.NTH.CONTROL.POINT (fetch (SCREENELT GLOBALPART) of SCRELEMENT) I) (SHOULDNT]) (SK.CONTROL.POINT.NUMBER [LAMBDA (SELPT SCRELT) (* rrb "22-Jan-86 10:54") (* returns the control point number that SELPT is on the element SCRELT) (for I from 1 as HOTPT in (fetch (SCREENELT HOTSPOTS) of SCRELT) when (EQUAL SELPT HOTPT) do (RETURN I]) (SK.DO.ALIGN.SETVALUE [LAMBDA (SELBUCKET VALUE DIMENSION VIEWER) (* rrb "22-Jan-86 17:23") (* performs the alignment of a  selection bucket structure.) (bind (SELPT _ (CAR SELBUCKET)) (MOVEFN _ (GETSKETCHPROP (INSURE.SKETCH VIEWER) 'WHENMOVEDFN)) GDELTA X for GELTSTRUC in (CDR SELBUCKET) when (PROG NIL (* calculate the amount that this global element point should be moved and  apply move fn) (* don't move it if it moves 0.0) [SETQ GDELTA (create POSITION XCOORD _ (COND ((EQ DIMENSION 'HORIZONTAL) (COND ([ZEROP (SETQ X (DIFFERENCE VALUE (fetch (POSITION XCOORD) of (CAR GELTSTRUC] (RETURN)) (T X))) (T 0)) YCOORD _ (COND ((EQ DIMENSION 'VERTICAL) (COND ([ZEROP (SETQ X (DIFFERENCE VALUE (fetch (POSITION YCOORD) of (CAR GELTSTRUC] (RETURN)) (T X))) (T 0] (COND ((NULL MOVEFN) (RETURN T))) (SETQ X (APPLY* MOVEFN VIEWER [LIST (LIST (SK.CONTROL.POINT.NUMBER SELPT (CADR GELTSTRUC)) (fetch (SCREENELT GLOBALPART) of (CADR GELTSTRUC] GDELTA)) (COND ((EQ X 'DON'T) (* if DON'T, don't move this guy.) (RETURN NIL)) ((POSITIONP X) (* value returned is the delta by which to move the point.  Set up new position) (SETQ GDELTA X))) (RETURN T)) join (* build the history structure here because this is where the old screen  element is known.) (AND (SETQ X (SK.MOVE.ITEM.POINTS (CADR GELTSTRUC) GDELTA VIEWER (LIST SELPT))) (CONS (LIST (fetch (SCREENELT GLOBALPART) of (CADR GELTSTRUC) ) X]) ) (* ; "stuff for supporting the GROUP sketch element.") (DEFINEQ (SKETCH.CREATE.GROUP [LAMBDA (LISTOFSKETCHELEMENTS CONTROLPOINT) (* rrb " 4-Dec-85 21:38") (* creates a sketch group element.) (SK.CREATE.GROUP1 LISTOFSKETCHELEMENTS (OR (POSITIONP CONTROLPOINT) (REGION.CENTER (SK.GLOBAL.REGION.OF.GLOBAL.ELEMENTS LISTOFSKETCHELEMENTS]) (SK.CREATE.GROUP1 [LAMBDA (GELTS CONTROLPT) (* rrb " 4-Dec-85 21:38") (* creates a group element.) (SK.UPDATE.GROUP.AFTER.CHANGE (create GLOBALPART INDIVIDUALGLOBALPART _ (create GROUP LISTOFGLOBALELTS _ GELTS GROUPCONTROLPOINT _ CONTROLPT]) (SK.UPDATE.GROUP.AFTER.CHANGE [LAMBDA (GROUPELT) (* rrb " 4-Dec-85 21:38") (* updates the dependent field of a group element after a change.) (PROG ((INDGROUPELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GROUPELT)) GROUPREGION) (SETQ GROUPREGION (SK.GLOBAL.REGION.OF.GLOBAL.ELEMENTS (fetch (GROUP LISTOFGLOBALELTS) of INDGROUPELT))) (replace (GROUP GROUPREGION) of INDGROUPELT with GROUPREGION) (* use same scales as a box would.) (BOX.SET.SCALES GROUPREGION GROUPELT) (RETURN GROUPELT]) (SK.GROUP.ELTS [LAMBDA (W) (* rrb "31-Jan-86 10:58") (* lets the user select a collection elements and groups them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.GROUP (KWOTE W)) W]) (SK.SEL.AND.GROUP [LAMBDA (W) (* rrb "10-Dec-85 17:08") (* lets the user select elements and  groups them.) (SK.GROUP.ELEMENTS (SK.SELECT.MULTIPLE.ITEMS W T NIL 'GROUP) W]) (SK.GROUP.ELEMENTS [LAMBDA (SCRELTS SKW) (* rrb "11-Jul-86 15:51") (* groups the collection of elements SCRELTS.  Does this by creating a group element, adding it and deleting the individual  elements.) (SKED.CLEAR.SELECTION SKW) (AND SCRELTS (PROG (GROUPELT LOCALGROUPELT) (* call the group fn if there is one.) (SETQ GROUPELT (SKETCH.CREATE.GROUP (for SCRELT in SCRELTS collect (fetch (SCREENELT GLOBALPART) of SCRELT)) (MAP.GLOBAL.PT.ONTO.GRID (REGION.CENTER (  SK.GLOBAL.REGION.OF.LOCAL.ELEMENTS SCRELTS (VIEWER.SCALE SKW))) SKW))) (* do grouping. This might return NIL if the when grouped function says not to.) (OR (SK.DO.GROUP GROUPELT SKW) (RETURN)) (* record it on the history list.) (SK.ADD.HISTEVENT 'GROUP (LIST (LIST GROUPELT)) SKW) (RETURN GROUPELT]) (SK.UNGROUP.ELT [LAMBDA (W) (* rrb "31-Jan-86 10:58") (* lets the user select a collection elements and groups them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.UNGROUP (KWOTE W)) W]) (SK.SEL.AND.UNGROUP [LAMBDA (W) (* rrb "10-Dec-85 18:03") (* lets the user select elements and  groups them.) (PROG NIL (RETURN (SK.UNGROUP.ELEMENT [SK.SELECT.MULTIPLE.ITEMS W T (COND [(SUBSET (LOCALSPECS.FROM.VIEWER W) (FUNCTION (LAMBDA (SCRELT) (AND (EQ (fetch (SCREENELT GTYPE) of SCRELT) 'GROUP) (NOT (SK.ELEMENT.PROTECTED? (fetch (SCREENELT GLOBALPART ) of SCRELT) 'UNGROUP] (T (* no group elements) (STATUSPRINT W "There are no grouped elements to ungroup.") (RETURN] W]) (SK.UNGROUP.ELEMENT [LAMBDA (SCRELTS SKW) (* rrb "15-Jan-86 16:12") (* ungroups the first group element in  SCRELTS.) (PROG ((GROUPELTS (for ELT in SCRELTS when (EQ (fetch (SCREENELT GTYPE) of ELT) 'GROUP) collect (fetch (SCREENELT GLOBALPART) of ELT))) X) (OR GROUPELTS (RETURN)) (* do the ungrouping. this may return NIL if the ungroup fn says don't.) (SETQ X (for GROUPELT in GROUPELTS when (SK.DO.UNGROUP GROUPELT SKW) collect (LIST GROUPELT))) (AND X (SK.ADD.HISTEVENT 'UNGROUP X SKW]) (SK.GLOBAL.REGION.OF.LOCAL.ELEMENTS [LAMBDA (SCRELTS SCALE) (* rrb "30-Sep-86 18:33") (* returns the global region occuppied by a list of local elements.) (PROG (GROUPREGION) [for SCRELT in SCRELTS do (SETQ GROUPREGION (COND (GROUPREGION (* first time because UNIONREGIONS  doesn't handle NIL) (SK.UNIONREGIONS GROUPREGION (SK.ITEM.REGION SCRELT))) (T (SK.ITEM.REGION SCRELT] (RETURN (UNSCALE.REGION GROUPREGION SCALE]) (SK.LOCAL.REGION.OF.LOCAL.ELEMENTS [LAMBDA (SCRELTS SCALE) (* rrb "30-Sep-86 18:33") (* returns the local region occupied by a list of local elements.) (bind GROUPREGION for SCRELT in SCRELTS do [SETQ GROUPREGION (COND (GROUPREGION (* first time because UNIONREGIONS  doesn't handle NIL) (SK.UNIONREGIONS GROUPREGION (SK.ITEM.REGION SCRELT))) (T (SK.ITEM.REGION SCRELT] finally (RETURN GROUPREGION]) (SK.GLOBAL.REGION.OF.GLOBAL.ELEMENTS [LAMBDA (GELTS) (* rrb "30-Sep-86 17:35") (* returns the global region occuppied by a list of global elements.) (COND [(LESSP (LENGTH GELTS) 50) (* for smallish numbers of elements, only do the cons to create the args to  SK.UNIONREGIONS.) (APPLY (FUNCTION SK.UNIONREGIONS) (for GELT in GELTS collect (SK.ELEMENT.GLOBAL.REGION GELT] (T (PROG (GROUPREGION) [for GELT in GELTS do (SETQ GROUPREGION (COND (GROUPREGION (* first time because UNIONREGIONS  doesn't handle NIL) (SK.UNIONREGIONS GROUPREGION (SK.ELEMENT.GLOBAL.REGION GELT))) (T (SK.ELEMENT.GLOBAL.REGION GELT] (RETURN GROUPREGION]) (SK.UNIONREGIONS [LAMBDA REGIONS (* rrb "30-Sep-86 18:14") (* returns the smallest region that encloses all of REGIONS Is different from  UNIONREGIONS because it works in floating pt) (COND ((EQ 0 REGIONS) NIL) (T (PROG (REG LFT RGHT BTTM TP X NEWLFT NEWBTM) (SETQ REG (ARG REGIONS 1)) (SETQ LFT (fetch (REGION LEFT) of REG)) (SETQ RGHT (PLUS LFT (fetch (REGION WIDTH) of REG))) (SETQ BTTM (fetch (REGION BOTTOM) of REG)) (SETQ TP (PLUS BTTM (fetch (REGION HEIGHT) of REG))) [for I from 2 thru REGIONS do (SETQ REG (ARG REGIONS I)) (COND ((LESSP (SETQ X (fetch (REGION LEFT) of REG)) LFT) (SETQ LFT X))) (COND ((GREATERP (SETQ X (PLUS X (fetch (REGION WIDTH) of REG))) RGHT) (SETQ RGHT X))) (COND ((LESSP (SETQ X (fetch (REGION BOTTOM) of REG)) BTTM) (SETQ BTTM X))) (COND ((GREATERP (SETQ X (PLUS X (fetch (REGION HEIGHT) of REG))) TP) (SETQ TP X] (RETURN (create REGION LEFT _ LFT BOTTOM _ BTTM WIDTH _ (DIFFERENCE RGHT LFT) HEIGHT _ (DIFFERENCE TP BTTM]) (SKETCH.REGION.OF.SKETCH [LAMBDA (SKETCH) (* rrb "23-Oct-85 11:17") (* returns the global region of a  sketch.) (SK.GLOBAL.REGION.OF.GLOBAL.ELEMENTS (fetch (SKETCH SKETCHELTS) of (INSURE.SKETCH SKETCH]) (SK.FLASHREGION [LAMBDA (REGION WINDOW TEXTURE) (* rrb "30-Jul-85 15:47") (* flashes a region) (DSPFILL REGION TEXTURE 'INVERT WINDOW) (DISMISS 400) (DSPFILL REGION TEXTURE 'INVERT WINDOW]) ) (DEFINEQ (INIT.GROUP.ELEMENT [LAMBDA NIL (* rrb "18-Oct-85 17:15") (* initializes the text box element.) (COND ((NOT (SKETCH.ELEMENT.TYPEP 'GROUP)) (CREATE.SKETCH.ELEMENT.TYPE 'GROUP NIL "groups a collection of elements as a single element." (FUNCTION GROUP.DRAWFN) (FUNCTION GROUP.EXPANDFN) 'OBSOLETE (FUNCTION SK.ELEMENTS.CHANGEFN) (FUNCTION TEXTBOX.INPUTFN) (FUNCTION GROUP.INSIDEFN) (FUNCTION GROUP.REGIONFN) (FUNCTION GROUP.TRANSLATEFN) NIL (FUNCTION GROUP.READCHANGEFN) (FUNCTION GROUP.TRANSFORMFN) NIL (FUNCTION GROUP.GLOBALREGIONFN]) (GROUP.DRAWFN [LAMBDA (GROUPELT WINDOW REGION OPERATION) (* rrb "10-Dec-85 12:38") (* draws a group element.) (for ELT in (fetch (LOCALGROUP LOCALELEMENTS) of (fetch (SCREENELT LOCALPART) of GROUPELT)) do (APPLY* (SK.DRAWFN (fetch (SCREENELT GTYPE) of ELT)) ELT WINDOW REGION OPERATION]) (GROUP.EXPANDFN [LAMBDA (GROUPELT SCALE STREAM) (* rrb "30-Dec-85 17:30") (* creates a local group screen element from a global group element) (PROG ((GROUPINDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GROUPELT)) LOCALREGION) (SETQ LOCALREGION (SCALE.REGION.OUT (fetch (GROUP GROUPREGION) of GROUPINDVELT) SCALE)) (* put the position in the center.) (RETURN (create SCREENELT LOCALPART _ (create LOCALGROUP GROUPPOSITION _ (SK.SCALE.POSITION.INTO.VIEWER (fetch (GROUP GROUPCONTROLPOINT) of GROUPINDVELT) SCALE) LOCALGROUPREGION _ LOCALREGION LOCALELEMENTS _ (for ELEMENT in (fetch (GROUP LISTOFGLOBALELTS) of GROUPINDVELT) collect (SK.LOCAL.FROM.GLOBAL ELEMENT STREAM SCALE))) GLOBALPART _ GROUPELT]) (GROUP.INSIDEFN [LAMBDA (GROUPELT WREG) (* rrb "10-Jan-85 10:37") (* determines if the global group element GROUPELT is inside of WREG.) (REGIONSINTERSECTP (fetch (GROUP GROUPREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GROUPELT)) WREG]) (GROUP.REGIONFN [LAMBDA (GROUPSCRELT) (* rrb "10-Dec-85 12:38") (* returns the region occuppied by a  group) (fetch (LOCALGROUP LOCALGROUPREGION) of (fetch (SCREENELT LOCALPART) of GROUPSCRELT]) (GROUP.GLOBALREGIONFN [LAMBDA (GGROUPELT) (* rrb "18-Oct-85 17:13") (* returns the global region occupied by a global group element.) (fetch (GROUP GROUPREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GGROUPELT]) (GROUP.TRANSLATEFN [LAMBDA (SKELT DELTAPOS) (* rrb "28-Apr-85 18:43") (* * returns a group element which has been translated by DELTAPOS) (PROG ((GGROUPELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKELT)) NEWREG) (SETQ NEWREG (REL.MOVE.REGION (fetch (GROUP GROUPREGION) of GGROUPELT) (fetch (POSITION XCOORD) of DELTAPOS) (fetch (POSITION YCOORD) of DELTAPOS))) (* makes a copy of the common global part because it includes the scales which  may change for one of the instances.) (RETURN (create GLOBALPART COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) of SKELT)) INDIVIDUALGLOBALPART _ (create GROUP GROUPREGION _ NEWREG LISTOFGLOBALELTS _ (for SUBELT in (fetch (GROUP LISTOFGLOBALELTS) of GGROUPELT) collect (SK.TRANSLATE.GLOBALPART SUBELT DELTAPOS T)) GROUPCONTROLPOINT _ (PTPLUS (fetch (GROUP GROUPCONTROLPOINT ) of GGROUPELT) DELTAPOS]) (GROUP.TRANSFORMFN [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb " 2-Jun-85 13:10") (* * returns a group element which has been transformed by TRANSFORMFN) (COND [(EQ TRANSFORMFN (FUNCTION SK.PUT.ON.GRID)) (* if putting things on a grid, move only the control point.) (PROG ((GGROUPELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) NOWPOS) (SETQ NOWPOS (fetch (GROUP GROUPCONTROLPOINT) of GGROUPELT)) (RETURN (GROUP.TRANSLATEFN GELT (PTDIFFERENCE (SK.TRANSFORM.POINT NOWPOS TRANSFORMFN TRANSFORMDATA) NOWPOS] (T (PROG ((GGROUPELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) NEWREG) (* this transforms the old region to get the new one.  This is not as good as recalculating the new one from the transformed elements.  The latter is hard because the region function only works on local elements and  here we have only global ones.) (SETQ NEWREG (SK.TRANSFORM.REGION (fetch (GROUP GROUPREGION) of GGROUPELT) TRANSFORMFN TRANSFORMDATA)) (* the control point could also profitably be put on a grid point but no other  elements points are so done and it would be hard.) (RETURN (BOX.SET.SCALES NEWREG (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART ) of GELT) INDIVIDUALGLOBALPART _ (create GROUP GROUPREGION _ NEWREG LISTOFGLOBALELTS _ (for SUBELT in (fetch (GROUP LISTOFGLOBALELTS) of GGROUPELT) collect (SK.TRANSFORM.ELEMENT SUBELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR)) GROUPCONTROLPOINT _ (SK.TRANSFORM.POINT (fetch (GROUP GROUPCONTROLPOINT ) of GGROUPELT) TRANSFORMFN TRANSFORMDATA]) (GROUP.READCHANGEFN [LAMBDA (SKW SCRNELTS) (* rrb "14-May-86 19:38") (* reads how the user wants to change  a textbox.) (PROG (ASPECT HOW) (SETQ HOW (SELECTQ (SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU (create MENU TITLE _ "Change which part?" ITEMS _ [APPEND (COND [(SKETCHINCOLORP) '(("Brush color" 'BRUSHCOLOR "changes the color of any lines or text in the group." ) ("Filling color" ' FILLINGCOLOR "changes the filling color of any boxes or text boxes in the group." ] (T NIL)) '((Arrowheads 'ARROW "allows changing of arrow head charactistics." ) (Shape 'SHAPE "changes the shape of the brush" ) (Size 'SIZE "changes the size of the lines" ) (Dashing 'DASHING "changes the dashing property of the elements with lines." ) (Filling 'FILLING "allows changing of the fillings." ) (Text 'TEXT "allows changing the properties of the text." ] CENTERFLG _ T))) (TEXT (* handle TEXT specially because it  has several different cases.) (AND (SETQ HOW (TEXT.READCHANGEFN SKW SCRNELTS T)) (RETURN HOW))) (SIZE (READSIZECHANGE "Change size how?")) (SHAPE (READBRUSHSHAPE)) (ARROW (READ.ARROW.CHANGE SCRNELTS)) (DASHING (READ.DASHING.CHANGE)) (FILLING (READ.FILLING.CHANGE)) (BRUSHCOLOR (READ.COLOR.CHANGE "Change line color how?")) (FILLINGCOLOR (READ.COLOR.CHANGE "Change filling color how?" T)) NIL)) (RETURN (AND HOW (LIST ASPECT HOW]) ) (DEFINEQ (REGION.CENTER [LAMBDA (REGION) (* rrb "11-Jan-85 18:22") (* returns the center of a region) (create POSITION XCOORD _ (PLUS (fetch (REGION LEFT) of REGION) (QUOTIENT (fetch (REGION WIDTH) of REGION) 2)) YCOORD _ (PLUS (fetch (REGION BOTTOM) of REGION) (QUOTIENT (fetch (REGION HEIGHT) of REGION) 2]) (REMOVE.LAST [LAMBDA (LST) (* removes the last element from a  list.) (COND ((NULL (CDR LST)) NIL) (T (for TAIL on LST when (NULL (CDDR TAIL)) do (RPLACD TAIL NIL) (RETURN LST]) ) (* ; "moving the control point of a group") (DEFINEQ (SK.MOVE.GROUP.CONTROL.PT [LAMBDA (W) (* rrb "31-Jan-86 10:59") (* lets the user move the control point of a group.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.MOVE.CONTROL.PT (KWOTE W)) W]) (SK.SEL.AND.MOVE.CONTROL.PT [LAMBDA (W) (* rrb "23-Jan-86 18:11") (* lets the user select a groups and move its control point.) (PROG NIL (RETURN (SK.MOVE.GROUP.ELEMENT.CONTROL.POINT [SK.SELECT.ITEM W T (COND [(SUBSET (LOCALSPECS.FROM.VIEWER W) (FUNCTION (LAMBDA (SCRELT) (AND (EQ (fetch (SCREENELT GTYPE) of SCRELT) 'GROUP) (NOT (SK.ELEMENT.PROTECTED? (fetch (SCREENELT GLOBALPART ) of SCRELT) 'CHANGE] (T (* no group elements) (STATUSPRINT W "There are no grouped elements.") (RETURN] W]) (SK.MOVE.GROUP.ELEMENT.CONTROL.POINT [LAMBDA (SCRGROUPELT SKW) (* rrb "27-Jun-86 15:34") (* reads a new location of the control point for a group element.) (PROG ((GELT (fetch (SCREENELT GLOBALPART) of SCRGROUPELT)) (INDVGELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of SCRGROUPELT)) OLDPOS NEWPOS NEWGROUPELT LOCALELT) (AND (EQ (SK.CHECK.PRECHANGEFN SKW GELT 'POSITION) 'DON'T) (RETURN)) (SETQ OLDPOS (GETSKETCHELEMENTPROP GELT 'POSITION)) (OR [SETQ NEWPOS (SK.READ.NEW.GROUP.CONTROL.PT SKW (fetch (LOCALGROUP LOCALGROUPREGION) of (fetch (SCREENELT LOCALPART) of SCRGROUPELT] (RETURN)) (OR (SK.CHECK.WHENCHANGEDFN SKW GELT 'POSITION NEWPOS OLDPOS) (RETURN)) (SETQ NEWGROUPELT (SKETCH.CREATE.GROUP (fetch (GROUP LISTOFGLOBALELTS) of INDVGELT) NEWPOS)) (SK.SET.ELEMENT.PRIORITY NEWGROUPELT (SK.ELEMENT.PRIORITY GELT)) (SK.DELETE.ELEMENT1 GELT SKW T) (SETQ LOCALELT (SK.ADD.ELEMENT NEWGROUPELT SKW T T T)) (SK.FLASHREGION (fetch (LOCALGROUP LOCALGROUPREGION) of (fetch (SCREENELT LOCALPART) of LOCALELT)) SKW GRAYSHADE) (SK.ADD.HISTEVENT 'CHANGE (LIST (create SKHISTORYCHANGESPEC NEWELT _ NEWGROUPELT OLDELT _ GELT PROPERTY _ 'POSITION NEWVALUE _ NEWPOS OLDVALUE _ OLDPOS)) SKW) (RETURN NEWGROUPELT]) (SK.READ.NEW.GROUP.CONTROL.PT [LAMBDA (VIEWER LOCALGROUPREGION) (* rrb "14-Jul-86 13:51") (* reads where the user wants the new control point to be.) (PROG (PT) (* outline the group) (SK.DRAWBOX (fetch (REGION LEFT) of LOCALGROUPREGION) (fetch (REGION BOTTOM) of LOCALGROUPREGION) (fetch (REGION WIDTH) of LOCALGROUPREGION) (fetch (REGION HEIGHT) of LOCALGROUPREGION) 1 'INVERT VIEWER 42405) (STATUSPRINT VIEWER " " "Indicate position of the new control point.") (SETQ PT (SK.READ.POINT.WITH.FEEDBACK VIEWER NIL NIL NIL NIL NIL SKETCH.USE.POSITION.PAD)) (* remove outline of the group) (SK.DRAWBOX (fetch (REGION LEFT) of LOCALGROUPREGION) (fetch (REGION BOTTOM) of LOCALGROUPREGION) (fetch (REGION WIDTH) of LOCALGROUPREGION) (fetch (REGION HEIGHT) of LOCALGROUPREGION) 1 'INVERT VIEWER 42405) (RETURN (AND PT (SK.MAP.INPUT.PT.TO.GLOBAL PT VIEWER]) ) (DECLARE%: EVAL@COMPILE (TYPERECORD GROUP (GROUPREGION LISTOFGLOBALELTS GROUPCONTROLPOINT)) (RECORD LOCALGROUP ((GROUPPOSITION) LOCALHOTREGION LOCALGROUPREGION LOCALELEMENTS)) ) (* ; "history and undo stuff for groups") (DEFINEQ (SK.DO.GROUP [LAMBDA (GROUPELT SKW) (* rrb "30-Sep-86 17:38") (* does a group event.  Used to undo UNGROUP too.) (PROG (LOCALELT OKEDGELTS) (OR [SETQ OKEDGELTS (SK.CHECK.WHENGROUPEDFN SKW (fetch (GROUP LISTOFGLOBALELTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GROUPELT] (RETURN NIL)) (replace (GROUP LISTOFGLOBALELTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GROUPELT) with (SK.ORDER.ELEMENTS OKEDGELTS)) (SK.UPDATE.GROUP.AFTER.CHANGE GROUPELT) (for GELT in OKEDGELTS do (SK.DELETE.ELEMENT1 GELT SKW T)) (SETQ LOCALELT (SK.ADD.ELEMENT GROUPELT SKW T T T)) (* flash the grouped area to let user know something happened.) (SK.FLASHREGION (fetch (LOCALGROUP LOCALGROUPREGION) of (fetch (SCREENELT LOCALPART) of LOCALELT)) SKW GRAYSHADE) (RETURN LOCALELT]) (SK.CHECK.WHENGROUPEDFN [LAMBDA (VIEWER ELEMENTS) (* rrb "15-Jan-86 16:07") (* checks the when grouped fn of a  sketch viewer.) (PROG (GROUPFN X) (AND (SETQ GROUPFN (GETSKETCHPROP (INSURE.SKETCH VIEWER) 'WHENGROUPEDFN)) (SETQ X (APPLY* GROUPFN VIEWER ELEMENTS))) (RETURN (COND ((EQ X 'DON'T) NIL) ((SKETCH.LIST.OF.ELEMENTSP X) X) (T ELEMENTS]) (SK.DO.UNGROUP [LAMBDA (GROUPELT SKW) (* rrb "11-Jul-86 15:51") (* does a ungroup event.  Used to undo GROUP too.) (PROG NIL (OR (SK.CHECK.WHENUNGROUPEDFN SKW GROUPELT) (RETURN)) (SK.DELETE.ELEMENT1 GROUPELT SKW T) (for GELT in (fetch (GROUP LISTOFGLOBALELTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GROUPELT)) do (SK.ADD.ELEMENT GELT SKW T T T)) (SK.FLASHREGION (SCALE.REGION.OUT (fetch (GROUP GROUPREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GROUPELT)) (VIEWER.SCALE SKW)) SKW GRAYSHADE) (RETURN GROUPELT]) (SK.CHECK.WHENUNGROUPEDFN [LAMBDA (VIEWER GROUPELT) (* rrb "15-Jan-86 16:19") (* checks the when ungrouped fn of a  sketch viewer.) (PROG (UNGROUPFN) (RETURN (OR [NULL (SETQ UNGROUPFN (GETSKETCHPROP (INSURE.SKETCH VIEWER) 'WHENUNGROUPEDFN] (NEQ (APPLY* UNGROUPFN VIEWER GROUPELT) 'DON'T]) (SK.GROUP.UNDO [LAMBDA (EVENTARGS SKW) (* rrb "15-Jan-86 16:12") (* undoes a group event) (for GRP in EVENTARGS do (SK.DO.UNGROUP (CAR GRP) SKW)) T]) (SK.UNGROUP.UNDO [LAMBDA (EVENTARGS SKW) (* rrb "15-Jan-86 15:47") (* undoes a ungroup event) (for GRP in EVENTARGS do (SK.DO.GROUP (CAR GRP) SKW)) T]) ) (PUTPROPS GROUP EVENTFNS (SK.GROUP.UNDO SK.TYPE.OF.FIRST.ARG SK.UNGROUP.UNDO)) (PUTPROPS UNGROUP EVENTFNS (SK.UNGROUP.UNDO SK.TYPE.OF.FIRST.ARG SK.GROUP.UNDO)) (* ; "stuff for supporting the freezing of elements") (DEFINEQ (SK.FREEZE.ELTS [LAMBDA (W) (* rrb "31-Jan-86 10:59") (* lets the user select a collection elements and freezes them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.FREEZE (KWOTE W)) W]) (SK.SEL.AND.FREEZE [LAMBDA (W) (* rrb "11-Dec-85 15:30") (* lets the user select elements and  freezes them.) (SK.FREEZE.ELEMENTS (SK.SELECT.MULTIPLE.ITEMS W T NIL 'FROZEN) W]) (SK.FREEZE.ELEMENTS [LAMBDA (SCRELTS SKW) (* rrb "11-Dec-85 15:30") (* freezes the collection of elements  SCRELTS.) (PROG (GELTS GELT) (OR (SETQ GELTS (for SCRELT in SCRELTS collect (fetch (SCREENELT GLOBALPART) of SCRELT))) (RETURN)) (SK.DO.FREEZE GELTS SKW) (SK.ADD.HISTEVENT 'FREEZE GELTS SKW]) (SK.UNFREEZE.ELT [LAMBDA (W) (* rrb "31-Jan-86 10:59") (* lets the user select a collection elements and unfreezes them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.UNFREEZE (KWOTE W)) W]) (SK.SEL.AND.UNFREEZE [LAMBDA (W) (* rrb "12-Dec-85 12:25") (* lets the user select elements and  freezes them.) (PROG NIL (RETURN (SK.UNFREEZE.ELEMENTS [SK.SELECT.MULTIPLE.ITEMS W T (COND [(SUBSET (LOCALSPECS.FROM.VIEWER W) (FUNCTION (LAMBDA (SCRELT) (EQMEMB 'FROZEN (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of SCRELT) 'PROTECTION] (T (* no group elements) (STATUSPRINT W "There are no frozen elements to unprotect." ) (RETURN] W]) (SK.UNFREEZE.ELEMENTS [LAMBDA (SCRELTS SKW) (* rrb "11-Dec-85 15:30") (* unfreezes the collection of  elements SCRELTS.) (PROG (GELTS GELT) (OR (SETQ GELTS (for SCRELT in SCRELTS collect (fetch (SCREENELT GLOBALPART) of SCRELT))) (RETURN)) (SK.DO.UNFREEZE GELTS SKW) (SK.ADD.HISTEVENT 'UNFREEZE GELTS SKW]) (SK.FREEZE.UNDO [LAMBDA (EVENTARGS SKW) (* rrb "11-Dec-85 15:28") (* undoes a freeze event) (SK.DO.UNFREEZE EVENTARGS SKW]) (SK.UNFREEZE.UNDO [LAMBDA (EVENTARGS SKW) (* rrb "11-Dec-85 15:28") (* undoes a unfreeze event) (SK.DO.FREEZE EVENTARGS SKW]) (SK.DO.FREEZE [LAMBDA (GELTS SKW) (* rrb "11-Dec-85 15:27") (* does a freeze event.  Used to undo UNFREEZE too.) (for GELT in GELTS do (ADDSKETCHELEMENTPROP GELT 'PROTECTION 'FROZEN)) GELTS]) (SK.DO.UNFREEZE [LAMBDA (GELTS SKW) (* rrb "11-Dec-85 15:27") (* does a unfreeze event.  Used to undo FREEZE too.) (for GELT in GELTS do (REMOVESKETCHELEMENTPROP GELT 'PROTECTION 'FROZEN)) GELTS]) ) (PUTPROPS FREEZE EVENTFNS (SK.FREEZE.UNDO SK.TYPE.OF.FIRST.ARG SK.UNFREEZE.UNDO)) (PUTPROPS UNFREEZE EVENTFNS (SK.UNFREEZE.UNDO SK.TYPE.OF.FIRST.ARG SK.FREEZE.UNDO)) (* ; "programmer interface entries") (DEFINEQ (SKETCH.ELEMENTS.OF.SKETCH [LAMBDA (SKETCH) (* rrb " 2-Aug-85 16:21") (* Returns the list of elements that are in SKETCH.  SKETCH can be either a SKETCH structure, a sketch window  (sometimes called a viewer) or a SKETCH stream  (obtained via (OPENIMAGESTREAM (QUOTE name)  (QUOTE SKETCH))%. If SKETCH is not a sketch, a sketch window or a sketch  stream, it returns NIL. This can be used with sketch streams to determine the  elements created by a call to a display function or series of functions by  looking at the list differences; new elements are always added at the end.)) (fetch (SKETCH SKETCHELTS) of (INSURE.SKETCH SKETCH T]) (SKETCH.LIST.OF.ELEMENTS [LAMBDA (SKETCH PREDICATE INSIDEGROUPSFLG) (* rrb "14-Aug-85 16:26") (* Returns a list of the sketch elements in SKETCH that satisfy PREDICATE.  If INSIDEGROUPSFLG is T, elements that are members of a group will be  considered too. Otherwise only top level objects are considered.  Note%: PREDICATE will be applied to GROUP elements even when INSIDEGROUPSFLG is  T.) (* FOR NOW, IGNORE INSIDEGROUPSFLG) (for ELT in (SKETCH.ELEMENTS.OF.SKETCH SKETCH) when (APPLY* PREDICATE ELT) collect ELT]) (SKETCH.ADD.ELEMENT [LAMBDA (ELEMENT SKETCH NODISPLAYFLG) (* rrb "30-Aug-86 15:09") (* Adds an element to a sketch. If NODISPLAYFLG is NIL, any windows currently  displaying SKETCH will be updated to reflect ELEMENT's addition.  If NODISPLAYFLG is T, the displays won't be updated.) (PROG [(SKSTRUC (COND ((NULL SKETCH) (SKETCH.CREATE NIL)) (T (INSURE.SKETCH SKETCH] (COND ((NULL ELEMENT) (RETURN SKSTRUC)) ((NOT (GLOBALELEMENTP ELEMENT)) (ERROR ELEMENT "is not a sketch element."))) (* add the element to the sketch.) (ADD.ELEMENT.TO.SKETCH ELEMENT SKSTRUC) (* propagate to the viewers.) (for SKW in (ALL.SKETCH.VIEWERS SKSTRUC) when (ELT.INSIDE.SKETCHWP ELEMENT SKW) do (SKETCH.ADD.AND.DISPLAY1 ELEMENT SKW NIL NODISPLAYFLG)) (RETURN SKSTRUC]) (SKETCH.DELETE.ELEMENT [LAMBDA (ELEMENT SKETCH INSIDEGROUPSFLG NODISPLAYFLG) (* rrb "19-Oct-85 17:09") (* Deletes an element from a sketch. If INSIDEGROUPSFLG is T, the element will  be deleted even if it is inside a group.  Otherwise it will be deleted only if it is on the top level.  If NODISPLAYFLG is NIL, any windows currently displaying SKETCH will be updated  to reflect ELEMENT's deletion. If NODISPLAYFLG is T, the displays won't be  updated. It returns ELEMENT if ELEMENT was deleted.) (PROG ((SKSTRUC (INSURE.SKETCH SKETCH)) LOCALELT OLDGELT) (* delete the element to the sketch.) (COND ((EQ T (SETQ OLDGELT (REMOVE.ELEMENT.FROM.SKETCH ELEMENT SKSTRUC INSIDEGROUPSFLG))) (* element deleted was top level.) ) (OLDGELT (* element deleted was part of a  group.) (printout PROMPTWINDOW T "member of group deleted but group not redrawn.")) (T (RETURN NIL))) (* propagate to the viewers.) (for SKW in (ALL.SKETCH.VIEWERS SKSTRUC) when (SETQ LOCALELT (SK.LOCAL.ELT.FROM.GLOBALPART ELEMENT SKW)) do (SK.ERASE.AND.DELETE.ITEM LOCALELT SKW NODISPLAYFLG)) (SK.CHECK.IMAGEOBJ.WHENDELETEDFN ELEMENT SKETCH) (RETURN OLDGELT]) (DELFROMGROUPELT [LAMBDA (ELTTODEL GROUPELT) (* rrb " 2-Aug-85 17:03") (* if ELTTODEL is a member of GROUPELT, this deletes it.) (AND (EQ (fetch (GLOBALPART GTYPE) of GROUPELT) 'GROUP) (PROG ((INDVGROUPELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GROUPELT)) SUBELTS) (SETQ SUBELTS (fetch (GROUP LISTOFGLOBALELTS) of INDVGROUPELT)) (COND ((MEMBER ELTTODEL SUBELTS) (replace (GROUP LISTOFGLOBALELTS) of INDVGROUPELT with (REMOVE ELTTODEL SUBELTS)) (RETURN T)) (T (RETURN (for ELT in SUBELTS thereis (DELFROMGROUPELT ELTTODEL ELT]) (SKETCH.ELEMENT.TYPE [LAMBDA (ELEMENT) (* rrb "14-Aug-85 16:35") (* returns the type of a global sketch  element) (fetch (GLOBALPART GTYPE) of ELEMENT]) (SKETCH.ELEMENT.CHANGED [LAMBDA (SKETCH ELEMENT SKETCHWINDOW) (* rrb " 4-Feb-86 15:04") (* If ELEMENT is an element of SKETCH, its local part is recalculated.  This is normally used to notify sketch that an image object element has  changed. Note%: this replaces the element with another one.) (PROG ((SKETCH (INSURE.SKETCH SKETCH)) OLDREG) (OR (GLOBALELEMENTP ELEMENT) (ERROR ELEMENT " is not a sketch element.")) (* note that the sketch has changed.) (SK.MARK.DIRTY SKETCH) (SETQ OLDREG (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of ELEMENT))) (SK.UPDATE.GLOBAL.IMAGE.OBJECT.ELEMENT ELEMENT SKETCHWINDOW) (* do the window that the interaction  occurred in first.) (AND SKETCHWINDOW (SK.ELEMENT.CHANGED1 ELEMENT OLDREG SKETCHWINDOW)) (* propagate to other windows.) (for SKW in (ALL.SKETCH.VIEWERS SKETCH) when (NEQ SKW SKETCHWINDOW) do (SK.ELEMENT.CHANGED1 ELEMENT OLDREG SKW)) (RETURN ELEMENT]) (SK.ELEMENT.CHANGED1 [LAMBDA (SKIMAGEOBJELT OLDREGION SKETCHW) (* rrb "21-Aug-85 15:54") (* updates the display of an image object element in a window.) (PROG (LOCALELT) (COND ((SETQ LOCALELT (SK.LOCAL.ELT.FROM.GLOBALPART SKIMAGEOBJELT SKETCHW)) (COND ((EQ (SKETCH.ELEMENT.TYPE SKIMAGEOBJELT) 'SKIMAGEOBJ) (SK.DELETE.ITEM LOCALELT SKETCHW) (DSPFILL OLDREGION WHITESHADE 'REPLACE SKETCHW) (RETURN (SKETCH.ADD.AND.DISPLAY1 SKIMAGEOBJELT SKETCHW]) (SK.UPDATE.GLOBAL.IMAGE.OBJECT.ELEMENT [LAMBDA (SKIMOBJELT VIEWER) (* rrb " 4-Feb-86 15:04") (* updates the fields to reflect changes in the size of the image object.) (PROG ((INDVSKIMOBJELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKIMOBJELT)) IMOBJSIZE REGION SCALE) (SETQ IMOBJSIZE (IMAGEBOXSIZE (fetch (SKIMAGEOBJ SKIMAGEOBJ) of INDVSKIMOBJELT) VIEWER)) (SETQ REGION (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of INDVSKIMOBJELT)) (SETQ SCALE (fetch (SKIMAGEOBJ SKIMOBJ.ORIGSCALE) of INDVSKIMOBJELT)) (replace (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of INDVSKIMOBJELT with (CREATEREGION (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (TIMES (fetch (IMAGEBOX XSIZE) of IMOBJSIZE) SCALE) (TIMES (fetch (IMAGEBOX YSIZE) of IMOBJSIZE) SCALE))) (replace (SKIMAGEOBJ SKIMOBJ.OFFSETPOS) of INDVSKIMOBJELT with (create POSITION XCOORD _ (fetch (IMAGEBOX XKERN) of IMOBJSIZE) YCOORD _ (fetch (IMAGEBOX YDESC) of IMOBJSIZE))) (RETURN SKIMOBJELT]) ) (* ; "utility routines for sketch windows.") (DEFINEQ (INSURE.SKETCH [LAMBDA (SK NOERRORFLG) (* rrb " 3-Oct-86 15:16") (* returns the SKETCH structure from a window, sketch stream, or a structure.) (SK.CHECK.SKETCH.VERSION (COND ((type? SKETCH SK) SK) [(WINDOWP SK) (COND ((WINDOWPROP SK 'SKETCH)) (T (AND (NULL NOERRORFLG) (ERROR SK "doesn't have a SKETCH property."] [(IMAGESTREAMTYPEP SK 'SKETCH) (* this is a sketch stream) (COND ((WINDOWPROP (\SKSTRM.WINDOW.FROM.STREAM SK) 'SKETCH)) (T (AND (NULL NOERRORFLG) (ERROR "sketch stream window doesn't have SKETCH property" SK] [(type? IMAGEOBJ SK) (PROG [(SK? (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of (LISTP (IMAGEOBJPROP SK 'OBJECTDATUM] (RETURN (COND ((type? SKETCH SK?) SK?) (NOERRORFLG NIL) (T (ERROR "not a sketch image object" SK] ((AND (LISTP SK) (LITATOM (CAR SK)) (for ELT in (CDR SK) always (GLOBALELEMENTP ELT))) (* old form, probably written out by notecards, update to new form.) (PROG (X) (SETQ X (SKIO.UPDATE.FROM.OLD.FORM SK)) (* smash sketch so this won't have to happen every time.) (RPLACA SK (CAR X)) (RPLACD SK (CDR X)) (RETURN X))) ((NULL NOERRORFLG) (ERROR SK "not a SKETCH"]) (LOCALSPECS.FROM.VIEWER [LAMBDA (SKW) (* rrb "12-May-85 16:46") (* returns the sketch specification  displayed in the window SKW.) (CDAR (WINDOWPROP SKW 'SKETCHSPECS]) (SK.LOCAL.ELT.FROM.GLOBALPART [LAMBDA (GLOBALPART SKW) (* rrb "18-MAR-83 13:09") (* returns the local element from SKW that has global part GLOBALPART -  NIL if there isn't one.) (for ELT in (LOCALSPECS.FROM.VIEWER SKW) when (EQ (fetch (SCREENELT GLOBALPART) of ELT) GLOBALPART) do (RETURN ELT]) (SKETCH.FROM.VIEWER [LAMBDA (SKETCHW) (* returns the sketch that the window  views.) (WINDOWPROP SKETCHW 'SKETCH]) (INSPECT.SKETCH [LAMBDA (SKW) (* rrb "18-Apr-84 14:44") (* calls the inspector on the sketch specs of a sketch window.) (PROG ((SPECS (LOCALSPECS.FROM.VIEWER SKW))) (COND (SPECS (INSPECT/TOP/LEVEL/LIST SPECS]) (ELT.INSIDE.SKETCHWP [LAMBDA (GELT SKW) (* rrb " 8-APR-83 13:18") (* determines if a global element is in the region of a viewer) (SK.INSIDE.REGION GELT (WINDOWPROP SKW 'REGION.VIEWED]) (SK.INSIDE.REGION [LAMBDA (GELT REGION) (* rrb "31-Aug-84 10:15") (* determines if the element GELT is inside of the global region REGION) (APPLY* (SK.INSIDEFN (fetch (GLOBALPART GTYPE) of GELT)) GELT REGION]) ) (DEFINEQ (MAPSKETCHSPECS [LAMBDA (SKSPECS SPECFN DATUM DATUM2 DATUM3) (* rrb "10-Sep-84 14:58") (* walks through a sketch specification list and applies SPECFN to each of the  individual elements.) (AND SKSPECS (COND ((SCREENELEMENTP SKSPECS) (APPLY* SPECFN SKSPECS DATUM DATUM2 DATUM3)) ((LISTP SKSPECS) (for FIGSPEC in SKSPECS do (MAPSKETCHSPECS FIGSPEC SPECFN DATUM DATUM2 DATUM3))) (T (ERROR "unknown figure specification" SKSPECS]) (MAPCOLLECTSKETCHSPECS [LAMBDA (SKSPECS SPECFN DATUM DATUM2 DATUM3 DATUM4) (* rrb "26-Apr-85 09:29") (* walks through a sketch specification list and applies SPECFN to each of the  individual (elements returning a list of the results.)) (AND SKSPECS (COND ((SCREENELEMENTP SKSPECS) (APPLY* SPECFN SKSPECS DATUM DATUM2 DATUM3 DATUM4)) ((LISTP SKSPECS) (for FIGSPEC in SKSPECS collect (MAPCOLLECTSKETCHSPECS FIGSPEC SPECFN DATUM DATUM2 DATUM3 DATUM4))) (T (ERROR "unknown figure specification" SKSPECS]) (MAPSKETCHSPECSUNTIL [LAMBDA (SKETCHSPECS SPECFN DATUM DATUM2) (* rrb " 4-AUG-83 15:22") (* walks through a sketch specification list and applies SPECFN to each of the  individual elements.) (AND SKETCHSPECS (COND ((SKETCH.ELEMENT.NAMEP (fetch (SCREENELT GTYPE) of SKETCHSPECS)) (APPLY* SPECFN SKETCHSPECS DATUM DATUM2)) ((LISTP SKETCHSPECS) (for FIGSPEC in SKETCHSPECS bind VALUE when (SETQ VALUE (MAPSKETCHSPECSUNTIL FIGSPEC SPECFN DATUM DATUM2)) do (RETURN VALUE))) (T (ERROR "unknown figure specification" SKETCHSPECS]) (MAPGLOBALSKETCHSPECS [LAMBDA (SKSPECS SPECFN DATUM DATUM2 DATUM3) (* rrb "19-Feb-85 17:52") (* walks through a list of global sketch elements and applies SPECFN to each of  the individual elements.) (AND SKSPECS (COND ((GLOBALELEMENTP SKSPECS) (APPLY* SPECFN SKSPECS DATUM DATUM2 DATUM3)) ((LISTP SKSPECS) (for FIGSPEC in SKSPECS collect (MAPGLOBALSKETCHSPECS FIGSPEC SPECFN DATUM DATUM2 DATUM3))) (T (ERROR "unknown global sketch element" SKSPECS]) (MAPGLOBALSKETCHELEMENTS [LAMBDA (SKSPECS SPECFN DATUM DATUM2 DATUM3) (* rrb "24-Apr-85 15:02") (* walks through a list of global sketch elements and applies SPECFN to each of  the individual elements. Differes from MAPGLOBALSKETCHSPECS in that it know  about and gets inside of GROUP elements.) (AND SKSPECS (COND [(GLOBALELEMENTP SKSPECS) (COND ((EQ (fetch (GLOBALPART GTYPE) of SKSPECS) 'GROUP) (* map function down the individual  elements.) (MAPGLOBALSKETCHELEMENTS (fetch (GROUP LISTOFGLOBALELTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKSPECS)) SPECFN DATUM DATUM2 DATUM3)) (T (APPLY* SPECFN SKSPECS DATUM DATUM2 DATUM3] ((LISTP SKSPECS) (for FIGSPEC in SKSPECS collect (MAPGLOBALSKETCHELEMENTS FIGSPEC SPECFN DATUM DATUM2 DATUM3))) (T (ERROR "unknown global sketch element" SKSPECS]) ) (* ; "multiple selection and copy select functions") (DEFINEQ (SK.ADD.SELECTION [LAMBDA (ITEM/POS WINDOW MARKBM FIRSTFLG) (* rrb " 9-May-85 10:42") (* adds an item to the selection list  of WINDOW.) (COND ([NOT (MEMBER ITEM/POS (WINDOWPROP WINDOW 'SKETCH.SELECTIONS] (* must turning off the element's selection before adding it to the window  selections because the display of the selection check to see if the points are  already selected in another element.) (SK.SELECT.ELT ITEM/POS WINDOW MARKBM) (WINDOWADDPROP WINDOW 'SKETCH.SELECTIONS ITEM/POS FIRSTFLG]) (SK.COPY.INSERTFN [LAMBDA (IMAGEOBJ SKW) (* rrb "23-Jun-87 13:25") (* * the function that gets called to insert a copy-selection into a sketch  window. Knows how to insert sketches, everything else is text.) (PROG (IMAGEOBJYET SELECTION EXTENDSELECTION) (* bind the selection so that if the user has to place an image obj, it is  restored before the characters are unBYSYSBUFed) [bind DATUM for IMOBJ inside IMAGEOBJ do (COND ((STRINGP IMOBJ) (BKSYSBUF IMOBJ)) ((EQ (fetch (IMAGEOBJ IMAGEOBJFNS) of IMOBJ) SKETCHIMAGEFNS) (* this is a sketch imageobj) [COND ((NULL IMAGEOBJYET) (* save SELECTION and  EXTENDSELECTION so they can be  restored) (SETQ IMAGEOBJYET T) (SETQ SELECTION (WINDOWPROP SKW 'SELECTION)) (SETQ EXTENDSELECTION (WINDOWPROP SKW 'EXTENDSELECTION] (SETQ DATUM (IMAGEOBJPROP IMOBJ 'OBJECTDATUM)) (OR (SK.INSERT.SKETCH SKW (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of DATUM) (fetch (SKETCHIMAGEOBJ SKIO.REGION) of DATUM) (fetch (SKETCHIMAGEOBJ SKIO.SCALE) of DATUM)) (RETURN))) (T (* insert the image object whatever  it is) [COND ((NULL IMAGEOBJYET) (* save SELECTION and  EXTENDSELECTION so they can be  restored) (SETQ IMAGEOBJYET T) (SETQ SELECTION (WINDOWPROP SKW 'SELECTION)) (SETQ EXTENDSELECTION (WINDOWPROP SKW 'EXTENDSELECTION] (* if the user placed it outside,  just return) (OR (SK.INSERT.SKETCH SKW [SKETCH.CREATE 'DUMMYNAME 'ELEMENTS (LIST (SETQ DATUM ( SK.ELEMENT.FROM.IMAGEOBJ IMOBJ SKW] (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of DATUM)) (VIEWER.SCALE SKW)) (RETURN] (COND (IMAGEOBJYET (* restore the selection) (WINDOWPROP SKW 'SELECTION SELECTION) (WINDOWPROP SKW 'EXTENDSELECTION EXTENDSELECTION) (SKED.SELECTION.FEEDBACK SKW]) (SCREENELEMENTP [LAMBDA (ELT?) (* rrb "26-Sep-86 14:53") (* * returns ELT? if it is a screen element.) (PROG (X) (RETURN (AND (LISTP ELT?) (LISTP (CDR ELT?)) (SETQ X (fetch (SCREENELT GLOBALPART) of ELT?)) (SKETCH.ELEMENT.NAMEP (fetch (GLOBALPART GTYPE) of X)) ELT?]) (SK.ITEM.REGION [LAMBDA (SCRELT) (* rrb "24-Jan-85 17:46") (* SCRELT is a sketch element This function returns the region it occupies.) (PROG [(REGIONFN (SK.REGIONFN (fetch (SCREENELT GTYPE) of SCRELT] (RETURN (COND ((OR (NULL REGIONFN) (EQ REGIONFN 'NILL)) NIL) ((APPLY* REGIONFN SCRELT]) (SK.ELEMENT.GLOBAL.REGION [LAMBDA (GELT) (* rrb "18-Oct-85 10:30") (* GELT is a global sketch element This function returns the global region it  occupies.) (PROG [(REGIONFN (SK.GLOBAL.REGIONFN (fetch (GLOBALPART GTYPE) of GELT] (RETURN (COND ((OR (NULL REGIONFN) (EQ REGIONFN 'NILL)) NIL) ((APPLY* REGIONFN GELT]) (SK.LOCAL.ITEMS.IN.REGION [LAMBDA (HOTSPOTCACHE LEFT BOTTOM RIGHT TOP) (* rrb "31-Jan-85 11:38") (* * returns a list of the LOCALITEMS that are within LOCALREGION) (* changed to take a hotspot cache instead of a list of local items.  OLD ARGS were (HOTSPOTCACHE LOCALREGION SCALE) OLD CODE  (PROG ((SKREGION (UNSCALE.REGION LOCALREGION SCALE)))  (RETURN (for SCRELT in LOCALITEMS when (SK.INSIDE.REGION  (fetch (SCREENELT GLOBALPART) of SCRELT) SKREGION) collect SCRELT)))) (PROG ((RLEFT (DIFFERENCE LEFT SK.POINT.WIDTH)) (RBOTTOM (DIFFERENCE BOTTOM SK.POINT.WIDTH)) (RRIGHT (PLUS RIGHT SK.POINT.WIDTH)) (RTOP (PLUS TOP SK.POINT.WIDTH)) ELTS) [for YBUCKET in HOTSPOTCACHE when (ILEQ (CAR YBUCKET) RTOP) do (COND ((ILESSP (CAR YBUCKET) RBOTTOM) (* stop when Y gets too small.) (RETURN))) (for XBUCKET in (CDR YBUCKET) when (ILEQ (CAR XBUCKET) RRIGHT) do (COND ((ILESSP (CAR XBUCKET) RLEFT) (* stop when X gets too small.) (RETURN))) (* collect the elements.) (SETQ ELTS (UNION (CDR XBUCKET) ELTS] (RETURN ELTS]) (SK.REGIONFN [LAMBDA (ELEMENTTYPE) (* rrb " 5-Sep-84 16:06") (* * access fn for getting the function that returns the region of an item from  its type.) (fetch (SKETCHTYPE REGIONFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) (SK.GLOBAL.REGIONFN [LAMBDA (ELEMENTTYPE) (* rrb "18-Oct-85 10:30") (* * access fn for getting the function that returns the global region of a  global sketch element from its type.) (fetch (SKETCHTYPE GLOBALREGIONFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) (SK.REMOVE.SELECTION [LAMBDA (ITEM/POS WINDOW MARKBM) (* rrb " 9-May-85 10:31") (* removes an item from the selection  list of WINDOW.) (COND ((MEMBER ITEM/POS (WINDOWPROP WINDOW 'SKETCH.SELECTIONS)) (* must remove element from window selections before turning off its selection  because the display of the selection check to see if the points are still  selected in another element.) (WINDOWDELPROP WINDOW 'SKETCH.SELECTIONS ITEM/POS) (SK.DESELECT.ELT ITEM/POS WINDOW MARKBM]) (SK.SELECT.MULTIPLE.ITEMS [LAMBDA (WINDOW ITEMFLG SELITEMS OPERATION) (* rrb "10-Dec-85 17:34") (* * selects allows the user to select a group of the sketch elements from the  sketch WINDOW. If ITEMFLG is NIL, the user is allows to select control points  as well as complete items and the returned value may be the position of a  control point. If SELITEMS is given it is used as the items to be marked and  selected from. Keeps control and probably shouldn't) (* the selection protocol is left to add, right to delete.  Multiple clicking in the same place upscales for both select and deselect.  Sweeping will select or deselect all of the items in the swept out area.  Also it keeps control as long as a shift key is down.) (PROG ((INTERIOR (DSPCLIPPINGREGION NIL WINDOW)) SELECTABLEITEMS HOTSPOTCACHE TIMER NOW OLDX ORIGX NEWX NEWY OLDY ORIGY OUTOFFIRSTPICK PREVMOUSEBUTTONS MOUSEINSIDE?) (COND (SELITEMS (SETQ SELECTABLEITEMS SELITEMS) (* create a cache for the items to  select from) (SETQ HOTSPOTCACHE (SK.ADD.HOTSPOTS.TO.CACHE SELITEMS NIL))) [(AND (SETQ SELECTABLEITEMS (LOCALSPECS.FROM.VIEWER WINDOW)) (SK.HAS.SOME.HOTSPOTS (SETQ HOTSPOTCACHE (SK.HOTSPOT.CACHE.FOR.OPERATION WINDOW OPERATION] (T (* no items, don't do anything.) (RETURN))) (TOTOPW WINDOW) (SK.PUT.MARKS.UP WINDOW HOTSPOTCACHE) (until (MOUSESTATE (NOT UP))) (COND ((INSIDEP INTERIOR (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (SETQ MOUSEINSIDE? T)) (T (* first press was outside of the window, don't select anything.) (SK.TAKE.MARKS.DOWN WINDOW HOTSPOTCACHE) (RETURN))) SELECTLP (COND ((MOUSESTATE UP) (GO SELECTEXIT))) (* this label provides an entry for the code that tests if the shift key is  down.) SELAFTERTEST (SETQ NEWY (LASTMOUSEY WINDOW)) (SETQ NEWX (LASTMOUSEX WINDOW)) [COND [(NOT MOUSEINSIDE?) (* mouse is outside, don't do anything other than wait for it to come back in.  If the user has let up all buttons, the branch to SELECTEXIT will have been  taken.) (COND ((INSIDEP INTERIOR NEWX NEWY) (SETQ MOUSEINSIDE? T) (* restore the saved selected items.) (for ELT in SELITEMS do (SK.ADD.SELECTION ELT WINDOW] ((NOT (INSIDEP INTERIOR NEWX NEWY)) (* mouse just went outside, remove selections but save them in case mouse comes  back in.) (SETQ MOUSEINSIDE? NIL) (SETQ SELITEMS (WINDOWPROP WINDOW 'SKETCH.SELECTIONS)) (for ELT in SELITEMS do (SK.REMOVE.SELECTION ELT WINDOW))) [(NEQ PREVMOUSEBUTTONS LASTMOUSEBUTTONS) (* another button has gone down, mark this as the origin of a new box to sweep.) (SETQ PREVMOUSEBUTTONS LASTMOUSEBUTTONS) (SETQ ORIGX (LASTMOUSEX WINDOW)) (SETQ ORIGY (LASTMOUSEY WINDOW)) [COND ((NULL ITEMFLG) (* clear any selections that are of  single points.) (for SEL in (WINDOWPROP WINDOW 'SKETCH.SELECTIONS) when (POSITIONP SEL) do (SK.REMOVE.SELECTION SEL WINDOW] (* add or delete the element that the button press occurred on if any.) (AND [SETQ NOW (IN.SKETCH.ELT? HOTSPOTCACHE (create POSITION XCOORD _ NEWX YCOORD _ NEWY) (AND (NULL ITEMFLG) (LASTMOUSESTATE (ONLY LEFT)) (NULL (WINDOWPROP WINDOW 'SKETCH.SELECTIONS] (COND ((LASTMOUSESTATE (ONLY LEFT)) (* add selection.) (SK.ADD.SELECTION NOW WINDOW)) ((LASTMOUSESTATE RIGHT) (* remove selection.) (SK.REMOVE.SELECTION NOW WINDOW] ((COND (OUTOFFIRSTPICK (OR (NEQ OLDX NEWX) (NEQ OLDY NEWY))) ((OR (IGREATERP (IABS (IDIFFERENCE ORIGX NEWX)) SK.NO.MOVE.DISTANCE) (IGREATERP (IABS (IDIFFERENCE ORIGY NEWY)) SK.NO.MOVE.DISTANCE)) (* make the first pick move further so that it is easier to multiple click.) (SETQ OUTOFFIRSTPICK T))) (* cursor has moved more than the minimum amount since last noticed.) (* add or delete any with in the swept out area.) (COND ([AND (LASTMOUSESTATE (NOT UP)) (SETQ SELITEMS (SK.LOCAL.ITEMS.IN.REGION HOTSPOTCACHE (MIN ORIGX NEWX) (MIN ORIGY NEWY) (MAX ORIGX NEWX) (MAX ORIGY NEWY] (* if selecting multiple things, it must be whole items.  Update NOW to be an item if it isn't already.) [COND ((POSITIONP NOW) (SK.REMOVE.SELECTION NOW WINDOW) (* if selecting, add the whole element  in.) (AND (LASTMOUSESTATE (ONLY LEFT)) (SETQ NOW (IN.SKETCH.ELT? HOTSPOTCACHE NOW)) (SK.ADD.SELECTION NOW WINDOW] (COND ((LASTMOUSESTATE (ONLY LEFT)) (* left only selects.) (for SELITEM in SELITEMS do (SK.ADD.SELECTION SELITEM WINDOW))) ((LASTMOUSESTATE RIGHT) (* right cause deselect.) (for SELITEM in SELITEMS do (SK.REMOVE.SELECTION SELITEM WINDOW] (SETQ OLDX NEWX) (SETQ OLDY NEWY) (GO SELECTLP) SELECTEXIT (COND (OUTOFFIRSTPICK (GO SHIFTDOWNLP))) (* wait for multiple clicks) (SETQ TIMER (SETUPTIMER CLICKWAITTIME TIMER)) CLICKLP (COND [(AND (MOUSESTATE (NOT UP)) (ILESSP (IABS (IDIFFERENCE ORIGX (LASTMOUSEX WINDOW))) SK.NO.MOVE.DISTANCE) (ILESSP (IABS (IDIFFERENCE ORIGY (LASTMOUSEY WINDOW))) SK.NO.MOVE.DISTANCE)) (AND (LASTMOUSESTATE (ONLY LEFT)) (COND ((POSITIONP NOW) (* thing selected is a point, select  the whole item.) (SK.REMOVE.SELECTION NOW WINDOW) (SK.ADD.SELECTION (SETQ NOW (IN.SKETCH.ELT? HOTSPOTCACHE NOW)) WINDOW)) ((SCREENELEMENTP NOW) (* thing now selected is an item, select all selectable items keeping the first  one selected on the front.) (for SELITEM in (SETQ NOW (CONS NOW (REMOVE NOW SELECTABLEITEMS))) do (SK.ADD.SELECTION SELITEM WINDOW] ((NOT (TIMEREXPIRED? TIMER)) (GO CLICKLP))) SHIFTDOWNLP (COND ((MOUSESTATE (NOT UP)) (* button went down again, initialize the button state and click position.) (SETQ PREVMOUSEBUTTONS NIL) (SETQ OUTOFFIRSTPICK NIL) (GO SELAFTERTEST)) ((.SHIFTKEYDOWNP.) (* flip selection marks because if cursor is outside when shift key is let up,  nothing is selected.) [COND [(NOT MOUSEINSIDE?) (* mouse is outside%: if it comes back in, mark the selections.) (COND ((INSIDEP INTERIOR (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (SETQ MOUSEINSIDE? T) (* restore the saved selected items.) (for ELT in SELITEMS do (SK.ADD.SELECTION ELT WINDOW] ((NOT (INSIDEP INTERIOR (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW))) (* mouse just went outside, remove  marks but keep selections) (SETQ MOUSEINSIDE? NIL) (SETQ SELITEMS (WINDOWPROP WINDOW 'SKETCH.SELECTIONS)) (for ELT in SELITEMS do (SK.REMOVE.SELECTION ELT WINDOW] (GO SHIFTDOWNLP))) (SETQ SELITEMS (WINDOWPROP WINDOW 'SKETCH.SELECTIONS)) (COND (MOUSEINSIDE? (* unmark and remove the selected items from the window property list.) (for SEL in SELITEMS do (SK.REMOVE.SELECTION SEL WINDOW))) (T (* they have already been unmarked, just remove them from the window.) (WINDOWPROP WINDOW 'SKETCH.SELECTIONS NIL))) (SK.TAKE.MARKS.DOWN WINDOW HOTSPOTCACHE) (RETURN SELITEMS]) (SKETCH.GET.ELEMENTS [LAMBDA (VIEWER SINGLEELEMENTFLG WHICHONES) (* rrb "17-Dec-85 15:35") (* hilites the selection points and lets the user select one or more.) (PROG [[SELECTABLEITEMS (COND ((LISTP WHICHONES) (for ELT in WHICHONES collect (COND ((GLOBALELEMENTP ELT) (SK.LOCAL.ELT.FROM.GLOBALPART ELT VIEWER)) (T (\ILLEGAL.ARG ELT] (OPERATION (SELECTQ (AND (NLISTP WHICHONES) WHICHONES) ((MOVE COPY DELETE CHANGE GROUP UNGROUP COPYSELECT T FROZEN NIL) WHICHONES) (\ILLEGAL.ARG WHICHONES] (RETURN (COND (SINGLEELEMENTFLG (fetch (SCREENELT GLOBALPART) of (SK.SELECT.ITEM VIEWER T SELECTABLEITEMS OPERATION))) (T (for SCRELT in (SK.SELECT.MULTIPLE.ITEMS VIEWER T SELECTABLEITEMS OPERATION) collect (fetch (SCREENELT GLOBALPART) of SCRELT]) (SK.PUT.MARKS.UP [LAMBDA (SKETCHW HOTSPOTCACHE) (* rrb "29-Jan-85 17:40") (* makes sure the selection points are up in a window.) (COND ((NULL (WINDOWPROP SKETCHW 'MARKS.UP)) (SK.SHOWMARKS SKETCHW HOTSPOTCACHE) (WINDOWPROP SKETCHW 'MARKS.UP T]) (SK.TAKE.MARKS.DOWN [LAMBDA (SKETCHW HOTSPOTCACHE) (* rrb "29-Jan-85 17:41") (* makes sure the selection points are down in a window.) (COND ((WINDOWPROP SKETCHW 'MARKS.UP) (SK.SHOWMARKS SKETCHW HOTSPOTCACHE) (WINDOWPROP SKETCHW 'MARKS.UP NIL]) (SK.TRANSLATE.GLOBALPART [LAMBDA (GLOBALELT DELTAPOS RETURNELTIFCANTFLG) (* rrb "19-May-86 14:52") (* GLOBALELT is a sketch element that was selected for a translate operation.  DELTAPOS is the amount the item is to be translated.) (PROG ((TRANSLATEFN (SK.TRANSLATEFN (fetch (GLOBALPART GTYPE) of GLOBALELT))) NEWGLOBAL OLDGLOBAL ACTIVEREGION) (RETURN (COND ((OR (NULL TRANSLATEFN) (EQ TRANSLATEFN 'NILL)) (* if can't translate, return the same thing.  This is probably an error condition.) GLOBALELT) ((SETQ NEWGLOBAL (APPLY* TRANSLATEFN GLOBALELT DELTAPOS)) (* copy the property list so that undoing works and because this code is used  to make copies too.) (SK.COPY.ELEMENT.PROPERTY.LIST NEWGLOBAL) [COND ([AND (SETQ ACTIVEREGION (GETSKETCHELEMENTPROP NEWGLOBAL 'ACTIVEREGION)) (EQUAL ACTIVEREGION (GETSKETCHELEMENTPROP GLOBALELT 'ACTIVEREGION] (* update the ACTIVEREGION if the element has one and it is the same in the new  element.) (PUTSKETCHELEMENTPROP NEWGLOBAL 'ACTIVEREGION (REL.MOVE.REGION ACTIVEREGION (fetch (POSITION XCOORD) of DELTAPOS) (fetch (POSITION YCOORD) of DELTAPOS] NEWGLOBAL) (RETURNELTIFCANTFLG (* in the case of translating a whole sketch, need to return something.) GLOBALELT]) (SK.TRANSLATE.ITEM [LAMBDA (SELELT GLOBALDELTAPOS W) (* rrb "21-Jan-85 18:35") (* SELELT is a sketch element that was selected for a translate operation.  GLOBALDELTAPOS is the amount the item is to be translated.) (PROG (NEWGLOBAL OLDGLOBAL) (COND ((SETQ NEWGLOBAL (SK.TRANSLATE.GLOBALPART (SETQ OLDGLOBAL (fetch (SCREENELT GLOBALPART) of SELELT)) GLOBALDELTAPOS)) (SK.UPDATE.ELEMENT OLDGLOBAL NEWGLOBAL W T) (* don't include history for now.  (SK.ADD.HISTEVENT (QUOTE TRANSLATE)  (LIST OLDGLOBAL NEWGLOBAL) W)) (RETURN NEWGLOBAL]) (SK.TRANSLATEFN [LAMBDA (ELEMENTTYPE) (* rrb " 4-Sep-84 17:01") (fetch (SKETCHTYPE TRANSLATEFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) (TRANSLATE.SKETCH [LAMBDA (SKETCH NEWXORG NEWYORG) (* rrb " 9-Jul-85 12:36") (* * translates all the elements in a sketch to make the new {0, 0} be NEWXORG  NEWYORG) (PROG [(DELTAPOS (create POSITION XCOORD _ (MINUS NEWXORG) YCOORD _ (MINUS NEWYORG] (RETURN (create SKETCH using SKETCH SKETCHELTS _ (for GELT in (fetch (SKETCH SKETCHELTS) of SKETCH) collect (SK.TRANSLATE.GLOBALPART GELT DELTAPOS T]) ) (DECLARE%: EVAL@COMPILE (RPAQQ SK.NO.MOVE.DISTANCE 4) (CONSTANTS (SK.NO.MOVE.DISTANCE 4)) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD SKFIGUREIMAGE (SKFIGURE.BITMAP SKFIGURE.LOWERLEFT)) ) ) (* ; "stuff for changing the input scale") (DEFINEQ (SK.INPUT.SCALE [LAMBDA (SKW) (* rrb " 4-Sep-85 15:35") (* returns the scale that input should  be) (PROG [(SK (WINDOWPROP SKW 'SKETCHCONTEXT] (COND ((NULL SK) (ERROR SKW "arg not sketch window") (RETURN NIL))) (RETURN (COND ((fetch (SKETCHCONTEXT SKETCHINPUTSCALE) of SK)) (T (* early form of sketch that doesn't have an input scale.) (SK.UPDATE.SKETCHCONTEXT SK) (replace (SKETCHCONTEXT SKETCHINPUTSCALE) of SK with 1.0) 1.0]) (SK.UPDATE.SKETCHCONTEXT [LAMBDA (SKETCHCONTEXT) (* rrb " 4-Sep-85 14:55") (* updates an instance of a sketch context to have enough fields.) (PROG ((NEWSK (CREATE.DEFAULT.SKETCH.CONTEXT))) [COND ((GREATERP (DIFFERENCE (LENGTH NEWSK) (LENGTH SKETCHCONTEXT)) 0) (* add fields to the sketch) (NCONC SKETCHCONTEXT (NTH NEWSK (ADD1 (LENGTH SKETCHCONTEXT] (RETURN SKETCHCONTEXT]) (SK.SET.INPUT.SCALE [LAMBDA (W) (* rrb "19-Aug-86 11:52") (* sets the size of the  (input scale)) (SK.SET.INPUT.SCALE.VALUE (RNUMBER (CONCAT "Input scale is now " (SK.INPUT.SCALE W) ". Enter new input scale. A larger scale will make new lines and text larger." ) NIL NIL NIL T T) W]) (SK.SET.INPUT.SCALE.CURRENT [LAMBDA (W) (* rrb "11-Jul-86 15:51") (* sets the size of the input scale to the scale of the current window.) (SK.SET.INPUT.SCALE.VALUE (VIEWER.SCALE W) W]) (SK.SET.INPUT.SCALE.VALUE [LAMBDA (NEWINPUTSCALE SKW) (* rrb "14-May-86 19:29") (* sets the input scale to  NEWINPUTSCALE) (AND (NUMBERP NEWINPUTSCALE) (NOT (ZEROP NEWINPUTSCALE)) (replace (SKETCHCONTEXT SKETCHINPUTSCALE) of (WINDOWPROP SKW 'SKETCHCONTEXT) with (ABS NEWINPUTSCALE]) ) (* ; "stuff for setting feedback amount") (DEFINEQ (SK.SET.FEEDBACK.MODE [LAMBDA (VALUE) (* rrb "19-Nov-85 13:25") (* sets the control on how much feedback to give the user as they are entering  new figure elements.) [OR (MEMB VALUE '(POINTS T ALWAYS)) (SETQ VALUE (\CURSOR.IN.MIDDLE.MENU (create MENU ITEMS _ '(("Points only" 'POINTS "Only the control points will be shown when entering elements." ) ("Fast figures" T "Wires, circles and ellipses are shown while they are being entered." ) ("All figures" 'ALWAYS "Most elements are shown while they are being entered. This will be slow for arcs and curves.")) CENTERFLG _ T] (AND VALUE (SETQ SKETCH.VERBOSE.FEEDBACK (SELECTQ VALUE (POINTS NIL) VALUE]) (SK.SET.FEEDBACK.POINT [LAMBDA NIL (* sets the feedback to points only) (SK.SET.FEEDBACK.MODE 'POINTS]) (SK.SET.FEEDBACK.VERBOSE [LAMBDA NIL (* sets the feedback to provide images on elements that are fast.) (SK.SET.FEEDBACK.MODE T]) (SK.SET.FEEDBACK.ALWAYS [LAMBDA NIL (* sets the feedback to give images on  all figures.) (SK.SET.FEEDBACK.MODE 'ALWAYS]) ) (RPAQ? SKETCH.VERBOSE.FEEDBACK T) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SKETCH.VERBOSE.FEEDBACK) ) (* ; "sketch icon support") (DEFINEQ (SKETCH.TITLE [LAMBDA (SKW) (* rrb " 5-May-86 13:19") (* gets the title of the sketch being edited in SKW.) (fetch (SKETCH SKETCHNAME) of (INSURE.SKETCH SKW]) (SK.SHRINK.ICONCREATE (LAMBDA (W OLD-ICON POSITION) (* ; "Edited 25-Apr-88 15:44 by drc:") (* ;;; "Create the icon that represents this window.") (LET ((ICONTITLE (WINDOWPROP W (QUOTE SKETCH.ICON.TITLE))) (TITLE (SKETCH.TITLE W)) (ICON (OR OLD-ICON (WINDOWPROP W (QUOTE ICON))))) (COND (ICON (CL:UNLESS (OR (EQUAL ICONTITLE TITLE) (NOT ICONTITLE)) (* ;; "if we built this and the title is the same, or he has already put an icon on this, then we don't need to update it.") (SETQ ICONTITLE (OR TITLE "")) (WINDOWPROP W (QUOTE SKETCH.ICON.TITLE) ICONTITLE) (ICONTITLE ICONTITLE NIL NIL ICON)) ICON) (T (* ;; "make a new icon. Give it a title of '' so it can be distinguished from an ICON that the user supplied without an ICONTITLE.") (SETQ ICONTITLE (OR TITLE "")) (WINDOWPROP W (QUOTE SKETCH.ICON.TITLE) ICONTITLE) (TITLEDICONW SKETCH.TITLED.ICON.TEMPLATE ICONTITLE (COND ((NEQ TEDIT.ICON.FONT (QUOTE NOBIND)) TEDIT.ICON.FONT) (T (DEFAULTFONT (QUOTE DISPLAY)))) POSITION T NIL (QUOTE FILE)))))) ) ) (READVARS-FROM-STRINGS '(SKETCH.TITLED.ICON.TEMPLATE) "(({(READBITMAP)(87 95 %"AOOOOOOOOOOOOOOOOOOOOL@@%" %"GOOOOOOOOOOOOOOOOOOOOL@@%" %"OKMHOHNCHNCHNCHNCHNCHN@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%" %"ONJJCLGALGALGALGALGALF@@%" %"LOOOOOOOOOOOOOOOOOOOON@@%" %"NKOJCLGALGALGALGALGALF@@%" %"ONOOOOOOOOOOOOOOOOOOON@@%" %"NJJOOOOOOOOOOOOOOOOOON@@%" %"NNKNGALGALGALGALGALGAL@@%" %"OJJNOCLOCLOCLOCLOCLOCN@@%" %"NJJNFAHFAHFAHFAHFAHFAN@@%" %"NNJN@@@@@@@@@@@@@@@@@N@@%" %"OJJN@@@@@@@@@@@@@@@@@N@@%" %"OJKN@@@@@@@@@@@@@@@@@N@@%" %"NJKN@@@@@@@@@@@@@@@@@N@@%" %"OKNN@@@@@@@@@@@@@@@@@N@@%" %"OKJN@@@@@@@@@@@@@@@@@N@@%" %"NJJN@@@@@@@@@@@@@@@@@N@@%" %"NJNN@@@@@@@@@@@@@@@@@N@@%" %"NKJN@@@@@@@@@@@@@@@@@N@@%" %"NJJN@@@@@@@@@@@@@@@@@N@@%" %"NNKN@@@@@@@@@@@@@@@@@N@@%" %"NNKN@@@@@@@@@@@@@@@@@N@@%" %"OJNN@@@@@@@@@@@@@@@@@N@@%" %"NJNN@@@@@@@@@@@@@@@@@N@@%" %"OJNN@@@@@@@@@@@@@@@@@N@@%" %"OJJN@@@@@@@@@@@@@@@@@N@@%" %"NNNN@@@@@@@@@@@@@@@@@N@@%" %"NNNN@@@@@@@@@@@@@@@@@N@@%" %"NJNN@@@@@@@@@@@@@@@@@N@@%" %"NJKN@@@@@@@@@@@@@@@@@N@@%" %"NJJN@@@@@@@@@@@@@@@@@N@@%" %"L@@N@@@@@@@@@@@@@@@@@N@@%" %"L@@N@@@@@@@@@@@@@@@@@N@@%" %"L@BN@@@@@@@@@@@@@@@@@N@@%" %"L@NN@@@@@@@@@@@@@@@@@N@@%" %"LA@N@@@@@@@@@@@@@@@@@N@@%" %"MM@N@@@@@@@@@@@@@@@@@N@@%" %"LCBN@@@@@@@@@@@@@@@@@N@@%" %"L@NN@@@@@@@@@@@@@@@@@N@@%" %"L@BN@@@@@@@@@@@@@@@@@N@@%" %"L@@N@@@@@@@@@@@@@@@@@N@@%" %"L@@N@@@@@@@@@@@@@@@@@N@@%" %"LB@N@@@@@@@@@@@@@@@@@N@@%" %"LDDN@@@@@@@@@@@@@@@@@N@@%" %"LDBN@@@@@@@@@@@@@@@@@N@@%" %"LBBN@@@@@@@@@@@@@@@@@N@@%" %"LALN@@@@@@@@@@@@@@@@@N@@%" %"L@@N@@@@@@@@@@@@@@@@@N@@%" %"L@@N@@@@@@@@@@@@@@@@@N@@%" %"L@@N@@@@@@@@@@@@@@@@@N@@%" %"LDDN@@@@@@@@@@@@@@@@@N@@%" %"MLBN@@@@@@@@@@@@@@@@@N@@%" %"LGBN@@@@@@@@@@@@@@@@@N@@%" %"LDNN@@@@@@@@@@@@@@@@@N@@%" %"L@@N@@@@@@@@@@@@@@@@@N@@%" %"L@@N@@@@@@@@@@@@@@@@@N@@%" %"L@@N@@@@@@@@@@@@@@@@@N@@%" %"LC@N@@@@@@@@@@@@@@@@@N@@%" %"LDHN@@@@@@@@@@@@@@@@@N@@%" %"LDJN@@@@@@@@@@@@@@@@@N@@%" %"LCJN@@@@@@@@@@@@@@@@@N@@%" %"LABN@@@@@@@@@@@@@@@@@N@@%" %"L@NN@@@@@@@@@@@@@@@@@N@@%" %"L@@N@@@@@@@@@@@@@@@@@N@@%" %"LD@N@@@@@@@@@@@@@@@@@N@@%" %"LB@N@@@@@@@@@@@@@@@@@N@@%" %"MBNN@@@@@@@@@@@@@@@@@N@@%" %"MM@N@@@@@@@@@@@@@@@@@N@@%" %"LCHN@@@@@@@@@@@@@@@@@N@@%" %"L@FN@@@@@@@@@@@@@@@@@N@@%" %"L@BN@@@@@@@@@@@@@@@@@N@@%" %"L@@N@@@@@@@@@@@@@@@@@N@@%" %"LH@N@@@@@@@@@@@@@@@@@N@@%" %"M@@N@@@@@@@@@@@@@@@@@N@@%" %"MAHN@@@@@@@@@@@@@@@@@N@@%" %"MBDN@@@@@@@@@@@@@@@@@N@@%" %"MBDN@@@@@@@@@@@@@@@@@N@@%" %"LLDN@@@@@@@@@@@@@@@@@N@@%" %"L@DN@@@@@@@@@@@@@@@@@N@@%" %"L@DN@@@@@@@@@@@@@@@@@N@@%" %"L@LN@@@@@@@@@@@@@@@@@N@@%" %"L@@N@@@@@@@@@@@@@@@@@N@@%" %"L@@N@@@@@@@@@@@@@@@@@N@@%" %"NJJN@@@@@@@@@@@@@@@@@N@@%" %"OJJN@@@@@@@@@@@@@@@@@N@@%" %"NKKN@@@@@@@@@@@@@@@@@N@@%" %"OJNN@@@@@@@@@@@@@@@@@N@@%" %"CNNN@@@@@@@@@@@@@@@@@N@@%" %"@OJN@@@@@@@@@@@@@@@@@N@@%" %"@CNN@@@@@@@@@@@@@@@@@N@@%" %"@@OOOOOOOOOOOOOOOOOOON@@%" %"@@COOOOOOOOOOOOOOOOOON@@%" %"@@@OOOOOOOOOOOOOOOOOON@@%")} {(READBITMAP)(87 95 %"AOOOOOOOOOOOOOOOOOOOOH@@%" %"GOOOOOOOOOOOOOOOOOOOOL@@%" %"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@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%" %"OOOOOOOOOOOOOOOOOOOOON@@%" %"COOOOOOOOOOOOOOOOOOOON@@%" %"@OOOOOOOOOOOOOOOOOOOON@@%" %"@COOOOOOOOOOOOOOOOOOON@@%" %"@@OOOOOOOOOOOOOOOOOOON@@%" %"@@COOOOOOOOOOOOOOOOOON@@%" %"@@@OOOOOOOOOOOOOOOOOON@@%")} (16 4 64 77))) ") (* ; "fns for reading in various values") (DEFINEQ (READBRUSHSHAPE [LAMBDA NIL (* rrb " 6-Nov-85 09:57") (* reads a brush shape from the user.) (\CURSOR.IN.MIDDLE.MENU (create MENU CENTERFLG _ T TITLE _ "pick a shape" ITEMS _ '(ROUND SQUARE VERTICAL HORIZONTAL DIAGONAL]) (READ.FUNCTION [LAMBDA (PRMPT W) (* rrb "11-May-84 15:41") (PROG ((PROMPTWIN (GETPROMPTWINDOW W 3)) OLDTTYDS LST) (SETQ OLDTTYDS (TTYDISPLAYSTREAM PROMPTWIN)) (COND (PRMPT (printout PROMPTWIN PRMPT T ">> "))) (* grab the tty.) (TTY.PROCESS NIL) (SETQ LST (CONS (READ T) (READLINE))) (CLOSEW (TTYDISPLAYSTREAM OLDTTYDS)) (RETURN (CAR LST]) (READBRUSHSIZE [LAMBDA (NOWSIZE) (* rrb "19-May-86 15:44") (PROG ((N (RNUMBER (COND (NOWSIZE (CONCAT "Current size is " NOWSIZE ". Enter new brush size.")) (T "Enter new brush size.")) NIL NIL NIL T T T T))) (RETURN (COND ((EQUAL N 0) NIL) (N (ABS N]) (READANGLE [LAMBDA NIL (* rrb "14-May-86 19:29") (* interacts to get an angle from the  user.) (PROG ((NEWVALUE (RNUMBER "Enter arc angle in degrees." NIL NIL NIL T NIL T))) (RETURN (COND ((EQ NEWVALUE 0) NIL) (T NEWVALUE]) (READARCDIRECTION [LAMBDA (MENUTITLE) (* rrb " 6-Nov-85 09:53") (* interacts to get whether an arc should go clockwise or counterclockwise) (\CURSOR.IN.MIDDLE.MENU (create MENU TITLE _ (OR MENUTITLE "Which way should the arc go?") ITEMS _ '(("Clockwise" 'CLOCKWISE "The arc will be drawn clockwise from the first point to the second point." ) ("Counterclockwise" 'COUNTERCLOCKWISE "The arc will be drawn counterclockwise from the first point to the second point." )) CENTERFLG _ T]) ) (DEFINEQ (SK.CHANGE.DASHING [LAMBDA (ELTWITHLINE DASHING SKW) (* rrb " 9-Jan-86 16:58") (* changes the line dashing of ELTWITHLINE if it has one) (* knows about the various types of sketch elements and shouldn't.) (PROG (SIZE GLINELT TYPE NEWDASHING NOWDASHING NEWELT) (COND ((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHLINE)) '(WIRE BOX CLOSEDWIRE CLOSEDCURVE OPENCURVE CIRCLE ELLIPSE TEXTBOX ARC)) (* only works for things of wire type.) (SETQ GLINELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHLINE)) (* the dashing may be stored in different places for the element types.) [SETQ NEWDASHING (COND ((EQ DASHING 'NONE) (* no dashing is marked with NIL) NIL) ((DASHINGP DASHING)) (T (ERROR "illegal dashing" DASHING] (SETQ NOWDASHING (SELECTQ TYPE (WIRE (fetch (WIRE OPENWIREDASHING) of GLINELT)) (BOX (fetch (BOX BOXDASHING) of GLINELT)) (ARC (fetch (ARC ARCDASHING) of GLINELT)) (TEXTBOX (fetch (TEXTBOX TEXTBOXDASHING) of GLINELT)) (CLOSEDWIRE (fetch (CLOSEDWIRE CLOSEDWIREDASHING) of GLINELT)) (CLOSEDCURVE (fetch (CLOSEDCURVE DASHING) of GLINELT)) (OPENCURVE (fetch (OPENCURVE DASHING) of GLINELT)) (CIRCLE (fetch (CIRCLE DASHING) of GLINELT)) (ELLIPSE (fetch (ELLIPSE DASHING) of GLINELT)) (SHOULDNT))) (COND ((EQUAL NEWDASHING NOWDASHING) (* if dashing isn't changing, don't bother creating a new one and repainting.) (RETURN))) (SETQ NEWELT (SELECTQ TYPE (WIRE (create WIRE using GLINELT OPENWIREDASHING _ NEWDASHING)) (BOX (create BOX using GLINELT BOXDASHING _ NEWDASHING)) (ARC (create ARC using GLINELT ARCDASHING _ NEWDASHING)) (TEXTBOX (create TEXTBOX using GLINELT TEXTBOXDASHING _ NEWDASHING)) (CLOSEDWIRE (create CLOSEDWIRE using GLINELT CLOSEDWIREDASHING _ NEWDASHING)) (CLOSEDCURVE (create CLOSEDCURVE using GLINELT DASHING _ NEWDASHING)) (OPENCURVE (create OPENCURVE using GLINELT DASHING _ NEWDASHING)) (CIRCLE (create CIRCLE using GLINELT DASHING _ NEWDASHING)) (ELLIPSE (create ELLIPSE using GLINELT DASHING _ NEWDASHING)) (SHOULDNT))) (RETURN (create SKHISTORYCHANGESPEC NEWELT _ (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) of ELTWITHLINE) INDIVIDUALGLOBALPART _ NEWELT) OLDELT _ ELTWITHLINE PROPERTY _ 'DASHING NEWVALUE _ NEWDASHING OLDVALUE _ NOWDASHING]) (READ.AND.SAVE.NEW.DASHING [LAMBDA NIL (* rrb " 6-Nov-85 09:57") (* reads a new dashing, confirms it with the user and adds it to  SK.DASHING.PATTERNS) (PROG (DASHING BM) LP (COND ((NULL (SETQ DASHING (READ.NEW.DASHING))) (* user aborted) (RETURN NIL))) (SETQ BM (SK.DASHING.LABEL DASHING)) CONFIRM (SELECTQ (\CURSOR.IN.MIDDLE.MENU (create MENU ITEMS _ (LIST (LIST BM T "Will use this as the dashing pattern." ) '(Yes T "Will accept this pattern.") '(No 'NO "Will ask you for another dashing pattern." )) CENTERFLG _ T TITLE _ "Is this pattern OK?")) (NO (GO LP)) (T (* add dashing to global list and  return it.) (SK.CACHE.DASHING DASHING BM) (RETURN DASHING)) (PROGN (PROMPTPRINT "Please select 'Yes' if this pattern is what you want; 'No' if it isn't." ) (GO CONFIRM]) (READ.NEW.DASHING [LAMBDA NIL (* rrb "14-May-86 19:30") (* reads a value of dashing from the  user.) (PROMPTPRINT "You will be prompted for a series of numbers which specify the number of points ON and OFF. Enter 0 to end the dashing pattern. Enter 'Abort' to leave the dashing unchanged.") (bind VAL DASHLST OFF? (ORIGPOS _ (create POSITION XCOORD _ LASTMOUSEX YCOORD _ LASTMOUSEY)) until (OR (EQ (SETQ VAL (RNUMBER (CONCAT "Enter the number of points " (COND (OFF? 'OFF) (T 'ON)) ". Enter 0 to end the dashing.") ORIGPOS NIL NIL T T T)) 0) (NULL VAL)) do (SETQ DASHLST (CONS (ABS VAL) DASHLST)) (SETQ OFF? (NOT OFF?)) finally (CLRPROMPT) (RETURN (COND ((NULL VAL) (* abort selection) NIL) (T (REVERSE DASHLST]) (READ.DASHING.CHANGE [LAMBDA NIL (DECLARE (GLOBALVARS SK.DASHING.PATTERNS)) (* rrb " 6-Nov-85 09:57") (* gets a description of how to change the arrow heads of a wire or curve.) (PROG (DASHING) (SELECTQ [SETQ DASHING (\CURSOR.IN.MIDDLE.MENU (create MENU CENTERFLG _ T TITLE _ "New dashing pattern?" ITEMS _ (APPEND (for DASHPAT in SK.DASHING.PATTERNS collect (LIST (CAR DASHPAT) (KWOTE (CADR DASHPAT)) "changes dashing to this pattern" )) '(("other" 'OTHER "will prompt you for a new dashing pattern." ) ("no dashing" 'NONE "removes dashing."] (OTHER (RETURN (READ.AND.SAVE.NEW.DASHING))) (RETURN DASHING]) (SK.CACHE.DASHING [LAMBDA (DASHING BITMAP) (* rrb " 3-May-85 14:33") (* adds a dashing and its bitmap label to the global cache.) (OR (for DASH in SK.DASHING.PATTERNS when (EQUAL (CADR DASH) DASHING) do (RETURN T)) (COND (SK.DASHING.PATTERNS (NCONC1 SK.DASHING.PATTERNS (LIST (COND ((BITMAPP BITMAP)) (T (SK.DASHING.LABEL DASHING))) DASHING))) (T (SETQ SK.DASHING.PATTERNS (LIST (LIST (COND ((BITMAPP BITMAP)) (T (SK.DASHING.LABEL DASHING))) DASHING]) (SK.DASHING.LABEL [LAMBDA (DASHING) (* rrb " 3-May-85 14:32") (* creates a bitmap label which shows  a dashing pattern.) (PROG (DS BM) [SETQ DS (DSPCREATE (SETQ BM (BITMAPCREATE 50 1] (DRAWLINE 0 0 50 0 1 NIL DS NIL DASHING) (RETURN BM]) ) (DEFINEQ (READ.FILLING.CHANGE [LAMBDA NIL (* rrb " 6-Nov-85 09:58") (* reads a shade for the filling  texture.) (PROG (FILLING) (SELECTQ (SETQ FILLING (\CURSOR.IN.MIDDLE.MENU (create MENU CENTERFLG _ T TITLE _ "New filling?" ITEMS _ [APPEND (for FILLPAT in SK.FILLING.PATTERNS collect (LIST (CAR FILLPAT) (KWOTE (CADR FILLPAT)) "changes filling to this pattern" )) '(("4x4 shade" '|4X4| "Allows creation of a 4 bits by 4 bits shade" ) ("16x16 shade" '|16X16| "Allows creation of a 16 bits by 16 bits shade" ) ("No filling" 'NONE "no filling will be used."] MENUBORDERSIZE _ 1))) (|4X4| (RETURN (READ.AND.SAVE.NEW.FILLING))) (|16X16| (RETURN (READ.AND.SAVE.NEW.FILLING T))) (RETURN FILLING]) (SK.CACHE.FILLING [LAMBDA (FILLING) (* rrb " 8-Jun-85 14:58") (* adds a dashing and its bitmap label to the global cache.) (OR (for FILL in SK.FILLING.PATTERNS when (EQUAL (CADR FILL) FILLING) do (RETURN T)) (COND (SK.FILLING.PATTERNS (NCONC1 SK.FILLING.PATTERNS (LIST (SK.FILLING.LABEL FILLING) FILLING))) (T (SETQ SK.FILLING.PATTERNS (LIST (LIST (SK.FILLING.LABEL FILLING) FILLING))) 'ADDED]) (READ.AND.SAVE.NEW.FILLING [LAMBDA (16X16FLG) (* rrb " 8-Jun-85 14:58") (* reads a new filling, confirms it with the user and adds it to  SK.FILLING.PATTERNS) (PROG (FILLING) (COND ([NULL (SETQ FILLING (EDITSHADE (COND (16X16FLG (BITMAPCREATE 16 16] (* user aborted) (RETURN NIL))) (SK.CACHE.FILLING FILLING) (RETURN FILLING]) (SK.FILLING.LABEL [LAMBDA (FILLING) (* rrb " 8-Jun-85 12:08") (* creates a bitmap label which fills it with the texture FILLING.) (PROG [(BM (BITMAPCREATE (PLUS 8 (STRINGWIDTH "16x16 shade" MENUFONT)) (FONTPROP MENUFONT 'HEIGHT] (BLTSHADE FILLING BM) (RETURN BM]) ) (RPAQ? SK.DASHING.PATTERNS ) (RPAQ? SK.FILLING.PATTERNS ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SK.DASHING.PATTERNS SK.FILLING.PATTERNS) ) (SK.CACHE.DASHING '(2 4)) (SK.CACHE.DASHING '(6 3 1 3)) (SK.CACHE.FILLING BLACKSHADE) (SK.CACHE.FILLING GRAYSHADE) (SK.CACHE.FILLING HIGHLIGHTSHADE) (* ; "stuff for reading input positions") (DEFINEQ (SK.GETGLOBALPOSITION [LAMBDA (W CURSOR) (* rrb "20-May-86 10:56") (* gets a position from the user and returns the global value of it.) (SK.MAP.INPUT.PT.TO.GLOBAL (SK.READ.POINT.WITH.FEEDBACK W CURSOR) W]) (SKETCH.TRACK.ELEMENTS [LAMBDA (ELEMENTS VIEWER CONSTRAINTFN HOTSPOT PROMPTMSG CONSTRAINTDATA FEEDBACKFN NOINITIALERASEFLG NOFINALPAINTFLG) (* rrb "22-Jul-86 14:41") (* gets a point from the user by displaying an image of ELEMENTS.  It calls CONSTRAINTFN everytime the cursor moves to allow user constraints on  where the image is displayed. All positions and elements are in sketch  coordinates.) (PROG (SCRELTS FIGINFO FIRSTHOTSPOT GLOBALHOTSPOT NEWPOS LOWLFT IMAGEPOSX IMAGEPOSY IMAGEBM DELTAPOS NEWGLOBALS SKETCH GDELTAPOS) (OR ELEMENTS (RETURN)) (SETQ FIGINFO (SK.FIGUREIMAGE (SETQ SCRELTS (MAP.SKETCH.ELEMENTS.INTO.VIEWER ELEMENTS VIEWER)) (DSPCLIPPINGREGION NIL VIEWER))) [SETQ FIRSTHOTSPOT (COND ((POSITIONP HOTSPOT) (MAP.GLOBAL.POSITION.INTO.VIEWER HOTSPOT VIEWER)) (T (CAR (fetch (SCREENELT HOTSPOTS) of (CAR SCRELTS] [SETQ GLOBALHOTSPOT (COND ((POSITIONP HOTSPOT)) (T (MAP.VIEWER.PT.INTO.GLOBAL (CAR (fetch (SCREENELT HOTSPOTS) of (CAR SCRELTS))) VIEWER] (SETQ IMAGEBM (fetch (SKFIGUREIMAGE SKFIGURE.BITMAP) of FIGINFO)) (SETQ LOWLFT (fetch (SKFIGUREIMAGE SKFIGURE.LOWERLEFT) of FIGINFO)) (SETQ IMAGEPOSX (fetch (POSITION XCOORD) of LOWLFT)) (SETQ IMAGEPOSY (fetch (POSITION YCOORD) of LOWLFT)) (* put the cursor on the hot spot) (CURSORPOSITION FIRSTHOTSPOT VIEWER) (COND ([NULL (ERSETQ (PROGN (OR NOINITIALERASEFLG (SK.SHOW.FIG.FROM.INFO IMAGEBM IMAGEPOSX IMAGEPOSY 'ERASE VIEWER)) (SETQ NEWPOS (SKETCH.TRACK.IMAGE VIEWER IMAGEBM 'PAINT PROMPTMSG (IDIFFERENCE IMAGEPOSX (fetch (POSITION XCOORD ) of FIRSTHOTSPOT)) (IDIFFERENCE IMAGEPOSY (fetch (POSITION YCOORD ) of FIRSTHOTSPOT)) CONSTRAINTFN CONSTRAINTDATA FEEDBACKFN] (* error happened, repaint the image.) (OR NOINITIALERASEFLG (SK.SHOW.FIG.FROM.INFO IMAGEBM IMAGEPOSX IMAGEPOSY 'PAINT VIEWER) ) (CLOSEPROMPTWINDOW VIEWER) (ERROR!)) (T (OR NOFINALPAINTFLG (SK.SHOW.FIG.FROM.INFO IMAGEBM IMAGEPOSX IMAGEPOSY 'PAINT VIEWER) ) (RETURN (AND NEWPOS (PTDIFFERENCE NEWPOS GLOBALHOTSPOT]) (SK.PICKOUT.WHOLE.MOVE.ELEMENTS [LAMBDA (MOVEELTLST) (* rrb "13-Dec-85 11:54") (* returns from a list of sketch elements that are being moved, the ones that  will be completely moved) (COND ((EQ (CAR MOVEELTLST) T) (CDR MOVEELTLST)) ((EVERY (CAR MOVEELTLST) (FUNCTION NUMBERP)) NIL) (T (for X in MOVEELTLST when (EQ (CAR X) T) collect (CDR X]) (MAP.SKETCH.ELEMENTS.INTO.VIEWER [LAMBDA (ELEMENTS VIEWER) (* rrb "12-Dec-85 12:25") (* maps a list of elements into a  viewer) (for SKELT in ELEMENTS collect (SK.LOCAL.FROM.GLOBAL SKELT VIEWER]) (MAP.GLOBAL.POSITION.INTO.VIEWER [LAMBDA (GPOS VIEWER) (* rrb "11-Jul-86 15:54") (* maps a sketch coordinate into a  viewer coordinate.) (SK.SCALE.POSITION.INTO.VIEWER GPOS (VIEWER.SCALE VIEWER]) (SKETCH.TO.VIEWER.POSITION [LAMBDA (POSITION VIEWERSCALE) (* rrb "11-Jul-86 15:54") (* Transforms a position from sketch coordinates into viewer coordinates.  VIEWERSCALE can be a scale or a viewer.) (SK.SCALE.POSITION.INTO.VIEWER POSITION (SK.INSURE.SCALE VIEWERSCALE]) (SKETCH.TRACK.IMAGE [LAMBDA (WINDOW BITMAP OPERATION MSG XOFFSET YOFFSET CONSTRAINTFN CONSTRAINTDATA FEEDBACKFN) (* rrb "11-Jun-86 13:44") (* gets a position by tracking with a and calling a user provided constraint  function. The spec returns is actually (ONGRID? position) so that caller can  tell whether it was placed on grid or not.) (PROG (WIDTH HEIGHT) (SETQ WIDTH (BITMAPWIDTH BITMAP)) (SETQ HEIGHT (BITMAPHEIGHT BITMAP)) (AND MSG (STATUSPRINT WINDOW " " MSG)) (RETURN (SK.TRACK.IMAGE1 WINDOW BITMAP (BITMAPCREATE WIDTH HEIGHT) WIDTH HEIGHT (OR OPERATION 'PAINT) XOFFSET YOFFSET CONSTRAINTFN CONSTRAINTDATA FEEDBACKFN]) (SK.TRACK.IMAGE1 [LAMBDA (W BITMAP BUFFER.BITMAP WIDTH HEIGHT OPERATION XOFFSET YOFFSET CONSTRAINTFN CONSTRAINTDATA FEEDBACKFN) (* rrb "11-Jun-86 13:59") (* tracks BITMAP until a button goes down and comes up.  It calls CONSTRAINTFN to determine the position at which to display the image.  Returns a point in global space that the image was placed.) (* there is other code in BIGFONT that is probably better for this.) (PROG (READPT) (SETQ READPT (SK.TRACK.BITMAP1 W BITMAP BUFFER.BITMAP WIDTH HEIGHT OPERATION XOFFSET YOFFSET CONSTRAINTFN CONSTRAINTDATA FEEDBACKFN)) (RETURN (AND READPT (MAP.VIEWER.XY.INTO.GLOBAL (fetch (POSITION XCOORD) of (fetch (INPUTPT INPUT.POSITION) of READPT)) (fetch (POSITION YCOORD) of (fetch (INPUTPT INPUT.POSITION) of READPT)) W (fetch (INPUTPT INPUT.ONGRID?) of READPT) (create POSITION]) (MAP.VIEWER.XY.INTO.GLOBAL [LAMBDA (X Y VIEWER ONGRID? SCRATCHPT) (* rrb "11-Jul-86 15:52") (* maps from an x y pair in a window to the corresponding global position.  ONGRID? is T if the X Y should be interpreted as being on the grid.  SCRATCHPT is a scratch position that should be clobbered with the result.) (PROG ((SCALE (VIEWER.SCALE VIEWER)) GRID) [COND (ONGRID? (SETQ GRID (SK.GRIDFACTOR VIEWER))) (T (* map the point onto a grid location that would have the same screen position  as the given point.) (SETQ GRID (GREATESTPOWEROF2LT SCALE] (RETURN (SK.SET.POSITION (NEAREST.ON.GRID (TIMES X SCALE) GRID) (NEAREST.ON.GRID (TIMES Y SCALE) GRID) SCRATCHPT]) (SK.SET.POSITION [LAMBDA (X Y POSITION) (* rrb "21-May-86 16:09") (* sets the x and y coordinate fields of a position.) (replace (POSITION XCOORD) of POSITION with X) (replace (POSITION YCOORD) of POSITION with Y) POSITION]) (MAP.VIEWER.PT.INTO.GLOBAL [LAMBDA (PT VIEWER ONGRID?) (* rrb "11-Jul-86 15:52") (* maps from an PT in a window to the corresponding global position.  ONGRID? is T if the PT should be interpreted as being on the grid.) (PROG ((SCALE (VIEWER.SCALE VIEWER)) GRID) [COND (ONGRID? (SETQ GRID (SK.GRIDFACTOR VIEWER))) (T (* map the point onto a grid location that would have the same screen position  as the given point.) (SETQ GRID (GREATESTPOWEROF2LT SCALE] (RETURN (create POSITION XCOORD _ (NEAREST.ON.GRID (TIMES (fetch (POSITION XCOORD) of PT) SCALE) GRID) YCOORD _ (NEAREST.ON.GRID (TIMES (fetch (POSITION YCOORD) of PT) SCALE) GRID]) (VIEWER.TO.SKETCH.POSITION [LAMBDA (POSITION VIEWERSCALE) (* rrb "11-Jul-86 15:56") (* Transforms a position from viewer coordinates into sketch coordinates.  VIEWERSCALE can be a scale or a viewer.) (SK.UNSCALE.POSITION.FROM.VIEWER POSITION (COND ((NUMBERP VIEWERSCALE)) ((WINDOWP VIEWERSCALE) (VIEWER.SCALE VIEWERSCALE)) (T (\ILLEGAL.ARG VIEWERSCALE]) (SK.INSURE.SCALE [LAMBDA (VIEWERSCALE) (* rrb "11-Jul-86 15:52") (COND ((NUMBERP VIEWERSCALE)) ((WINDOWP VIEWERSCALE) (VIEWER.SCALE VIEWERSCALE)) (T (\ILLEGAL.ARG VIEWERSCALE]) (SKETCH.TO.VIEWER.REGION [LAMBDA (REGION VIEWERSCALE) (* rrb " 6-Jun-86 14:05") (* Transforms a region from sketch coordinates into viewer coordinates.  VIEWERSCALE can be a scale or a viewer.) (PROG ((SCALE (SK.INSURE.SCALE VIEWERSCALE))) (RETURN (CREATEREGION (QUOTIENT (fetch (REGION LEFT) of REGION) SCALE) (QUOTIENT (fetch (REGION BOTTOM) of REGION) SCALE) (QUOTIENT (fetch (REGION WIDTH) of REGION) SCALE) (QUOTIENT (fetch (REGION HEIGHT) of REGION) SCALE]) (VIEWER.TO.SKETCH.REGION [LAMBDA (REGION VIEWERSCALE) (* rrb " 6-Jun-86 14:05") (* Transforms a region from viewer coordinates into sketch coordinates.  VIEWERSCALE can be a scale or a viewer.) (UNSCALE.REGION REGION (SK.INSURE.SCALE VIEWERSCALE]) (SK.READ.POINT.WITH.FEEDBACK [LAMBDA (WINDOW CURSOR FEEDBACKFN FEEDBACKFNDATA BUTTONFOREXISTINGPTS CONSTRAINTFN NUMBERPADTOOFLG) (* rrb "11-Jul-86 15:52") (* internal function that reads a point from the user.  Each time the cursor moves, a feedback fn is called passing it the new X, new  Y, WINDOW and FEEDBACKDATA It is expected to XOR something on the screen that  tells the user something.) (RESETLST (RESETSAVE (CURSOR (OR CURSOR CROSSHAIRS))) (RESETSAVE NIL (LIST 'DSPOPERATION (DSPOPERATION 'INVERT WINDOW) WINDOW)) (PROG ((USEGRID (WINDOWPROP WINDOW 'USEGRID)) (GRID (SK.GRIDFACTOR WINDOW)) (SCALE (VIEWER.SCALE WINDOW)) (HOTSPOTCACHE (SK.HOTSPOT.CACHE WINDOW)) (SCRATCHPT (AND CONSTRAINTFN (create POSITION))) XSCREEN YSCREEN XGRID YGRID NEWX NEWY MOUSEDOWN LASTBUTTONSTATE ONGRID? NEARPOS CONSTRAINTPT POSITIONPAD) (OR FEEDBACKFN (SETQ FEEDBACKFN 'SHOWSKETCHXY)) [COND (NUMBERPADTOOFLG (* IT WOULD BE NICER TO PUT THE POSITION READER OVERTOP OF THE MENU BUT THIS  ROUTINE IS CALLED SEVERAL TIMES BY SEVERAL OF THE POINT READERS AND IT FLIPS UP  AND DOWN SO STILL NEEDS MORE WORK TO GET RIGHT  (* detach the window menu so that it doesn't come to top over the position  reader.) (AND (OPENWP (SETQ MENUW (SK.INSURE.HAS.MENU WINDOW)))  (RESETSAVE (DETACHWINDOW MENUW) (LIST (QUOTE SK.FIX.MENU) WINDOW)))) (RESETSAVE NIL (LIST 'CLOSEW (SETQ POSITIONPAD (  SK.POSITION.PAD.FROM.VIEWER WINDOW] (RETURN (PROG1 (until [PROGN (GETMOUSESTATE) (COND [(AND POSITIONPAD (INSIDEP (WINDOWPROP POSITIONPAD 'REGION) LASTMOUSEX LASTMOUSEY)) (COND ((AND XGRID (INSIDEP WINDOW XGRID YGRID)) (* leaving the window, turn off the  last feedback.) (APPLY* FEEDBACKFN XGRID YGRID WINDOW FEEDBACKFNDATA) (SETQ XGRID))) (* invoke position reader If it returns a position, return it.) (AND (SETQ YSCREEN (SK.READ.POSITION.PAD.HANDLER POSITIONPAD WINDOW FEEDBACKFN FEEDBACKFNDATA CONSTRAINTFN)) (COND [(EQ YSCREEN 'ABORT) (COND ((EQ NUMBERPADTOOFLG 'MULTIPLE) (* if NUMBERPADTOOFLG is MULTIPLE, this is a context in which multiple values  are being read and the only way to abort is to error.  Note%: this leaves stuff on the screen.) (ERROR!)) (T (RETURN NIL] ((EQ YSCREEN 'STOP) (RETURN NIL)) (T (RETURN YSCREEN] (MOUSEDOWN (LASTMOUSESTATE UP)) ((LASTMOUSESTATE (OR LEFT MIDDLE RIGHT)) (COND ((INSIDEP (WINDOWPROP WINDOW 'REGION) LASTMOUSEX LASTMOUSEY) (SETQ MOUSEDOWN T) NIL) (T (RETURN] do (SETQ NEWX (LASTMOUSEX WINDOW)) (SETQ NEWY (LASTMOUSEY WINDOW)) [COND ((OR (NEQ NEWX XSCREEN) (NEQ NEWY YSCREEN) (NEQ LASTBUTTONSTATE LASTMOUSEBUTTONS)) (* cursor changed position or a button went down, check if grid pt moved.) (SKETCHW.UPDATE.LOCATORS WINDOW) (SETQ XSCREEN NEWX) (SETQ YSCREEN NEWY) (SETQ LASTBUTTONSTATE LASTMOUSEBUTTONS) [COND ((AND HOTSPOTCACHE (SELECTQ BUTTONFOREXISTINGPTS (MIDDLE (LASTMOUSESTATE MIDDLE)) (LEFT (LASTMOUSESTATE LEFT)) NIL) (SETQ NEARPOS (NEAREST.HOT.SPOT HOTSPOTCACHE NEWX NEWY))) (* on middle, pick the closest point) (SETQ NEWX (fetch (POSITION XCOORD) of NEARPOS)) (SETQ NEWY (fetch (POSITION YCOORD) of NEARPOS)) (SETQ ONGRID? NIL)) ((SETQ ONGRID? (COND ((LASTMOUSESTATE RIGHT) (* if right is down, flip sense of  using grid) (NOT USEGRID)) (T (* otherwise use the grid if told to.) USEGRID))) (SETQ NEWX (MAP.WINDOW.ONTO.GRID NEWX SCALE GRID)) (SETQ NEWY (MAP.WINDOW.ONTO.GRID NEWY SCALE GRID] (PROGN [COND ([AND CONSTRAINTFN (POSITIONP (SETQ CONSTRAINTPT (APPLY* CONSTRAINTFN (  MAP.VIEWER.XY.INTO.GLOBAL NEWX NEWY VIEWER ONGRID? SCRATCHPT) W FEEDBACKFNDATA] (SETQ NEWX (FIXR (QUOTIENT (fetch (POSITION XCOORD) of CONSTRAINTPT) SCALE))) (SETQ NEWY (FIXR (QUOTIENT (fetch (POSITION YCOORD) of CONSTRAINTPT) SCALE] (COND ((OR (NEQ XGRID NEWX) (NEQ YGRID NEWY)) (* grid point has changed too. Call the feedback function if the point is in  the window. If it is outside, don't show anything.) (AND XGRID (INSIDEP WINDOW XGRID YGRID) (APPLY* FEEDBACKFN XGRID YGRID WINDOW FEEDBACKFNDATA)) (AND (INSIDEP WINDOW (SETQ XGRID NEWX) (SETQ YGRID NEWY)) (APPLY* FEEDBACKFN XGRID YGRID WINDOW FEEDBACKFNDATA] finally (RETURN (COND ((AND XGRID (INSIDEP WINDOW XGRID YGRID)) (* if the cursor was outside the window when let up, return NIL) (APPLY* FEEDBACKFN XGRID YGRID WINDOW FEEDBACKFNDATA) (create INPUTPT INPUT.ONGRID? _ ONGRID? INPUT.POSITION _ (create POSITION XCOORD _ XGRID YCOORD _ YGRID]) (SKETCH.GET.POSITION [LAMBDA (VIEWER CURSOR FEEDBACKFN FEEDBACKFNDATA CONSTRAINTFN) (* rrb "21-May-86 16:51") (* user available version of  SK.READ.POINT.WITH.FEEDBACK.) (* reads a point from the user. Each time the cursor moves, a feedback fn is  called passing it the new X, new Y, VIEWER and FEEDBACKDATA It is expected to  XOR something on the screen that tells the user something.  CONSTRAINTFN is called to constrain the read point.) (PROG (READPT) (SETQ READPT (SK.READ.POINT.WITH.FEEDBACK VIEWER CURSOR FEEDBACKFN FEEDBACKFNDATA 'MIDDLE CONSTRAINTFN SKETCH.USE.POSITION.PAD)) (RETURN (COND ((NULL READPT) (RETURN NIL)) ((EQ (fetch (INPUTPT INPUT.ONGRID?) of READPT) 'GLOBAL) (* user entered a global number  directly.) (fetch (INPUTPT INPUT.GLOBALPOSITION) of READPT)) (T (MAP.VIEWER.XY.INTO.GLOBAL (fetch (POSITION XCOORD) of (fetch (INPUTPT INPUT.POSITION) of READPT)) (fetch (POSITION YCOORD) of (fetch (INPUTPT INPUT.POSITION) of READPT)) VIEWER (fetch (INPUTPT INPUT.ONGRID?) of READPT) (create POSITION]) (\CLOBBER.POSITION [LAMBDA (X Y OLDPT) (* rrb " 4-Apr-86 13:34") (* returns a position with values x and y.  Clobbers OLDPT if it is a POSITION.) (COND ((POSITIONP OLDPT) (replace (POSITION XCOORD) of OLDPT with X) (replace (POSITION YCOORD) of OLDPT with Y) OLDPT) (T (CREATEPOSITION X Y]) (NEAREST.HOT.SPOT [LAMBDA (CACHE X Y) (* rrb "31-Jul-85 10:14") (* returns the nearest hot spot to X Y) (PROG ((BESTMEASURE 10000) BESTX BESTY YDIF THISDIF) [for YBUCKET in CACHE do (SETQ YDIF (ABS (DIFFERENCE (CAR YBUCKET) Y))) (for XBUCKET in (CDR YBUCKET) do (COND ((CDR XBUCKET) (* this bucket has entries) (* use Manhattan distance for  efficiency.) [SETQ THISDIF (PLUS YDIF (ABS (DIFFERENCE (CAR XBUCKET) X] (COND ((ILESSP THISDIF BESTMEASURE) (SETQ BESTMEASURE THISDIF) (SETQ BESTX (CAR XBUCKET)) (SETQ BESTY (CAR YBUCKET] (RETURN (AND BESTX (create POSITION XCOORD _ BESTX YCOORD _ BESTY]) (GETWREGION [LAMBDA (W NEWREGIONFN NEWREGIONFNDATA MINWIDTH MINHEIGHT) (* ; "Edited 12-Jun-90 13:25 by mitani") (* gets a region from a window) (PROG ((REG (GETREGION MINWIDTH MINHEIGHT NIL NEWREGIONFN NEWREGIONFNDATA))) (RETURN (CREATEREGION (IDIFFERENCE (fetch (REGION LEFT) of REG) (DSPXOFFSET NIL W)) (IDIFFERENCE (fetch (REGION BOTTOM) of REG) (DSPYOFFSET NIL W)) (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG]) (GET.BITMAP.POSITION [LAMBDA (WINDOW BITMAP OPERATION MSG XOFFSET YOFFSET) (* rrb "11-Jul-85 11:00") (* gets a position by tracking with a bitmap The spec returns is actually  (ONGRID? position) so that caller can tell whether it was placed on grid or  not.) (PROG (BUFFER.BITMAP WIDTH HEIGHT) (SETQ WIDTH (BITMAPWIDTH BITMAP)) (SETQ HEIGHT (BITMAPHEIGHT BITMAP)) (SETQ BUFFER.BITMAP (BITMAPCREATE WIDTH HEIGHT)) (STATUSPRINT WINDOW " " MSG) (RETURN (SK.TRACK.BITMAP1 WINDOW BITMAP BUFFER.BITMAP WIDTH HEIGHT (OR OPERATION 'PAINT) XOFFSET YOFFSET]) (SK.TRACK.BITMAP1 [LAMBDA (W BITMAP BUFFER.BITMAP WIDTH HEIGHT OPERATION XOFFSET YOFFSET CONSTRAINTFN CONSTRAINTDATA FEEDBACKFN) (* rrb "11-Jul-86 15:52") (* tracks BITMAP until a button goes down and comes up.  It calls CONSTRAINTFN to determine the position at which to display the image.  Returns a list of (ongrid? position) so that caller can know whether the point  chosen was on a grid or not.) (* there is other code in BIGFONT that might be better for this.) (PROG [DOWN LEFT BOTTOM NEW.LEFT NEW.BOTTOM GRID.LEFT GRID.BOTTOM ONGRID? NEARPOS CONSTRAINTPT (DSP (WINDOWPROP W 'DSP)) (USEGRID (WINDOWPROP W 'USEGRID)) (GRID (SK.GRIDFACTOR W)) (SCALE (VIEWER.SCALE W)) (HOTSPOTCACHE (SK.HOTSPOT.CACHE W)) CONSTRAINTPT (SCRATCHPT (AND CONSTRAINTFN (create POSITION] (OR XOFFSET (SETQ XOFFSET 0)) (OR YOFFSET (SETQ YOFFSET 0)) (TOTOPW W) (RETURN (until (AND DOWN (LASTMOUSESTATE UP)) do (GETMOUSESTATE) (COND ((LASTMOUSESTATE (NOT UP)) (SETQ DOWN T))) (SETQ NEW.LEFT (LASTMOUSEX DSP)) (SETQ NEW.BOTTOM (LASTMOUSEY DSP)) [COND ((OR (NEQ NEW.LEFT LEFT) (NEQ NEW.BOTTOM BOTTOM)) (* cursor changed position check if  grid pt moved.) (SKETCHW.UPDATE.LOCATORS W) (SETQ LEFT NEW.LEFT) (SETQ BOTTOM NEW.BOTTOM) [COND ((AND HOTSPOTCACHE (LASTMOUSESTATE MIDDLE) (SETQ NEARPOS (NEAREST.HOT.SPOT HOTSPOTCACHE NEW.LEFT NEW.BOTTOM )))(* on middle, pick the closest point) (SETQ ONGRID? NIL) (SETQ NEW.LEFT (fetch (POSITION XCOORD) of NEARPOS)) (SETQ NEW.BOTTOM (fetch (POSITION YCOORD) of NEARPOS))) ((SETQ ONGRID? (COND ((LASTMOUSESTATE RIGHT) (* if right is down, flip sense of  using grid) (NOT USEGRID)) (T (* otherwise use the grid if told to.) USEGRID))) (SETQ NEW.LEFT (MAP.WINDOW.ONTO.GRID NEW.LEFT SCALE GRID)) (SETQ NEW.BOTTOM (MAP.WINDOW.ONTO.GRID NEW.BOTTOM SCALE GRID] (* check the constraintfn) [COND ([AND CONSTRAINTFN (POSITIONP (SETQ CONSTRAINTPT (APPLY* CONSTRAINTFN (MAP.VIEWER.XY.INTO.GLOBAL NEW.LEFT NEW.BOTTOM W ONGRID? SCRATCHPT) W CONSTRAINTDATA] (* scale the returns global position  into window coordinates) (SETQ NEW.LEFT (FIXR (QUOTIENT (fetch (POSITION XCOORD) of CONSTRAINTPT ) SCALE))) (SETQ NEW.BOTTOM (FIXR (QUOTIENT (fetch (POSITION YCOORD) of CONSTRAINTPT) SCALE] (COND ((OR (NEQ NEW.LEFT GRID.LEFT) (NEQ NEW.BOTTOM GRID.BOTTOM)) (* grid location changed, move the  text image.) [COND (GRID.LEFT (AND FEEDBACKFN (APPLY* FEEDBACKFN GRID.LEFT GRID.BOTTOM W CONSTRAINTDATA)) (BITBLT BUFFER.BITMAP 0 0 W (IPLUS GRID.LEFT XOFFSET) (IPLUS GRID.BOTTOM YOFFSET) WIDTH HEIGHT 'INPUT 'REPLACE] (SETQ GRID.LEFT NEW.LEFT) (SETQ GRID.BOTTOM NEW.BOTTOM) (BITBLT W (IPLUS GRID.LEFT XOFFSET) (IPLUS GRID.BOTTOM YOFFSET) BUFFER.BITMAP 0 0 NIL NIL 'INPUT 'REPLACE) (BITBLT BITMAP 0 0 DSP (IPLUS GRID.LEFT XOFFSET) (IPLUS GRID.BOTTOM YOFFSET) WIDTH HEIGHT 'INPUT OPERATION) (AND FEEDBACKFN (APPLY* FEEDBACKFN GRID.LEFT GRID.BOTTOM W CONSTRAINTDATA] finally [COND (GRID.LEFT (* restore screen) (AND FEEDBACKFN (APPLY* FEEDBACKFN GRID.LEFT GRID.BOTTOM W CONSTRAINTDATA)) (BITBLT BUFFER.BITMAP 0 0 W (IPLUS GRID.LEFT XOFFSET) (IPLUS GRID.BOTTOM YOFFSET) WIDTH HEIGHT 'INPUT 'REPLACE] (* return the position if any part of the bitmap is visible.) (RETURN (AND (REGIONSINTERSECTP (DSPCLIPPINGREGION NIL DSP) (CREATEREGION (IPLUS LEFT XOFFSET) (IPLUS BOTTOM YOFFSET) WIDTH HEIGHT)) (create INPUTPT INPUT.ONGRID? _ ONGRID? INPUT.POSITION _ (create POSITION XCOORD _ GRID.LEFT YCOORD _ GRID.BOTTOM]) ) (DECLARE%: EVAL@COMPILE (RECORD INPUTPT (INPUT.ONGRID? INPUT.POSITION INPUT.GLOBALPOSITION) [TYPE? (AND (LISTP DATUM) (OR (NULL (CAR DATUM)) (EQ (CAR DATUM) T)) (LISTP (CDR DATUM)) (POSITIONP (CADR DATUM]) ) (* ; "stuff to allow reading positions from a number pad") (RPAQ? SKETCH.USE.POSITION.PAD NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SKETCH.USE.POSITION.PAD) ) (DEFINEQ (SK.BRING.UP.POSITION.PAD [LAMBDA (VIEWER MSG OPENFLG) (* rrb "10-Jun-86 15:26") (* * brings up a position reading number pad associated with VIEWER.  Puts it over the menu if it is up.) (RESETFORM (RADIX 10) (PROG ((NUMBER/READER/MAXDIGITS 8) (MARGIN 6) (DIGITFONT (FONTCREATE 'MODERN 12 'BOLD)) (MSGFONT (FONTCREATE DEFAULTFONT)) (VIEWERREGION (WINDOWPROP VIEWER 'REGION)) WIN WINWIDTH WINHEIGHT TOTALSWIDTH TOTALSHEIGHT FONTHEIGHT MSGLINES XNUMBERPAD YNUMBERPAD COMMANDPAD) [SETQ TOTALSWIDTH (IPLUS 12 (ITIMES (ADD1 NUMBER/READER/MAXDIGITS) (CHARWIDTH (CHARCODE 0) DIGITFONT] [SETQ TOTALSHEIGHT (PLUS 2 (FONTPROP DIGITFONT 'HEIGHT] (SETQ XNUMBERPAD (\POSITION.READER.NUMBERPAD DIGITFONT TOTALSWIDTH)) (SETQ YNUMBERPAD (\POSITION.READER.NUMBERPAD DIGITFONT TOTALSWIDTH)) (SETQ COMMANDPAD (create MENU ITEMS _ '(abort enter quit) CENTERFLG _ T MENUFONT _ DIGITFONT WHENHELDFN _ (FUNCTION POSITIONPAD.HELDFN) WHENSELECTEDFN _ (FUNCTION POSITION.PAD.READER.HANDLER) MENUBORDERSIZE _ 1 MENUOUTLINESIZE _ 2 ITEMHEIGHT _ (PLUS 6 TOTALSHEIGHT))) (* leave room for three lines and the number at the top) (* use the numberpad's width so things  look better.) (SETQ TOTALSWIDTH (fetch (MENU IMAGEWIDTH) of XNUMBERPAD)) (SETQ WINWIDTH (IPLUS (TIMES 2 (PLUS MARGIN TOTALSWIDTH)) MARGIN (fetch (MENU IMAGEWIDTH) of COMMANDPAD) MARGIN)) (SETQ WINHEIGHT (IPLUS (COND [MSG (* if there is a msg, leave room for it at the top.  In any case, leave room for the labels X and Y.) (ITIMES (LENGTH (SETQ MSGLINES (BREAK.MSG.INTO.LINES MSG MSGFONT WINWIDTH) )) (FONTPROP MSGFONT 'HEIGHT] (T 0)) (FONTPROP DIGITFONT 'HEIGHT) (TIMES MARGIN 3) TOTALSHEIGHT MARGIN (fetch (MENU IMAGEHEIGHT) of XNUMBERPAD)) ) [SETQ WINHEIGHT (HEIGHTIFWINDOW WINHEIGHT NIL (WINDOWPROP VIEWER 'BORDER] (SETQ WIN (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW WINWIDTH) WINHEIGHT) NIL (WINDOWPROP VIEWER 'BORDER) T)) (MOVEW WIN (SK.PAD.READER.POSITION VIEWER WIN)) (WINDOWADDPROP WIN 'REPAINTFN (FUNCTION SK.POSITION.READER.REPAINTFN)) [COND (MSG (* save msg on the window so repaintfn can get at it) (WINDOWPROP WIN 'MESSAGE MSGLINES) (WINDOWPROP WIN 'MESSAGEFONT MSGFONT) (* note where the message begins.) (MOVETOUPPERLEFT WIN) (WINDOWPROP WIN 'MESSAGEBOTTOM (DSPYPOSITION NIL WIN] (WINDOWPROP WIN 'DIGITFONT DIGITFONT) (OPENW WIN) (* window is opened because of bug in ADDMENU that it doesn't work unless  window is open.) (\POSITION.PAD.ADD.DIGIT.MENU WIN MARGIN MARGIN 'X XNUMBERPAD TOTALSWIDTH TOTALSHEIGHT NUMBER/READER/MAXDIGITS) (\POSITION.PAD.ADD.DIGIT.MENU WIN (PLUS MARGIN TOTALSWIDTH MARGIN) MARGIN 'Y YNUMBERPAD TOTALSWIDTH TOTALSHEIGHT NUMBER/READER/MAXDIGITS) (REDISPLAYW WIN NIL T) [ADDMENU COMMANDPAD WIN (create POSITION XCOORD _ (PLUS MARGIN (TIMES 2 (PLUS MARGIN TOTALSWIDTH))) YCOORD _ (PLUS MARGIN (QUOTIENT (DIFFERENCE (fetch (MENU IMAGEHEIGHT) of XNUMBERPAD) (fetch (MENU IMAGEHEIGHT) of COMMANDPAD)) 2] (OR OPENFLG (CLOSEW WIN)) (RETURN WIN]) (SK.PAD.READER.POSITION [LAMBDA (VIEWER READERWINDOW) (* rrb "10-Jun-86 12:24") (* returns the lower left corner where a position reading pad should be placed  for the sketch viewer VIEWER.) (PROG ((VIEWERREGION (WINDOWPROP VIEWER 'REGION)) (READERREGION (WINDOWPROP READERWINDOW 'REGION)) VLFT VBTM PWID) (SETQ VLFT (fetch (REGION LEFT) of VIEWERREGION)) (SETQ VBTM (fetch (REGION BOTTOM) of VIEWERREGION)) (SETQ PWID (fetch (REGION WIDTH) of READERREGION)) (RETURN (COND [(OR (GREATERP VLFT PWID) (GREATERP VLFT VBTM) (GREATERP PWID (fetch (REGION WIDTH) of VIEWERREGION))) (* the position reader will fit to the left, or there is more room on the left,  or the position pad reader is wider than the viewer.) (create POSITION XCOORD _ (DIFFERENCE (MAX 10 VLFT) PWID) YCOORD _ (DIFFERENCE (fetch (REGION PTOP) of VIEWERREGION) (fetch (REGION HEIGHT) of READERREGION] (T (* more room on the bottom) (create POSITION XCOORD _ (MAX 10 VLFT) YCOORD _ (DIFFERENCE VBTM (fetch (REGION HEIGHT) of READERREGION]) (SK.POSITION.READER.REPAINTFN [LAMBDA (POSITIONPAD) (* rrb "11-Jun-86 13:28") (* repaints a position pad reader) (PROG ((MSGLINES (WINDOWPROP POSITIONPAD 'MESSAGE)) NUMBERMENU TOTALREGION) [COND (MSGLINES (* if there is a msg, print it at the top.) (DSPFONT (WINDOWPROP POSITIONPAD 'MESSAGEFONT) POSITIONPAD) (MOVETO 0 (WINDOWPROP POSITIONPAD 'MESSAGEBOTTOM) POSITIONPAD) (for LINE in MSGLINES do (PRIN3 LINE POSITIONPAD) (TERPRI POSITIONPAD] (DSPFONT (WINDOWPROP POSITIONPAD 'DIGITFONT) POSITIONPAD) (* the actual displaying of the menus is done by the repaintfn supplied by  ADDMENU) (for LABEL in '(X Y) do (SETQ NUMBERMENU (WINDOWPROP POSITIONPAD LABEL)) (SETQ TOTALREGION (GETMENUPROP NUMBERMENU 'TOTALREG)) (\READNUMBER.OUTLINEREGION TOTALREGION POSITIONPAD 2) (CENTERPRINTINAREA LABEL (fetch (REGION LEFT) of TOTALREGION) (PLUS 6 (fetch (REGION TOP) of TOTALREGION)) (fetch (REGION WIDTH) of TOTALREGION) (fetch (REGION HEIGHT) of TOTALREGION) POSITIONPAD) (DISPLAY.POSITION.READER.TOTAL NUMBERMENU]) (SK.POSITION.PAD.FROM.VIEWER [LAMBDA (VIEWER) (* rrb "11-Jun-86 14:17") (* cache the position pad because it takes a while to create.  Opens it too.) (PROG (PAD) (COND ((SETQ PAD (WINDOWPROP VIEWER 'POSITION.PAD)) (WINDOWPROP PAD 'FINISHEDFLG NIL) (* move the pad in case the window has moved or been reshaped.) (MOVEW PAD (SK.PAD.READER.POSITION VIEWER PAD)) (OPENW PAD) (* initialize some values) (SK.INIT.POSITION.NUMBER.PAD.MENU (WINDOWPROP PAD 'X)) (SK.INIT.POSITION.NUMBER.PAD.MENU (WINDOWPROP PAD 'Y)) (RETURN PAD)) (T (* flip cursor because this may  require font search) (RESETFORM (CURSOR WAITINGCURSOR) (SETQ PAD (SK.BRING.UP.POSITION.PAD VIEWER "Select the location of the desired position in the window or enter its X and Y coordinates here." T))) (WINDOWPROP VIEWER 'POSITION.PAD PAD) (RETURN PAD]) (SK.INIT.POSITION.NUMBER.PAD.MENU [LAMBDA (MNU) (* rrb "21-May-86 15:29") (* reinitializes a numberpad reader) (PUTMENUPROP MNU 'TOTAL 0) (PUTMENUPROP MNU 'DECIMALPOWER NIL) (DISPLAY.POSITION.READER.TOTAL MNU]) (SK.READ.POSITION.PAD.HANDLER [LAMBDA (POSITIONPAD VIEWER FEEDBACKFN FEEDBACKFNDATA CONSTRAINTFN) (* rrb "11-Jul-86 15:54") (* tracks the cursor while it is in the position pad and sets variables for  SK.READ.POINT.WITH.FEEDBACK and returned T if it succeeded) (* uses many variable freely from  SK.READ.POINT.WITH.FEEDBACK) (PROG (NEWX NEWY CONSTRX CONSTRY PREVX PREVY FINISHVAL (SCALE (VIEWER.SCALE VIEWER))) (SPAWN.MOUSE) (WINDOWADDPROP POSITIONPAD 'CLOSEFN (FUNCTION \NUMBERPAD.READER.CLOSEFN)) (RETURN (until [PROGN (GETMOUSESTATE) (OR (NOT (INSIDEP (WINDOWPROP POSITIONPAD 'REGION) LASTMOUSEX LASTMOUSEY)) (SETQ FINISHVAL (WINDOWPROP POSITIONPAD 'FINISHEDFLG NIL] do (* keep bringing the numberpad to the  top.) (TOTOPW POSITIONPAD) (DISMISS 100) (SETQ NEWX (GETMENUPROP (WINDOWPROP POSITIONPAD 'X) 'TOTAL)) (SETQ NEWY (GETMENUPROP (WINDOWPROP POSITIONPAD 'Y) 'TOTAL)) [COND ((OR (NEQ NEWX PREVX) (NEQ NEWY PREVY)) (* user entered a new number) (SETQ PREVX NEWX) (SETQ PREVY NEWY) (* this code is differerent from the code in SK.READ.POINT.WITH.FEEDBACK in  that is works in sketch coordinates.) [COND ([AND CONSTRAINTFN (POSITIONP (SETQ CONSTRAINTPT (APPLY* CONSTRAINTFN (SK.SET.POSITION NEWX NEWY SCRATCHPT) VIEWER FEEDBACKFNDATA] (SETQ NEWX (fetch (POSITION XCOORD) of CONSTRAINTPT)) (SETQ NEWY (fetch (POSITION YCOORD) of CONSTRAINTPT] (COND ((OR (NEQ CONSTRX NEWX) (NEQ CONSTRY NEWY)) (* grid point has changed too. Update the position numberpads and Call the  feedback function if the point is in the window.  If it is outside, don't show anything.) (PUTMENUPROP (WINDOWPROP POSITIONPAD 'X) 'TOTAL NEWX) (PUTMENUPROP (WINDOWPROP POSITIONPAD 'Y) 'TOTAL NEWY) (DISPLAY.POSITION.READER.TOTAL (WINDOWPROP POSITIONPAD 'X)) (DISPLAY.POSITION.READER.TOTAL (WINDOWPROP POSITIONPAD 'Y)) (AND CONSTRX (APPLY* FEEDBACKFN CONSTRX CONSTRY VIEWER FEEDBACKFNDATA )) (APPLY* FEEDBACKFN (QUOTIENT (SETQ CONSTRX NEWX) SCALE) (QUOTIENT (SETQ CONSTRY NEWY) SCALE) VIEWER FEEDBACKFNDATA] finally (* remove the closefn so that it doesn't get run on the way out.) (WINDOWDELPROP POSITIONPAD 'CLOSEFN (FUNCTION \NUMBERPAD.READER.CLOSEFN)) (AND CONSTRX (APPLY* FEEDBACKFN CONSTRX CONSTRY VIEWER FEEDBACKFNDATA)) (RETURN (COND ((MEMB FINISHVAL '(STOP ABORT)) (* means the numberpad reader was closed.  If the number pad includes the ABORT command, do what it would do, otherwise  the program is not expecting NIL so cause an error.) (RETURN FINISHVAL)) (FINISHVAL (AND CONSTRX (SETQ FINISHVAL (create POSITION XCOORD _ CONSTRX YCOORD _ CONSTRY)) (create INPUTPT INPUT.ONGRID? _ 'GLOBAL INPUT.POSITION _ ( SK.SCALE.POSITION.INTO.VIEWER FINISHVAL SCALE) INPUT.GLOBALPOSITION _ FINISHVAL))) (T (* mouse left the window, return) NIL]) (DISPLAY.POSITION.READER.TOTAL [LAMBDA (MNU) (* rrb "19-May-86 17:09") (* displays the number total in the box in the window.) (PROG ((TOTALREG (GETMENUPROP MNU 'TOTALREG)) (DECIMALPLACES (GETMENUPROP MNU 'DECIMALPOWER)) (WIN (WFROMMENU MNU))) (DSPFILL TOTALREG WHITESHADE 'REPLACE WIN) (RESETFORM (RADIX 10) (CENTERPRINTINREGION [COND [DECIMALPLACES (* printing a decimal number must check to make sure the correct number of  decimal places print.) (PROG ([TOTSTR (MKSTRING (GETMENUPROP MNU 'TOTAL] DECPOS NAFTERDEC NCHARS) (SETQ NCHARS (NCHARS TOTSTR)) (SETQ DECPOS (STRPOS "." TOTSTR)) (RETURN (COND ((EQ (SUB1 DECIMALPLACES) (SETQ NAFTERDEC (DIFFERENCE NCHARS DECPOS))) (* right number of places) TOTSTR) [(GEQ NAFTERDEC DECIMALPLACES) (* strip off the unwanted ones.) (SUBSTRING TOTSTR 1 (PLUS DECPOS (SUB1 DECIMALPLACES] (T (* not enough zeros on the end) (CONCAT TOTSTR (bind STR for I from 1 to (DIFFERENCE (SUB1 DECIMALPLACES) NAFTERDEC) do (COND (STR (SETQ STR (CONCAT STR "0"))) (T (SETQ STR "0"))) finally (RETURN STR] (T (GETMENUPROP MNU 'TOTAL] TOTALREG WIN]) (POSITION.PAD.READER.HANDLER [LAMBDA (DIGIT MNU) (* rrb "10-Jun-86 15:50") (* handles a key stroke or menu digit selection for a number pad reader.) (PROG (TOTAL POWER OPERATION TOPOFSTACK (WIN (WFROMMENU MNU))) (SETQ TOTAL (GETMENUPROP MNU 'TOTAL)) [PUTMENUPROP MNU 'TOTAL (SELECTQ DIGIT ((¬ bs) (COND ((NULL (GETMENUPROP MNU 'DIGITYET)) (* bs was the first key) (PUTMENUPROP MNU 'DIGITYET T) 0) [(SETQ POWER (GETMENUPROP MNU 'DECIMALPOWER)) (* have read decimal pt -  much harder) (COND ((EQ POWER 1) (* backspace over the decimal point.) (PUTMENUPROP MNU 'DECIMALPOWER NIL) (FIX TOTAL)) (T (PUTMENUPROP MNU 'DECIMALPOWER (SETQ POWER (SUB1 POWER))) (* dirty but effective.) (PROG ((TOTSTR (MKSTRING TOTAL))) (* SUBSTRING will be NIL if the total has a trailing zero.) (RETURN (MKATOM (OR (SUBSTRING TOTSTR 1 (PLUS (STRPOS "." TOTSTR) (SUB1 POWER))) TOTSTR] (T (* no decimal point) (IQUOTIENT TOTAL 10)))) (± (* +/- sign) (MINUS TOTAL)) ((¸ ´ - + =) (* operation sign) [COND ((NULL (GETMENUPROP MNU 'DIGITYET)) (* last thing hit was an operation, just save this one.) (PUTMENUPROP MNU 'OPERATION (COND ((EQ DIGIT '=) NIL) (T DIGIT))) (RETURN)) ((SETQ OPERATION (GETMENUPROP MNU 'OPERATION)) (* perform the operation that is stored between the top of stack and the  current total) (COND [(SETQ TOPOFSTACK (GETMENUPROP MNU 'TOPOFSTACK)) (* a previous value exists) (SETQ TOTAL (SELECTQ OPERATION (¸ (* divide, check for 0 divisor) (COND ((ZEROP TOTAL) (PROMPTPRINT "Can't divide by zero")) (T (QUOTIENT TOPOFSTACK TOTAL)))) (´ (* times) (TIMES TOPOFSTACK TOTAL)) (- (* minus) (DIFFERENCE TOPOFSTACK TOTAL)) (PLUS TOPOFSTACK TOTAL] (T TOTAL] (PUTMENUPROP MNU 'TOPOFSTACK TOTAL) (PUTMENUPROP MNU 'DIGITYET NIL) (PUTMENUPROP MNU 'DECIMALPOWER NIL) (PUTMENUPROP MNU 'OPERATION (COND ((EQ DIGIT '=) NIL) (T DIGIT))) TOTAL) (% (* empty key) TOTAL) (%. (* decimal point) (COND ((GETMENUPROP MNU 'DECIMALPOWER) (* already has a decimal pt, don't do  anything) (RETURN)) ((NULL (GETMENUPROP MNU 'DIGITYET)) (* first key hit is a decimal point.) (PUTMENUPROP MNU 'DIGITYET T) (PUTMENUPROP MNU 'DECIMALPOWER 1) 0.0) (T (PUTMENUPROP MNU 'DECIMALPOWER 1) (FLOAT TOTAL)))) (enter (WINDOWPROP WIN 'FINISHEDFLG T) (RETURN)) (quit (WINDOWPROP WIN 'FINISHEDFLG 'STOP) (RETURN)) (abort (* abort key) (WINDOWPROP WIN 'FINISHEDFLG 'ABORT) (RETURN)) (C (* clear key) (PUTMENUPROP MNU 'DECIMALPOWER NIL) (PUTMENUPROP MNU 'DIGITYET T) (PUTMENUPROP MNU 'TOPOFSTACK NIL) 0) (ce (* clear key) (PUTMENUPROP MNU 'DECIMALPOWER NIL) (PUTMENUPROP MNU 'DIGITYET T) 0) (COND [(NUMBERP DIGIT) (COND ((NULL (GETMENUPROP MNU 'DIGITYET)) (* first key hit after an operation, note this and clear the total.) (PUTMENUPROP MNU 'DIGITYET T) (SETQ TOTAL 0))) (COND ((EQ (GETMENUPROP MNU 'MAXDIGITS) (NCHARS (ABS TOTAL))) (* don't take any more.) (\READNUMBER.FLASHAREA 0 0 1000 1000 WIN) TOTAL) [(SETQ POWER (GETMENUPROP MNU 'DECIMALPOWER)) (* have read decimal pt) (PUTMENUPROP MNU 'DECIMALPOWER (ADD1 POWER)) (SETQ POWER (bind (N _ 1.0) for I from 1 to POWER do (SETQ N (FTIMES N 0.1)) finally (RETURN N))) (COND ((GEQ TOTAL 0) (PLUS TOTAL (TIMES DIGIT POWER))) (T (DIFFERENCE TOTAL (TIMES DIGIT POWER] ((GEQ TOTAL 0) (PLUS (TIMES TOTAL 10) DIGIT)) (T (DIFFERENCE (TIMES TOTAL 10) DIGIT] (T (* uninteresting key struck, ignore it) (RETURN] (DISPLAY.POSITION.READER.TOTAL MNU]) (POSITIONPAD.HELDFN [LAMBDA (ITEM MENU BUTTON) (* rrb "10-Jun-86 15:29") (* prints the help information for a  numberpad.) (PROMPTPRINT (SELECTQ ITEM (enter "Indicates that you are through entering the position.") (ce "Will reset the total to 0") (C "Will clear the stack and set the total to 0") (= "performs the previously specified operation between the memory and the current total") (+ "Will read another number to be added to the current total") (- "Will read another number to be subtracted to the current total") (´ "Will read another number to be multiplied by the current total") (¸ "Will read another number and divides the current total by it") (quit "Will stop prompting you for points.") (abort "will abort this sketch operation.") (± " will change the sign of the total") (%. "will enter a decimal point.") ((bs ¬) "Will erase the last digit entered.") (% "doesn't do anything.") "Will put this digit on the right of the total."]) (\POSITION.PAD.ADD.DIGIT.MENU [LAMBDA (WIN LEFT MARGIN LABEL MENU TOTALSWIDTH TOTALSHEIGHT NUMBER/READER/MAXDIGITS) (* rrb "10-Jun-86 12:06") (* * adds a menu which is a number pad menu to WIN, allocates the total region  for it.) (PROG (TOTALREGION) (ADDMENU MENU WIN (create POSITION XCOORD _ LEFT YCOORD _ MARGIN)) (PUTMENUPROP MENU 'TOTALREG (SETQ TOTALREGION (create REGION LEFT _ LEFT BOTTOM _ (PLUS (fetch (MENU IMAGEHEIGHT ) of MENU) MARGIN MARGIN) WIDTH _ TOTALSWIDTH HEIGHT _ TOTALSHEIGHT))) (PUTMENUPROP MENU 'TOTAL 0) (PUTMENUPROP MENU 'MAXDIGITS NUMBER/READER/MAXDIGITS) (* put link to the menu so the window can eventually get the values.) (WINDOWPROP WIN LABEL MENU) (RETURN WIN]) (\POSITION.READER.NUMBERPAD [LAMBDA (DIGITFONT WIDTH) (* rrb "10-Jun-86 15:33") (* returns a menu which is a numberpad suitable for a position reader.) (create MENU ITEMS _ '(¬ ce C ¸ 1 2 3 ´ 4 5 6 - 7 8 9 + ± 0 %. =) MENUCOLUMNS _ 4 CENTERFLG _ T MENUFONT _ DIGITFONT WHENHELDFN _ (FUNCTION POSITIONPAD.HELDFN) WHENSELECTEDFN _ (FUNCTION POSITION.PAD.READER.HANDLER) MENUOUTLINESIZE _ 2 ITEMHEIGHT _ (IPLUS 2 (FONTPROP DIGITFONT 'HEIGHT)) ITEMWIDTH _ (AND WIDTH (QUOTIENT (DIFFERENCE WIDTH 8) 4]) ) (RPAQ? ALL.SKETCHES ) (RPAQ? INITIAL.SCALE 1.0) (RPAQ? DEFAULT.VISIBLE.SCALE.FACTOR 10.0) (RPAQ? MINIMUM.VISIBLE.SCALE.FACTOR 4.0) (RPAQQ SKETCH.ELEMENT.TYPES NIL) (RPAQQ SKETCH.ELEMENT.TYPE.NAMES NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS ALL.SKETCHES INITIAL.SCALE DEFAULT.VISIBLE.SCALE.FACTOR MINIMUM.VISIBLE.SCALE.FACTOR SKETCH.ELEMENT.TYPES SKETCH.ELEMENT.TYPE.NAMES SK.SELECTEDMARK SK.LOCATEMARK COPYSELECTIONMARK MOVESELECTIONMARK DELETESELECTIONMARK) ) (READVARS-FROM-STRINGS '(SK.SELECTEDMARK SK.LOCATEMARK COPYSELECTIONMARK MOVESELECTIONMARK DELETESELECTIONMARK OTHERCONTROLPOINTMARK) "({(READBITMAP)(7 7 %"ON@@%" %"ON@@%" %"ON@@%" %"ON@@%" %"ON@@%" %"ON@@%" %"ON@@%")} {(READBITMAP)(11 11 %"OON@%" %"OON@%" %"L@F@%" %"L@F@%" %"L@F@%" %"L@F@%" %"L@F@%" %"L@F@%" %"L@F@%" %"OON@%" %"OON@%")} {(READBITMAP)(11 11 %"@@@@%" %"EED@%" %"BJH@%" %"EED@%" %"BJH@%" %"EED@%" %"BJH@%" %"EED@%" %"BJH@%" %"EED@%" %"@@@@%")} {(READBITMAP)(19 19 %"OL@@@@@@%" %"N@@@@@@@%" %"O@@@@@@@%" %"KH@@@@@@%" %"I@@@@@@@%" %"H@@@@@@@%" %"@CH@@@@@%" %"@CL@@@@@%" %"@CN@@@@@%" %"@AO@@@@@%" %"@@OH@@@@%" %"@@GH@@@@%" %"@@CH@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%")} {(READBITMAP)(13 13 %"L@AH%" %"H@@H%" %"@@@@%" %"AHL@%" %"AML@%" %"@OH@%" %"@G@@%" %"@OH@%" %"AML@%" %"AHL@%" %"@@@@%" %"H@@H%" %"L@AH%")} {(READBITMAP)(11 11 %"@@@@%" %"@D@@%" %"BJH@%" %"AE@@%" %"BJH@%" %"EED@%" %"BJH@%" %"AE@@%" %"BJH@%" %"@D@@%" %"@@@@%")}) ") (* ; "accessing functions for the methods of a sketch type.") (DEFINEQ (SK.DRAWFN [LAMBDA (ELEMENTTYPE) (* rrb "17-MAR-83 22:28") (* goes from an element type name to  its DRAWFN) (fetch (SKETCHTYPE DRAWFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) (SK.TRANSFORMFN [LAMBDA (ELEMENTTYPE) (* rrb " 7-Feb-85 12:08") (* goes from an element type name to  its TRANSFORMFN) (fetch (SKETCHTYPE TRANSFORMFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) (SK.EXPANDFN [LAMBDA (ELEMENTTYPE) (* goes from an element type name to  its EXPANDFN) (fetch (SKETCHTYPE EXPANDFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) (SK.INPUT [LAMBDA (ELEMENTTYPE SKETCHW) (* rrb "11-MAR-83 09:54") (* applies an element types input  function to a window.) (APPLY* (fetch (SKETCHTYPE INPUTFN) of ELEMENTTYPE) SKETCHW]) (SK.INSIDEFN [LAMBDA (ELEMENTTYPE) (* rrb " 4-Oct-86 11:02") (* goes from an element type name to its inside predicate) (PROG (SKTYPE) LP (COND ([NULL (SETQ SKTYPE (GETPROP ELEMENTTYPE 'SKETCHTYPE] (* unknown sketch type and this is the first place where such is encountered.) (ERROR ELEMENTTYPE "Unknown sketch type. If you can load the file containing it, do so and type 'RETURN'. Otherwise, type '^'.") (GO LP))) (RETURN (fetch (SKETCHTYPE INSIDEFN) of SKTYPE]) (SK.UPDATEFN [LAMBDA (ELEMENTTYPE) (* rrb "21-Dec-84 11:28") (* goes from an element type name to its updatefn The update function is called  when an element in a window has changed.  It will get args of the old local screen element, the new global element and  the window. If it can update the display more efficiently than erasing and  redrawing, it should and return the new local sketch element.) (fetch (SKETCHTYPE UPDATEFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) ) (/DECLAREDATATYPE 'SKETCHTYPE '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((SKETCHTYPE 0 POINTER) (SKETCHTYPE 2 POINTER) (SKETCHTYPE 4 POINTER) (SKETCHTYPE 6 POINTER) (SKETCHTYPE 8 POINTER) (SKETCHTYPE 10 POINTER) (SKETCHTYPE 12 POINTER) (SKETCHTYPE 14 POINTER) (SKETCHTYPE 16 POINTER) (SKETCHTYPE 18 POINTER) (SKETCHTYPE 20 POINTER) (SKETCHTYPE 22 POINTER) (SKETCHTYPE 24 POINTER) (SKETCHTYPE 26 POINTER) (SKETCHTYPE 28 POINTER)) '30) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD SCREENELT (LOCALPART . GLOBALPART) (RECORD GLOBALPART (COMMONGLOBALPART INDIVIDUALGLOBALPART) (RECORD INDIVIDUALGLOBALPART (GTYPE . GOTHERINFO)) (RECORD COMMONGLOBALPART (MINSCALE MAXSCALE SKELEMENTPROPLIST))) (RECORD LOCALPART (HOTSPOTS LOCALHOTREGION . OTHERLOCALINFO))) (RECORD GLOBALPART (COMMONGLOBALPART INDIVIDUALGLOBALPART) (RECORD INDIVIDUALGLOBALPART (GTYPE . RESTOFGLOBALPART)) (RECORD COMMONGLOBALPART (MINSCALE MAXSCALE SKELEMENTPROPLIST))) (RECORD COMMONGLOBALPART (MINSCALE MAXSCALE SKELEMENTPROPLIST)) (RECORD INDIVIDUALGLOBALPART (GTYPE . RESTOFGLOBALPART)) (RECORD LOCALPART (HOTSPOTS LOCALHOTREGION . OTHERLOCALINFO)) (RECORD SKETCH (ALLSKETCHPROPS . SKETCHTCELL) [RECORD ALLSKETCHPROPS (SKETCHKEY SKETCHNAME . SKETCHPROPS) (CREATE (LIST 'SKETCH NIL 'VERSION SKETCH.VERSION 'PRIRANGE (CONS 0 0] [RECORD SKETCHTCELL (SKETCHELTS) (CREATE (CONS SKETCHELTS (LAST SKETCHELTS] [TYPE? (AND (LISTP DATUM) (LISTP (CAR DATUM)) (EQ (CAAR DATUM) 'SKETCH]) (DATATYPE SKETCHTYPE (LABEL (* the label if it is non-NIL will  be used in the sketch menu.) DOCSTR (* if put in the menu, this is the  help string for its item.) DRAWFN EXPANDFN obsolete CHANGEFN INPUTFN INSIDEFN REGIONFN TRANSLATEFN UPDATEFN READCHANGEFN TRANSFORMFN (* fn to transform the control  points of an element.  takes args Gelt Tranfn trandata.) TRANSLATEPTSFN (* fn to move some but not all points of a screen element.  Takes args%: LocalSelectedPts GlobalDeltaToTranslate ScreenElt SketchWindow) GLOBALREGIONFN (* takes a GLOBAL element and returns the global region it occupies.  Note%: this is the only fn that takes a global rather that a local element.) )) (RECORD SKETCHCONTEXT (SKETCHBRUSH SKETCHFONT SKETCHTEXTALIGNMENT SKETCHARROWHEAD SKETCHDASHING SKETCHUSEARROWHEAD SKETCHTEXTBOXALIGNMENT SKETCHFILLING SKETCHLINEMODE SKETCHARCDIRECTION SKETCHMOVEMODE SKETCHINPUTSCALE SKETCHDRAWINGMODE)) ) (/DECLAREDATATYPE 'SKETCHTYPE '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((SKETCHTYPE 0 POINTER) (SKETCHTYPE 2 POINTER) (SKETCHTYPE 4 POINTER) (SKETCHTYPE 6 POINTER) (SKETCHTYPE 8 POINTER) (SKETCHTYPE 10 POINTER) (SKETCHTYPE 12 POINTER) (SKETCHTYPE 14 POINTER) (SKETCHTYPE 16 POINTER) (SKETCHTYPE 18 POINTER) (SKETCHTYPE 20 POINTER) (SKETCHTYPE 22 POINTER) (SKETCHTYPE 24 POINTER) (SKETCHTYPE 26 POINTER) (SKETCHTYPE 28 POINTER)) '30) ) (ADDTOVAR BackgroundMenuCommands (Sketch '(SKETCHW.CREATE NIL NIL (GETREGION) NIL NIL T T) "Opens a sketch window for use." (SUBITEMS ("Page sized sketch" '(EDITSLIDE NIL) "Opens a sketch window the size of a page.") ("Landscaped sketch" '(EDITSLIDE NIL T) "Opens a sketch window the size of a landscaped page.") ("Sketch, from a file" '(SKETCH.FROM.A.FILE) "Reads a file name and opens a sketch window onto the sketch it contains." )))) (RPAQQ BackgroundMenu NIL) (FILESLOAD SKETCHOPS SKETCHELEMENTS SKETCHEDIT SKETCHOBJ SKETCHBMELT) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) SKETCHOPS SKETCHELEMENTS SKETCHOBJ SKETCHEDIT) ) (* ; "recompute the sketch element types because loading SKETCH clobbers the previous ones.") (INIT.BITMAP.ELEMENT) (INIT.SKETCH.ELEMENTS) (INIT.GROUP.ELEMENT) (* ; "version checking stuff") (DECLARE%: EVAL@COMPILE (RPAQQ SKETCH.VERSION 3) (CONSTANTS (SKETCH.VERSION 3)) ) (DEFINEQ (SK.CHECK.SKETCH.VERSION [LAMBDA (SKETCH) (* ;  "Edited 21-Oct-92 18:40 by sybalsky:mv:envos") (* ;;  "makes sure the sketch is the correct version. If not, it tries to update it. Returns SKETCH.") (COND ((EQ (LISTGET (fetch (SKETCH SKETCHPROPS) of SKETCH) 'VERSION) SKETCH.VERSION) SKETCH) (T (SK.INSURE.RECORD.LENGTH (fetch (SKETCH SKETCHELTS) of SKETCH)) (* ;;  "this is basically a PUTSKETCHPROP expanded in line to avoid coersions which can cause loops.") [PROG (PLIST) (SETQ PLIST (fetch (SKETCH SKETCHPROPS) of SKETCH)) (COND ((SETQ PLIST (fetch (SKETCH SKETCHPROPS) of SKETCH)) (LISTPUT PLIST 'VERSION SKETCH.VERSION)) (T (replace (SKETCH SKETCHPROPS) of SKETCH with (LIST 'VERSION SKETCH.VERSION] SKETCH]) (SK.INSURE.RECORD.LENGTH [LAMBDA (SKETCHELTS) (* ;  "Edited 21-Oct-92 18:35 by sybalsky:mv:envos") (* ;; "makes sure the elements have the proper number of fields.") (bind INDPART TYPE NFIELDS for ELT in SKETCHELTS do (SETQ INDPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELT)) (SETQ TYPE (fetch (INDIVIDUALGLOBALPART GTYPE) of INDPART)) (COND ([OR (SETQ NFIELDS (SK.RECORD.LENGTH TYPE)) (AND (RECLOOK TYPE) (SETQ SKETCH.RECORD.LENGTHS (NCONC1 SKETCH.RECORD.LENGTHS (LIST TYPE (SETQ NFIELDS (LENGTH (EVAL (LIST 'CREATE TYPE] (SK.INSURE.HAS.LENGTH INDPART NFIELDS TYPE))) (* ;; "if it's not a record, either it's an unknown sketch element type or its declaration wasn't copied to the compiled file. In either case, assume it has the correct number of fields.") (COND ((EQ TYPE 'GROUP) (* ;  "recurse thru the subelements too.") (SK.INSURE.RECORD.LENGTH (fetch (GROUP LISTOFGLOBALELTS) of INDPART]) (SK.INSURE.HAS.LENGTH [LAMBDA (LIST N TYPE) (* ;  "Edited 21-Oct-92 18:36 by sybalsky:mv:envos") (* ;; "makes sure LIST is at least N long. If not, it creates a record of type TYPE and nconcs the enough fields from the end to make it be N long.") (OR (EQLENGTH LIST N) (NCONC LIST (COND [(RECLOOK TYPE) (NTH (EVAL (LIST 'CREATE TYPE)) (ADD1 (LENGTH LIST] (T (* ; "no record, add NILs and hope.") (for I from (ADD1 (LENGTH LIST)) to N collect NIL]) (SK.RECORD.LENGTH [LAMBDA (SKETCHRECORDTYPE) (* rrb "20-Mar-86 14:11") (CADR (ASSOC SKETCHRECORDTYPE SKETCH.RECORD.LENGTHS]) (SK.SET.RECORD.LENGTHS [LAMBDA NIL (* rrb "18-Oct-85 15:35") (* sets up a variable that contains the lengths of the sketch element records.) (SETQ SKETCH.RECORD.LENGTHS (SK.SET.RECORD.LENGTHS.MACRO]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS SK.SET.RECORD.LENGTHS.MACRO MACRO [ARGS (CONS 'LIST (for X in SKETCH.ELEMENT.TYPE.NAMES collect (LIST 'LIST (KWOTE X) (LIST 'LENGTH (LIST 'CREATE X]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SKETCH.RECORD.LENGTHS) ) (SK.SET.RECORD.LENGTHS) (* ; "to correct for a bug in the file package that marks LOADCOMPed file as changed") (UNMARKASCHANGED 'SKETCH 'FILE) (UNMARKASCHANGED 'SKETCHELEMENTS 'FILE) (UNMARKASCHANGED 'SKETCHOPS 'FILE) (UNMARKASCHANGED 'SKETCHEDIT 'FILE) (UNMARKASCHANGED 'SKETCHOBJ 'FILE) (* ; "add sketch as option to file browser edit command") (DEFINEQ (SK.ADD.EDIT.COMMAND.TO.FILE.BROWSER [LAMBDA NIL (* ; "Edited 12-Feb-88 16:49 by rrb") (* adds sketch as an option to the file browser edit command.) (AND (BOUNDP 'FB.MENU.ITEMS) (PROG [(PTRX (for MITEM in FB.MENU.ITEMS when (STRING-EQUAL (CAR MITEM) "Edit") do (RETURN MITEM] (SETQ PTRX (ASSOC 'SUBITEMS PTRX)) (for SUBI in PTRX when (STRING-EQUAL (CAR SUBI) "Sketch") do (RETURN) finally (NCONC1 PTRX (LIST '"Sketch" '(FB.EDITCOMMAND SKETCH) "Calls the Sketch editor on selected files"]) ) (SK.ADD.EDIT.COMMAND.TO.FILE.BROWSER) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA SK.UNIONREGIONS SKETCH.CREATE) ) (PUTPROPS SKETCH COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1990 1992 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (22416 85555 (SKETCH 22426 . 24531) (SKETCH.FROM.A.FILE 24533 . 24848) (SKETCHW.CREATE 24850 . 29424) (SKETCH.RESET 29426 . 30948) (SKETCHW.FIG.CHANGED 30950 . 31290) (SK.WINDOW.TITLE 31292 . 31679) (EDITSLIDE 31681 . 32087) (EDITSKETCH 32089 . 32413) (SK.PUT.ON.FILE 32415 . 33867) ( SK.OUTPUT.FILE.NAME 33869 . 34243) (SKETCH.PUT 34245 . 36919) (SK.GET.FROM.FILE 36921 . 37814) ( SK.INCLUDE.FILE 37816 . 40324) (SK.GET.IMAGEOBJ.FROM.FILE 40326 . 42529) (SKETCH.GET 42531 . 42838) ( ADD.SKETCH.TO.VIEWER 42840 . 45426) (FILENAMELESSVERSION 45428 . 45704) (SK.ADD.ELEMENTS.TO.SKETCH 45706 . 46220) (SKETCH.SET.A.DEFAULT 46222 . 53380) (SK.POPUP.SELECTIONFN 53382 . 53924) ( GETSKETCHWREGION 53926 . 54132) (SK.ADD.ELEMENT 54134 . 55713) (SK.ADD.PRIORITY.ELEMENT.TO.SKETCH 55715 . 57109) (SK.ELTS.BY.PRIORITY 57111 . 57407) (SK.ORDER.ELEMENTS 57409 . 57676) ( SK.ADD.PRIORITY.LOCAL.ELEMENT.TO.SKETCH 57678 . 59172) (SK.ADD.ELEMENTS 59174 . 59698) ( SK.CHECK.WHENADDEDFN 59700 . 60430) (SK.APPLY.MENU.COMMAND 60432 . 61230) (SK.DELETE.ELEMENT1 61232 . 62810) (SK.MARK.DIRTY 62812 . 63478) (SK.MARK.UNDIRTY 63480 . 63811) (SK.MENU.AND.RETURN.FIELD 63813 . 64478) (SKETCH.SET.BRUSH.SHAPE 64480 . 65065) (SKETCH.SET.BRUSH.SIZE 65067 . 65573) ( SKETCHW.CLOSEFN 65575 . 67366) (SK.CONFIRM.DESTRUCTION 67368 . 68367) (SKETCHW.OUTFN 68369 . 68633) ( SKETCHW.REOPENFN 68635 . 69047) (MAKE.LOCAL.SKETCH 69049 . 69779) (MAP.SKETCHSPEC.INTO.VIEWER 69781 . 70991) (SKETCHW.REPAINTFN 70993 . 71821) (SKETCHW.REPAINTFN1 71823 . 72762) (SK.DRAWFIGURE.IF 72764 . 73286) (SKETCHW.SCROLLFN 73288 . 77481) (SKETCHW.RESHAPEFN 77483 . 79741) (SK.UPDATE.EVENT.SELECTION 79743 . 81798) (LIGHTGRAYWINDOW 81800 . 81963) (SK.ADD.SPACES 81965 . 82711) (SK.SKETCH.MENU 82713 . 83035) (SK.CHECK.IMAGEOBJ.WHENDELETEDFN 83037 . 83889) (SK.APPLY.IMAGEOBJ.WHENDELETEDFN 83891 . 84851) (SK.RETURN.TTY 84853 . 85221) (SK.TAKE.TTY 85223 . 85553)) (85609 108602 (SKETCH.COMMANDMENU 85619 . 85956) (SKETCH.COMMANDMENU.ITEMS 85958 . 105706) (CREATE.SKETCHW.COMMANDMENU 105708 . 106128) ( SKETCHW.SELECTIONFN 106130 . 107233) (SKETCH.MONITORLOCK 107235 . 107706) (SK.EVAL.AS.PROCESS 107708 . 108321) (SK.EVAL.WITH.LOCK 108323 . 108600)) (108603 116407 (SK.FIX.MENU 108613 . 109707) ( SK.SET.UP.MENUS 109709 . 112010) (SK.INSURE.HAS.MENU 112012 . 112674) (SK.CREATE.STANDARD.MENU 112676 . 113121) (SK.ADD.ITEM.TO.MENU 113123 . 113798) (SK.GET.VIEWER.POPUP.MENU 113800 . 116001) ( SK.CLEAR.POPUP.MENU 116003 . 116405)) (116463 125285 (SKETCH.CREATE 116473 . 117259) (GETSKETCHPROP 117261 . 120318) (PUTSKETCHPROP 120320 . 124252) (CREATE.DEFAULT.SKETCH.CONTEXT 124254 . 125283)) ( 125451 148347 (SK.COPY.BUTTONEVENTFN 125461 . 136689) (SK.BUTTONEVENT.MARK 136691 . 137074) ( SK.BUILD.IMAGEOBJ 137076 . 146991) (SK.BUTTONEVENT.OVERP 146993 . 147616) (SK.BUTTONEVENT.SAME.KEYS 147618 . 148345)) (148634 174449 (SK.SEL.AND.CHANGE 148644 . 148936) (SK.CHECK.WHENCHANGEDFN 148938 . 149644) (SK.CHECK.PRECHANGEFN 149646 . 150247) (SK.CHANGE.ELT 150249 . 150441) (SK.CHANGE.THING 150443 . 151694) (SKETCH.CHANGE.ELEMENTS 151696 . 152879) (SK.APPLY.SINGLE.CHANGEFN 152881 . 153454) ( SK.DO.CHANGESPECS 153456 . 155115) (SK.VIEWER.FROM.SKETCH.ARG 155117 . 155559) (SK.DO.CHANGESPEC1 155561 . 157436) (SK.CHANGEFN 157438 . 158018) (SK.READCHANGEFN 158020 . 158479) (SK.DEFAULT.CHANGEFN 158481 . 160953) (CHANGEABLEFIELDITEMS 160955 . 161602) (SK.APPLY.CHANGE.COMMAND 161604 . 162221) ( SK.DO.AND.RECORD.CHANGES 162223 . 163620) (SK.APPLY.CHANGE.COMMAND1 163622 . 165110) ( SK.ELEMENTS.CHANGEFN 165112 . 167436) (READ.POINT.TO.ADD 167438 . 168382) (GLOBAL.KNOT.FROM.LOCAL 168384 . 168844) (SK.ADD.KNOT.TO.ELEMENT 168846 . 169790) (SK.GROUP.CHANGEFN 169792 . 171004) ( SK.GROUP.CHANGEFN1 171006 . 174447)) (174616 188349 (ADD.ELEMENT.TO.SKETCH 174626 . 176332) ( ADD.SKETCH.VIEWER 176334 . 177002) (REMOVE.SKETCH.VIEWER 177004 . 177617) (ALL.SKETCH.VIEWERS 177619 . 177859) (SKETCH.ALL.VIEWERS 177861 . 178121) (VIEWER.BUCKET 178123 . 178274) (ELT.INSIDE.REGION? 178276 . 178603) (ELT.INSIDE.SKWP 178605 . 178896) (SCALE.FROM.SKW 178898 . 179148) ( SK.ADDELT.TO.WINDOW 179150 . 180010) (SK.CALC.REGION.VIEWED 180012 . 180390) (SK.DRAWFIGURE 180392 . 181681) (SK.DRAWFIGURE1 181683 . 182067) (SK.LOCAL.FROM.GLOBAL 182069 . 183304) (SKETCH.REGION.VIEWED 183306 . 185993) (SKETCH.VIEW.FROM.NAME 185995 . 186425) (SK.UPDATE.REGION.VIEWED 186427 . 186819) ( SKETCH.ADD.AND.DISPLAY 186821 . 187229) (SKETCH.ADD.AND.DISPLAY1 187231 . 187669) (SK.ADD.ITEM 187671 . 188003) (SKETCHW.ADD.INSTANCE 188005 . 188347)) (188390 201578 (SK.SEL.AND.DELETE 188400 . 188788) (SK.ERASE.AND.DELETE.ITEM 188790 . 189209) (REMOVE.ELEMENT.FROM.SKETCH 189211 . 190322) ( SK.DELETE.ELEMENT 190324 . 190882) (SK.DELETE.ELEMENT2 190884 . 191545) (SK.DELETE.KNOT 191547 . 191838) (SK.SEL.AND.DELETE.KNOT 191840 . 192965) (SK.DELETE.ELEMENT.KNOT 192967 . 196174) ( SK.CHECK.WHENDELETEDFN 196176 . 196956) (SK.CHECK.PREEDITFN 196958 . 197442) ( SK.CHECK.END.INITIAL.EDIT 197444 . 197978) (SK.CHECK.WHENPOINTDELETEDFN 197980 . 198776) (SK.ERASE.ELT 198778 . 199114) (SK.DELETE.ELT 199116 . 199491) (SK.DELETE.ITEM 199493 . 199901) (DELFROMTCONC 199903 . 201576)) (201617 215451 (SK.COPY.ELT 201627 . 201997) (SK.SEL.AND.COPY 201999 . 202382) ( SK.COPY.ELEMENTS 202384 . 208012) (SK.ADD.COPY.OF.ELEMENTS 208014 . 209781) ( SK.GLOBAL.FROM.LOCAL.ELEMENTS 209783 . 210023) (SK.COPY.ITEM 210025 . 210822) (SK.INSERT.SKETCH 210824 . 215449)) (215491 245512 (SK.MOVE.ELT 215501 . 215776) (SK.MOVE.ELT.OR.PT 215778 . 216091) ( SK.APPLY.DEFAULT.MOVE 216093 . 216527) (SK.SEL.AND.MOVE 216529 . 217076) (SK.MOVE.ELEMENTS 217078 . 227950) (SKETCH.MOVE.ELEMENTS 227952 . 229883) (SKETCH.COPY.ELEMENTS 229885 . 231932) ( \SKETCH.COPY.ELEMENT 231934 . 232659) (SK.TRANSLATE.ELEMENT 232661 . 233144) (SK.COPY.GLOBAL.ELEMENT 233146 . 233357) (SK.MAKE.ELEMENT.MOVE.ARG 233359 . 233979) (SK.MAKE.ELEMENTS.MOVE.ARG 233981 . 234503 ) (SK.MAKE.POINTS.AND.ELEMENTS.MOVE.ARG 234505 . 235574) (SK.SHOW.FIG.FROM.INFO 235576 . 235944) ( SK.MOVE.THING 235946 . 236852) (UPDATE.ELEMENT.IN.SKETCH 236854 . 238909) (SK.UPDATE.ELEMENT 238911 . 240470) (SK.UPDATE.ELEMENTS 240472 . 241191) (SK.UPDATE.ELEMENT1 241193 . 245093) ( SK.MOVE.ELEMENT.POINT 245095 . 245510)) (245575 267864 (SK.MOVE.POINTS 245585 . 245872) ( SK.SEL.AND.MOVE.POINTS 245874 . 246179) (SK.DO.MOVE.ELEMENT.POINTS 246181 . 254838) ( SK.MOVE.ITEM.POINTS 254840 . 256511) (SK.TRANSLATEPTSFN 256513 . 256897) (SK.TRANSLATE.POINTS 256899 . 257800) (SK.SELECT.MULTIPLE.POINTS 257802 . 263442) (SK.CONTROL.POINTS.IN.REGION 263444 . 264865) ( SK.ADD.PT.SELECTION 264867 . 265331) (SK.REMOVE.PT.SELECTION 265333 . 265950) (SK.ADD.POINT 265952 . 266575) (SK.ELTS.CONTAINING.PTS 266577 . 267202) (SK.HOTSPOTS.NOT.ON.LIST 267204 . 267862)) (268030 270826 (SK.SET.MOVE.MODE 268040 . 268711) (SK.SET.MOVE.MODE.POINTS 268713 . 269052) ( SK.SET.MOVE.MODE.ELEMENTS 269054 . 269398) (SK.SET.MOVE.MODE.COMBINED 269400 . 269750) (READMOVEMODE 269752 . 270824)) (270827 289582 (SK.ALIGN.POINTS 270837 . 271127) (SK.SEL.AND.ALIGN.POINTS 271129 . 271438) (SK.ALIGN.POINTS.LEFT 271440 . 271743) (SK.ALIGN.POINTS.RIGHT 271745 . 272050) ( SK.ALIGN.POINTS.TOP 272052 . 272353) (SK.ALIGN.POINTS.BOTTOM 272355 . 272662) ( SK.EVEN.SPACE.POINTS.IN.X 272664 . 272984) (SK.EVEN.SPACE.POINTS.IN.Y 272986 . 273306) ( SK.DO.ALIGN.POINTS 273308 . 283930) (SK.NTH.CONTROL.POINT 283932 . 284393) ( SK.GET.SELECTED.ELEMENT.STRUCTURE 284395 . 285061) (SK.CORRESPONDING.CONTROL.PT 285063 . 285617) ( SK.CONTROL.POINT.NUMBER 285619 . 285989) (SK.DO.ALIGN.SETVALUE 285991 . 289580)) (289646 303078 ( SKETCH.CREATE.GROUP 289656 . 290145) (SK.CREATE.GROUP1 290147 . 290694) (SK.UPDATE.GROUP.AFTER.CHANGE 290696 . 291485) (SK.GROUP.ELTS 291487 . 291768) (SK.SEL.AND.GROUP 291770 . 292156) (SK.GROUP.ELEMENTS 292158 . 293807) (SK.UNGROUP.ELT 293809 . 294093) (SK.SEL.AND.UNGROUP 294095 . 295764) ( SK.UNGROUP.ELEMENT 295766 . 296702) (SK.GLOBAL.REGION.OF.LOCAL.ELEMENTS 296704 . 297626) ( SK.LOCAL.REGION.OF.LOCAL.ELEMENTS 297628 . 298639) (SK.GLOBAL.REGION.OF.GLOBAL.ELEMENTS 298641 . 299981) (SK.UNIONREGIONS 299983 . 302349) (SKETCH.REGION.OF.SKETCH 302351 . 302767) (SK.FLASHREGION 302769 . 303076)) (303079 316550 (INIT.GROUP.ELEMENT 303089 . 303961) (GROUP.DRAWFN 303963 . 304413) ( GROUP.EXPANDFN 304415 . 305978) (GROUP.INSIDEFN 305980 . 306389) (GROUP.REGIONFN 306391 . 306786) ( GROUP.GLOBALREGIONFN 306788 . 307106) (GROUP.TRANSLATEFN 307108 . 309140) (GROUP.TRANSFORMFN 309142 . 312622) (GROUP.READCHANGEFN 312624 . 316548)) (316551 317559 (REGION.CENTER 316561 . 317162) ( REMOVE.LAST 317164 . 317557)) (317612 322719 (SK.MOVE.GROUP.CONTROL.PT 317622 . 317913) ( SK.SEL.AND.MOVE.CONTROL.PT 317915 . 319319) (SK.MOVE.GROUP.ELEMENT.CONTROL.POINT 319321 . 321394) ( SK.READ.NEW.GROUP.CONTROL.PT 321396 . 322717)) (322982 327606 (SK.DO.GROUP 322992 . 324444) ( SK.CHECK.WHENGROUPEDFN 324446 . 325156) (SK.DO.UNGROUP 325158 . 326363) (SK.CHECK.WHENUNGROUPEDFN 326365 . 326952) (SK.GROUP.UNDO 326954 . 327277) (SK.UNGROUP.UNDO 327279 . 327604)) (327847 332769 ( SK.FREEZE.ELTS 327857 . 328141) (SK.SEL.AND.FREEZE 328143 . 328533) (SK.FREEZE.ELEMENTS 328535 . 329086) (SK.UNFREEZE.ELT 329088 . 329377) (SK.SEL.AND.UNFREEZE 329379 . 330915) (SK.UNFREEZE.ELEMENTS 330917 . 331476) (SK.FREEZE.UNDO 331478 . 331723) (SK.UNFREEZE.UNDO 331725 . 331972) (SK.DO.FREEZE 331974 . 332367) (SK.DO.UNFREEZE 332369 . 332767)) (332999 342809 (SKETCH.ELEMENTS.OF.SKETCH 333009 . 333844) (SKETCH.LIST.OF.ELEMENTS 333846 . 334564) (SKETCH.ADD.ELEMENT 334566 . 335641) ( SKETCH.DELETE.ELEMENT 335643 . 337375) (DELFROMGROUPELT 337377 . 338177) (SKETCH.ELEMENT.TYPE 338179 . 338528) (SKETCH.ELEMENT.CHANGED 338530 . 340098) (SK.ELEMENT.CHANGED1 340100 . 340751) ( SK.UPDATE.GLOBAL.IMAGE.OBJECT.ELEMENT 340753 . 342807)) (342863 347475 (INSURE.SKETCH 342873 . 345488) (LOCALSPECS.FROM.VIEWER 345490 . 345850) (SK.LOCAL.ELT.FROM.GLOBALPART 345852 . 346320) ( SKETCH.FROM.VIEWER 346322 . 346556) (INSPECT.SKETCH 346558 . 346883) (ELT.INSIDE.SKETCHWP 346885 . 347158) (SK.INSIDE.REGION 347160 . 347473)) (347476 351806 (MAPSKETCHSPECS 347486 . 348107) ( MAPCOLLECTSKETCHSPECS 348109 . 348858) (MAPSKETCHSPECSUNTIL 348860 . 349668) (MAPGLOBALSKETCHSPECS 349670 . 350371) (MAPGLOBALSKETCHELEMENTS 350373 . 351804)) (351868 377760 (SK.ADD.SELECTION 351878 . 352618) (SK.COPY.INSERTFN 352620 . 356251) (SCREENELEMENTP 356253 . 356726) (SK.ITEM.REGION 356728 . 357215) (SK.ELEMENT.GLOBAL.REGION 357217 . 357745) (SK.LOCAL.ITEMS.IN.REGION 357747 . 359726) ( SK.REGIONFN 359728 . 360050) (SK.GLOBAL.REGIONFN 360052 . 360410) (SK.REMOVE.SELECTION 360412 . 361140 ) (SK.SELECT.MULTIPLE.ITEMS 361142 . 371584) (SKETCH.GET.ELEMENTS 371586 . 373009) (SK.PUT.MARKS.UP 373011 . 373350) (SK.TAKE.MARKS.DOWN 373352 . 373691) (SK.TRANSLATE.GLOBALPART 373693 . 375820) ( SK.TRANSLATE.ITEM 375822 . 376749) (SK.TRANSLATEFN 376751 . 376947) (TRANSLATE.SKETCH 376949 . 377758) ) (378026 380933 (SK.INPUT.SCALE 378036 . 378883) (SK.UPDATE.SKETCHCONTEXT 378885 . 379482) ( SK.SET.INPUT.SCALE 379484 . 380133) (SK.SET.INPUT.SCALE.CURRENT 380135 . 380426) ( SK.SET.INPUT.SCALE.VALUE 380428 . 380931)) (380984 382896 (SK.SET.FEEDBACK.MODE 380994 . 382300) ( SK.SET.FEEDBACK.POINT 382302 . 382470) (SK.SET.FEEDBACK.VERBOSE 382472 . 382641) ( SK.SET.FEEDBACK.ALWAYS 382643 . 382894)) (383047 384324 (SKETCH.TITLE 383057 . 383320) ( SK.SHRINK.ICONCREATE 383322 . 384322)) (390014 392828 (READBRUSHSHAPE 390024 . 390483) (READ.FUNCTION 390485 . 391000) (READBRUSHSIZE 391002 . 391460) (READANGLE 391462 . 391954) (READARCDIRECTION 391956 . 392826)) (392829 403240 (SK.CHANGE.DASHING 392839 . 396787) (READ.AND.SAVE.NEW.DASHING 396789 . 398557) (READ.NEW.DASHING 398559 . 400299) (READ.DASHING.CHANGE 400301 . 401776) (SK.CACHE.DASHING 401778 . 402780) (SK.DASHING.LABEL 402782 . 403238)) (403241 406946 (READ.FILLING.CHANGE 403251 . 405232) (SK.CACHE.FILLING 405234 . 405952) (READ.AND.SAVE.NEW.FILLING 405954 . 406552) ( SK.FILLING.LABEL 406554 . 406944)) (407330 443583 (SK.GETGLOBALPOSITION 407340 . 407645) ( SKETCH.TRACK.ELEMENTS 407647 . 411167) (SK.PICKOUT.WHOLE.MOVE.ELEMENTS 411169 . 411728) ( MAP.SKETCH.ELEMENTS.INTO.VIEWER 411730 . 412122) (MAP.GLOBAL.POSITION.INTO.VIEWER 412124 . 412504) ( SKETCH.TO.VIEWER.POSITION 412506 . 412865) (SKETCH.TRACK.IMAGE 412867 . 413721) (SK.TRACK.IMAGE1 413723 . 415135) (MAP.VIEWER.XY.INTO.GLOBAL 415137 . 416131) (SK.SET.POSITION 416133 . 416469) ( MAP.VIEWER.PT.INTO.GLOBAL 416471 . 417577) (VIEWER.TO.SKETCH.POSITION 417579 . 418214) ( SK.INSURE.SCALE 418216 . 418476) (SKETCH.TO.VIEWER.REGION 418478 . 419284) (VIEWER.TO.SKETCH.REGION 419286 . 419624) (SK.READ.POINT.WITH.FEEDBACK 419626 . 430629) (SKETCH.GET.POSITION 430631 . 432511) ( \CLOBBER.POSITION 432513 . 432961) (NEAREST.HOT.SPOT 432963 . 434491) (GETWREGION 434493 . 435254) ( GET.BITMAP.POSITION 435256 . 436040) (SK.TRACK.BITMAP1 436042 . 443581)) (444196 475082 ( SK.BRING.UP.POSITION.PAD 444206 . 450066) (SK.PAD.READER.POSITION 450068 . 451717) ( SK.POSITION.READER.REPAINTFN 451719 . 453503) (SK.POSITION.PAD.FROM.VIEWER 453505 . 454847) ( SK.INIT.POSITION.NUMBER.PAD.MENU 454849 . 455199) (SK.READ.POSITION.PAD.HANDLER 455201 . 460933) ( DISPLAY.POSITION.READER.TOTAL 460935 . 463233) (POSITION.PAD.READER.HANDLER 463235 . 471278) ( POSITIONPAD.HELDFN 471280 . 472764) (\POSITION.PAD.ADD.DIGIT.MENU 472766 . 474345) ( \POSITION.READER.NUMBERPAD 474347 . 475080)) (476708 479386 (SK.DRAWFN 476718 . 477084) ( SK.TRANSFORMFN 477086 . 477467) (SK.EXPANDFN 477469 . 477746) (SK.INPUT 477748 . 478129) (SK.INSIDEFN 478131 . 478771) (SK.UPDATEFN 478773 . 479384)) (485115 489060 (SK.CHECK.SKETCH.VERSION 485125 . 486365) (SK.INSURE.RECORD.LENGTH 486367 . 487850) (SK.INSURE.HAS.LENGTH 487852 . 488590) ( SK.RECORD.LENGTH 488592 . 488766) (SK.SET.RECORD.LENGTHS 488768 . 489058)) (489805 490692 ( SK.ADD.EDIT.COMMAND.TO.FILE.BROWSER 489815 . 490690))))) STOP \ No newline at end of file diff --git a/library/SKETCHBMELT b/library/SKETCHBMELT new file mode 100644 index 00000000..7890aac6 --- /dev/null +++ b/library/SKETCHBMELT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "24-Mar-92 14:07:17" |{PELE:MV:ENVOS}LIBRARY>SKETCHBMELT.;3| 47688 changes to%: (FNS BITMAPELT.DRAWFN) previous date%: "12-Jun-90 14:45:06" |{PELE:MV:ENVOS}LIBRARY>SKETCHBMELT.;2|) (* ; " Copyright (c) 1985, 1986, 1988, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SKETCHBMELTCOMS) (RPAQQ SKETCHBMELTCOMS ((* BITMAP element done to allow zooming of bitmaps that is not possible with image object bitmaps.) (FNS SKETCH.CREATE.BITMAP INIT.BITMAP.ELEMENT BITMAPELT.CHANGEFN BITMAPELT.DRAWFN DSPVIEWPORT SK.COMPUTE.LOCAL.SCALED.BITMAP BITMAPELT.EXPANDFN BITMAPELT.INSIDEFN BITMAPELT.TRANSLATEFN BITMAPELT.REGIONFN BITMAPELT.GLOBALREGIONFN BITMAPELT.READCHANGEFN BITMAPELT.TRANSFORMFN SK.BITMAP.CREATE BITMAP.SET.SCALES BITMAPELT.INPUTFN BITMAPELT.CHOOSE.BITMAP) (DECLARE%: DONTCOPY (RECORDS BITMAPELT LOCALBITMAPELT)) (FILES SCALEBITMAP))) (* BITMAP element done to allow zooming of bitmaps that is not possible with image object bitmaps.) (DEFINEQ (SKETCH.CREATE.BITMAP [LAMBDA (BITMAP POSITION SCALE SCALECACHE PRIORITY) (* rrb "13-Mar-86 17:30") (* creates a sketch bitmap element.) (SK.BITMAP.CREATE (OR (BITMAPP BITMAP) (\ILLEGAL.ARG BITMAP)) (SK.INSURE.POSITION POSITION) (OR (NUMBERP SCALE) 1.0) [COND (SCALECACHE (for CACHE in SCALECACHE do (OR (AND (NUMBERP (CAR CACHE)) (BITMAPP (CADR CACHE))) (\ILLEGAL.ARG CACHE))) (SORT SCALECACHE (FUNCTION (LAMBDA (A B) (GREATERP A B] PRIORITY]) (INIT.BITMAP.ELEMENT [LAMBDA NIL (* rrb "18-Oct-85 17:17") (* creates a bitmap element.  This will scale bitmaps) (COND ((NOT (SKETCH.ELEMENT.TYPEP 'BITMAPELT)) (CREATE.SKETCH.ELEMENT.TYPE 'BITMAPELT "Bit image" "prompts for a region of the screen as a scalable bitmap." (FUNCTION BITMAPELT.DRAWFN) (FUNCTION BITMAPELT.EXPANDFN) 'OBSOLETE (FUNCTION BITMAPELT.CHANGEFN) (FUNCTION BITMAPELT.INPUTFN) (FUNCTION BITMAPELT.INSIDEFN) (FUNCTION BITMAPELT.REGIONFN) (FUNCTION BITMAPELT.TRANSLATEFN) NIL (FUNCTION BITMAPELT.READCHANGEFN) (FUNCTION BITMAPELT.TRANSFORMFN) NIL (FUNCTION BITMAPELT.GLOBALREGIONFN]) (BITMAPELT.CHANGEFN [LAMBDA (SCRELTS SKW HOW) (* rrb "11-Jul-86 15:51") (* changefn for scaleable bitmaps. Only works on the first bitmap for now.) (PROG ((BMELT (AND (EQ (fetch (SCREENELT GTYPE) of (CAR SCRELTS)) 'BITMAPELT) (CAR SCRELTS))) GBMELT INDGBMELT NEWBM BMCACHEENTRY BM ORIGBM BMREGION BMSCALE ORIGSCALE BMCACHE NEWSCALE NEWVALUE ELTPRI) (OR BMELT (RETURN)) (SETQ INDGBMELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of BMELT)) [SETQ ELTPRI (SK.ELEMENT.PRIORITY (SETQ GBMELT (fetch (SCREENELT GLOBALPART) of BMELT] (SETQ ORIGBM (fetch (BITMAPELT SKBITMAP) of INDGBMELT)) (SETQ ORIGSCALE (fetch (BITMAPELT SKBITMAPSCALE) of INDGBMELT)) (* get the bitmap that generated the image the user was seeing.) (SETQ BMCACHEENTRY (fetch (LOCALBITMAPELT SOURCEFORIMAGE) of (fetch (SCREENELT LOCALPART) of BMELT))) (SETQ BMSCALE (CAR BMCACHEENTRY)) (SETQ BM (CADR BMCACHEENTRY)) (SETQ BMREGION (fetch (BITMAPELT SKBITMAPREGION) of INDGBMELT)) (SETQ BMCACHE (fetch (BITMAPELT SKBITMAPCACHE) of INDGBMELT)) (RETURN (AND (SETQ NEWBM (SELECTQ HOW (EDIT (* call the bitmap editor and if changes are made, recreate the element) (AND (SETQ NEWBM (EDIT.BITMAP BM)) (create SKHISTORYCHANGESPEC NEWELT _ (COND ((EQ BM ORIGBM) (SK.BITMAP.CREATE NEWBM (create POSITION XCOORD _ (fetch (REGION LEFT) of BMREGION) YCOORD _ (fetch (REGION BOTTOM) of BMREGION)) ORIGSCALE BMCACHE ELTPRI)) (T (* clobber the cache and redo the  image.) (RPLACA (CDR BMCACHEENTRY) NEWBM) (SK.BITMAP.CREATE ORIGBM (create POSITION XCOORD _ (fetch (REGION LEFT) of BMREGION) YCOORD _ (fetch (REGION BOTTOM) of BMREGION)) ORIGSCALE BMCACHE ELTPRI))) OLDELT _ GBMELT PROPERTY _ 'DATA NEWVALUE _ NEWBM OLDVALUE _ ORIGBM))) (CHANGEBITMAP (* make the image shown be the  original) (COND ((EQ ORIGBM BM) (create SKHISTORYCHANGESPEC NEWELT _ (SK.BITMAP.CREATE (fetch (LOCALBITMAPELT LOCALBITMAP) of (fetch (SCREENELT LOCALPART) of BMELT)) (create POSITION XCOORD _ (fetch (REGION LEFT) of BMREGION) YCOORD _ (fetch (REGION BOTTOM) of BMREGION)) (VIEWER.SCALE SKW) BMCACHE ELTPRI) OLDELT _ GBMELT PROPERTY _ 'SCALE NEWVALUE _ (VIEWER.SCALE SKW) OLDVALUE _ ORIGSCALE)) (T (* clobber cache and redraw) (RPLACA BMCACHEENTRY (VIEWER.SCALE SKW)) (create SKHISTORYCHANGESPEC NEWELT _ (SK.BITMAP.CREATE ORIGBM (create POSITION XCOORD _ (fetch (REGION LEFT) of BMREGION) YCOORD _ (fetch (REGION BOTTOM) of BMREGION)) ORIGSCALE BMCACHE ELTPRI) OLDELT _ GBMELT PROPERTY _ 'CACHE NEWVALUE _ BMCACHE OLDVALUE _ BMCACHE)))) (CHANGEBITMAP&SCALE (* makes the image shown be the original bitmap at the original scale.  Provides a way of expanding the bitmap.) (* rather than figure out what the cache should do here just flush it.  Maybe should be scaled but too lazy now.) (create SKHISTORYCHANGESPEC NEWELT _ (SK.BITMAP.CREATE (fetch (LOCALBITMAPELT LOCALBITMAP) of (fetch (SCREENELT LOCALPART) of BMELT)) (create POSITION XCOORD _ (fetch (REGION LEFT) of BMREGION) YCOORD _ (fetch (REGION BOTTOM) of BMREGION)) BMSCALE NIL ELTPRI) OLDELT _ GBMELT PROPERTY _ 'DATA NEWVALUE _ (fetch (LOCALBITMAPELT LOCALBITMAP) of (fetch (SCREENELT LOCALPART) of BMELT)) OLDVALUE _ ORIGBM)) (CHANGESCALE (* make the bitmap have this as its  current scale.) (* rather than figure out what the cache should do here just flush it.  Maybe should be scaled but too lazy now.) (create SKHISTORYCHANGESPEC NEWELT _ (SK.BITMAP.CREATE ORIGBM (create POSITION XCOORD _ (fetch (REGION LEFT) of BMREGION) YCOORD _ (fetch (REGION BOTTOM) of BMREGION)) (VIEWER.SCALE SKW) BMCACHE NIL ELTPRI) OLDELT _ GBMELT PROPERTY _ 'SCALE NEWVALUE _ (VIEWER.SCALE SKW) OLDVALUE _ ORIGSCALE)) (CACHE (COND ((AND (NOT (EQP (SETQ NEWSCALE (VIEWER.SCALE SKW)) ORIGSCALE)) (NOT (SASSOC NEWSCALE BMCACHE))) (* make sure there isn't already a cache at this scale.) (create SKHISTORYCHANGESPEC NEWELT _ (SK.BITMAP.CREATE ORIGBM (create POSITION XCOORD _ (fetch (REGION LEFT) of BMREGION) YCOORD _ (fetch (REGION BOTTOM) of BMREGION)) ORIGSCALE [SETQ NEWVALUE (SORT (CONS (LIST NEWSCALE (fetch (LOCALBITMAPELT LOCALBITMAP) of (fetch (SCREENELT LOCALPART) of BMELT))) (APPEND BMCACHE)) (FUNCTION (LAMBDA (A B) (GREATERP (CAR A) (CAR B] ELTPRI) OLDELT _ GBMELT PROPERTY _ 'CACHE NEWVALUE _ NEWVALUE OLDVALUE _ BMCACHE)))) (DELETECACHE (COND ((EQ BM ORIGBM) (* wants to delete the original, replace it with a nearby cache.) (STATUSPRINT SKW "Not implemented to delete the original. If you really want to, you can change the original with the other bitmap change edit commands." )) (T (create SKHISTORYCHANGESPEC NEWELT _ (SK.BITMAP.CREATE ORIGBM (create POSITION XCOORD _ (fetch (REGION LEFT) of BMREGION) YCOORD _ (fetch (REGION BOTTOM) of BMREGION)) ORIGSCALE (SETQ NEWVALUE (REMOVE BMCACHEENTRY BMCACHE) ) ELTPRI) OLDELT _ GBMELT PROPERTY _ 'CACHE NEWVALUE _ NEWVALUE OLDVALUE _ BMCACHE)))) NIL)) (LIST NEWBM]) (BITMAPELT.DRAWFN [LAMBDA (BITMAPELT WINDOW) (* ; "Edited 24-Mar-92 13:59 by jds") (* ;; "shows a bitmap element. The local bitmap is only computed and cached for streams that don't support a scaled bitblt operation.") (PROG ((GLOBALBMELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of BITMAPELT)) (LOCALBMELT (fetch (SCREENELT LOCALPART) of BITMAPELT)) BITMAP) (RETURN (COND [(OR (IMAGESTREAMTYPEP WINDOW 'INTERPRESS) (SETQ BITMAP (fetch (LOCALBITMAPELT LOCALBITMAP) of LOCALBMELT))) (* ;  "INTERPRESS has a SCALEDBITBLT operation but it doesn't work so don't use it.") (PROG (LOCALREGION VISIBLEREGION IMAGEREGION) (* ;; "make sure the local region of the current cached image completely covers the visible part of the bitmap. This allows us to only compute the visible portion of large bitmaps.") (SETQ LOCALREGION (fetch (LOCALBITMAPELT LOCALBITMAPREGION) of LOCALBMELT)) (* ;  "if nothing is visible, don't do anything. This may happen if the bitmap is part of a group.") (OR (SETQ VISIBLEREGION (INTERSECTREGIONS (fetch (LOCALBITMAPELT LOCALBITMAPREGION) of LOCALBMELT) (DSPVIEWPORT NIL WINDOW))) (RETURN)) [COND ([OR (COND ((NOT (BITMAPP BITMAP)) (* ;  "the local bitmap hasn't been calculated yet.") T)) (NOT (OR (EQUAL LOCALREGION (SETQ IMAGEREGION (fetch (LOCALBITMAPELT LOCALIMAGEREGION) of LOCALBMELT ))) (SUBREGIONP IMAGEREGION VISIBLEREGION] (SETQ BITMAP (SK.COMPUTE.LOCAL.SCALED.BITMAP (fetch (LOCALBITMAPELT SOURCEFORIMAGE) of LOCALBMELT) (TIMES (DSPSCALE NIL WINDOW) (fetch (LOCALBITMAPELT LOCALSCALE) of LOCALBMELT)) LOCALREGION VISIBLEREGION)) (* ;  "save the bitmap and the area its image covers.") (replace (LOCALBITMAPELT LOCALIMAGEREGION) of LOCALBMELT with (SETQ IMAGEREGION (CAR BITMAP))) (replace (LOCALBITMAPELT LOCALBITMAP) of LOCALBMELT with (SETQ BITMAP (CADR BITMAP] (RETURN (BITBLT BITMAP 0 0 WINDOW (fetch (REGION LEFT) of IMAGEREGION ) (fetch (REGION BOTTOM) of IMAGEREGION) (BITMAPWIDTH BITMAP) (BITMAPHEIGHT BITMAP) 'INPUT] (T (* ;  "use the closest cache entry and scale it as needed.") (SCALEDBITBLT (SETQ BITMAP (CADR (fetch (LOCALBITMAPELT SOURCEFORIMAGE) of LOCALBMELT))) 0 0 WINDOW (fetch (POSITION XCOORD) of (fetch ( LOCALBITMAPELT LOCALBITMAPPOSITION ) of LOCALBMELT)) (fetch (POSITION YCOORD) of (fetch (LOCALBITMAPELT LOCALBITMAPPOSITION ) of LOCALBMELT )) (BITMAPWIDTH BITMAP) (BITMAPHEIGHT BITMAP) 'INPUT NIL NIL NIL (FIXR (QUOTIENT (QUOTIENT (CAR (fetch (LOCALBITMAPELT SOURCEFORIMAGE) of LOCALBMELT)) (fetch (LOCALBITMAPELT LOCALSCALE) of LOCALBMELT)) (DSPSCALE NIL WINDOW]) (DSPVIEWPORT [LAMBDA (NEWREGION WINDOW) (* rrb "29-Oct-85 18:06") (* returns the region that the window is viewing in stream coordinates.  This is different from DSPCLIPPINGREGION because the clipping region gets set  down during repaint.) (COND [(WINDOWP WINDOW) (PROG [(WREG (WINDOWPROP WINDOW 'REGION)) (BORDER (WINDOWPROP WINDOW 'BORDER] (RETURN (CREATEREGION (DIFFERENCE (PLUS (fetch (REGION LEFT) of WREG) BORDER) (DSPXOFFSET NIL WINDOW)) (DIFFERENCE (PLUS (fetch (REGION BOTTOM) of WREG) BORDER) (DSPYOFFSET NIL WINDOW)) (WINDOWPROP WINDOW 'WIDTH) (WINDOWPROP WINDOW 'HEIGHT] (T (DSPCLIPPINGREGION NIL WINDOW]) (SK.COMPUTE.LOCAL.SCALED.BITMAP [LAMBDA (BMCACHE LOCALSCALE LOCALREGION VISIBLEREGION) (* rrb "30-Oct-85 09:58") (* computes a scaled bitmap starting from GBITMAP that is large enough to  cover LOCALREGION. Returns (localregion bitmap)) (PROG ((SCALEAMOUNT (QUOTIENT (CAR BMCACHE) LOCALSCALE)) LOCALPIECE LLEFT LBOT SBM) [COND ((SUBREGIONP VISIBLEREGION LOCALREGION) (* whole thing is visible) (RETURN (LIST LOCALREGION (COND ((EQP SCALEAMOUNT 1.0) (CADR BMCACHE)) (T (SCALEBITMAP (CADR BMCACHE) SCALEAMOUNT] (SETQ LOCALPIECE (INTERSECTREGIONS LOCALREGION VISIBLEREGION)) (* convert the local amount of the bitmap seen into bitmap coordinates.  * round outward to get the limits of the rectangle that is necessary to fill  the region.) (SETQ LLEFT (FIX (QUOTIENT (DIFFERENCE (fetch (REGION LEFT) of LOCALPIECE) (fetch (REGION LEFT) of LOCALREGION)) SCALEAMOUNT))) (SETQ LBOT (FIX (QUOTIENT (DIFFERENCE (fetch (REGION BOTTOM) of LOCALPIECE) (fetch (REGION BOTTOM) of LOCALREGION)) SCALEAMOUNT))) (* copy the piece of bitmap that we want into an auxiliary to be scaled.) [SETQ SBM (BITMAPCREATE (FIX (PLUS (QUOTIENT (fetch (REGION WIDTH) of LOCALPIECE) SCALEAMOUNT) 1.0)) (FIX (PLUS (QUOTIENT (fetch (REGION HEIGHT) of LOCALPIECE) SCALEAMOUNT) 1.0] (BITBLT (CADR BMCACHE) LLEFT LBOT SBM) (RETURN (LIST (CREATEREGION (PLUS (fetch (REGION LEFT) of LOCALREGION) (QUOTIENT LLEFT LOCALSCALE)) (PLUS (fetch (REGION BOTTOM) of LOCALREGION) (QUOTIENT LBOT LOCALSCALE)) (BITMAPWIDTH SBM) (BITMAPHEIGHT SBM)) (SCALEBITMAP SBM SCALEAMOUNT]) (BITMAPELT.EXPANDFN [LAMBDA (GBITMAPELT SCALE STREAM) (* rrb "11-Jul-86 15:55") (* creates a local bitmap screen element from a global bitmap element.) (PROG ((INDGBMELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GBITMAPELT)) LOCALBITMAPREGION BMSCALE BMCACHE) [SETQ BMSCALE (QUOTIENT (fetch (BITMAPELT SKBITMAPSCALE) of INDGBMELT) (TIMES SCALE (DSPSCALE NIL STREAM] (SETQ LOCALBITMAPREGION (SK.SCALE.REGION (fetch (BITMAPELT SKBITMAPREGION) of INDGBMELT) SCALE)) (SETQ BMCACHE (BITMAPELT.CHOOSE.BITMAP (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GBITMAPELT) SCALE)) (RETURN (create SCREENELT LOCALPART _ (create LOCALBITMAPELT LOCALBITMAPPOSITION _ (create POSITION XCOORD _ (fetch (REGION LEFT) of LOCALBITMAPREGION ) YCOORD _ (fetch (REGION BOTTOM) of LOCALBITMAPREGION )) LOCALBITMAP _ (COND ((OR (MEMB (fetch (IMAGEOPS IMSCALEDBITBLT) of (fetch (STREAM IMAGEOPS) of STREAM)) '(NIL NILL)) (IMAGESTREAMTYPEP STREAM 'PRESS)) (* see if the stream supports scaled bitblt This assumes that windows don't  and will have to be changed when they do.  Spruce printers don't implement scaled bitblt even though the image ops  vector has an entry that works for full press.  Since diagonal lines and curves don't work to full press, let's just make  everything work as best possible to Spruce.  Also the scale bitblt operation for Interpress doesn't work;  there is code in BITMAPELT.DRAWFN to hack around this.) (* the actual bitmap to be displayed will be computed by the display fn.) T) (T (* if stream implements scaled bitblt, not need for caching a scaled bitmap.) NIL)) LOCALBITMAPREGION _ LOCALBITMAPREGION LOCALSCALE _ SCALE SOURCEFORIMAGE _ BMCACHE) GLOBALPART _ GBITMAPELT]) (BITMAPELT.INSIDEFN [LAMBDA (GBMELT WREG) (* rrb "28-Sep-85 19:43") (* determines if the global bitmap element GBMELT is inside of WREG.) (REGIONSINTERSECTP (fetch (BITMAPELT SKBITMAPREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GBMELT )) WREG]) (BITMAPELT.TRANSLATEFN [LAMBDA (SKELT DELTAPOS) (* rrb "28-Sep-85 19:49") (* * returns a bitmap element which has the bitmap translated by DELTAPOS) (PROG ((GBMELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKELT))) (RETURN (create GLOBALPART COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) of SKELT)) INDIVIDUALGLOBALPART _ (create BITMAPELT using GBMELT SKBITMAPREGION _ (REL.MOVE.REGION (fetch (BITMAPELT SKBITMAPREGION) of GBMELT) (fetch (POSITION XCOORD) of DELTAPOS) (fetch (POSITION YCOORD) of DELTAPOS]) (BITMAPELT.REGIONFN [LAMBDA (BMSCRLET) (* rrb "28-Sep-85 19:45") (* returns the region occuppied by a  bitmap) (fetch (LOCALBITMAPELT LOCALBITMAPREGION) of (fetch (SCREENELT LOCALPART) of BMSCRLET]) (BITMAPELT.GLOBALREGIONFN [LAMBDA (GBITMAPELT) (* rrb "18-Oct-85 17:17") (* returns the global region occupied by a global bitmap element.) (fetch (BITMAPELT SKBITMAPREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GBITMAPELT]) (BITMAPELT.READCHANGEFN [LAMBDA (SKW SCRNELTS) (* rrb "11-Jul-86 15:51") (* the users has selected SCRNELT to be changed this function reads a  specification of how the bitmap elements should change.) (* if the bitmap is at its original scale,let the user edit it like an image  object bitmap. If it isn't, give them the option of moving it to this scale,  making the one shown be the original one or EDIT which informs them they must  do one of the other two.) (PROG [(BMELT (for ELT in SCRNELTS when (EQ (fetch (SCREENELT GTYPE) of ELT) 'BITMAPELT) do (RETURN (fetch (SCREENELT INDIVIDUALGLOBALPART) of ELT] (RETURN (COND ((EQUAL (fetch (BITMAPELT SKBITMAPSCALE) of BMELT) (VIEWER.SCALE SKW)) (* do bitmap editor.) 'EDIT) (T (\CURSOR.IN.MIDDLE.MENU (create MENU CENTERFLG _ T TITLE _ "Scaled bitmap operations" ITEMS _ (APPEND '(( "Perform edit operations on the source bitmap of this image." 'EDIT "Allows editing of the original or cached bitmap. Result will be scaled back into this image." ) ( "Make the image shown be the source" 'CHANGEBITMAP "Replaces the original or cached bitmap that is the source of this image with this image at this scale. Further scaling are done from this image." ) ( "Make the source be at this scale" 'CHANGESCALE "changed the scale of the original or cached bitmap to be at this scale." ) ( "Make the image shown be the source at the source scale" 'CHANGEBITMAP&SCALE "makes it as if the bitmap image shown had been input at the original scale." ) ( "Save this image to be used as a source at this scale" 'CACHE "This image will be saved and used when displaying the image at this scale. It can then be edited without effecting the original.")) (AND (fetch (BITMAPELT SKBITMAPCACHE) of BMELT) '(("Remove this source from the cache." 'DELETECACHE "Removes the source of this image from the cache. The image will then come from the nearest other source." ]) (BITMAPELT.TRANSFORMFN [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "13-Mar-86 17:31") (* returns a copy of the global bitmap element that has its control point  transformed by transformfn. TRANSFORMDATA is arbitrary data that is passed to  tranformfn.) (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) GREG) (RETURN (SK.BITMAP.CREATE (fetch (BITMAPELT SKBITMAP) of INDVPART) (SK.TRANSFORM.POINT (create POSITION XCOORD _ (fetch (REGION LEFT) of (SETQ GREG (fetch (BITMAPELT SKBITMAPREGION ) of INDVPART) )) YCOORD _ (fetch (REGION BOTTOM) of GREG)) TRANSFORMFN TRANSFORMDATA) (TIMES (fetch (BITMAPELT SKBITMAPSCALE) of INDVPART) SCALEFACTOR]) (SK.BITMAP.CREATE [LAMBDA (BITMAP POSITION INITSCALE CACHELST PRIORITY) (* rrb "13-Mar-86 17:29") (* creates a BITMAPELT sketch  element) (PROG (NEWBMELT) (SETQ NEWBMELT (create GLOBALPART INDIVIDUALGLOBALPART _ (create BITMAPELT SKBITMAP _ BITMAP SKBITMAPREGION _ (CREATEREGION (fetch (POSITION XCOORD) of POSITION) (fetch (POSITION YCOORD) of POSITION) (TIMES (BITMAPWIDTH BITMAP) INITSCALE) (TIMES (BITMAPHEIGHT BITMAP) INITSCALE)) SKBITMAPSCALE _ INITSCALE SKBITMAPCACHE _ CACHELST))) (BITMAP.SET.SCALES NEWBMELT) (AND PRIORITY (SK.SET.ELEMENT.PRIORITY NEWBMELT)) (RETURN NEWBMELT]) (BITMAP.SET.SCALES [LAMBDA (GBMELT) (* rrb "17-Oct-85 17:34") (* updates the scale field after a change in a bitmap element.) (PROG ((GREG (fetch (BITMAPELT SKBITMAPREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GBMELT))) WIDTH HEIGHT) (replace (GLOBALPART MINSCALE) of GBMELT with (FQUOTIENT (MIN (SETQ WIDTH (fetch (REGION WIDTH) of GREG)) (SETQ HEIGHT (fetch (REGION HEIGHT ) of GREG))) 1000.0)) (replace (GLOBALPART MAXSCALE) of GBMELT with (FQUOTIENT (MAX WIDTH HEIGHT) 2.0)) (RETURN GBMELT]) (BITMAPELT.INPUTFN [LAMBDA (WINDOW) (* rrb "11-Jul-86 15:51") (* gets a region of the screen and makes it a scalable bitmap.) (PROG ((REGION (GETREGION 4 4)) BM POS) (OR (REGIONP REGION) (RETURN)) (SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION))) (BITBLT (SCREENBITMAP) (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) BM 0 0 (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION)) (OR (SETQ POS (GET.BITMAP.POSITION WINDOW BM NIL "Place the bitmap image.")) (RETURN)) (RETURN (SK.BITMAP.CREATE BM (SK.MAP.INPUT.PT.TO.GLOBAL POS WINDOW) (VIEWER.SCALE WINDOW]) (BITMAPELT.CHOOSE.BITMAP [LAMBDA (GBMELT SCALE) (* rrb "17-Oct-85 17:50") (* chooses the closest bitmap image from the cache and returns a list of  (itsscale bitmap)) (PROG ((CACHE (fetch (BITMAPELT SKBITMAPCACHE) of GBMELT)) (ORIGSCALE (fetch (BITMAPELT SKBITMAPSCALE) of GBMELT)) (ORIGBITMAP (fetch (BITMAPELT SKBITMAP) of GBMELT)) GREATER LESSER) [COND ((OR (NULL CACHE) (EQP ORIGSCALE SCALE)) (* special case) (RETURN (LIST ORIGSCALE ORIGBITMAP] (* find the bounding cached values) [for PR in CACHE do (COND ((GREATERP (CAR PR) SCALE) (SETQ GREATER PR)) (T (SETQ LESSER PR) (RETURN] [COND [(GREATERP ORIGSCALE SCALE) (* the original is larger than this scale, see how it compares to the greater  one found in the cache.) (COND [GREATER (COND ((EQP (CAR LESSER) SCALE) (* special check since LESSER might  have been equal.) (RETURN LESSER)) ((LESSP ORIGSCALE (CAR GREATER)) (SETQ GREATER (LIST ORIGSCALE ORIGBITMAP] (T (SETQ GREATER (LIST ORIGSCALE ORIGBITMAP] [LESSER (* the original is smaller than this scale, see how it compares to the lesser  one found in the cache.) (COND ((GREATERP ORIGSCALE (CAR LESSER)) (SETQ LESSER (LIST ORIGSCALE ORIGBITMAP))) ((EQP (CAR LESSER) SCALE) (* special check since LESSER might  have been equal.) (RETURN LESSER] (T (SETQ LESSER (LIST ORIGSCALE ORIGBITMAP] (* GREATER is scaled just greater than SCALE.  LESSER is just less. Choose between them.) (RETURN (COND (GREATER (COND (LESSER (* pick closest one) (COND ((GREATERP SCALE (QUOTIENT (PLUS (CAR LESSER) (CAR GREATER)) 2)) GREATER) (T LESSER))) (T GREATER))) (T LESSER]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (TYPERECORD BITMAPELT (SKBITMAP SKBITMAPREGION SKBITMAPSCALE SKBITMAPCACHE)) (RECORD LOCALBITMAPELT ((LOCALBITMAPPOSITION) LOCALHOTREGION LOCALBITMAP LOCALBITMAPREGION (* coordinates of entire region  covered by the bitmap in local  coordinates.) LOCALSCALE SOURCEFORIMAGE (* pair of the scale and cached  image from which LOCALBITMAP was  generated.) LOCALIMAGEREGION (* region in local coordinates of the area covered by LOCALBITMAP.  This may be a subregion of LOCALBITMAPREGION) )) ) ) (FILESLOAD SCALEBITMAP) (PUTPROPS SKETCHBMELT COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1988 1990 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1205 46541 (SKETCH.CREATE.BITMAP 1215 . 2049) (INIT.BITMAP.ELEMENT 2051 . 3052) ( BITMAPELT.CHANGEFN 3054 . 16483) (BITMAPELT.DRAWFN 16485 . 23256) (DSPVIEWPORT 23258 . 24304) ( SK.COMPUTE.LOCAL.SCALED.BITMAP 24306 . 26938) (BITMAPELT.EXPANDFN 26940 . 30787) (BITMAPELT.INSIDEFN 30789 . 31391) (BITMAPELT.TRANSLATEFN 31393 . 32695) (BITMAPELT.REGIONFN 32697 . 33153) ( BITMAPELT.GLOBALREGIONFN 33155 . 33534) (BITMAPELT.READCHANGEFN 33536 . 37579) (BITMAPELT.TRANSFORMFN 37581 . 39105) (SK.BITMAP.CREATE 39107 . 40848) (BITMAP.SET.SCALES 40850 . 42359) (BITMAPELT.INPUTFN 42361 . 43333) (BITMAPELT.CHOOSE.BITMAP 43335 . 46539))))) STOP \ No newline at end of file diff --git a/library/SKETCHEDIT b/library/SKETCHEDIT new file mode 100644 index 00000000..aa94a1c4 --- /dev/null +++ b/library/SKETCHEDIT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "12-Jun-90 14:48:37" {DSK}local>lde>lispcore>library>SKETCHEDIT.;2 108477 changes to%: (VARS SKETCHEDITCOMS) previous date%: " 1-Dec-87 18:13:28" {DSK}local>lde>lispcore>library>SKETCHEDIT.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SKETCHEDITCOMS) (RPAQQ SKETCHEDITCOMS ((COMS (* selection functions) (FNS BUTLAST CHAR.BEGIN CLOSEST.CHAR CLOSEST.LINE FLASHW HILITE.LINE HILITE.TEXT IN.TEXT.EXTEND INIMAGEOBJ INTEXT NEW.TEXT.EXTEND NEW.TEXT.SELECTIONP NTHCHARWIDTH NTHLOCALREGION ONCHAR SHOW.EXTENDED.SELECTION.FEEDBACK SHOW.FEEDBACK SHOW.FEEDBACK.BOX SELECTION.POSITION SKED.CLEAR.SELECTION SKETCH.CLEANUP SK.ENTER.EDIT.CHANGE SKED.REMOVE.OTHER.SELECTIONS SKED.EXTEND.SELECTION SKED.MOVE.SELECTION CREATE.TEXT.SELECTION SKED.SELECTION.FEEDBACK SKED.SET.EXTENDSELECTION SKED.SET.SELECTION LINE.BEGIN SELECTION.GREATERP SK.WORD.BREAK.CLASS SK.GETSYNTAX) (DECLARE%: DONTCOPY (RECORDS TEXTELTSELECTION)) (UGLYVARS IN.TEXT.FEEDBACK.CURSOR NEW.TEXT.FEEDBACK.CURSOR NEW.TEXT.FEEDBACK.SHADE SELECTION.HIGHLIGHT.SHADE) (GLOBALVARS IN.TEXT.FEEDBACK.CURSOR NEW.TEXT.FEEDBACK.CURSOR NEW.TEXT.FEEDBACK.SHADE SELECTION.HIGHLIGHT.SHADE)) (COMS (* editting functions) (FNS WB.EDITOR SK.TTYENTRYFN SK.TTYEXITFN SKED.INSERT \SKED.INSERT FIRST.N.ELEMENTS SKED.CREATE.NEW.TEXTBOX SKED.CHARACTERPOSITION SKED.LINE.AND.CHAR# \SKED.DELETE.WORD.FROM.STRING \SKED.INSERT.CHARS.TO.STR JOINCHARS STRINGFROMCHARACTERS GETALLCHARS CLEANUP.EDIT SKED.NEW.TEXTELT)) (COMS (* line adding functions) (FNS MAP.SCREEN.POSITION.ONTO.GRID NEAREST.ON.GRID SK.MIDDLE.TITLEFN WB.BUTTON.HANDLER WB.ADD.NEW.POINT WB.DRAWLINE WB.RUBBERBAND.POSITION SK.RUBBERBAND.FEEDBACKFN RESET.LINE.BEING.INPUT) (FNS NEAREST.EXISTING.POSITION WB.NEARPT LASTMOUSEPOSITION)))) (* selection functions) (DEFINEQ (BUTLAST [LAMBDA (LST) (* rrb "17-JUL-83 13:58") (* returns a list that has everything but the last element of the list.) (COND ((OR (NULL LST) (NULL (CDR LST))) NIL) (T (CONS (CAR LST) (BUTLAST (CDR LST]) (CHAR.BEGIN [LAMBDA (CHAR# LINE# TEXTELT STRM) (* rrb "14-Jan-85 15:40") (* determines the x position of the first bit of character CHAR# in LINE# of  TEXTELT.) (PROG ((LTEXT (fetch (SCREENELT LOCALPART) of TEXTELT)) TEXT XPOS LFONT LREGION) (SETQ TEXT (CAR (NTH (fetch (LOCALTEXT LOCALLISTOFCHARACTERS) of LTEXT) LINE#))) [SETQ XPOS (fetch (REGION LEFT) of (SETQ LREGION (CAR (NTH (fetch (LOCALTEXT LINEREGIONS) of LTEXT) LINE#] (COND ((EQ CHAR# 0) (* before the first character.) (RETURN XPOS))) (SETQ LFONT (fetch (LOCALTEXT LOCALFONT) of LTEXT)) (RETURN (IPLUS XPOS (COND ((IMAGESTREAMTYPEP STRM 'HARDCOPY) (* hardcopy streams must pass the stream so correction in widths is accounted  for.) (DSPFONT LFONT STRM) (STRINGWIDTH (SUBSTRING TEXT 1 CHAR#) STRM)) ((FONTP LFONT) (for I from 1 to CHAR# sum (CHARWIDTH (CHCON1 (NTHCHAR TEXT I)) LFONT))) (T (* if it is printed in shade, put cursor a percentage of the way across the  area.) (IQUOTIENT (ITIMES CHAR# (fetch (REGION WIDTH) of LREGION)) (NCHARS TEXT]) (CLOSEST.CHAR [LAMBDA (XPOS LINE# TEXTELT STRM) (* rrb "28-Apr-85 15:48") (* * determines the the slot between characters that is closest to XPOS.  it will return 0 if the position is in the first half of the first character or  before the first character) (PROG ((LTEXT (fetch (SCREENELT LOCALPART) of TEXTELT)) TEXT LREGION LFONT LEFT THISCHARWIDTH) (SETQ TEXT (CAR (NTH (fetch (LOCALTEXT LOCALLISTOFCHARACTERS) of LTEXT) LINE#))) (SETQ LFONT (fetch (LOCALTEXT LOCALFONT) of LTEXT)) (RETURN (COND ((IGREATERP [SETQ LEFT (fetch (REGION LEFT) of (SETQ LREGION (CAR (NTH (fetch (LOCALTEXT LINEREGIONS) of LTEXT) LINE#] XPOS) (* before the first character.) 0) ((IGEQ XPOS (IPLUS LEFT (fetch (REGION WIDTH) of LREGION))) (* past the rightmost character.) (NCHARS TEXT)) [(IMAGESTREAMTYPEP STRM 'HARDCOPY) (* hardcopy stream code is cobbled from STRINGWIDTH.  Must be done because widths of characters is not an integral number of points  and error would accumulate through the line.) (PROG ([FONT (FONTCREATE LFONT NIL NIL NIL (STREAMPROP STRM 'HARDCOPYIMAGETYPE] (LEFTMICAPOS (ITIMES (CONSTANT IMICASPERPT) LEFT)) (XMICAPOS (ITIMES (CONSTANT IMICASPERPT) XPOS))) (COND [(STRINGP TEXT) (* assumes PRIN1 mode.) (RETURN (for C instring TEXT as CHAR# from 1 when (IGREATERP [SETQ LEFTMICAPOS (IPLUS LEFTMICAPOS (SETQ THISCHARWIDTH (CHARWIDTH C FONT] XMICAPOS) do (RETURN (COND ((IGREATERP (IDIFFERENCE LEFTMICAPOS (LRSH THISCHARWIDTH 1)) XMICAPOS) (SUB1 CHAR#)) (T CHAR#))) finally (RETURN (SUB1 CHAR#] (T (\ILLEGAL.ARG TEXT] (T (for CHAR# from 1 to (NCHARS TEXT) when (IGREATERP [SETQ LEFT (IPLUS LEFT (SETQ THISCHARWIDTH (NTHCHARWIDTH TEXT CHAR# LFONT] XPOS) do (* have the hotspot be between the  characters.) (RETURN (COND ((IGREATERP (IDIFFERENCE LEFT (LRSH THISCHARWIDTH 1)) XPOS) (SUB1 CHAR#)) (T CHAR#))) finally (RETURN (SUB1 CHAR#]) (CLOSEST.LINE [LAMBDA (TEXTELT Y) (* rrb " 1-MAY-83 10:15") (* determines the line of TEXTELT that Y is closest to.) (* assumes that the text elements are ordered from top to bottom.) (for LREGION in (fetch (LOCALTEXT LINEREGIONS) of (fetch (SCREENELT LOCALPART) of TEXTELT)) as LINE# from 1 when (IGEQ Y (fetch (REGION BOTTOM) of LREGION)) do (RETURN LINE#) finally (RETURN (SUB1 LINE#]) (FLASHW [LAMBDA (WIN) (* flashs a window.) (INVERTW WIN) (DISMISS BELLRATE) (INVERTW WIN]) (HILITE.LINE [LAMBDA (TEXTELT LINE# MINLEFT MAXLEFT WINDOW) (* rrb " 1-MAY-83 09:54") (* highlights within a single line of text between MINLEFT and MAXLEFT.  If MINLEFT is NIL it uses the beginning of the line.  If MAXLEFT is NIL it uses the end of the line.) (PROG ((LREGION (NTHLOCALREGION TEXTELT LINE#))) (BITBLT NIL NIL NIL WINDOW (OR MINLEFT (SETQ MINLEFT (fetch (REGION LEFT) of LREGION))) (fetch (REGION BOTTOM) of LREGION) (IDIFFERENCE (OR MAXLEFT (fetch (REGION PRIGHT) of LREGION)) MINLEFT) (fetch (REGION HEIGHT) of LREGION) 'TEXTURE 'INVERT SELECTION.HIGHLIGHT.SHADE]) (HILITE.TEXT [LAMBDA (TEXTELT SELLEFT SELLINE# EXTLEFT EXTLINE# WINDOW) (* rrb "30-Dec-84 17:59") (* high lights between two positions  in a text element.) (COND ((EQ SELLINE# EXTLINE#) (* on the same line, highlight between  them.) (PROG (MIN MAX) (COND ((NULL SELLEFT) (* SELLEFT is NIL during recursive calls and means use the beginning of the  text.) (SETQ MIN NIL) (SETQ MAX EXTLEFT)) ((IGREATERP SELLEFT EXTLEFT) (SETQ MIN EXTLEFT) (SETQ MAX SELLEFT)) (T (SETQ MIN SELLEFT) (SETQ MAX EXTLEFT))) (HILITE.LINE TEXTELT SELLINE# MIN MAX WINDOW))) ((IGREATERP EXTLINE# SELLINE#) (* fill from SEL to end of its line and recurse.) (HILITE.LINE TEXTELT SELLINE# SELLEFT NIL WINDOW) (HILITE.TEXT TEXTELT NIL (ADD1 SELLINE#) EXTLEFT EXTLINE# WINDOW)) (T (* fill from EXT to the end of its line and recurse.) (HILITE.LINE TEXTELT EXTLINE# EXTLEFT NIL WINDOW) (* always recurse to have highest  selection first.) (HILITE.TEXT TEXTELT NIL (ADD1 EXTLINE#) SELLEFT SELLINE# WINDOW]) (IN.TEXT.EXTEND [LAMBDA (SELECTION SKW) (* rrb "22-May-85 11:40") (* the user has right buttoned and the first selection was to in existing text.) (* current selection has already been  undisplayed.) (PROG [(OLDLINE (fetch (TEXTELTSELECTION SKLINE#) of SELECTION)) (OLDX (fetch (TEXTELTSELECTION SKLEFT) of SELECTION)) (INTEXT (fetch (TEXTELTSELECTION SKTEXTELT) of SELECTION)) FEEDBACKX FEEDBACKY FEEDBACKLINE FEEDBACKCHAR (REGION (DSPCLIPPINGREGION NIL SKW)) (DSP (WINDOWPROP SKW 'DSP] (while (MOUSESTATE RIGHT) do (* track with the appropriate feedback) (COND ([NOT (INSIDEP REGION (SETQ FEEDBACKX (LASTMOUSEX DSP)) (SETQ FEEDBACKY (LASTMOUSEY DSP] (* cursor moved outside of the window. Reset selection and quit.) (SKED.SELECTION.FEEDBACK SKW) (RETURN))) (SETQ FEEDBACKLINE (CLOSEST.LINE INTEXT FEEDBACKY)) (* inside of a text element.) (SETQ FEEDBACKX (CHAR.BEGIN (SETQ FEEDBACKCHAR (CLOSEST.CHAR FEEDBACKX FEEDBACKLINE INTEXT DSP)) FEEDBACKLINE INTEXT DSP)) (COND ((OR (NEQ OLDX FEEDBACKX) (NEQ OLDLINE FEEDBACKLINE)) (HILITE.TEXT INTEXT OLDX OLDLINE (SETQ OLDX FEEDBACKX) (SETQ OLDLINE FEEDBACKLINE) SKW))) finally (* erase feedback. It will be put in as a result of setting the extention  selection.) (HILITE.TEXT INTEXT OLDX OLDLINE (fetch (TEXTELTSELECTION SKLEFT) of SELECTION) (fetch (TEXTELTSELECTION SKLINE#) of SELECTION) SKW) (SKED.SET.EXTENDSELECTION (create TEXTELTSELECTION SKTEXTELT _ INTEXT SKLINE# _ OLDLINE SKCHAR# _ FEEDBACKCHAR SKLEFT _ OLDX SKBOTTOM _ (LINE.BEGIN (OR FEEDBACKLINE 1) INTEXT)) SKW]) (INIMAGEOBJ [LAMBDA (SKIMAGEOBJSCREENELT X Y) (* rrb "31-Mar-84 11:43") (* return T if X Y is inside of the image object SKIMAGEOBJSCREENELT.) (INSIDEP (fetch (LOCALSKIMAGEOBJ SKIMOBJLOCALREGION) of (fetch (SCREENELT LOCALPART) of SKIMAGEOBJSCREENELT )) X Y]) (INTEXT [LAMBDA (TEXTELT XORPT Y) (* rrb " 6-MAY-83 19:37") (* determines which line if any a  position is on.) (for LREGION in (fetch (LOCALTEXT LINEREGIONS) of (fetch (SCREENELT LOCALPART) of TEXTELT)) as LINE# from 1 when (INSIDEP LREGION XORPT Y) do (RETURN LINE#]) (NEW.TEXT.EXTEND [LAMBDA (SELECTION SKW) (* rrb "30-APR-83 16:25") (* the user has right buttoned and the first selection was to new text.) (* current selection has already been  undisplayed.) (PROG (FEEDBACKX FEEDBACKY EXTENDEDSEL OLDX OLDY OLDCUR) (until (MOUSESTATE (NOT RIGHT)) do (* track with the appropriate feedback) (SETQ FEEDBACKX (LASTMOUSEX SKW)) (SETQ FEEDBACKY (LASTMOUSEY SKW)) (COND ((OR (NEQ OLDX FEEDBACKX) (NEQ OLDY FEEDBACKY)) (* erase previous feedback) (AND EXTENDEDSEL (SHOW.FEEDBACK.BOX SELECTION EXTENDEDSEL SKW)) (SHOW.FEEDBACK.BOX SELECTION (SETQ EXTENDEDSEL (create POSITION XCOORD _ (SETQ OLDX FEEDBACKX) YCOORD _ (SETQ OLDY FEEDBACKY))) SKW))) finally (AND EXTENDEDSEL (SHOW.FEEDBACK.BOX SELECTION EXTENDEDSEL SKW)) (SKED.SET.EXTENDSELECTION EXTENDEDSEL SKW]) (NEW.TEXT.SELECTIONP [LAMBDA (SELECTION) (* determines if a selection is pointing to new text location or existing text.) (POSITIONP SELECTION]) (NTHCHARWIDTH [LAMBDA (STR N FONT) (* rrb "23-Aug-84 09:43") (* returns the character width of the Nth character in STR.) (CHARWIDTH (CHCON1 (NTHCHAR STR N)) FONT]) (NTHLOCALREGION [LAMBDA (TEXTELT N) (* rrb " 1-MAY-83 09:53") (CAR (NTH (fetch (LOCALTEXT LINEREGIONS) of (fetch (SCREENELT LOCALPART) of TEXTELT)) N]) (ONCHAR [LAMBDA (XPOS LINE# TEXTELT STRM) (* rrb "24-Aug-84 11:14") (* determines the character number that XPOS is on in a particular line of a  text element.) (* will return 1 if the position is in the first half of the first character.) (CLOSEST.CHAR XPOS LINE# TEXTELT STRM NIL]) (SHOW.EXTENDED.SELECTION.FEEDBACK [LAMBDA (SEL EXTENDSEL SKW) (* rrb " 1-MAY-83 09:55") (* hi lights the selection between SEL  and EXTENDSEL) (COND ((NEQ (fetch (TEXTELTSELECTION SKTEXTELT) of SEL) (fetch (TEXTELTSELECTION SKTEXTELT) of EXTENDSEL)) (* if the two selections aren't in the same text element, things are confused.) (SHOULDNT))) (HILITE.TEXT (fetch (TEXTELTSELECTION SKTEXTELT) of SEL) (fetch (TEXTELTSELECTION SKLEFT) of SEL) (fetch (TEXTELTSELECTION SKLINE#) of SEL) (fetch (TEXTELTSELECTION SKLEFT) of EXTENDSEL) (fetch (TEXTELTSELECTION SKLINE#) of EXTENDSEL) SKW]) (SHOW.FEEDBACK [LAMBDA (FEEDBACKCUR FEEDBACKX FEEDBACKY WINDOW) (* ; "Edited 9-Jan-87 13:49 by rrb") (* displays a cursor in XOR mode at a  position.) (BITBLT (CAR FEEDBACKCUR) 0 0 WINDOW (IDIFFERENCE FEEDBACKX (CADR FEEDBACKCUR)) (IDIFFERENCE FEEDBACKY (CDDR FEEDBACKCUR)) NIL NIL 'INPUT 'INVERT]) (SHOW.FEEDBACK.BOX [LAMBDA (P1 P2 WINDOW) (* rrb "30-APR-83 16:23") (* draws a box between two points.) (PROG ((X1 (fetch (POSITION XCOORD) of SELECTION P1)) (Y1 (fetch (POSITION YCOORD) of SELECTION P1)) (X2 (fetch (POSITION XCOORD) of SELECTION P2)) (Y2 (fetch (POSITION YCOORD) of SELECTION P2))) (BITBLT NIL NIL NIL WINDOW (IMIN X1 X2) (IMIN Y1 Y2) (ABS (IDIFFERENCE X1 X2)) (ABS (IDIFFERENCE Y1 Y2)) 'TEXTURE 'INVERT NEW.TEXT.FEEDBACK.SHADE) (* put cursor where the center would  be.) (SHOW.FEEDBACK NEW.TEXT.FEEDBACK.CURSOR (IQUOTIENT (IPLUS X1 X2) 2) (IQUOTIENT (IPLUS Y1 Y2) 2) WINDOW]) (SELECTION.POSITION [LAMBDA (FIRSTPT SECONDPT) (* rrb " 6-MAY-83 18:09") (* returns the place where the text should go from one or two selections in  open space.) (COND (SECONDPT (create POSITION XCOORD _ (IQUOTIENT (IPLUS (fetch (POSITION XCOORD) of FIRSTPT) (fetch (POSITION XCOORD) of SECONDPT)) 2) YCOORD _ (IQUOTIENT (IPLUS (fetch (POSITION YCOORD) of FIRSTPT) (fetch (POSITION YCOORD) of SECONDPT)) 2))) (T FIRSTPT]) (SKED.CLEAR.SELECTION [LAMBDA (SKW DONTDISPLAYFLG DONTMAKEHISTEVENTFLG) (* rrb " 5-Dec-85 14:30") (* clears the selection and removes it  from the display.) (OR DONTMAKEHISTEVENTFLG (SKETCH.CLEANUP SKW)) (COND ((OR DONTDISPLAYFLG (SKED.SELECTION.FEEDBACK SKW)) (WINDOWPROP SKW 'SELECTION NIL) (WINDOWPROP SKW 'EXTENDSELECTION NIL]) (SKETCH.CLEANUP [LAMBDA (SKETCHWINDOW) (* ; "Edited 20-Feb-87 17:51 by rrb") (* finishes up the currently being  edited element.) (PROG (INITSELECTION NEWELT) (COND ((NOT (WINDOWP SKETCHWINDOW)) (* only one of the viewers should have any changes but do this in lieu of  figuring out which one.) (for VIEWER in (ALL.SKETCH.VIEWERS (INSURE.SKETCH SKETCHWINDOW)) do (SKETCH.CLEANUP VIEWER))) ((SETQ INITSELECTION (WINDOWPROP SKETCHWINDOW 'CHANGEDTEXTELT NIL)) (* also checks to see if the current selection was edited and makes a history  event if necessary.) [SETQ NEWELT (fetch (SCREENELT GLOBALPART) of (fetch (TEXTELTSELECTION SKTEXTELT) of (OR (WINDOWPROP SKETCHWINDOW 'SELECTION) (RETURN] (COND ((POSITIONP INITSELECTION) (* add an ADD event because previously there was nothing here.) (SK.ADD.HISTEVENT 'ADD (LIST NEWELT) SKETCHWINDOW) (SK.CHECK.END.INITIAL.EDIT SKETCHWINDOW NEWELT)) (T (SK.ENTER.EDIT.CHANGE SKETCHWINDOW (fetch (SCREENELT GLOBALPART) of (fetch (TEXTELTSELECTION SKTEXTELT) of INITSELECTION)) NEWELT]) (SK.ENTER.EDIT.CHANGE [LAMBDA (VIEWER OLDELT NEWELT) (* rrb " 3-Jan-86 18:48") (* adds a history event for the change operation that occurs at the end of a  series of edits and calls the when changed function.) (SK.CHECK.WHENCHANGEDFN VIEWER OLDELT 'DATA (fetch (TEXT LISTOFCHARACTERS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWELT)) (fetch (TEXT LISTOFCHARACTERS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of OLDELT))) (SK.ADD.HISTEVENT 'CHANGE (LIST (create SKHISTORYCHANGESPEC OLDELT _ OLDELT NEWELT _ NEWELT PROPERTY _ 'DATA NEWVALUE _ (fetch (TEXT LISTOFCHARACTERS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWELT)) OLDVALUE _ (fetch (TEXT LISTOFCHARACTERS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of OLDELT))) (LIST OLDELT NEWELT)) VIEWER]) (SKED.REMOVE.OTHER.SELECTIONS [LAMBDA (SKW) (* rrb " 5-Dec-85 12:12") (* removes and undisplays any selections in any other windows onto the same  sketch as SKW.) (for SKETCHWINDOW in (ALL.SKETCH.VIEWERS (SKETCH.FROM.VIEWER SKW)) when (NEQ SKETCHWINDOW SKW) do (SKED.CLEAR.SELECTION SKETCHWINDOW]) (SKED.EXTEND.SELECTION [LAMBDA (SKW) (* rrb "17-Jul-85 20:11") (* the user has left buttoned in a sketch window.  Put the caret there.) (* take down the current selection.) (PROG [(SELECTION (WINDOWPROP SKW 'SELECTION)) (EXTENSION (WINDOWPROP SKW 'EXTENDSELECTION] (RETURN (COND [SELECTION (COND [(NEW.TEXT.SELECTIONP SELECTION) (* if the previous selection was in new text, treat the right the same as the  left.) (SKED.MOVE.SELECTION SKW (NOT (WINDOWPROP SKW 'USEGRID] (T (SKED.SELECTION.FEEDBACK SKW) (* extend within text.) (* MAYBE SHOULD DO -  if there is already an extension, make the fixed point be the one of the two  selections that is farthest from the current position.) (IN.TEXT.EXTEND SELECTION SKW] (T (* here is a right button before any left ones.  Treat as if it were left.) (SKED.MOVE.SELECTION SKW (NOT (WINDOWPROP SKW 'USEGRID]) (SKED.MOVE.SELECTION [LAMBDA (SKW USEGRID) (* rrb "11-Jul-86 15:51") (* the user has left buttoned in a sketch window.  Put the caret there.) (SKED.CLEAR.SELECTION SKW) (PROG (FEEDBACKX FEEDBACKY OLDGRIDX OLDGRIDY OLDX OLDY OLDCUR FEEDBACKCUR INTEXT INIMAGEOBJ STARTLINE STARTCHAR X Y (DSP (WINDOWPROP SKW 'DSP)) (SCALE (VIEWER.SCALE SKW)) (GRID (SK.GRIDFACTOR SKW))) (until (MOUSESTATE UP) do (* track with the appropriate caret depending upon whether the cursor is inside  of existing text or not.) (SETQ X (LASTMOUSEX DSP)) (SETQ Y (LASTMOUSEY DSP)) (COND ((OR (NEQ OLDX X) (NEQ OLDY Y)) (* only look for things when the cursor position has changed.) (SETQ OLDX X) (SETQ OLDY Y) [COND ([AND (SETQ INTEXT (for ELT in (LOCALSPECS.FROM.VIEWER SKW) when (SELECTQ (fetch (SCREENELT GTYPE) of ELT) (TEXT (AND (NEQ (fetch (LOCALTEXT LOCALFONT) of (fetch (SCREENELT LOCALPART) of ELT)) 'SHADE) (SETQ STARTLINE (INTEXT ELT X Y)))) (TEXTBOX (AND (NEQ (fetch (LOCALTEXTBOX LOCALFONT) of (fetch (SCREENELT LOCALPART) of ELT)) 'SHADE) (INSIDE? (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION) of (fetch (SCREENELT LOCALPART) of ELT)) X Y) (SETQ STARTLINE (CLOSEST.LINE ELT Y)))) NIL) do (RETURN ELT))) (NOT (SK.ELEMENT.PROTECTED? (fetch (SCREENELT GLOBALPART) of INTEXT) 'CHANGE] (* inside of a text element.) (SETQ FEEDBACKCUR IN.TEXT.FEEDBACK.CURSOR) (SETQ FEEDBACKX (CHAR.BEGIN (SETQ STARTCHAR (CLOSEST.CHAR X STARTLINE INTEXT DSP)) STARTLINE INTEXT DSP)) (SETQ FEEDBACKY (LINE.BEGIN STARTLINE INTEXT))) (T (SETQ FEEDBACKCUR NEW.TEXT.FEEDBACK.CURSOR) (COND (USEGRID (SETQ FEEDBACKX (MAP.WINDOW.ONTO.GRID X SCALE GRID)) (SETQ FEEDBACKY (MAP.WINDOW.ONTO.GRID Y SCALE GRID))) (T (* no grid) (SETQ FEEDBACKX X) (SETQ FEEDBACKY Y] (COND ((OR (NEQ OLDGRIDX FEEDBACKX) (NEQ OLDGRIDY FEEDBACKY) (NEQ OLDCUR FEEDBACKCUR)) (AND OLDGRIDX (SHOW.FEEDBACK OLDCUR OLDGRIDX OLDGRIDY SKW)) (SHOW.FEEDBACK (SETQ OLDCUR FEEDBACKCUR) (SETQ OLDGRIDX FEEDBACKX) (SETQ OLDGRIDY FEEDBACKY) SKW))) (* give the coordinate display window  a shot.) (SKETCHW.UPDATE.LOCATORS SKW))) finally (AND OLDGRIDX (SHOW.FEEDBACK OLDCUR OLDGRIDX OLDGRIDY SKW)) (COND ((EQ OLDCUR IN.TEXT.FEEDBACK.CURSOR) (* selection is existing text) (SKED.SET.SELECTION (CREATE.TEXT.SELECTION INTEXT STARTLINE STARTCHAR OLDGRIDX OLDGRIDY DSP) SKW)) (OLDGRIDX (SKED.SET.SELECTION (create POSITION XCOORD _ OLDGRIDX YCOORD _ OLDGRIDY) SKW]) (CREATE.TEXT.SELECTION [LAMBDA (TEXTELT LINE# CHAR# LFT BTM STRM) (* rrb "23-Aug-84 13:48") (* creates a text selection object. If LFT or BTM are NIL they are computed  from the other arguments.) (create TEXTELTSELECTION SKTEXTELT _ TEXTELT SKLINE# _ LINE# SKCHAR# _ CHAR# SKLEFT _ (OR LFT (CHAR.BEGIN CHAR# LINE# TEXTELT STRM)) SKBOTTOM _ (OR BTM (LINE.BEGIN LINE# TEXTELT]) (SKED.SELECTION.FEEDBACK [LAMBDA (SKETCHW) (* rrb "14-Sep-84 18:20") (* displays the feedback to the user about what the current selection is.  Returns NIL if there is no selection, T otherwise.) (PROG ((SELECTION (WINDOWPROP SKETCHW 'SELECTION)) EXTENDSELECTION) (OR SELECTION (RETURN)) (SETQ EXTENDSELECTION (WINDOWPROP SKETCHW 'EXTENDSELECTION)) [COND [(NEW.TEXT.SELECTIONP SELECTION) (* outside of existing text region) (COND (EXTENDSELECTION (* display a box whose center will be used as the center of mass of the text.) (SHOW.FEEDBACK.BOX SELECTION EXTENDSELECTION SKETCHW)) (T (SHOW.FEEDBACK NEW.TEXT.FEEDBACK.CURSOR (fetch (POSITION XCOORD) of SELECTION) (fetch (POSITION YCOORD) of SELECTION) SKETCHW] (T (COND (EXTENDSELECTION (* display a box whose center will be used as the center of mass of the text.) (SHOW.EXTENDED.SELECTION.FEEDBACK SELECTION EXTENDSELECTION SKETCHW)) (T (SHOW.FEEDBACK IN.TEXT.FEEDBACK.CURSOR (fetch (TEXTELTSELECTION SKLEFT) of SELECTION) (fetch (TEXTELTSELECTION SKBOTTOM) of SELECTION) SKETCHW] (RETURN T]) (SKED.SET.EXTENDSELECTION [LAMBDA (SELECTION SKETCHW) (* rrb "30-APR-83 16:36") (* stores the selection for a sketch window and displays its feedback.) (WINDOWPROP SKETCHW 'EXTENDSELECTION SELECTION) (SKED.SELECTION.FEEDBACK SKETCHW]) (SKED.SET.SELECTION [LAMBDA (SELECTION SKETCHW) (* rrb " 2-MAY-83 12:29") (* stores the selection for a sketch window and displays its feedback.) (WINDOWPROP SKETCHW 'SELECTION SELECTION) (* clear the extension also.) (WINDOWPROP SKETCHW 'EXTENDSELECTION NIL) (SKED.SELECTION.FEEDBACK SKETCHW]) (LINE.BEGIN [LAMBDA (LINE# TEXTELT) (* rrb "30-APR-83 15:45") (* returns the bottom of the LINE# th text element of TEXTELT.) (fetch (REGION BOTTOM) of (CAR (NTH (fetch (LOCALTEXT LINEREGIONS) of (fetch (SCREENELT LOCALPART ) of TEXTELT)) LINE#]) (SELECTION.GREATERP [LAMBDA (SEL1 SEL2) (* rrb " 1-MAY-83 11:31") (* return T if SEL1 appears before  SEL2) (PROG (L1 L2) (RETURN (COND ((IGREATERP (SETQ L2 (fetch (TEXTELTSELECTION SKLINE#) of SEL2)) (SETQ L1 (fetch (TEXTELTSELECTION SKLINE#) of SEL1))) T) ((EQ L1 L2) (* look at characters) (IGREATERP (fetch (TEXTELTSELECTION SKCHAR#) of SEL2) (fetch (TEXTELTSELECTION SKCHAR#) of SEL1]) (SK.WORD.BREAK.CLASS [LAMBDA (CHCODE) (* rrb "11-Jul-86 17:17") (* version of TEDIT.WORDGET that makes  sure TEDIT is loaded.) (COND ((DEFINEDP (FUNCTION TEDIT.WORDGET)) (TEDIT.WORDGET CHCODE)) ((EQ CHCODE 32) (* space, return the code tedit uses  for word separators) 22) (T (* this probably isn't right but  should do something reasonable.) (GETSYNTAX CHCODE (GETREADTABLE]) (SK.GETSYNTAX [LAMBDA (CHARCODE) (* rrb "11-Jul-86 17:18") (* version of getsyntax that uses the TEDIT table if it is available, otherwise  the terminal.) (COND ((DEFINEDP (FUNCTION TEDIT.GETSYNTAX)) (TEDIT.GETSYNTAX CHARCODE TEDIT.READTABLE)) (T (GETSYNTAX CHARCODE (GETTERMTABLE]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD TEXTELTSELECTION (SKTEXTELT SKLINE# SKCHAR# SKLEFT SKBOTTOM)) ) ) (READVARS-FROM-STRINGS '(IN.TEXT.FEEDBACK.CURSOR NEW.TEXT.FEEDBACK.CURSOR NEW.TEXT.FEEDBACK.SHADE SELECTION.HIGHLIGHT.SHADE) "(({(READBITMAP)(16 16 %"@@@@%" %"@@@@%" %"L@@@%" %"L@@@%" %"L@@@%" %"L@@@%" %"L@@@%" %"L@@@%" %"L@@@%" %"L@@@%" %"L@@@%" %"L@@@%" %"L@@@%" %"L@@@%" %"L@@@%" %"L@@@%")} 1 . 0) ({(READBITMAP)(16 16 %"@@@@%" %"@@@@%" %"@@@@%" %"@@@@%" %"@@@@%" %"@@@@%" %"@@@@%" %"@@@@%" %"@@@@%" %"@@@@%" %"@@@@%" %"@H@@%" %"AL@@%" %"CF@@%" %"FC@@%" %"LAH@%")} 4 . 4) 8 65535) ") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS IN.TEXT.FEEDBACK.CURSOR NEW.TEXT.FEEDBACK.CURSOR NEW.TEXT.FEEDBACK.SHADE SELECTION.HIGHLIGHT.SHADE) ) (* editting functions) (DEFINEQ (WB.EDITOR [LAMBDA (SKW) (* rrb "17-Jul-85 15:53") (* the process that looks for characters and adds them to the white board as  text elements.) (* save the value of del as an interrupt character so it is restored when this  process exits. This is also done by TTYENTRYFN and TTYEXITFN on the process.) (RESETFORM (INTERRUPTCHAR 127 T) (PROG (CHARS EDITINPROGRESS) (TTYDISPLAYSTREAM SKW) LP (COND ((\SYSBUFP) (* a character has been typed, read all of the characters, delete the current  selection if extended and insert the new characters.) (RESET.LINE.BEING.INPUT SKW) (SKED.INSERT (GETALLCHARS T) SKW) (SETQ EDITINPROGRESS T)) ((AND EDITINPROGRESS (NOT (INSIDEP (WINDOWPROP SKW 'REGION) LASTMOUSEX LASTMOUSEY))) (CLEANUP.EDIT SKW) (SETQ EDITINPROGRESS NIL))) (* let the mouse process run.) (BLOCK) (GO LP]) (SK.TTYENTRYFN [LAMBDA (SKPROC) (* rrb "20-Jun-85 14:13") (* the sketch process just got the tty. Turns off DEL as an interrupt) (PROCESSPROP SKPROC 'OLDINTERRUPTVALUE (INTERRUPTCHAR 127 NIL]) (SK.TTYEXITFN [LAMBDA (SKPROC) (* rrb "20-Jun-85 13:55") (* the sketch process just got the tty. Turns off DEL as an interrupt) (INTERRUPTCHAR (PROCESSPROP SKPROC 'OLDINTERRUPTVALUE]) (SKED.INSERT [LAMBDA (CHARCODES SKW ATSCALE) (* rrb "10-Feb-86 10:15") (* deletes the characters in the extension and inserts characters into the  currently selected position of SKW and leaves the selection at the end of the  insertion.) (WITH.MONITOR (SKETCH.MONITORLOCK SKW) (\SKED.INSERT CHARCODES SKW ATSCALE]) (\SKED.INSERT [LAMBDA (CHARCODES SKW ATSCALE) (* ; "Edited 20-Feb-87 17:28 by rrb") (COND ((GREATERP (LENGTH CHARCODES) 200) (* the maximum string length limits the number of characters that can be  inserted at once. This can happen from a shift select.) (SKED.INSERT (FIRST.N.ELEMENTS CHARCODES 200) SKW ATSCALE) (SKED.INSERT (NTH CHARCODES 201) SKW ATSCALE)) (T (PROG ((SELECTION (WINDOWPROP SKW 'SELECTION)) (EXTENSION (WINDOWPROP SKW 'EXTENDSELECTION)) TEXTELT ELTTYPE GTEXTELT FIRSTLINE# FIRSTCHAR# LASTLINE# LASTCHAR# STRLST NEWSTRS NEWELT STRPIECE NEWLINE# NEWCHAR# SKCONTEXT PTRCHAR# CONTROLCHARTAIL) (COND ((EQ (SK.GETSYNTAX (CAR CHARCODES)) 'UNDO) (* user typed an undo Avoid the overhead of inserting no characters and allow  undo to be typed without a selection.) (SETQ CONTROLCHARTAIL 'UNDO) (GO UNDO))) (COND ((NULL SELECTION) (* add a new text element with these  characters.) (STATUSPRINT SKW " " "Indicate the position the typing should go with the left button.") (RETURN))) (SKED.CLEAR.SELECTION SKW NIL T) (SKED.REMOVE.OTHER.SELECTIONS SKW) [COND ((AND (OR (EQ (CAR CHARCODES) (CHARCODE EOL)) (EQ (CAR CHARCODES) (CHARCODE LINEFEED))) (KEYDOWNP 'CTRL)) (* user hit control CR. create a new text or textbox.) (SKED.CREATE.NEW.TEXTBOX [COND ((NEW.TEXT.SELECTIONP SELECTION) NIL) (T (fetch (SCREENELT INDIVIDUALGLOBALPART) of (fetch (TEXTELTSELECTION SKTEXTELT) of SELECTION] SKW (CDR CHARCODES)) (RETURN)) [(NEW.TEXT.SELECTIONP SELECTION) (* selection is in open space, create a new text element.) (* merge the characters into strings  of each line.) (SETQ ELTTYPE 'TEXT) (SETQ CONTROLCHARTAIL (\SKED.INSERT.CHARS.TO.STR CHARCODES NIL SKW)) (COND ((OR NEWSTRS STRPIECE) (* if there are any new characters, add a new text element.) (* save the selection that marked the spot where the new text goes and add the  text but not in a way that puts an event on the history list.  this is done during clean up.) (WINDOWPROP SKW 'CHANGEDTEXTELT SELECTION) (SETQ NEWELT (SK.ADD.ELEMENT (CREATE.TEXT.ELEMENT (SETQ NEWSTRS (NCONC1 NEWSTRS STRPIECE)) (SK.MAP.INPUT.PT.TO.GLOBAL (create INPUTPT INPUT.ONGRID? _ NIL INPUT.POSITION _ (  SELECTION.POSITION SELECTION EXTENSION)) SKW) (OR (NUMBERP ATSCALE) (SK.INPUT.SCALE SKW)) [fetch (SKETCHCONTEXT SKETCHTEXTALIGNMENT) of (SETQ SKCONTEXT (WINDOWPROP SKW 'SKETCHCONTEXT] (fetch (SKETCHCONTEXT SKETCHFONT) of SKCONTEXT) (fetch (BRUSH BRUSHCOLOR) of (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKCONTEXT))) SKW T))) (CONTROLCHARTAIL (* user typed control return to get textbox in the middle of no where.) (SKED.CREATE.NEW.TEXTBOX NIL SKW (CDR CONTROLCHARTAIL) ATSCALE) (RETURN)) (T (* user typed backspace, etc. when no text exists.  Put caret back in same place.) (SKED.SET.SELECTION SELECTION SKW) (RETURN))) (* put selection marker at the end.) (SETQ NEWLINE# (LENGTH NEWSTRS)) (SETQ NEWCHAR# (NCHARS (CAR (LAST NEWSTRS] (T [SETQ GTEXTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of (SETQ TEXTELT (fetch (TEXTELTSELECTION SKTEXTELT) of SELECTION] (SETQ ELTTYPE (fetch (INDIVIDUALGLOBALPART GTYPE) of GTEXTELT)) (SETQ STRLST (fetch (LOCALTEXT LOCALLISTOFCHARACTERS) of (fetch (SCREENELT LOCALPART) of TEXTELT))) (* set up points to beginning and end  of selection.) [COND [(NULL EXTENSION) (SETQ LASTCHAR# (SETQ FIRSTCHAR# (fetch (TEXTELTSELECTION SKCHAR#) of SELECTION))) (SETQ LASTLINE# (SETQ FIRSTLINE# (fetch (TEXTELTSELECTION SKLINE#) of SELECTION] ((SELECTION.GREATERP SELECTION EXTENSION) (SETQ FIRSTLINE# (fetch (TEXTELTSELECTION SKLINE#) of SELECTION)) (SETQ FIRSTCHAR# (fetch (TEXTELTSELECTION SKCHAR#) of SELECTION)) (SETQ LASTLINE# (fetch (TEXTELTSELECTION SKLINE#) of EXTENSION)) (SETQ LASTCHAR# (fetch (TEXTELTSELECTION SKCHAR#) of EXTENSION)) (* make SELECTION be the candidate for the selection after the deletion.) (SETQ SELECTION EXTENSION)) (T (SETQ FIRSTLINE# (fetch (TEXTELTSELECTION SKLINE#) of EXTENSION)) (SETQ FIRSTCHAR# (fetch (TEXTELTSELECTION SKCHAR#) of EXTENSION)) (SETQ LASTLINE# (fetch (TEXTELTSELECTION SKLINE#) of SELECTION)) (SETQ LASTCHAR# (fetch (TEXTELTSELECTION SKCHAR#) of SELECTION] [for STR in STRLST as LINE# from 1 do [COND ((ILESSP LINE# FIRSTLINE#) (* before the first, copy across) (SETQ NEWSTRS (NCONC1 NEWSTRS STR))) ((IGREATERP LINE# LASTLINE#) (* After the last, copy across) (SETQ NEWSTRS (NCONC1 NEWSTRS STR))) ((EQ LINE# FIRSTLINE#) (* on the first, save the part before.) (SETQ STRPIECE (SUBSTRING STR 1 FIRSTCHAR#)) (* insert new text.) (COND [CHARCODES (SETQ CONTROLCHARTAIL (\SKED.INSERT.CHARS.TO.STR CHARCODES (EQ ELTTYPE 'TEXTBOX) SKW)) (SETQ NEWCHAR# (COND (STRPIECE (NCHARS STRPIECE)) (T 0))) (SETQ NEWLINE# (ADD1 (LENGTH NEWSTRS] (T (SETQ NEWCHAR# FIRSTCHAR#) (SETQ NEWLINE# FIRSTLINE#] (COND ((EQ LINE# LASTLINE#) (* on the last, copy the part before and the part after as one) (SETQ NEWSTRS (COND [STRPIECE (NCONC1 NEWSTRS (COND ((EQ LASTCHAR# (NCHARS STR)) (* special check because SUBSTRING returns NIL rather than the empty string.) STRPIECE) (T (CONCAT STRPIECE (SUBSTRING STR (ADD1 LASTCHAR# ] [(NEQ LASTCHAR# (NCHARS STR)) (NCONC1 NEWSTRS (SUBSTRING STR (ADD1 LASTCHAR#] (T NEWSTRS] (* any other windows that had this selection have had it deleted already so  this doesn't do anything for them.) [COND ((IGREATERP NEWLINE# (LENGTH NEWSTRS)) (* this corresponds to deleting every thing in a line.  Make sure that if it is the last line that the selection is reset) (COND ((EQ (SETQ NEWLINE# (LENGTH NEWSTRS)) 0) (SETQ NEWCHAR# 0) (COND ((EQ ELTTYPE 'TEXT) (* deleted everything in a text element, delete the text element and set the  selection to new text cursor.) (COND [(WINDOWPROP SKW 'CHANGEDTEXTELT) (* make the history event for this edit so that it will restore the original  text element) (PROG ((INITSELECTION (WINDOWPROP SKW 'CHANGEDTEXTELT NIL))) (COND ((POSITIONP INITSELECTION) (* this text element was typing that was never officially added, don't record  the deletion either.) (SK.DELETE.ELEMENT (LIST TEXTELT) SKW 'DON'T)) (T (* selection was existing text, record this as a delete event.) (SK.DELETE.ELEMENT (LIST TEXTELT) SKW (LIST (fetch (SCREENELT GLOBALPART) of (fetch (TEXTELTSELECTION SKTEXTELT) of INITSELECTION] (T (SK.DELETE.ELEMENT (LIST TEXTELT) SKW))) (SKED.SET.SELECTION (SK.SCALE.POSITION.INTO.VIEWER (fetch (TEXT LOCATIONLATLON) of (fetch (SCREENELT INDIVIDUALGLOBALPART) of TEXTELT)) (VIEWER.SCALE SKW)) SKW) (RETURN NIL)) ((EQ ELTTYPE 'TEXTBOX) (* deleted everything in a textbox) NIL))) (T (SETQ NEWCHAR# (NCHARS (CAR (LAST NEWSTRS] (SETQ PTRCHAR# (SKED.CHARACTERPOSITION NEWSTRS NEWLINE# NEWCHAR#)) (COND ((WINDOWPROP SKW 'CHANGEDTEXTELT) (* this is not the first change to the text element.  Collect the changes so that only one element is put on the undo stack, not one  for each character.) (SETQ NEWELT (SK.UPDATE.ELEMENT (fetch (SCREENELT GLOBALPART) of TEXTELT) (SK.REPLACE.TEXT.IN.ELEMENT (fetch (SCREENELT GLOBALPART) of TEXTELT) NEWSTRS) SKW T))) ((AND CONTROLCHARTAIL (NEQ CONTROLCHARTAIL 'UNDO)) (* user typed a character command to create a new text box.  Create it and put the remaining characters in it and set the cursor there.) (* this is done here so that no undo event is created for the textbox that the  user was in when all they did was type a control-cr.) (SKED.CREATE.NEW.TEXTBOX (fetch (SCREENELT INDIVIDUALGLOBALPART) of NEWELT) SKW (CDR CONTROLCHARTAIL)) (RETURN)) (T (* this is the first edit change to a new element, call the PREEDITFN and save  old text element so undo event can be constructed when the selection changes.) (OR (SK.CHECK.PREEDITFN SKW (fetch (SCREENELT GLOBALPART) of TEXTELT)) (RETURN NIL)) (SETQ NEWELT (SK.UPDATE.ELEMENT (fetch (SCREENELT GLOBALPART) of TEXTELT) (SKED.NEW.TEXTELT (fetch (SCREENELT GLOBALPART) of TEXTELT) NEWSTRS) SKW)) (WINDOWPROP SKW 'CHANGEDTEXTELT SELECTION))) (* recalculate the line %# and char %# of the insertion point as the textboxes  at least do justification.) [SETQ NEWCHAR# (CDR (SETQ NEWLINE# (SKED.LINE.AND.CHAR# (fetch (LOCALTEXTBOX LOCALLISTOFCHARACTERS) of (fetch (SCREENELT LOCALPART) of NEWELT)) PTRCHAR#] (SETQ NEWLINE# (CAR NEWLINE#] UNDO (COND ((NULL CONTROLCHARTAIL) (* set the selection to where the characters were just inserted.) (SKED.SET.SELECTION (CREATE.TEXT.SELECTION NEWELT NEWLINE# NEWCHAR# NIL NIL (WINDOWPROP SKW 'DSP)) SKW)) [(EQ CONTROLCHARTAIL 'UNDO) (* user types in an undo after some characters or while selection was in the  middle of text.) (PROG (INITSELECTION EDITEDELT) (COND ((SETQ INITSELECTION (WINDOWPROP SKW 'CHANGEDTEXTELT NIL)) (* in the middle of editing, undo  these edits.) [SETQ EDITEDELT (fetch (SCREENELT GLOBALPART) of (OR NEWELT (fetch (TEXTELTSELECTION SKTEXTELT) of (OR SELECTION (ERROR "NO SELECTION WHEN THERE SHOULD BE" ] (* add event to history list so the undo can be undone.) (COND ((POSITIONP INITSELECTION) (* add an ADD event because previously there was nothing here.) (SK.ADD.HISTEVENT 'ADD (LIST EDITEDELT) SKW) (SK.CHECK.END.INITIAL.EDIT SKW EDITEDELT)) (T (SK.ENTER.EDIT.CHANGE SKW (fetch (SCREENELT GLOBALPART) of (fetch (TEXTELTSELECTION SKTEXTELT) of INITSELECTION)) EDITEDELT))) (SK.UNDO.LAST SKW) (SKED.SET.SELECTION INITSELECTION SKW)) (T (* haven't edited any characters in the current element, just undo the last  thing.) (SK.UNDO.LAST SKW] (T (* user typed a character command to create a new text box.  Create it and put the remaining characters in it and set the cursor there.) (* set the selection so that adding the new text box will create an undo event  for the character change that took place in this text box before the control-cr  was typed.) (SKED.SET.SELECTION (CREATE.TEXT.SELECTION NEWELT NEWLINE# NEWCHAR# NIL NIL (WINDOWPROP SKW 'DSP)) SKW) (SKED.CREATE.NEW.TEXTBOX (fetch (SCREENELT INDIVIDUALGLOBALPART) of NEWELT) SKW (CDR CONTROLCHARTAIL]) (FIRST.N.ELEMENTS [LAMBDA (LST N) (* rrb "20-Jan-86 18:05") (* returns a list of the first N elements of LST) (for I from 1 to N as ELT in LST collect ELT]) (SKED.CREATE.NEW.TEXTBOX [LAMBDA (TEXTELT SKW CHARSTOINSERT ATSCALE) (* ; "Edited 20-Feb-87 17:53 by rrb") (* create a new text box. Create it and put the remaining characters in it and  set the cursor there.) (PROG (CURRENTREGION CURRENTPOS NEWELT) (COND ((EQ (fetch (INDIVIDUALGLOBALPART GTYPE) of TEXTELT) 'TEXT) (* current selection is text, move cursor so that a new text will be created.) (SETQ CURRENTREGION (APPLY (FUNCTION UNIONREGIONS) (fetch (TEXT LISTOFREGIONS) of TEXTELT))) (* get the position of the text now  in.) (SETQ CURRENTPOS (fetch (TEXT LOCATIONLATLON) of TEXTELT)) (* translate the position downward, leaving enough room for another the same  size.) [SETQ CURRENTPOS (CREATEPOSITION (fetch (POSITION XCOORD) of CURRENTPOS) (DIFFERENCE (fetch (POSITION YCOORD) of CURRENTPOS) (fetch (REGION HEIGHT) of CURRENTREGION] (* transform the position into viewer coordinates, subtract 16 for room in  between and set the selection.) [SETQ CURRENTPOS (SK.SCALE.POSITION.INTO.VIEWER CURRENTPOS (OR (NUMBERP ATSCALE) (VIEWER.SCALE SKW] (SKED.SET.SELECTION (CREATEPOSITION (fetch (POSITION XCOORD) of CURRENTPOS) (DIFFERENCE (fetch (POSITION YCOORD) of CURRENTPOS) 16)) SKW) (* insert a space so that there will be a text element here.) (SKED.INSERT [OR CHARSTOINSERT (CONSTANT (LIST (CHARCODE SPACE] SKW ATSCALE) (RETURN)) (T [SETQ CURRENTREGION (COND [(NULL TEXTELT) (* create a region around the cursor) (UNSCALE.REGION (CREATEREGION (DIFFERENCE (LASTMOUSEX SKW) 50) (DIFFERENCE (LASTMOUSEY SKW) 35) 100 70) (OR (NUMBERP ATSCALE) (VIEWER.SCALE SKW] (T (* create a region below the current  element.) (* should limit the dimensions of this box and put it to right if it would  appear off the screen. Later) (SETQ CURRENTREGION (fetch (TEXTBOX TEXTBOXREGION) of TEXTELT)) (create REGION using CURRENTREGION BOTTOM _ (DIFFERENCE (fetch (REGION BOTTOM) of CURRENTREGION ) (PLUS (fetch (REGION HEIGHT) of CURRENTREGION ) (TIMES (OR (NUMBERP ATSCALE) (VIEWER.SCALE SKW)) 16] (SETQ CURRENTREGION (MAP.GLOBAL.REGION.ONTO.GRID CURRENTREGION SKW)) [SETQ NEWELT (COND ((NULL TEXTELT) (* create a default textbox) (SK.TEXTBOX.CREATE CURRENTREGION (fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP SKW ' SKETCHCONTEXT)) (OR (NUMBERP ATSCALE) (SK.INPUT.SCALE SKW)) SKW)) ((EQ (fetch (INDIVIDUALGLOBALPART GTYPE) of TEXTELT) 'TEXTBOX) (* copy the characteristics of the  current text box) (SK.TEXTBOX.CREATE1 CURRENTREGION (fetch (TEXTBOX TEXTBOXBRUSH) of TEXTELT) (LIST "") (fetch (TEXTBOX INITIALSCALE) of TEXTELT) (fetch (TEXTBOX TEXTSTYLE) of TEXTELT) (fetch (TEXTBOX FONT) of TEXTELT) (fetch (TEXTBOX TEXTBOXDASHING) of TEXTELT) (fetch (TEXTBOX TEXTBOXFILLING) of TEXTELT) (fetch (TEXTBOX TEXTCOLOR) of TEXTELT] (SKED.SET.SELECTION (CREATE.TEXT.SELECTION (SKETCH.ADD.AND.DISPLAY NEWELT SKW) 1 0 NIL NIL (WINDOWPROP SKW 'DSP)) SKW))) (* put the remaining characters in the  new textbox.) (AND CHARSTOINSERT (SKED.INSERT CHARSTOINSERT SKW ATSCALE]) (SKED.CHARACTERPOSITION [LAMBDA (STRLST LINE# CHAR#) (* rrb "22-Jan-85 15:39") (* returns the character position of the character at line number LINE# and  character position CHAR#) (PROG ((CHARPOS 0)) [bind NCHARS for STR in STRLST as N from 1 to (SUB1 LINE#) do [SETQ CHARPOS (PLUS CHARPOS (SETQ NCHARS (NCHARS STR] (COND ((NEQ (NTHCHARCODE STR NCHARS) (CHARCODE EOL)) (* unless the last character in the string is CR, add one for the implied space  or CR.) (SETQ CHARPOS (ADD1 CHARPOS] (RETURN (PLUS CHARPOS CHAR#]) (SKED.LINE.AND.CHAR# [LAMBDA (STRLST CHARPOS) (* rrb "14-Jun-85 18:12") (* returns a dotted pair of the line number and character within line position  of a character position.) (bind NCHARS (CHARSLEFT _ CHARPOS) for STR in STRLST as N from 1 do [COND [(EQ (SETQ NCHARS (NCHARS STR)) CHARSLEFT) (* at end of a line. If the line ends in CR, return ptr to beginning of next  line.) (COND ((AND (EQ (NTHCHARCODE STR NCHARS) (CHARCODE EOL)) (GREATERP (LENGTH STRLST) N)) (RETURN (CONS (ADD1 N) 0))) (T (RETURN (CONS N CHARSLEFT] ((IGREATERP NCHARS CHARSLEFT) (RETURN (CONS N CHARSLEFT))) (T (SETQ CHARSLEFT (DIFFERENCE CHARSLEFT (COND ((EQ (NTHCHARCODE STR NCHARS) (CHARCODE EOL)) (* if the line ends in CR, don't add one for the) NCHARS) (T (ADD1 NCHARS] finally (* return something that is after last character of last line.) (RETURN (CONS (LENGTH STRLST) (NCHARS (CAR (LAST STRLST]) (\SKED.DELETE.WORD.FROM.STRING [LAMBDA (STRING) (* rrb "11-Jul-86 17:17") (* returns a string that has the last word of STRING deleted.) (PROG ((END (NCHARS STRING)) CLASS) SKBLANKS (COND ((EQ END 0) (* ran out of characters.) (RETURN)) ((EQ (SETQ CLASS (SK.WORD.BREAK.CLASS (NTHCHARCODE STRING END))) 22) (SETQ END (SUB1 END)) (GO SKBLANKS))) (* now skip characters that have the same class as the first one encountered.) SKSAME (SETQ END (SUB1 END)) (COND ((EQ END 0) (* ran out of characters.) (RETURN)) ((EQ (SK.WORD.BREAK.CLASS (NTHCHARCODE STRING END)) CLASS) (GO SKSAME)) (T (RETURN (SUBSTRING STRING 1 END]) (\SKED.INSERT.CHARS.TO.STR [LAMBDA (CHARCODES INCLUDECR SKW) (* rrb "11-Jul-86 17:18") (DECLARE (SPECVARS NEWSTRS STRPIECE)) (* takes a list of characters and makes it into strings on the free variable  NEWSTRS. The variable STRPIECE is set to the last line of characters.  NEWSTRS is a list of the strings that precede this one which is used in the  case of backspace onto the previous line.) (PROG (LINELST THISLINE REMAININGCHARS CLASS) [for CHAR in CHARCODES do (SELECTQ (SK.GETSYNTAX CHAR) (CHARDELETE (* delete the previous character.) [COND (THISLINE (* easy case of deleting type in.) (SETQ THISLINE (CDR THISLINE))) (LINELST (* deleting a typed in CR.) (SETQ THISLINE (CAR LINELST)) (SETQ LINELST (CDR LINELST))) [STRPIECE (* remove the previous character from  the current string.) (COND ((EQ (NCHARS STRPIECE) 1) (SETQ STRPIECE NIL)) (T (SETQ STRPIECE (SUBSTRING STRPIECE 1 -2] [NEWSTRS (SETQ STRPIECE (CAR (LAST NEWSTRS))) (SETQ NEWSTRS (BUTLAST NEWSTRS)) (COND ((EQ (NTHCHARCODE STRPIECE -1) (CHARCODE EOL)) (* remove previous eol) (COND ((EQ (NCHARS STRPIECE) 1) (SETQ STRPIECE NIL)) (T (SETQ STRPIECE (SUBSTRING STRPIECE 1 -2] (T (* no characters to delete) (FLASHW (TTYDISPLAYSTREAM]) (WORDDELETE (* delete the previous word) (* use the TEdit word bounding readtable.  Code are%: character = 21 -  space = 22 -  punctuation = 20) [COND [[OR THISLINE (PROG1 (SETQ THISLINE (CAR LINELST)) (SETQ LINELST (CDR LINELST] (* easy case of deleting type in.) (* if this line was empty, skip the cr that created it as part of the white  space before the word.) (* skip any whitespace) (COND ([NULL (SETQ THISLINE (for TAIL on THISLINE while (EQ (SK.WORD.BREAK.CLASS (CAR TAIL)) 22) finally (RETURN TAIL] (* the whitespace backed up to the beginning of a line.  quit there.) NIL) (T (SETQ CLASS (SK.WORD.BREAK.CLASS (CAR THISLINE))) (* skip all things of the same class as the first character before the  whitespace) (SETQ THISLINE (for TAIL on THISLINE until (NEQ (SK.WORD.BREAK.CLASS (CAR TAIL)) CLASS) finally (RETURN TAIL] (STRPIECE (* remove the previous character from  the current string.) (SETQ STRPIECE (\SKED.DELETE.WORD.FROM.STRING STRPIECE))) (NEWSTRS [SETQ STRPIECE (\SKED.DELETE.WORD.FROM.STRING (CAR (LAST NEWSTRS] (SETQ NEWSTRS (BUTLAST NEWSTRS))) (T (* no characters to delete) (FLASHW (TTYDISPLAYSTREAM]) (DELETE (* delete selection.  Here that means don't insert anything.)) (UNDO (* by side effect this flushes any characters typed after the undo but it's not  clear where they should go anyway.) (RETURN 'UNDO)) ((REDO FN CMD) (STATUSPRINT SKW " " "Not implemented in this editor. Sorry.")) (COND [(OR (EQ CHAR (CHARCODE EOL)) (EQ CHAR (CHARCODE LINEFEED))) (* eol) (COND ((KEYDOWNP 'CTRL) (* user entered control return, save remaining characters and return indicator) (SETQ REMAININGCHARS (MEMB CHAR CHARCODES)) (RETURN)) (T (SETQ LINELST (CONS (COND (INCLUDECR (* text boxes need to have the CRs  left in.) (CONS (CHARCODE EOL) THISLINE)) (T THISLINE)) LINELST)) (SETQ THISLINE NIL] (T (* add this character onto the front of this line;  reversal will happen before conversion to string and return.) (SETQ THISLINE (CONS CHAR THISLINE] (COND [LINELST (* had a cr in the character set.) [SETQ NEWSTRS (NCONC NEWSTRS [CONS (JOINCHARS STRPIECE (REVERSE (CAR (LAST LINELST] (for CHLST in (REVERSE (BUTLAST LINELST)) collect (STRINGFROMCHARACTERS (REVERSE CHLST] (SETQ STRPIECE (STRINGFROMCHARACTERS (REVERSE THISLINE] [THISLINE (* no new lines, add these characters  onto STRPIECE) (SETQ STRPIECE (JOINCHARS STRPIECE (REVERSE THISLINE] (T (* no new lines, or characters, leave  STRPIECE alone.) NIL)) (RETURN REMAININGCHARS]) (JOINCHARS [LAMBDA (STR CHARCODES) (* rrb "27-Dec-84 16:56") (* makes a string by attaching the list of character codes CHARCODES onto the  end of the string STR.) (COND ((NULL STR) (STRINGFROMCHARACTERS CHARCODES)) (T (CONCAT STR (STRINGFROMCHARACTERS CHARCODES]) (STRINGFROMCHARACTERS [LAMBDA (CHARS) (* rrb "27-Dec-84 16:56") (* makes a string from a list of  characters) (MKSTRING (PACKC CHARS]) (GETALLCHARS [LAMBDA (FILE) (* rrb "11-Jul-86 17:22") (* reads all of the characters that  are on FILE.) (while (\SYSBUFP) collect (\GETKEY]) (CLEANUP.EDIT [LAMBDA (SKW) (* rrb "12-Oct-84 11:23") (* Place holder to propagates the current edit into other windows that might be  viewing the same sketch.) (* called when the cursor leaves the  sketch window.) NIL]) (SKED.NEW.TEXTELT [LAMBDA (OLDGTEXTELT NEWSTRLST) (* rrb "26-Apr-85 15:59") (* creates a new text element by replacing only the list of characters of an  old one.) (create GLOBALPART COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) of OLDGTEXTELT) INDIVIDUALGLOBALPART _ (COND ((EQ (fetch (GLOBALPART GTYPE) of OLDGTEXTELT) 'TEXT) (TEXT.SET.GLOBAL.REGIONS (create TEXT using (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of OLDGTEXTELT ) LISTOFCHARACTERS _ NEWSTRLST) )) (T (TEXTBOX.SET.GLOBAL.REGIONS (create TEXTBOX using (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of OLDGTEXTELT ) LISTOFCHARACTERS _ (OR NEWSTRLST '(""]) ) (* line adding functions) (DEFINEQ (MAP.SCREEN.POSITION.ONTO.GRID [LAMBDA (PT WINDOW FLIPGRIDSENSEFLG) (* rrb "11-Jul-86 15:51") (* maps a point in screen coordinates into the screen coordinate that is  closest to the grid in WINDOW. FLIPGRIDSENSEFLG is used to flip whether to use  the grid or not and allows right buttoning to be the opposite of standard.) (COND [(COND ((WINDOWPROP WINDOW 'USEGRID) (* window is calling for grid. Use it unless grid sense is switched.) (NOT FLIPGRIDSENSEFLG)) (T (* window is not calling for grid, don't use it unless grid sense is switched.) FLIPGRIDSENSEFLG)) (PROG ((GRID (SK.GRIDFACTOR WINDOW)) (SCALE (VIEWER.SCALE WINDOW))) (RETURN (create POSITION XCOORD _ (MAP.SCREEN.ONTO.GRID (fetch (POSITION XCOORD) of PT) SCALE GRID (DSPXOFFSET NIL WINDOW)) YCOORD _ (MAP.SCREEN.ONTO.GRID (fetch (POSITION YCOORD) of PT) SCALE GRID (DSPYOFFSET NIL WINDOW] (T (* avoid pt creation in the non-grid  case.) PT]) (NEAREST.ON.GRID [LAMBDA (X GRIDSIZE) (* rrb "23-Sep-86 10:51") (* returns the point on a grid of size GRIDSIZE that is closest to X) (TIMES GRIDSIZE (FIX (FQUOTIENT [COND ((GREATERP X 0.0) (* assymetry around 0.0) (FPLUS X (FQUOTIENT GRIDSIZE 2.0))) (T (FDIFFERENCE X (FQUOTIENT GRIDSIZE 2.0] GRIDSIZE]) (SK.MIDDLE.TITLEFN [LAMBDA (SKW STANDARDMENUFLG) (* rrb "23-Sep-86 17:59") (* the middle button when down in the title bar.  If the operations menu is not up, put it up, wait for a selection then take it  down.) (PROG (OPMENUW) (OR [SETQ OPMENUW (COND (STANDARDMENUFLG (MENUWINDOW (CREATE.SKETCHW.COMMANDMENU NIL NIL T SKW ) T)) (T (SK.GET.VIEWER.POPUP.MENU SKW] (RETURN)) (* move opmenu to near cursor) [MOVEW OPMENUW [IMIN (ADD1 LASTMOUSEX) (IDIFFERENCE (BITMAPWIDTH (SCREENBITMAP SKW)) (WINDOWPROP OPMENUW 'WIDTH] (IMAX 0 (IMIN (IDIFFERENCE LASTMOUSEY (IQUOTIENT (WINDOWPROP OPMENUW 'HEIGHT) 2)) (IDIFFERENCE (BITMAPHEIGHT (SCREENBITMAP SKW)) (WINDOWPROP OPMENUW 'HEIGHT] (RETURN (PROG ([OPMENU (CAR (WINDOWPROP OPMENUW 'MENU] (DSP (WINDOWPROP OPMENUW 'DSP)) SELCOMMAND) [SETQ SELCOMMAND (CADR (CAR (RESETLST (RESETSAVE (OPENW OPMENUW) (LIST 'CLOSEW OPMENUW)) (MENU.HANDLER OPMENU DSP T T NIL] (* evaluate menu form after image has  been taken down.) (RETURN (SK.APPLY.MENU.COMMAND SELCOMMAND SKW]) (WB.BUTTON.HANDLER [LAMBDA (W) (* ; "Edited 19-Nov-87 11:37 by rrb") (* handles a button event in a  whiteboard window.) (TOTOPW W) (RESETLST (COND ([AND (LASTMOUSESTATE RIGHT) (NOT (INSIDEP (DSPCLIPPINGREGION NIL W) (LASTMOUSEX W) (LASTMOUSEY W] (* handle the right button with out  the lock) (DOWINDOWCOM W)) [(OBTAIN.MONITORLOCK (SKETCH.MONITORLOCK W) T T) (* * make sure nothing else is happening in the window.) (PROG (ACTIVEREGION BUTTONFN X Y IMAGEOBJ) (RETURN (COND ((OR (.DELETEKEYDOWNP.) (.MOVEKEYDOWNP.)) (* if the DELETE key is held down, handle it with the copy button event fn.) (SK.COPY.BUTTONEVENTFN W)) [(AND [NOT (INSIDEP (DSPCLIPPINGREGION NIL W) (SETQ X (LASTMOUSEX W)) (SETQ Y (LASTMOUSEY W] (LASTMOUSESTATE (NOT UP))) (* title bar or border action) (COND ((LASTMOUSESTATE MIDDLE) (* offer command menu) (SK.MIDDLE.TITLEFN W)) ((LASTMOUSESTATE RIGHT) (DOWINDOWCOM W] [(AND (LASTMOUSESTATE (OR LEFT MIDDLE)) (for ELT in (LOCALSPECS.FROM.VIEWER W) do (COND ((AND (SETQ ACTIVEREGION (fetch (SCREENELT LOCALHOTREGION) of ELT)) (SETQ BUTTONFN (GETSKETCHPROP W 'BUTTONEVENTINFN)) (INSIDEP ACTIVEREGION X Y)) (* look for an element with a hot region.  This is done before the image object region so that the image objects  function can be overridden.) (* inside of the hot region for an element with a button event fn.) (APPLY* BUTTONFN W (fetch (SCREENELT GLOBALPART) of ELT)) (RETURN T)) ([AND (type? SKIMAGEOBJ (fetch (SCREENELT INDIVIDUALGLOBALPART) of ELT)) (INIMAGEOBJ ELT X Y) (NOT (SK.ELEMENT.PROTECTED? (fetch (SCREENELT GLOBALPART) of ELT) 'BUTTONEVENTINFN] (* element is frozen, don't call it's imageobject fn.  The rationale here is that the buttonineventfn is often used to edit the  image object.) (* inside of a imageobj, run its  BUTTONEVENTINFN element.) (* there are miriad other arguments to the BUTTONEVENTINFN that are not  applicable.) (COND ((EQ [RESETLST (RESETSAVE NIL (LIST 'DSPCLIPPINGREGION (DSPCLIPPINGREGION (INTERSECTREGIONS (fetch (LOCALSKIMAGEOBJ SKIMOBJLOCALREGION ) of (fetch (SCREENELT LOCALPART) of ELT)) (DSPCLIPPINGREGION NIL W)) W) W)) (APPLY* [fetch (IMAGEFNS BUTTONEVENTINFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of (SETQ IMAGEOBJ (fetch (SKIMAGEOBJ SKIMAGEOBJ) of (fetch (SCREENELT INDIVIDUALGLOBALPART ) of ELT] IMAGEOBJ (GETSTREAM W 'OUTPUT) NIL [DIFFERENCE X (fetch (REGION LEFT) of (SETQ ACTIVEREGION (SK.ITEM.REGION ELT] (DIFFERENCE Y (fetch (REGION BOTTOM) of ACTIVEREGION)) W NIL (CAR (DECODEBUTTONS LASTMOUSEBUTTONS] 'CHANGED) (* the extra arguments to the buttonineventfn are to make it look more like  the call an image object gets from Tedit.) (* element changed, update the local  fields and redisplay it.) (SKETCH.ELEMENT.CHANGED W (fetch (SCREENELT GLOBALPART) of ELT) W))) (* exit loop) (RETURN T] [(LASTMOUSESTATE LEFT) (* move cursor) (RESET.LINE.BEING.INPUT W) (SKED.MOVE.SELECTION W (WINDOWPROP W 'USEGRID] ((LASTMOUSESTATE RIGHT) (* extend selection) (RESET.LINE.BEING.INPUT W) (SKED.EXTEND.SELECTION W)) ((LASTMOUSESTATE MIDDLE) (* add a point to the current line) (WB.ADD.NEW.POINT W] (T (STATUSPRINT W " " "Sketch operation in progress. Please wait."]) (WB.ADD.NEW.POINT [LAMBDA (WIN) (* rrb "12-May-86 18:25") (* tracks the cursor with a point cursor drawing a rubberband line until the  cursor is let up. Nothing happens if cursor goes outside.  Adds line segment to the currently being built line.) (PROG ((LINEPTS (WINDOWPROP WIN 'INPUTLINE)) PT ELT) (* INPUTLINE are the points on the curve being input in most recently added  first.) (COND [(NULL LINEPTS) (* this is the first point being put  down;) (COND ((SETQ PT (SK.READ.POINT.WITH.FEEDBACK WIN POINTREADINGCURSOR NIL NIL 'LEFT)) (* put the local wire element on the property list so that it can be added to.) (WINDOWPROP WIN 'INPUTLINE PT] [(type? INPUTPT LINEPTS) (* this is the second point being put down, make a line for it) (COND ((SETQ PT (WB.RUBBERBAND.POSITION (fetch (INPUTPT INPUT.POSITION) of LINEPTS) WIN)) (* read the second point of the line on the upclick and make a sketch element) (SETQ ELT (SKETCH.ADD.AND.DISPLAY (WIRE.INPUTFN WIN (LIST ( SK.MAP.INPUT.PT.TO.GLOBAL LINEPTS WIN) ( SK.MAP.INPUT.PT.TO.GLOBAL PT WIN))) WIN T)) (WINDOWPROP WIN 'INPUTLINE (COND ((fetch (SKETCHCONTEXT SKETCHLINEMODE) of (WINDOWPROP WIN 'SKETCHCONTEXT)) (* T indicates two point default.  Start a new line.) NIL) (T (* put the local wire element on the property list so that it can be added to.) ELT] ((type? WIRE (fetch (SCREENELT INDIVIDUALGLOBALPART) of LINEPTS)) (* add this point to all this sketch.) (COND ((SETQ PT (WB.RUBBERBAND.POSITION [CAR (LAST (fetch KNOTS of (fetch (SCREENELT LOCALPART) of LINEPTS] WIN)) (WINDOWPROP WIN 'INPUTLINE (WIRE.ADD.POINT.TO.END LINEPTS PT WIN]) (WB.DRAWLINE [LAMBDA (WIREELT STREAM REG OPERATION CLOSEDFLG DASHING BRUSH) (* rrb " 6-May-86 17:43") (* draws a line from its white board  element.) (PROG ((LWIRE (fetch (SCREENELT LOCALPART) of WIREELT)) (GWIRE (fetch (SCREENELT INDIVIDUALGLOBALPART) of WIREELT)) (BRUSHSIZE (IMAX (FIXR (fetch (BRUSH BRUSHSIZE) of BRUSH)) 1)) (BRUSHCOLOR (fetch (BRUSH BRUSHCOLOR) of BRUSH)) PTS LOCALARROWPTS GARROWSPECS) (COND ((SETQ PTS (fetch (LOCALWIRE KNOTS) of LWIRE)) (SETQ GARROWSPECS (fetch (WIRE WIREARROWHEADS) of GWIRE)) (SETQ LOCALARROWPTS (fetch (LOCALWIRE ARROWHEADPTS) of LWIRE)) (SETQ PTS (\SK.ADJUST.FOR.ARROWHEADS PTS LOCALARROWPTS GARROWSPECS STREAM)) (COND [(NEQ (fetch (BRUSH BRUSHSHAPE) of BRUSH) 'ROUND) (* use the slower curve drawing method  that handles brushes) (for PTTAIL on PTS while (CDR PTTAIL) do (DRAWCURVE (LIST (CAR PTTAIL) (CADR PTTAIL)) NIL BRUSH DASHING STREAM) finally (COND (CLOSEDFLG (* if closed, finish with a line back to the origin.) (DRAWCURVE (LIST (CAR PTTAIL) (CAR PTS)) NIL BRUSH DASHING STREAM)) (T (* if not closed, check for  arrowheads.) (DRAWARROWHEADS GARROWSPECS LOCALARROWPTS STREAM BRUSH OPERATION] (T (OR (EQ BRUSHSIZE 1) (DRAWCURVE (LIST (CAR PTS)) NIL BRUSH NIL STREAM)) (for PTTAIL on PTS while (CDR PTTAIL) do (DRAWLINE (fetch (POSITION XCOORD) of (CAR PTTAIL)) (fetch (POSITION YCOORD) of (CAR PTTAIL)) (fetch (POSITION XCOORD) of (CADR PTTAIL)) (fetch (POSITION YCOORD) of (CADR PTTAIL)) BRUSHSIZE OPERATION STREAM BRUSHCOLOR DASHING) (* put a round shape at each  intersection point.) (OR (EQ BRUSHSIZE 1) (DRAWCURVE (LIST (CADR PTTAIL)) NIL BRUSH NIL STREAM)) finally (COND (CLOSEDFLG (* if closed, finish with a line back to the origin.) (DRAWLINE (fetch (POSITION XCOORD) of (CAR PTTAIL)) (fetch (POSITION YCOORD) of (CAR PTTAIL)) (fetch (POSITION XCOORD) of (CAR PTS)) (fetch (POSITION YCOORD) of (CAR PTS)) BRUSHSIZE OPERATION STREAM BRUSHCOLOR DASHING)) (T (* if not closed, check for  arrowheads.) (DRAWARROWHEADS GARROWSPECS LOCALARROWPTS STREAM BRUSH OPERATION ]) (WB.RUBBERBAND.POSITION [LAMBDA (STARTPOSITION WINDOW) (* rrb "11-Jul-86 15:51") (* gets the other end of a line via a rubberband prompting) (SK.READ.POINT.WITH.FEEDBACK WINDOW POINTREADINGCURSOR (FUNCTION SK.RUBBERBAND.FEEDBACKFN) (LIST STARTPOSITION (MAX (TIMES [fetch (BRUSH BRUSHSIZE) of (fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP WINDOW 'SKETCHCONTEXT] (QUOTIENT (SK.INPUT.SCALE WINDOW) (VIEWER.SCALE WINDOW))) 1)) 'LEFT]) (SK.RUBBERBAND.FEEDBACKFN [LAMBDA (X Y WINDOW ORIGPT&SIZE) (* rrb "12-May-86 18:01") (* provides the rubberbanding feedback for the user inputting a point for an  open wire from the middle button.) (SHOWSKETCHXY X Y WINDOW) (DRAWLINE (fetch (POSITION XCOORD) of (CAR ORIGPT&SIZE)) (fetch (POSITION YCOORD) of (CAR ORIGPT&SIZE)) X Y (CADR ORIGPT&SIZE) 'INVERT WINDOW]) (RESET.LINE.BEING.INPUT [LAMBDA (SKW) (* rrb "31-MAR-83 18:03") (* resets the line that is being input by the user.) (WINDOWPROP SKW 'INPUTLINE NIL]) ) (DEFINEQ (NEAREST.EXISTING.POSITION [LAMBDA (SKW) (* returns the existing position of skw that is closed to the lastmouse x and  y.) (LASTMOUSEPOSITION SKW]) (WB.NEARPT [LAMBDA (TARGETPT HITPT) (* rrb " 4-MAR-83 16:22") (* returns T if HITPT is "near"  TARGETPT.) (PROG ((TX (fetch (POSITION XCOORD) of TARGETPT)) (TY (fetch (POSITION YCOORD) of TARGETPT)) (HX (fetch (POSITION XCOORD) of HITPT)) (HY (fetch (POSITION YCOORD) of HITPT)) (WB.POINT.WIDTH 4)) (RETURN (AND (IGREATERP HX (IDIFFERENCE TX WB.POINT.WIDTH)) (IGREATERP (IPLUS TX WB.POINT.WIDTH) HX) (IGREATERP HY (IDIFFERENCE TY WB.POINT.WIDTH)) (IGREATERP (IPLUS TY WB.POINT.WIDTH) HY]) (LASTMOUSEPOSITION [LAMBDA (WIN) (create POSITION XCOORD _ (LASTMOUSEX WIN) YCOORD _ (LASTMOUSEY WIN]) ) (PUTPROPS SKETCHEDIT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2365 39501 (BUTLAST 2375 . 2723) (CHAR.BEGIN 2725 . 4650) (CLOSEST.CHAR 4652 . 8875) ( CLOSEST.LINE 8877 . 9439) (FLASHW 9441 . 9598) (HILITE.LINE 9600 . 10419) (HILITE.TEXT 10421 . 12069) (IN.TEXT.EXTEND 12071 . 15344) (INIMAGEOBJ 15346 . 15851) (INTEXT 15853 . 16350) (NEW.TEXT.EXTEND 16352 . 18571) (NEW.TEXT.SELECTIONP 18573 . 18753) (NTHCHARWIDTH 18755 . 19012) (NTHLOCALREGION 19014 . 19252) (ONCHAR 19254 . 19649) (SHOW.EXTENDED.SELECTION.FEEDBACK 19651 . 20586) (SHOW.FEEDBACK 20588 . 21078) (SHOW.FEEDBACK.BOX 21080 . 22162) (SELECTION.POSITION 22164 . 22956) (SKED.CLEAR.SELECTION 22958 . 23481) (SKETCH.CLEANUP 23483 . 25397) (SK.ENTER.EDIT.CHANGE 25399 . 26944) ( SKED.REMOVE.OTHER.SELECTIONS 26946 . 27373) (SKED.EXTEND.SELECTION 27375 . 28840) (SKED.MOVE.SELECTION 28842 . 34003) (CREATE.TEXT.SELECTION 34005 . 34521) (SKED.SELECTION.FEEDBACK 34523 . 36179) ( SKED.SET.EXTENDSELECTION 36181 . 36498) (SKED.SET.SELECTION 36500 . 36900) (LINE.BEGIN 36902 . 37456) (SELECTION.GREATERP 37458 . 38253) (SK.WORD.BREAK.CLASS 38255 . 39095) (SK.GETSYNTAX 39097 . 39499)) ( 40343 86077 (WB.EDITOR 40353 . 41678) (SK.TTYENTRYFN 41680 . 41958) (SK.TTYEXITFN 41960 . 42229) ( SKED.INSERT 42231 . 42659) (\SKED.INSERT 42661 . 63783) (FIRST.N.ELEMENTS 63785 . 64052) ( SKED.CREATE.NEW.TEXTBOX 64054 . 70583) (SKED.CHARACTERPOSITION 70585 . 71372) (SKED.LINE.AND.CHAR# 71374 . 73005) (\SKED.DELETE.WORD.FROM.STRING 73007 . 74046) (\SKED.INSERT.CHARS.TO.STR 74048 . 82459) (JOINCHARS 82461 . 82848) (STRINGFROMCHARACTERS 82850 . 83175) (GETALLCHARS 83177 . 83518) ( CLEANUP.EDIT 83520 . 83972) (SKED.NEW.TEXTELT 83974 . 86075)) (86112 107120 ( MAP.SCREEN.POSITION.ONTO.GRID 86122 . 87571) (NEAREST.ON.GRID 87573 . 88117) (SK.MIDDLE.TITLEFN 88119 . 90062) (WB.BUTTON.HANDLER 90064 . 97886) (WB.ADD.NEW.POINT 97888 . 101217) (WB.DRAWLINE 101219 . 105453) (WB.RUBBERBAND.POSITION 105455 . 106372) (SK.RUBBERBAND.FEEDBACKFN 106374 . 106878) ( RESET.LINE.BEING.INPUT 106880 . 107118)) (107121 108362 (NEAREST.EXISTING.POSITION 107131 . 107333) ( WB.NEARPT 107335 . 108220) (LASTMOUSEPOSITION 108222 . 108360))))) STOP \ No newline at end of file diff --git a/library/SKETCHELEMENTS b/library/SKETCHELEMENTS new file mode 100644 index 00000000..9216fab9 --- /dev/null +++ b/library/SKETCHELEMENTS @@ -0,0 +1,7756 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "31-Dec-2000 10:58:28" {DSK}medley3.5>library>SKETCHELEMENTS.;2 553808 changes to%: (FNS ADD.KNOWN.SKETCH.FONT SK.PICK.FONT SK.CHOOSE.TEXT.FONT) previous date%: "21-Jan-93 12:00:34" {DSK}medley3.5>library>SKETCHELEMENTS.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1990, 1991, 1992, 1993, 2000 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SKETCHELEMENTSCOMS) (RPAQQ SKETCHELEMENTSCOMS ( (* ;  "contains the functions need to implement the sketch basic element types") (FNS INIT.SKETCH.ELEMENTS CREATE.SKETCH.ELEMENT.TYPE SKETCH.ELEMENT.TYPEP SKETCH.ELEMENT.NAMEP \CURSOR.IN.MIDDLE.MENU) (COMS (* ; "color and filling stuff") (FNS SKETCHINCOLORP READ.COLOR.CHANGE) (INITVARS (SKETCHINCOLORFLG) (FILLPOLYGONFLG T) (FILLINGMODEFLG T)) (INITVARS (SK.DEFAULT.BACKCOLOR) (SK.DEFAULT.OPERATION)) (GLOBALVARS SKETCHINCOLORFLG SK.DEFAULT.BACKCOLOR) (RECORDS SKFILLING) (* ;; "fns included until system is fixed so that it is ok to call DSPCOLOR in a system without color loaded. Should be removed after J release.") (FNS SK.CREATE.DEFAULT.FILLING SKFILLINGP SK.INSURE.FILLING SK.INSURE.COLOR) (FNS SK.TRANSLATE.MODE SK.CHANGE.FILLING.MODE READ.FILLING.MODE)) (COMS (FNS SKETCH.CREATE.CIRCLE CIRCLE.EXPANDFN CIRCLE.DRAWFN \CIRCLE.DRAWFN1 CIRCLE.INPUTFN SK.UPDATE.CIRCLE.AFTER.CHANGE SK.READ.CIRCLE.POINT SK.SHOW.CIRCLE CIRCLE.INSIDEFN CIRCLE.REGIONFN CIRCLE.GLOBALREGIONFN CIRCLE.TRANSLATE CIRCLE.READCHANGEFN CIRCLE.TRANSFORMFN CIRCLE.TRANSLATEPTS SK.CIRCLE.CREATE SET.CIRCLE.SCALE SK.BRUSH.READCHANGE) (FNS SK.INSURE.BRUSH SK.INSURE.DASHING) (RECORDS BRUSH) (DECLARE%: DONTCOPY (RECORDS LOCALCIRCLE CIRCLE)) (UGLYVARS CIRCLEICON) (CURSORS CIRCLE.CENTER CIRCLE.EDGE) (INITVARS [SK.DEFAULT.BRUSH (CONS 'ROUND (CONS 1 (CONS 'BLACK NIL] (* ;  "Original was (create BRUSH BRUSHSHAPE _ 'ROUND BRUSHSIZE _ 1 BRUSHCOLOR _ 'BLACK).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (SK.DEFAULT.DASHING) (SK.DEFAULT.TEXTURE)) (GLOBALVARS SK.DEFAULT.BRUSH SK.DEFAULT.DASHING SK.DEFAULT.TEXTURE)) (COMS (FNS SKETCH.CREATE.ELLIPSE ELLIPSE.EXPANDFN ELLIPSE.DRAWFN ELLIPSE.INPUTFN SK.READ.ELLIPSE.MAJOR.PT SK.SHOW.ELLIPSE.MAJOR.RADIUS SK.READ.ELLIPSE.MINOR.PT SK.SHOW.ELLIPSE.MINOR.RADIUS ELLIPSE.INSIDEFN ELLIPSE.CREATE SK.UPDATE.ELLIPSE.AFTER.CHANGE ELLIPSE.REGIONFN ELLIPSE.GLOBALREGIONFN ELLIPSE.TRANSLATEFN ELLIPSE.TRANSFORMFN ELLIPSE.TRANSLATEPTS MARK.SPOT DISTANCEBETWEEN SK.DISTANCE.TO SQUARE COMPUTE.ELLIPSE.ORIENTATION SK.COMPUTE.ELLIPSE.MINOR.RADIUS.PT) (DECLARE%: DONTCOPY (RECORDS LOCALELLIPSE ELLIPSE)) (UGLYVARS ELLIPSEICON) (CURSORS ELLIPSE.CENTER ELLIPSE.SEMI.MAJOR ELLIPSE.SEMI.MINOR)) (COMS (FNS SKETCH.CREATE.OPEN.CURVE OPENCURVE.INPUTFN SK.CURVE.CREATE MAXXEXTENT MAXYEXTENT KNOT.SET.SCALE.FIELD OPENCURVE.DRAWFN OPENCURVE.EXPANDFN OPENCURVE.READCHANGEFN OPENCURVE.TRANSFORMFN OPENCURVE.TRANSLATEFN OPENCURVE.TRANSLATEPTSFN SKETCH.CREATE.CLOSED.CURVE CLOSEDCURVE.DRAWFN CLOSEDCURVE.EXPANDFN CLOSEDCURVE.REGIONFN CLOSEDCURVE.GLOBALREGIONFN READ.LIST.OF.POINTS CLOSEDCURVE.INPUTFN CLOSEDCURVE.READCHANGEFN CLOSEDCURVE.TRANSFORMFN CLOSEDCURVE.TRANSLATEPTSFN INVISIBLEPARTP SHOWSKETCHPOINT SHOWSKETCHXY KNOTS.REGIONFN OPENWIRE.GLOBALREGIONFN CURVE.REGIONFN OPENCURVE.GLOBALREGIONFN KNOTS.TRANSLATEFN REGION.CONTAINING.PTS) (FNS CHANGE.ELTS.BRUSH.SIZE CHANGE.ELTS.BRUSH CHANGE.ELTS.BRUSH.SHAPE SK.CHANGE.BRUSH.SHAPE SK.CHANGE.BRUSH.COLOR SK.CHANGE.BRUSH.SIZE SK.CHANGE.ANGLE SK.CHANGE.ARC.DIRECTION SK.SET.DEFAULT.BRUSH.SIZE READSIZECHANGE) (FNS SK.CHANGE.ELEMENT.KNOTS) (FNS SK.INSURE.POINT.LIST SK.INSURE.POSITION) (DECLARE%: DONTCOPY (RECORDS KNOTELT LOCALCURVE OPENCURVE CLOSEDCURVE LOCALCLOSEDCURVE LOCALCLOSEDWIRE)) (UGLYVARS OPENCURVEICON CLOSEDCURVEICON) (CURSORS CURVE.KNOT)) (COMS (FNS SKETCH.CREATE.WIRE CLOSEDWIRE.EXPANDFN KNOTS.INSIDEFN OPEN.WIRE.DRAWFN WIRE.EXPANDFN SK.UPDATE.WIRE.ELT.AFTER.CHANGE OPENWIRE.READCHANGEFN OPENWIRE.TRANSFORMFN OPENWIRE.TRANSLATEFN OPENWIRE.TRANSLATEPTSFN WIRE.INPUTFN SK.READ.WIRE.POINTS SK.READ.POINTS.WITH.FEEDBACK OPENWIRE.FEEDBACKFN CLOSEDWIRE.FEEDBACKFN CLOSEDWIRE.REGIONFN CLOSEDWIRE.GLOBALREGIONFN SK.WIRE.CREATE WIRE.ADD.POINT.TO.END READ.ARROW.CHANGE CHANGE.ELTS.ARROWHEADS) (FNS SKETCH.CREATE.CLOSED.WIRE CLOSED.WIRE.INPUTFN CLOSED.WIRE.DRAWFN CLOSEDWIRE.READCHANGEFN CLOSEDWIRE.TRANSFORMFN CLOSEDWIRE.TRANSLATEPTSFN) (FNS SK.EXPAND.ARROWHEADS SK.COMPUTE.ARC.ARROWHEAD.POINTS ARC.ARROWHEAD.POINTS SET.ARC.ARROWHEAD.POINTS SET.OPENCURVE.ARROWHEAD.POINTS SK.COMPUTE.CURVE.ARROWHEAD.POINTS SET.WIRE.ARROWHEAD.POINTS SK.COMPUTE.WIRE.ARROWHEAD.POINTS SK.EXPAND.ARROWHEAD CHANGED.ARROW SK.CHANGE.ARROWHEAD SK.CHANGE.ARROWHEAD1 SK.CREATE.ARROWHEAD SK.ARROWHEAD.CREATE SK.ARROWHEAD.END.TEST READ.ARROWHEAD.END ARROW.HEAD.POSITIONS ARROWHEAD.POINTS.LIST CURVE.ARROWHEAD.POINTS LEFT.MOST.IS.BEGINP WIRE.ARROWHEAD.POINTS DRAWARROWHEADS \SK.DRAW.TRIANGLE.ARROWHEAD \SK.ENDPT.OF.ARROW \SK.ADJUST.FOR.ARROWHEADS SK.SET.ARROWHEAD.LENGTH SK.SET.ARROWHEAD.ANGLE SK.SET.ARROWHEAD.TYPE SK.SET.LINE.ARROWHEAD SK.UPDATE.ARROWHEAD.FORMAT SK.SET.LINE.LENGTH.MODE) (FNS SK.INSURE.ARROWHEADS SK.ARROWHEADP) (DECLARE%: DONTCOPY (RECORDS LOCALWIRE WIRE CLOSEDWIRE LOCALCLOSEDWIRE)) (RECORDS ARROWHEAD) (UGLYVARS VSHAPE.ARROWHEAD.BITMAP TRIANGLE.ARROWHEAD.BITMAP SOLIDTRIANGLE.ARROWHEAD.BITMAP CURVEDV.ARROWHEAD.BITMAP) (UGLYVARS WIREICON CLOSEDWIREICON) (INITVARS (SK.ARROWHEAD.ANGLE.INCREMENT 5) (SK.ARROWHEAD.LENGTH.INCREMENT 2)) (ADDVARS (SK.ARROWHEAD.TYPES LINE CLOSEDLINE CURVE SOLID)) (INITVARS (SK.DEFAULT.ARROW.LENGTH 8) (SK.DEFAULT.ARROW.TYPE 'CURVE) (SK.DEFAULT.ARROW.ANGLE 18.0)) (GLOBALVARS SK.DEFAULT.ARROW.LENGTH SK.DEFAULT.ARROW.TYPE SK.DEFAULT.ARROW.ANGLE SK.ARROWHEAD.TYPES) (INITVARS (SK.ARROW.END.MENU) (SK.ARROW.EDIT.MENU))) (COMS (* ;  "stuff to support the text element type.") (FNS SKETCH.CREATE.TEXT TEXT.CHANGEFN TEXT.READCHANGEFN \SK.READ.FONT.SIZE1 SK.TEXT.ELT.WITH.SAME.FIELDS SK.READFONTFAMILY CLOSE.PROMPT.WINDOW TEXT.DRAWFN TEXT.DRAWFN1 TEXT.INSIDEFN TEXT.EXPANDFN SK.TEXT.LINE.REGIONS TEXT.UPDATE.GLOBAL.REGIONS REL.MOVE.REGION LTEXT.LINE.REGIONS TEXT.INPUTFN READ.TEXT TEXT.POSITION.AND.CREATE CREATE.TEXT.ELEMENT SK.UPDATE.TEXT.AFTER.CHANGE SK.TEXT.FROM.TEXTBOX TEXT.SET.GLOBAL.REGIONS TEXT.REGIONFN TEXT.GLOBALREGIONFN TEXT.TRANSLATEFN TEXT.TRANSFORMFN TEXT.TRANSLATEPTSFN TEXT.UPDATEFN SK.CHANGE.TEXT TEXT.SET.SCALES BREAK.AT.CARRIAGE.RETURNS) (FNS ADD.KNOWN.SKETCH.FONT SK.PICK.FONT SK.CHOOSE.TEXT.FONT SK.NEXTSIZEFONT SK.DECREASING.FONT.LIST SK.GUESS.FONTSAVAILABLE) (INITVARS (\KNOWN.SKETCH.FONTSIZES)) (GLOBALVARS \KNOWN.SKETCH.FONTSIZES) (DECLARE%: DONTCOPY (RECORDS TEXT LOCALTEXT)) (FNS SK.SET.FONT SK.SET.TEXT.FONT SK.SET.TEXT.SIZE SK.SET.TEXT.HORIZ.ALIGN SK.READFONTSIZE SK.COLLECT.FONT.SIZES SK.SET.TEXT.VERT.ALIGN SK.SET.TEXT.LOOKS SK.SET.DEFAULT.TEXT.FACE) (FNS CREATE.SKETCH.TERMTABLE) (FNS SK.FONT.LIST SK.INSURE.FONT SK.INSURE.STYLE SK.INSURE.TEXT) (VARS INDICATE.TEXT.SHADE) [INITVARS (SK.DEFAULT.FONT) (SK.DEFAULT.TEXT.ALIGNMENT '(CENTER BASELINE] (INITVARS \FONTSONFILE) (ADDVARS (SK.HORIZONTAL.STYLES LEFT RIGHT CENTER) (SK.VERTICAL.STYLES TOP CENTER BASELINE BOTTOM)) (VARS (SKETCH.TERMTABLE (CREATE.SKETCH.TERMTABLE))) (GLOBALVARS SKETCH.TERMTABLE SK.DEFAULT.TEXT.ALIGNMENT INDICATE.TEXT.SHADE \FONTSONFILE SK.HORIZONTAL.STYLES SK.VERTICAL.STYLES)) (COMS (* ;  "stuff for supporting the TEXTBOX sketch element.") (FNS SKETCH.CREATE.TEXTBOX SK.COMPUTE.TEXTBOX.REGION.FOR.STRING SK.BREAK.INTO.LINES SK.BRUSH.SIZE SK.TEXTBOX.CREATE SK.TEXTBOX.CREATE1 SK.UPDATE.TEXTBOX.AFTER.CHANGE SK.TEXTBOX.POSITION.IN.BOX TEXTBOX.CHANGEFN TEXTBOX.DRAWFN SK.TEXTURE.AROUND.REGIONS ALL.EMPTY.REGIONS TEXTBOX.EXPANDFN TEXTBOX.INPUTFN TEXTBOX.INSIDEFN TEXTBOX.REGIONFN TEXTBOX.GLOBALREGIONFN TEXTBOX.SET.GLOBAL.REGIONS TEXTBOX.TRANSLATEFN TEXTBOX.TRANSLATEPTSFN TEXTBOX.TRANSFORMFN TEXTBOX.UPDATEFN TEXTBOX.READCHANGEFN SK.TEXTBOX.TEXT.POSITION SK.TEXTBOX.FROM.TEXT ADD.EOLS) (DECLARE%: DONTCOPY (RECORDS LOCALTEXTBOX TEXTBOX)) (COMS (* ;  "stuff to handle default alignment for text boxes") (FNS SK.SET.TEXTBOX.VERT.ALIGN SK.SET.TEXTBOX.HORIZ.ALIGN) (VARS TEXTBOXICON) [INITVARS (SK.DEFAULT.TEXTBOX.ALIGNMENT '(CENTER CENTER] (GLOBALVARS SK.DEFAULT.TEXTBOX.ALIGNMENT))) (COMS (* ;  "functions to implement the box sketch element.") (FNS SKETCH.CREATE.BOX SK.BOX.DRAWFN BOX.DRAWFN1 KNOTS.OF.REGION SK.DRAWAREABOX SK.DRAWBOX SK.BOX.EXPANDFN SK.BOX.GETREGIONFN BOX.SET.SCALES SK.BOX.INPUTFN SK.BOX.CREATE SK.UPDATE.BOX.AFTER.CHANGE SK.BOX.INSIDEFN SK.BOX.REGIONFN SK.BOX.GLOBALREGIONFN SK.BOX.READCHANGEFN SK.CHANGE.FILLING SK.CHANGE.FILLING.COLOR SK.BOX.TRANSLATEFN SK.BOX.TRANSFORMFN SK.BOX.TRANSLATEPTSFN UNSCALE.REGION.TO.GRID INCREASEREGION INSUREREGIONSIZE EXPANDREGION REGION.FROM.COORDINATES) (DECLARE%: DONTCOPY (RECORDS BOX LOCALBOX)) (UGLYVARS BOXICON)) (COMS (* ;  "fns for the arc sketch element type") (FNS SKETCH.CREATE.ARC ARC.DRAWFN ARC.EXPANDFN ARC.INPUTFN SK.INVERT.CIRCLE SK.READ.ARC.ANGLE.POINT SK.SHOW.ARC ARC.CREATE SK.UPDATE.ARC.AFTER.CHANGE ARC.MOVEFN ARC.TRANSLATEPTS ARC.INSIDEFN ARC.REGIONFN ARC.GLOBALREGIONFN ARC.TRANSLATE ARC.TRANSFORMFN ARC.READCHANGEFN) (FNS SK.COMPUTE.ARC.ANGLE.PT SK.COMPUTE.ARC.ANGLE.PT.FROM.ANGLE SK.COMPUTE.ARC.PTS SK.SET.ARC.DIRECTION SK.SET.ARC.DIRECTION.CW SK.SET.ARC.DIRECTION.CCW SK.COMPUTE.SLOPE.OF.LINE SK.CREATE.ARC.USING SET.ARC.SCALES) (FNS SK.INSURE.DIRECTION) (INITVARS (SK.NUMBER.OF.POINTS.IN.ARC 8)) (GLOBALVARS SK.NUMBER.OF.POINTS.IN.ARC) (DECLARE%: DONTCOPY (RECORDS ARC LOCALARC)) (CURSORS ARC.RADIUS.CURSOR ARC.ANGLE.CURSOR CW.ARC.ANGLE.CURSOR CW.ARC.RADIUS.CURSOR) (UGLYVARS ARCICON)) (COMS (* ;  "property getting and setting stuff") (FNS GETSKETCHELEMENTPROP \SK.GET.ARC.ANGLEPT \GETSKETCHELEMENTPROP1 \SK.GET.BRUSH \SK.GET.FILLING \SK.GET.ARROWHEADS \SK.GET.FONT \SK.GET.JUSTIFICATION \SK.GET.DIRECTION \SK.GET.DASHING PUTSKETCHELEMENTPROP \SK.PUT.FILLING ADDSKETCHELEMENTPROP REMOVESKETCHELEMENTPROP \SK.PUT.FONT \SK.PUT.JUSTIFICATION \SK.PUT.DIRECTION \SK.PUT.DASHING \SK.PUT.BRUSH \SK.PUT.ARROWHEADS SK.COPY.ELEMENT.PROPERTY.LIST SKETCH.UPDATE SKETCH.UPDATE1 \SKELT.GET.SCALE \SKELT.PUT.SCALE \SKELT.PUT.DATA SK.REPLACE.TEXT.IN.ELEMENT \SKELT.GET.DATA \SK.GET.1STCONTROLPT \SK.PUT.1STCONTROLPT \SK.GET.2NDCONTROLPT \SK.PUT.2NDCONTROLPT \SK.GET.3RDCONTROLPT \SK.PUT.3RDCONTROLPT) (FNS LOWERLEFTCORNER UPPERRIGHTCORNER)))) (* ; "contains the functions need to implement the sketch basic element types") (DEFINEQ (INIT.SKETCH.ELEMENTS + [LAMBDA NIL (* ; "Edited 23-Jul-90 15:38 by matsuda") + (* sets up the initial sketch + element types.) + + (* put the datatype for the element on the property list of the name and use + the name in the instances.) + + [COND + ((NOT (SKETCH.ELEMENT.TYPEP 'CIRCLE)) + (CREATE.SKETCH.ELEMENT.TYPE 'CIRCLE CIRCLEICON "Adds a circle to the figure." + (FUNCTION CIRCLE.DRAWFN) + (FUNCTION CIRCLE.EXPANDFN) + 'OBSOLETE + (FUNCTION SK.ELEMENTS.CHANGEFN) + (FUNCTION CIRCLE.INPUTFN) + (FUNCTION CIRCLE.INSIDEFN) + (FUNCTION CIRCLE.REGIONFN) + (FUNCTION CIRCLE.TRANSLATE) + NIL + (FUNCTION CIRCLE.READCHANGEFN) + (FUNCTION CIRCLE.TRANSFORMFN) + (FUNCTION CIRCLE.TRANSLATEPTS) + (FUNCTION CIRCLE.GLOBALREGIONFN] + [COND + ((NOT (SKETCH.ELEMENT.TYPEP 'ELLIPSE)) + (CREATE.SKETCH.ELEMENT.TYPE 'ELLIPSE ELLIPSEICON "Adds an ellipse to the figure." + (FUNCTION ELLIPSE.DRAWFN) + (FUNCTION ELLIPSE.EXPANDFN) + 'OBSOLETE + (FUNCTION SK.ELEMENTS.CHANGEFN) + (FUNCTION ELLIPSE.INPUTFN) + (FUNCTION ELLIPSE.INSIDEFN) + (FUNCTION ELLIPSE.REGIONFN) + (FUNCTION ELLIPSE.TRANSLATEFN) + NIL + (FUNCTION SK.BRUSH.READCHANGE) + (FUNCTION ELLIPSE.TRANSFORMFN) + (FUNCTION ELLIPSE.TRANSLATEPTS) + (FUNCTION ELLIPSE.GLOBALREGIONFN] + [COND + ((NOT (SKETCH.ELEMENT.TYPEP 'ARC)) + (CREATE.SKETCH.ELEMENT.TYPE 'ARC ARCICON "Adds an arc to the figure." + (FUNCTION ARC.DRAWFN) + (FUNCTION ARC.EXPANDFN) + 'OBSOLETE + (FUNCTION SK.ELEMENTS.CHANGEFN) + (FUNCTION ARC.INPUTFN) + (FUNCTION ARC.INSIDEFN) + (FUNCTION ARC.REGIONFN) + (FUNCTION ARC.TRANSLATE) + NIL + (FUNCTION ARC.READCHANGEFN) + (FUNCTION ARC.TRANSFORMFN) + (FUNCTION ARC.TRANSLATEPTS) + (FUNCTION ARC.GLOBALREGIONFN] + [COND + ((NOT (SKETCH.ELEMENT.TYPEP 'OPENCURVE)) + (CREATE.SKETCH.ELEMENT.TYPE 'OPENCURVE OPENCURVEICON + "Adds a curve by accepting points the curve goes through." (FUNCTION OPENCURVE.DRAWFN) + (FUNCTION OPENCURVE.EXPANDFN) + 'OBSOLETE + (FUNCTION SK.ELEMENTS.CHANGEFN) + (FUNCTION OPENCURVE.INPUTFN) + (FUNCTION KNOTS.INSIDEFN) + (FUNCTION CURVE.REGIONFN) + (FUNCTION OPENCURVE.TRANSLATEFN) + NIL + (FUNCTION OPENCURVE.READCHANGEFN) + (FUNCTION OPENCURVE.TRANSFORMFN) + (FUNCTION OPENCURVE.TRANSLATEPTSFN) + (FUNCTION OPENCURVE.GLOBALREGIONFN] + [COND + ((NOT (SKETCH.ELEMENT.TYPEP 'CLOSEDCURVE)) + (CREATE.SKETCH.ELEMENT.TYPE 'CLOSEDCURVE CLOSEDCURVEICON + "Adds a closed curve by accepting points that it goes though." (FUNCTION + CLOSEDCURVE.DRAWFN) + (FUNCTION CLOSEDCURVE.EXPANDFN) + 'OBSOLETE + (FUNCTION SK.ELEMENTS.CHANGEFN) + (FUNCTION CLOSEDCURVE.INPUTFN) + (FUNCTION KNOTS.INSIDEFN) + (FUNCTION CLOSEDCURVE.REGIONFN) + (FUNCTION KNOTS.TRANSLATEFN) + NIL + (FUNCTION CLOSEDCURVE.READCHANGEFN) + (FUNCTION CLOSEDCURVE.TRANSFORMFN) + (FUNCTION CLOSEDCURVE.TRANSLATEPTSFN) + (FUNCTION CLOSEDCURVE.GLOBALREGIONFN] + [COND + ((NOT (SKETCH.ELEMENT.TYPEP 'WIRE)) + (CREATE.SKETCH.ELEMENT.TYPE 'WIRE WIREICON "Adds a series of lines by accepting points." + (FUNCTION OPEN.WIRE.DRAWFN) + (FUNCTION WIRE.EXPANDFN) + 'OBSOLETE + (FUNCTION SK.ELEMENTS.CHANGEFN) + (FUNCTION WIRE.INPUTFN) + (FUNCTION KNOTS.INSIDEFN) + (FUNCTION KNOTS.REGIONFN) + (FUNCTION OPENWIRE.TRANSLATEFN) + NIL + (FUNCTION OPENCURVE.READCHANGEFN) + (FUNCTION OPENWIRE.TRANSFORMFN) + (FUNCTION OPENWIRE.TRANSLATEPTSFN) + (FUNCTION OPENWIRE.GLOBALREGIONFN] + [COND + ((NOT (SKETCH.ELEMENT.TYPEP 'CLOSEDWIRE)) + (CREATE.SKETCH.ELEMENT.TYPE 'CLOSEDWIRE CLOSEDWIREICON + "Adds a closed polygon by accepting the corners." (FUNCTION CLOSED.WIRE.DRAWFN) + (FUNCTION CLOSEDWIRE.EXPANDFN) + 'OBSOLETE + (FUNCTION SK.ELEMENTS.CHANGEFN) + (FUNCTION CLOSED.WIRE.INPUTFN) + (FUNCTION KNOTS.INSIDEFN) + (FUNCTION CLOSEDWIRE.REGIONFN) + (FUNCTION KNOTS.TRANSLATEFN) + NIL + (FUNCTION CLOSEDWIRE.READCHANGEFN) + (FUNCTION CLOSEDWIRE.TRANSFORMFN) + (FUNCTION CLOSEDWIRE.TRANSLATEPTSFN) + (FUNCTION CLOSEDWIRE.GLOBALREGIONFN] + [COND + ((NOT (SKETCH.ELEMENT.TYPEP 'TEXT)) + (CREATE.SKETCH.ELEMENT.TYPE 'TEXT NIL + "text is added by pointing to its position and typing." (FUNCTION TEXT.DRAWFN) + (FUNCTION TEXT.EXPANDFN) + 'OBSOLETE + (FUNCTION SK.ELEMENTS.CHANGEFN) + (FUNCTION TEXT.INPUTFN) + (FUNCTION TEXT.INSIDEFN) + (FUNCTION TEXT.REGIONFN) + (FUNCTION TEXT.TRANSLATEFN) + (FUNCTION TEXT.UPDATEFN) + (FUNCTION TEXT.READCHANGEFN) + (FUNCTION TEXT.TRANSFORMFN) + (FUNCTION TEXT.TRANSLATEPTSFN) + (FUNCTION TEXT.GLOBALREGIONFN] + [COND + ((NOT (SKETCH.ELEMENT.TYPEP 'BOX)) + (CREATE.SKETCH.ELEMENT.TYPE 'BOX BOXICON "Adds a box by accepting two corners." + (FUNCTION SK.BOX.DRAWFN) + (FUNCTION SK.BOX.EXPANDFN) + 'OBSOLETE + (FUNCTION SK.ELEMENTS.CHANGEFN) + (FUNCTION SK.BOX.INPUTFN) + (FUNCTION SK.BOX.INSIDEFN) + (FUNCTION SK.BOX.REGIONFN) + (FUNCTION SK.BOX.TRANSLATEFN) + NIL + (FUNCTION SK.BOX.READCHANGEFN) + (FUNCTION SK.BOX.TRANSFORMFN) + (FUNCTION SK.BOX.TRANSLATEPTSFN) + (FUNCTION SK.BOX.GLOBALREGIONFN] + (COND + ((NOT (SKETCH.ELEMENT.TYPEP 'TEXTBOX)) + (CREATE.SKETCH.ELEMENT.TYPE 'TEXTBOX TEXTBOXICON + "Adds a box into which text can be typed." (FUNCTION TEXTBOX.DRAWFN) + (FUNCTION TEXTBOX.EXPANDFN) + 'OBSOLETE + (FUNCTION SK.ELEMENTS.CHANGEFN) + (FUNCTION TEXTBOX.INPUTFN) + (FUNCTION TEXTBOX.INSIDEFN) + (FUNCTION TEXTBOX.REGIONFN) + (FUNCTION TEXTBOX.TRANSLATEFN) + (FUNCTION TEXTBOX.UPDATEFN) + (FUNCTION TEXTBOX.READCHANGEFN) + (FUNCTION TEXTBOX.TRANSFORMFN) + (FUNCTION TEXTBOX.TRANSLATEPTSFN) + (FUNCTION TEXTBOX.GLOBALREGIONFN]) (CREATE.SKETCH.ELEMENT.TYPE + [LAMBDA (SKETCHTYPE LABEL DOCSTR DRAWFN EXPANDFN OBSOLETE CHANGEFN INPUTFN INSIDEFN REGIONFN + TRANSLATEFN UPDATEFN READCHANGEFN TRANSFORMFN TRANSLATEPTSFN GLOBALREGIONFN) + (* rrb "18-Oct-85 17:18") + (* creates a new sketch element type.) + (COND + ((AND OBSOLETE (NEQ OBSOLETE 'OBSOLETE)) + (printout T OBSOLETE " will never be called. CREATE.SKETCH.ELEMENT.TYPE"))) + (SETQ SKETCH.ELEMENT.TYPES + (CONS (PUTPROP SKETCHTYPE 'SKETCHTYPE + (create SKETCHTYPE + LABEL _ LABEL + DOCSTR _ DOCSTR + DRAWFN _ DRAWFN + EXPANDFN _ EXPANDFN + CHANGEFN _ CHANGEFN + INPUTFN _ INPUTFN + INSIDEFN _ INSIDEFN + REGIONFN _ REGIONFN + TRANSLATEFN _ TRANSLATEFN + UPDATEFN _ UPDATEFN + READCHANGEFN _ READCHANGEFN + TRANSFORMFN _ TRANSFORMFN + TRANSLATEPTSFN _ TRANSLATEPTSFN + GLOBALREGIONFN _ GLOBALREGIONFN)) + SKETCH.ELEMENT.TYPES)) + (OR (MEMB SKETCHTYPE SKETCH.ELEMENT.TYPE.NAMES) + (SETQ SKETCH.ELEMENT.TYPE.NAMES (CONS SKETCHTYPE SKETCH.ELEMENT.TYPE.NAMES))) + SKETCHTYPE]) (SKETCH.ELEMENT.TYPEP + [LAMBDA (SKETCHTYPE) (* rrb "28-Dec-84 15:39") + (* is SKETCHTYPE a sketch element + type?) + (AND (MEMB SKETCHTYPE SKETCH.ELEMENT.TYPE.NAMES) + (GETPROP SKETCHTYPE 'SKETCHTYPE]) (SKETCH.ELEMENT.NAMEP + [LAMBDA (X) (* rrb "18-MAR-83 11:53") + (* is X a sketch element type name?) + (FMEMB X SKETCH.ELEMENT.TYPE.NAMES]) (\CURSOR.IN.MIDDLE.MENU + [LAMBDA (MENU) (* rrb " 6-Nov-85 09:46") + + (* brings up the menu so that the cursor is in the middle.) + + (MENU MENU (create POSITION + XCOORD _ (DIFFERENCE LASTMOUSEX (QUOTIENT (fetch (MENU IMAGEWIDTH) of MENU) + 2)) + YCOORD _ (DIFFERENCE LASTMOUSEY (QUOTIENT (fetch (MENU IMAGEHEIGHT) + of MENU) + 2]) ) (* ; "color and filling stuff") (DEFINEQ (SKETCHINCOLORP + [LAMBDA NIL (* rrb "12-Jul-85 10:11") + (* hook to determine if sketch should + allow color.) + SKETCHINCOLORFLG]) (READ.COLOR.CHANGE + [LAMBDA (MSG ALLOWNONEFLG CURRENTCOLOR) (* rrb "29-Oct-85 12:30") + (* reads a color from the user and + returns it) + (READCOLOR1 MSG ALLOWNONEFLG CURRENTCOLOR]) ) (RPAQ? SKETCHINCOLORFLG ) (RPAQ? FILLPOLYGONFLG T) (RPAQ? FILLINGMODEFLG T) (RPAQ? SK.DEFAULT.BACKCOLOR ) (RPAQ? SK.DEFAULT.OPERATION ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SKETCHINCOLORFLG SK.DEFAULT.BACKCOLOR) ) (DECLARE%: EVAL@COMPILE (RECORD SKFILLING (FILLING.TEXTURE FILLING.COLOR FILLING.OPERATION)) ) (* ;; "fns included until system is fixed so that it is ok to call DSPCOLOR in a system without color loaded. Should be removed after J release." ) (DEFINEQ (SK.CREATE.DEFAULT.FILLING + [LAMBDA NIL (* rrb "21-Feb-86 11:22") + (create SKFILLING + FILLING.TEXTURE _ SK.DEFAULT.TEXTURE + FILLING.COLOR _ SK.DEFAULT.BACKCOLOR + FILLING.OPERATION _ SK.DEFAULT.OPERATION]) (SKFILLINGP + [LAMBDA (FILLING) (* rrb "21-Feb-86 11:20") + (* determines if FILLING is a legal + sketch filling.) + (COND + ((AND (LISTP FILLING) + (TEXTUREP (fetch (SKFILLING FILLING.TEXTURE) of FILLING)) + (NULL (CDDDR FILLING))) + + (* should also check if (fetch (SKFILLING FILLING.COLOR)) is a color and that + (SKFILLING FILLING.OPERATION) is an operation.) + + FILLING]) (SK.INSURE.FILLING + [LAMBDA (FILLING SKW) (* rrb "16-Oct-85 15:47") + + (* converts several possible legal filling specifications into a sketch filling) + + (COND + ((SKFILLINGP FILLING)) + (T (PROG [(DEFAULTFILLING (COND + [(WINDOWP SKW) + (fetch (SKETCHCONTEXT SKETCHFILLING) of (WINDOWPROP SKW + 'SKETCHCONTEXT] + (T (SK.CREATE.DEFAULT.FILLING] + (RETURN (COND + ((NULL FILLING) + DEFAULTFILLING) + ((TEXTUREP FILLING) + (create SKFILLING using DEFAULTFILLING FILLING.TEXTURE _ FILLING)) + ((\POSSIBLECOLOR FILLING) + + (* note that small numbers can be either a texture or a color. + This algorithm will make them be a texture.) + + (create SKFILLING using DEFAULTFILLING FILLING.COLOR _ FILLING)) + (T (* should be a check here for a color + too.) + (\ILLEGAL.ARG FILLING]) (SK.INSURE.COLOR + [LAMBDA (COLOR) (* rrb "16-Oct-85 18:05") + (* checks the validity of a color + argument.) + (COND + ((NULL COLOR) + NIL) + ((\POSSIBLECOLOR COLOR)) + (T (\ILLEGAL.ARG COLOR]) ) (DEFINEQ (SK.TRANSLATE.MODE + [LAMBDA (OPERATION STREAM) (* rrb "10-Mar-86 17:20") + (* picks the best operation for a + filling.) + (COND + ((EQ (DSPOPERATION NIL STREAM) + 'ERASE) + + (* drawing should do its best job of erasing the current image) + + (SELECTQ OPERATION + (INVERT 'INVERT) + (ERASE + + (* don't know what to do because we don't know what bits were removed but this + at least lets the user know something happened wrt this element.) + + 'PAINT) + 'ERASE)) + (T OPERATION]) (SK.CHANGE.FILLING.MODE + [LAMBDA (ELTWITHFILLING HOW SKW) (* rrb " 3-Mar-86 14:36") + (* changes the texture in the element + ELTWITHFILLING.) + (PROG (GFILLEDELT MODE FILLING NEWFILLING TYPE NEWELT) + (RETURN (COND + ((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHFILLING)) + '(BOX TEXTBOX CLOSEDWIRE CIRCLE)) + + (* only works for things that have a filling, for now just boxes and polygons) + + (SETQ GFILLEDELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHFILLING)) + [SETQ MODE (fetch (SKFILLING FILLING.OPERATION) + of (SETQ FILLING (SELECTQ TYPE + (BOX (fetch (BOX BOXFILLING) of GFILLEDELT)) + (TEXTBOX (fetch (TEXTBOX TEXTBOXFILLING) + of GFILLEDELT)) + (CIRCLE (fetch (CIRCLE CIRCLEFILLING) + of GFILLEDELT)) + (CLOSEDWIRE (fetch (CLOSEDWIRE + CLOSEDWIREFILLING) + of GFILLEDELT)) + (SHOULDNT] + (COND + ((NOT (EQUAL HOW MODE)) (* new filling mode) + (SETQ NEWFILLING (create SKFILLING using FILLING FILLING.OPERATION _ HOW)) + (SETQ NEWELT (SELECTQ TYPE + (BOX (create BOX using GFILLEDELT BOXFILLING _ NEWFILLING)) + (TEXTBOX (create TEXTBOX using GFILLEDELT TEXTBOXFILLING _ + NEWFILLING)) + (CLOSEDWIRE (create CLOSEDWIRE using GFILLEDELT + CLOSEDWIREFILLING _ + NEWFILLING)) + (CIRCLE (create CIRCLE using GFILLEDELT CIRCLEFILLING _ + NEWFILLING)) + (SHOULDNT))) + (create SKHISTORYCHANGESPEC + NEWELT _ (create GLOBALPART + COMMONGLOBALPART _ (fetch (GLOBALPART + COMMONGLOBALPART) + of ELTWITHFILLING) + INDIVIDUALGLOBALPART _ NEWELT) + OLDELT _ ELTWITHFILLING + PROPERTY _ 'FILLING + NEWVALUE _ NEWFILLING + OLDVALUE _ FILLING]) (READ.FILLING.MODE + [LAMBDA NIL (* rrb " 3-Mar-86 14:30") + (* reads a filling mode from the user.) + (\CURSOR.IN.MIDDLE.MENU (create MENU + CENTERFLG _ T + TITLE _ "How should the filling merge with the covered figures?" + MENUROWS _ 1 + ITEMS _ '((REPLACE 'REPLACE + "the filling completely covers anything under it." + ) + (PAINT 'PAINT + "the black parts of the filling cover but the white parts show through." + ) + (ERASE 'ERASE + "the black parts of the filling are erased.") + (INVERT 'INVERT + "the black parts of the filling are inverted."]) ) (DEFINEQ (SKETCH.CREATE.CIRCLE + [LAMBDA (CENTERPT RADIUSPT BRUSH DASHING FILLING SCALE) (* rrb "11-Dec-85 10:43") + (* creates a sketch circle element.) + (SK.CIRCLE.CREATE (SK.INSURE.POSITION CENTERPT) + (COND + [(NUMBERP RADIUSPT) + (create POSITION + XCOORD _ (PLUS (fetch (POSITION XCOORD) of CENTERPT) + RADIUSPT) + YCOORD _ (PLUS (fetch (POSITION YCOORD) of CENTERPT] + (T (SK.INSURE.POSITION RADIUSPT))) + (SK.INSURE.BRUSH BRUSH) + (SK.INSURE.DASHING DASHING) + (OR (NUMBERP SCALE) + 1.0) + (SK.INSURE.FILLING FILLING]) (CIRCLE.EXPANDFN + [LAMBDA (GCIRCLE SCALE) (* rrb " 7-Dec-85 20:45") + + (* returns a screen elt that has a circle screen element calculated from the + global part.) + + (PROG (CENTER RADIUSPT BRUSH (INDGCIRCLE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCIRCLE))) + + (* check to make sure there is an initial scale field. + This change was introduced on Apr 27 and can be taken out the release after + Jazz It can also be taken out of the other expand fns as well.) + + [COND + ((fetch (CIRCLE CIRCLEINITSCALE) of INDGCIRCLE)) + (T + + (* old format didn't have an initial scale, default it to 1.0) + + (replace (GLOBALPART INDIVIDUALGLOBALPART) of GCIRCLE + with (SETQ INDGCIRCLE (create CIRCLE using INDGCIRCLE CIRCLEINITSCALE _ 1.0] + (RETURN (create SCREENELT + LOCALPART _ + (create LOCALCIRCLE + CENTERPOSITION _ (SETQ CENTER (SK.SCALE.POSITION.INTO.VIEWER + (fetch (CIRCLE CENTERLATLON) + of INDGCIRCLE) + SCALE)) + RADIUSPOSITION _ (SETQ RADIUSPT (SK.SCALE.POSITION.INTO.VIEWER + (fetch (CIRCLE RADIUSLATLON) + of INDGCIRCLE) + SCALE)) + RADIUS _ (DISTANCEBETWEEN CENTER RADIUSPT) + LOCALCIRCLEBRUSH _ + (SCALE.BRUSH (COND + ([NOT (NUMBERP (SETQ BRUSH (fetch (CIRCLE BRUSH) + of INDGCIRCLE] + (* new format, old format had brush + width only.) + BRUSH) + (T [replace (CIRCLE BRUSH) of INDGCIRCLE + with (SETQ BRUSH + (create BRUSH + BRUSHSIZE _ BRUSH + BRUSHSHAPE _ 'ROUND] + BRUSH)) + (fetch (CIRCLE CIRCLEINITSCALE) of INDGCIRCLE) + SCALE) + LOCALCIRCLEFILLING _ (APPEND (fetch (CIRCLE CIRCLEFILLING) + of INDGCIRCLE)) + LOCALCIRCLEDASHING _ (fetch (CIRCLE DASHING) of INDGCIRCLE)) + GLOBALPART _ GCIRCLE]) (CIRCLE.DRAWFN + [LAMBDA (CIRCLEELT WINDOW REGION) (* rrb "20-Jun-86 17:08") + (* draws a circle from a circle + element.) + (PROG ((GCIRCLE (fetch (SCREENELT INDIVIDUALGLOBALPART) of CIRCLEELT)) + (LCIRCLE (fetch (SCREENELT LOCALPART) of CIRCLEELT)) + CPOS DASHING FILLING) + (SETQ CPOS (fetch (LOCALCIRCLE CENTERPOSITION) of LCIRCLE)) + (SETQ DASHING (fetch (LOCALCIRCLE LOCALCIRCLEDASHING) of LCIRCLE)) + (SETQ FILLING (fetch (LOCALCIRCLE LOCALCIRCLEFILLING) of LCIRCLE)) + (COND + ((fetch (SKFILLING FILLING.COLOR) of FILLING) + + (* if the circle is filled with a color call FILLCIRCLE with both the texture + and the color. This allows iris to do its thing before textures and colors are + merged.) + + (DSPOPERATION (PROG1 (DSPOPERATION (fetch (SKFILLING FILLING.OPERATION) of FILLING) + WINDOW) + (FILLCIRCLE (fetch (POSITION XCOORD) of CPOS) + (fetch (POSITION YCOORD) of CPOS) + (fetch (LOCALCIRCLE RADIUS) of LCIRCLE) + FILLING WINDOW)) + WINDOW)) + ((fetch (SKFILLING FILLING.TEXTURE) of FILLING) (* if the circle is filled with + texture, call FILLCIRCLE.) + (DSPOPERATION (PROG1 (DSPOPERATION (fetch (SKFILLING FILLING.OPERATION) of FILLING) + WINDOW) + (FILLCIRCLE (fetch (POSITION XCOORD) of CPOS) + (fetch (POSITION YCOORD) of CPOS) + (fetch (LOCALCIRCLE RADIUS) of LCIRCLE) + (COND + ((EQ (DSPOPERATION NIL WINDOW) + 'ERASE) + + (* use black in case the window moved because of texture to window alignment + bug.) + + BLACKSHADE) + (T (fetch (SKFILLING FILLING.TEXTURE) of FILLING))) + WINDOW)) + WINDOW))) + (RETURN (\CIRCLE.DRAWFN1 CPOS (fetch (LOCALCIRCLE RADIUSPOSITION) of LCIRCLE) + (fetch (LOCALCIRCLE RADIUS) of LCIRCLE) + (fetch (LOCALCIRCLE LOCALCIRCLEBRUSH) of LCIRCLE) + DASHING WINDOW]) (\CIRCLE.DRAWFN1 + [LAMBDA (CENTERPT RADIUSPT RADIUS BRUSH DASHING WINDOW) + (* ; "Edited 17-Apr-90 17:24 by matsuda") + (* draws a circle for sketch from + some information. Calls by + CIRCLE.DRAWFN and ARC.DRAWFN) + (COND + (DASHING (* draw it with the arc drawing code + which does dashing.) + (DRAWCURVE (SK.COMPUTE.ARC.PTS CENTERPT RADIUSPT + [COND + [(LESSP (FETCH (POSITION XCOORD) OF CENTERPT) + (FETCH (POSITION XCOORD) OF RADIUSPT)) + (PTPLUS RADIUSPT (CONSTANT (create POSITION + XCOORD _ 0 + YCOORD _ -1] + [(GREATERP (FETCH (POSITION XCOORD) OF CENTERPT) + (FETCH (POSITION XCOORD) OF RADIUSPT)) + (PTPLUS RADIUSPT (CONSTANT (create POSITION + XCOORD _ 0 + YCOORD _ 1] + [(LESSP (FETCH (POSITION YCOORD) OF CENTERPT) + (FETCH (POSITION YCOORD) OF RADIUSPT)) + (PTPLUS RADIUSPT (CONSTANT (create POSITION + XCOORD _ 1 + YCOORD _ 0] + (T (PTPLUS RADIUSPT + (CONSTANT (create POSITION + XCOORD _ -1 + YCOORD _ 0] + NIL) + T BRUSH DASHING WINDOW)) + (T (DRAWCIRCLE (fetch (POSITION XCOORD) of CENTERPT) + (fetch (POSITION YCOORD) of CENTERPT) + RADIUS BRUSH DASHING WINDOW]) (CIRCLE.INPUTFN + [LAMBDA (WINDOW) (* rrb "20-May-86 10:49") + + (* reads a two points from the user and returns a circle element that it + represents.) + + (PROG [CENTERPT RADIUSPT (SKETCHCONTEXT (WINDOWPROP WINDOW 'SKETCHCONTEXT] + (STATUSPRINT WINDOW " +" "Indicate center of circle") + (COND + ((NOT (SETQ CENTERPT (SK.READ.POINT.WITH.FEEDBACK WINDOW CIRCLE.CENTER NIL NIL NIL NIL + SKETCH.USE.POSITION.PAD))) + (CLOSEPROMPTWINDOW WINDOW) + (RETURN NIL))) + (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTERPT) + NIL WINDOW) + (STATUSPRINT WINDOW " +" "Indicate a point of the circumference of the circle") + (SETQ RADIUSPT (SK.READ.CIRCLE.POINT WINDOW (fetch (INPUTPT INPUT.POSITION) of CENTERPT) + CIRCLE.EDGE)) (* erase center mark) + (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTERPT) + NIL WINDOW) + (CLOSEPROMPTWINDOW WINDOW) + (OR RADIUSPT (RETURN NIL)) + (SETQ CENTERPT (SK.MAP.INPUT.PT.TO.GLOBAL CENTERPT WINDOW)) + (SETQ RADIUSPT (SK.MAP.INPUT.PT.TO.GLOBAL RADIUSPT WINDOW)) + (RETURN (SK.CIRCLE.CREATE CENTERPT RADIUSPT (fetch (SKETCHCONTEXT SKETCHBRUSH) of + SKETCHCONTEXT + ) + (fetch (SKETCHCONTEXT SKETCHDASHING) of SKETCHCONTEXT) + (SK.INPUT.SCALE WINDOW) + (fetch (SKETCHCONTEXT SKETCHFILLING) of SKETCHCONTEXT]) (SK.UPDATE.CIRCLE.AFTER.CHANGE + [LAMBDA (GCIRELT) (* rrb " 7-Dec-85 19:50") + + (* updates the dependent fields of a circle element when a field changes.) + + (replace (CIRCLE CIRCLEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCIRELT) + with NIL]) (SK.READ.CIRCLE.POINT + [LAMBDA (WINDOW CENTERPT CURSOR) (* rrb "20-May-86 10:46") + + (* reads a point from the user prompting them with a circle that follows the + cursor) + + (SK.READ.POINT.WITH.FEEDBACK WINDOW CURSOR (AND SKETCH.VERBOSE.FEEDBACK (FUNCTION SK.SHOW.CIRCLE) + ) + CENTERPT + 'MIDDLE NIL SKETCH.USE.POSITION.PAD]) (SK.SHOW.CIRCLE + [LAMBDA (X Y WINDOW CENTERPT) (* rrb "15-Nov-85 14:18") + + (* xors a circle to X Y from CENTERPT in a window. + Used as the feedback function for reading the radius point for circles.) + (* Mark the point too.) + (SHOWSKETCHXY X Y WINDOW) + (PROG ((CENTERX (fetch (POSITION XCOORD) of CENTERPT)) + (CENTERY (fetch (POSITION YCOORD) of CENTERPT))) + (DRAWCIRCLE CENTERX CENTERY (SK.DISTANCE.TO CENTERX CENTERY X Y) + 1 NIL WINDOW]) (CIRCLE.INSIDEFN + [LAMBDA (GCIRCLE WREG) (* rrb "20-Jan-87 14:44") + + (* determines if the global circle GCIRCLE is inside of WREG.) + + (REGIONSINTERSECTP WREG (CIRCLE.GLOBALREGIONFN GCIRCLE]) (CIRCLE.REGIONFN + [LAMBDA (CIRCSCRELT) (* rrb " 3-Oct-85 17:12") + (* returns the region occuppied by a + circle.) + (PROG ((LOCALCIRCLE (fetch (SCREENELT LOCALPART) of CIRCSCRELT)) + RADIUS) + (SETQ RADIUS (IPLUS (FIX (ADD1 (fetch (LOCALCIRCLE RADIUS) of LOCALCIRCLE))) + (LRSH [ADD1 (MAX 1 (fetch (BRUSH BRUSHSIZE) of (fetch (LOCALCIRCLE + LOCALCIRCLEBRUSH + ) of LOCALCIRCLE + ] + 1))) + (RETURN (CREATEREGION (IDIFFERENCE (fetch (POSITION XCOORD) of (SETQ LOCALCIRCLE + (fetch (LOCALCIRCLE + CENTERPOSITION + ) + of LOCALCIRCLE))) + RADIUS) + (IDIFFERENCE (fetch (POSITION YCOORD) of LOCALCIRCLE) + RADIUS) + (SETQ RADIUS (ITIMES RADIUS 2)) + RADIUS]) (CIRCLE.GLOBALREGIONFN + [LAMBDA (GCIRELT) (* rrb "18-Oct-85 16:32") + + (* returns the global region occupied by a global circle element.) + + (OR (fetch (CIRCLE CIRCLEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCIRELT)) + (PROG ((INDVCIRCLE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCIRELT)) + RADIUS CENTER REGION) + + (* make the radius be too large by the amount of the brush to catch round off, + i.e. it should be half the brush size.) + + [SETQ RADIUS (PLUS (DISTANCEBETWEEN (SETQ CENTER (fetch (CIRCLE CENTERLATLON) + of INDVCIRCLE)) + (fetch (CIRCLE RADIUSLATLON) of INDVCIRCLE)) + (fetch (BRUSH BRUSHSIZE) of (fetch (CIRCLE BRUSH) of INDVCIRCLE] + (SETQ REGION (CREATEREGION (DIFFERENCE (fetch (POSITION XCOORD) of CENTER) + RADIUS) + (DIFFERENCE (fetch (POSITION YCOORD) of CENTER) + RADIUS) + (SETQ RADIUS (TIMES RADIUS 2)) + RADIUS)) + (replace (CIRCLE CIRCLEREGION) of INDVCIRCLE with REGION) + (RETURN REGION]) (CIRCLE.TRANSLATE + [LAMBDA (CIRCLESKELT DELTAPOS) (* rrb "18-Oct-85 11:00") + + (* returns a changed global circle element which has the circle translated by + DELTAPOS.) + + (PROG ((GCIRCLE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of CIRCLESKELT))) + (RETURN (create GLOBALPART + COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) of + CIRCLESKELT + )) + INDIVIDUALGLOBALPART _ (create CIRCLE using GCIRCLE CENTERLATLON _ + (PTPLUS (fetch (CIRCLE + CENTERLATLON + ) + of GCIRCLE) + DELTAPOS) + RADIUSLATLON _ + (PTPLUS (fetch (CIRCLE + RADIUSLATLON + ) + of GCIRCLE) + DELTAPOS) + CIRCLEREGION _ NIL]) (CIRCLE.READCHANGEFN + [LAMBDA (SKW SCRNELTS) (* ; "Edited 23-Jul-90 15:30 by matsuda") + + (* the users has selected SCRNELT to be changed this function reads a + specification of how the circle elements should change.) + + (PROG (ASPECT HOW) + (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU + (create MENU + CENTERFLG _ T + TITLE _ "Which aspect?" + ITEMS _ + (APPEND (COND + [(SKETCHINCOLORP) + '(("Brush color" 'BRUSHCOLOR + "changes the color of the outline" + ) + ("Filling color" 'FILLINGCOLOR + "changes the color of the filling" + ] + (T NIL)) + [COND + (FILLPOLYGONFLG + '((Filling 'FILLING + "allows changing of the filling texture of the box." + ] + [COND + (FILLINGMODEFLG + '(("Filling mode" 'FILLINGMODE + "changes how the filling effects the figures it covers." + ] + '((Shape 'SHAPE + "changes the shape of the brush") + (Size 'SIZE + "changes the size of the brush") + (Dashing 'DASHING + "changes the dashing of the line."] + (SIZE (READSIZECHANGE "Change size how?" T)) + (FILLING (READ.FILLING.CHANGE)) + (FILLINGMODE (READ.FILLING.MODE)) + (DASHING (READ.DASHING.CHANGE)) + (SHAPE (READBRUSHSHAPE)) + (BRUSHCOLOR [READ.COLOR.CHANGE "Change outline color how?" NIL + (fetch (BRUSH BRUSHCOLOR) + of (GETSKETCHELEMENTPROP (fetch + (SCREENELT GLOBALPART + ) + of (CAR + SCRNELTS + )) + 'BRUSH]) + (FILLINGCOLOR [READ.COLOR.CHANGE "Change filling color how?" T + (fetch (SKFILLING FILLING.COLOR) + of (GETSKETCHELEMENTPROP (fetch + (SCREENELT + GLOBALPART) + of + (CAR SCRNELTS)) + 'FILLING]) + NIL)) + (RETURN (AND HOW (LIST ASPECT HOW]) (CIRCLE.TRANSFORMFN + [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "18-Oct-85 11:04") + + (* returns a copy of the global element that has had each of its control points + transformed by transformfn. TRANSFORMDATA is arbitrary data that is passed to + tranformfn.) + + (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (RETURN (create GLOBALPART using GELT INDIVIDUALGLOBALPART _ + (create CIRCLE using INDVPART CENTERLATLON _ + (SK.TRANSFORM.POINT + (fetch (CIRCLE CENTERLATLON) + of INDVPART) + TRANSFORMFN TRANSFORMDATA) + RADIUSLATLON _ + (SK.TRANSFORM.POINT + (fetch (CIRCLE RADIUSLATLON) + of INDVPART) + TRANSFORMFN TRANSFORMDATA) + BRUSH _ (SK.TRANSFORM.BRUSH + (fetch (CIRCLE BRUSH) + of INDVPART) + SCALEFACTOR) + CIRCLEREGION _ NIL]) (CIRCLE.TRANSLATEPTS + [LAMBDA (CIRCLESPEC SELPTS GLOBALDELTA WINDOW) (* rrb " 9-Aug-85 09:55") + + (* returns a changed global circle element which has the part SELPOS moved to + NEWPOS.) + + (PROG ((LCIRCLE (fetch (SCREENELT LOCALPART) of CIRCLESPEC)) + (GCIRCLE (fetch (SCREENELT INDIVIDUALGLOBALPART) of CIRCLESPEC))) + (RETURN (SK.CIRCLE.CREATE (COND + ((MEMBER (fetch (LOCALCIRCLE CENTERPOSITION) of LCIRCLE) + SELPTS) (* move the center) + (PTPLUS (fetch (CIRCLE CENTERLATLON) of GCIRCLE) + GLOBALDELTA)) + (T (fetch (CIRCLE CENTERLATLON) of GCIRCLE))) + (COND + ((MEMBER (fetch (LOCALCIRCLE RADIUSPOSITION) of LCIRCLE) + SELPTS) (* move the radius point.) + (PTPLUS (fetch (CIRCLE RADIUSLATLON) of GCIRCLE) + GLOBALDELTA)) + (T (fetch (CIRCLE RADIUSLATLON) of GCIRCLE))) + (fetch (CIRCLE BRUSH) of GCIRCLE) + (fetch (CIRCLE DASHING) of GCIRCLE) + (fetch (CIRCLE CIRCLEINITSCALE) of GCIRCLE) + (fetch (CIRCLE CIRCLEFILLING) of GCIRCLE]) (SK.CIRCLE.CREATE + [LAMBDA (CENTERPT RADIUSPT BRUSH DASHING INITSCALE FILLING)(* rrb "18-Oct-85 11:01") + (* creates a sketch element) + + (* region is a cache that will be filled if needed.) + + (SET.CIRCLE.SCALE (create GLOBALPART + INDIVIDUALGLOBALPART _ + (create CIRCLE + CENTERLATLON _ CENTERPT + RADIUSLATLON _ RADIUSPT + BRUSH _ BRUSH + DASHING _ DASHING + CIRCLEINITSCALE _ INITSCALE + CIRCLEFILLING _ FILLING + CIRCLEREGION _ NIL]) (SET.CIRCLE.SCALE + [LAMBDA (GCIRCELT) (* rrb " 7-Feb-85 12:22") + + (* sets the scale fields in a circle. Sets scale so that it goes from radius 1 + to 3000.0) + + (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCIRCELT)) + RAD) + (SETQ RAD (DISTANCEBETWEEN (fetch (CIRCLE CENTERLATLON) of INDVPART) + (fetch (CIRCLE RADIUSLATLON) of INDVPART))) + (replace (GLOBALPART COMMONGLOBALPART) of GCIRCELT + with (create COMMONGLOBALPART + MAXSCALE _ RAD + MINSCALE _ (QUOTIENT RAD 3000.0))) + (RETURN GCIRCELT]) (SK.BRUSH.READCHANGE + [LAMBDA (SKW SCRNELTS) (* rrb " 6-Nov-85 09:49") + (* changefn for curves) + (PROG (ASPECT HOW) + (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU + (create MENU + CENTERFLG _ T + TITLE _ "select aspect of brush to change" + ITEMS _ (APPEND (COND + [(SKETCHINCOLORP) + '(("Color" 'BRUSHCOLOR + "changes the color of the brush" + ] + (T NIL)) + '((Shape 'SHAPE + "changes the shape of the brush" + ) + (Size 'SIZE + "changes the size of the brush" + ) + (Dashing 'DASHING + "changes the dashing of the line." + ] + (SIZE (READSIZECHANGE "Change size how?")) + (SHAPE (READBRUSHSHAPE)) + (DASHING (READ.DASHING.CHANGE)) + (BRUSHCOLOR [READ.COLOR.CHANGE "Change brush color how?" NIL + (fetch (BRUSH BRUSHCOLOR) + of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) + of (CAR SCRNELTS)) + 'BRUSH]) + NIL)) + (RETURN (AND HOW (LIST ASPECT HOW]) ) (DEFINEQ (SK.INSURE.BRUSH + [LAMBDA (BRUSH) (* rrb "16-Oct-85 15:37") + + (* coerces BRUSH into a brush. Errors if it won't go.) + + (COND + ((BRUSHP BRUSH)) + ((NUMBERP BRUSH) + (create BRUSH + BRUSHSIZE _ BRUSH)) + ((NULL BRUSH) + SK.DEFAULT.BRUSH) + (T (\ILLEGAL.ARG BRUSH]) (SK.INSURE.DASHING + [LAMBDA (DASHING) (* rrb "16-Oct-85 17:04") + + (* checks the validity of a dashing argument. + NIL is ok and means no dashing.) + + (AND DASHING (OR (DASHINGP DASHING) + (\ILLEGAL.ARG DASHING]) ) (DECLARE%: EVAL@COMPILE (RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR) BRUSHSHAPE _ 'ROUND BRUSHSIZE _ 1) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD LOCALCIRCLE ((CENTERPOSITION RADIUSPOSITION) LOCALHOTREGION RADIUS LOCALCIRCLEBRUSH LOCALCIRCLEFILLING LOCALCIRCLEDASHING )) (TYPERECORD CIRCLE (CENTERLATLON RADIUSLATLON BRUSH DASHING CIRCLEINITSCALE CIRCLEFILLING CIRCLEREGION)) ) ) (READVARS-FROM-STRINGS '(CIRCLEICON) "({(READBITMAP)(20 12 %"@AOH@@@@%" %"@COL@@@@%" %"@G@N@@@@%" %"@F@F@@@@%" %"@N@G@@@@%" %"@L@C@@@@%" %"@L@C@@@@%" %"@N@G@@@@%" %"@F@F@@@@%" %"@G@N@@@@%" %"@COL@@@@%" %"@AOH@@@@%")}) ") (RPAQ CIRCLE.CENTER (CURSORCREATE (QUOTE #*(16 16)@@@@@GL@AOO@CLGHG@ALF@@LN@@NL@@FL@@FL@@FN@@NF@@LG@ALCLGHAON@@GH@ ) (QUOTE NIL) 7 7)) (RPAQ CIRCLE.EDGE (CURSORCREATE (QUOTE #*(16 16)@@@L@@@D@@@F@@@B@@@C@@LA@@OA@@GMOOOO@@GM@@OA@@LC@@@B@@@F@@@D@@@L ) (QUOTE NIL) 15 7)) (RPAQ? SK.DEFAULT.BRUSH (CONS 'ROUND (CONS 1 (CONS 'BLACK NIL)))) (RPAQ? SK.DEFAULT.DASHING ) (RPAQ? SK.DEFAULT.TEXTURE ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SK.DEFAULT.BRUSH SK.DEFAULT.DASHING SK.DEFAULT.TEXTURE) ) (DEFINEQ (SKETCH.CREATE.ELLIPSE + [LAMBDA (CENTERPT ORIENTATIONPT OTHERRADIUSPT BRUSH DASHING WILLBEFILLING SCALE) + (* rrb "16-Oct-85 17:05") + (* creates a sketch ellipse element.) + (ELLIPSE.CREATE (SK.INSURE.POSITION CENTERPT) + (SK.INSURE.POSITION ORIENTATIONPT) + (SK.INSURE.POSITION OTHERRADIUSPT) + (SK.INSURE.BRUSH BRUSH) + (SK.INSURE.DASHING DASHING) + (OR (NUMBERP SCALE) + 1.0]) (ELLIPSE.EXPANDFN + [LAMBDA (GELLIPSE SCALE) (* rrb " 7-Dec-85 20:40") + + (* returns a screen elt that has a ellipse screen element calculated from the + global part.) + + (PROG (CENTER MINRAD MAJRAD BRUSH (INDGELLIPSE (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELLIPSE))) + [COND + ((fetch (ELLIPSE ELLIPSEINITSCALE) of INDGELLIPSE)) + (T + + (* old format didn't have an initial scale, create one and default it to 1.0) + + (replace (GLOBALPART INDIVIDUALGLOBALPART) of GELLIPSE + with (SETQ INDGELLIPSE (create ELLIPSE using INDGELLIPSE ELLIPSEINITSCALE _ 1.0 + ELLIPSEREGION _ NIL] + (RETURN (create SCREENELT + LOCALPART _ + (create LOCALELLIPSE + ELLIPSECENTER _ (SETQ CENTER (SK.SCALE.POSITION.INTO.VIEWER + (fetch (ELLIPSE ELLIPSECENTERLATLON) + of INDGELLIPSE) + SCALE)) + MINORRADIUSPOSITION _ (SETQ MINRAD (SK.SCALE.POSITION.INTO.VIEWER + (fetch (ELLIPSE SEMIMINORLATLON) + of INDGELLIPSE) + SCALE)) + MAJORRADIUSPOSITION _ (SETQ MAJRAD (SK.SCALE.POSITION.INTO.VIEWER + (fetch (ELLIPSE SEMIMAJORLATLON) + of INDGELLIPSE) + SCALE)) + SEMIMINORRADIUS _ (DISTANCEBETWEEN CENTER MINRAD) + SEMIMAJORRADIUS _ (DISTANCEBETWEEN CENTER MAJRAD) + LOCALELLIPSEBRUSH _ + (SCALE.BRUSH (COND + ([NOT (NUMBERP (SETQ BRUSH (fetch (ELLIPSE BRUSH) + of INDGELLIPSE] + (* new format, old format had brush + width only.) + BRUSH) + (T [replace (ELLIPSE BRUSH) of INDGELLIPSE + with (SETQ BRUSH + (create BRUSH + BRUSHSIZE _ BRUSH + BRUSHSHAPE _ 'ROUND] + BRUSH)) + (fetch (ELLIPSE ELLIPSEINITSCALE) of INDGELLIPSE) + SCALE) + LOCALELLIPSEDASHING _ (fetch (ELLIPSE DASHING) of INDGELLIPSE)) + GLOBALPART _ GELLIPSE]) (ELLIPSE.DRAWFN + [LAMBDA (ELLIPSEELT WINDOW REGION) (* rrb " 7-Dec-85 20:40") + (* draws a ellipse from a circle + element.) + (PROG ((GELLIPSE (fetch (SCREENELT INDIVIDUALGLOBALPART) of ELLIPSEELT)) + (LELLIPSE (fetch (SCREENELT LOCALPART) of ELLIPSEELT)) + CPOS DASHING ORIENTATION) + (SETQ CPOS (fetch (LOCALELLIPSE ELLIPSECENTER) of LELLIPSE)) + (SETQ DASHING (fetch (LOCALELLIPSE LOCALELLIPSEDASHING) of LELLIPSE)) + (SETQ ORIENTATION (fetch (ELLIPSE ORIENTATION) of GELLIPSE)) + (RETURN (COND + (DASHING + + (* draw it with the curve drawing code which does dashing.) + + (PROG ((SINOR (SIN ORIENTATION)) + (COSOR (COS ORIENTATION)) + (CENTERX (fetch (POSITION XCOORD) of CPOS)) + (CENTERY (fetch (POSITION YCOORD) of CPOS)) + (SEMIMINORRADIUS (fetch (LOCALELLIPSE SEMIMINORRADIUS) + of LELLIPSE)) + (SEMIMAJORRADIUS (fetch (LOCALELLIPSE SEMIMAJORRADIUS) + of LELLIPSE))) + (DRAWCURVE [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 + (fetch (LOCALELLIPSE LOCALELLIPSEBRUSH) of LELLIPSE) + DASHING WINDOW))) + (T (DRAWELLIPSE (fetch (POSITION XCOORD) of CPOS) + (fetch (POSITION YCOORD) of CPOS) + (fetch (LOCALELLIPSE SEMIMINORRADIUS) of LELLIPSE) + (fetch (LOCALELLIPSE SEMIMAJORRADIUS) of LELLIPSE) + ORIENTATION + (fetch (LOCALELLIPSE LOCALELLIPSEBRUSH) of LELLIPSE) + DASHING WINDOW]) (ELLIPSE.INPUTFN + [LAMBDA (WINDOW) (* rrb "21-May-86 16:13") + + (* reads three points from the user and returns the ellipse figure element that + it represents.) + + (PROG (CENTER MAJRAD MINRAD) + (STATUSPRINT WINDOW " +" "Indicate center of ellipse") + (COND + ((SETQ CENTER (SK.READ.POINT.WITH.FEEDBACK WINDOW ELLIPSE.CENTER NIL NIL NIL NIL + SKETCH.USE.POSITION.PAD)) + (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER) + NIL WINDOW)) + (T (CLOSEPROMPTWINDOW WINDOW) + (RETURN NIL))) + (STATUSPRINT WINDOW " +" "Indicate semi-major axis") + (COND + ((SETQ MAJRAD (SK.READ.ELLIPSE.MAJOR.PT WINDOW (fetch (INPUTPT INPUT.POSITION) + of CENTER))) + (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of MAJRAD) + NIL WINDOW)) + (T (* erase center pt on way out) + (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER) + NIL WINDOW) + (CLOSEPROMPTWINDOW WINDOW) + (RETURN NIL))) + (STATUSPRINT WINDOW " +" "Indicate semi-minor axis") + (SETQ MINRAD (SK.READ.ELLIPSE.MINOR.PT WINDOW (fetch (INPUTPT INPUT.POSITION) of CENTER) + (fetch (INPUTPT INPUT.POSITION) of MAJRAD))) + (CLOSEPROMPTWINDOW WINDOW) (* erase the point marks.) + (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of MAJRAD) + NIL WINDOW) + (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER) + NIL WINDOW) + (OR MINRAD (RETURN NIL)) + (RETURN (ELLIPSE.CREATE (SK.MAP.INPUT.PT.TO.GLOBAL CENTER WINDOW) + (SK.MAP.INPUT.PT.TO.GLOBAL MINRAD WINDOW) + (SK.MAP.INPUT.PT.TO.GLOBAL MAJRAD WINDOW) + (fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP WINDOW 'SKETCHCONTEXT)) + (fetch (SKETCHCONTEXT SKETCHDASHING) of (WINDOWPROP WINDOW 'SKETCHCONTEXT)) + (SK.INPUT.SCALE WINDOW]) (SK.READ.ELLIPSE.MAJOR.PT + [LAMBDA (SKW CENTERPT) (* rrb "20-May-86 10:47") + + (* reads a position from the user that will be the major radius point of an + ellipse.) + + (SK.READ.POINT.WITH.FEEDBACK WINDOW ELLIPSE.SEMI.MAJOR (AND SKETCH.VERBOSE.FEEDBACK + (FUNCTION + SK.SHOW.ELLIPSE.MAJOR.RADIUS)) + CENTERPT + 'MIDDLE NIL SKETCH.USE.POSITION.PAD]) (SK.SHOW.ELLIPSE.MAJOR.RADIUS + [LAMBDA (X Y WINDOW CENTERPT) (* rrb "14-Nov-85 16:46") + + (* xors a line from X Y to a point the opposite side of CENTERPT in a window. + Used as the feedback function for reading the major radius point for ellipses.) + (* Mark the point too.) + (SHOWSKETCHXY X Y WINDOW) + (DRAWLINE X Y (PLUS X (TIMES 2 (DIFFERENCE (fetch (POSITION XCOORD) of CENTERPT) + X))) + (PLUS Y (TIMES 2 (DIFFERENCE (fetch (POSITION YCOORD) of CENTERPT) + Y))) + 1 + 'INVERT WINDOW]) (SK.READ.ELLIPSE.MINOR.PT + [LAMBDA (SKW CENTERPT MAJORPT) (* rrb "20-May-86 10:47") + + (* reads a position from the user that will be the major radius point of an + ellipse.) + + (SK.READ.POINT.WITH.FEEDBACK WINDOW ELLIPSE.SEMI.MINOR (AND SKETCH.VERBOSE.FEEDBACK + (FUNCTION + SK.SHOW.ELLIPSE.MINOR.RADIUS)) + (LIST CENTERPT (DISTANCEBETWEEN CENTERPT MAJORPT) + (COMPUTE.ELLIPSE.ORIENTATION CENTERPT MAJORPT)) + 'MIDDLE NIL SKETCH.USE.POSITION.PAD]) (SK.SHOW.ELLIPSE.MINOR.RADIUS + [LAMBDA (X Y WINDOW ELLIPSEARGS) (* rrb "15-Nov-85 14:17") + + (* xors a line from X Y to a point the opposite side of CENTERPT in a window. + Used as the feedback function for reading the major radius point for ellipses.) + (* Mark the point too.) + (SHOWSKETCHXY X Y WINDOW) + (PROG ((CENTERX (CAR ELLIPSEARGS)) + CENTERY) + (SETQ CENTERY (fetch (POSITION YCOORD) of CENTERX)) + (SETQ CENTERX (fetch (POSITION XCOORD) of CENTERX)) + (DRAWELLIPSE CENTERX CENTERY (SK.DISTANCE.TO CENTERX CENTERY X Y) + (CADR ELLIPSEARGS) + (CADDR ELLIPSEARGS) + 1 NIL WINDOW]) (ELLIPSE.INSIDEFN + [LAMBDA (GELLIPSE WREG) (* rrb "20-Jan-87 14:45") + + (* determines if the global ellipse GELLIPSE is inside of WREG.) + + (REGIONSINTERSECTP WREG (ELLIPSE.GLOBALREGIONFN GELLIPSE]) (ELLIPSE.CREATE + [LAMBDA (CENTERPT MINPT MAJPT BRUSH DASHING INITSCALE) (* rrb "19-Jul-85 14:26") + (* creates a global ellipse element.) + (PROG ((MAXRAD (MAX (DISTANCEBETWEEN CENTERPT MINPT) + (DISTANCEBETWEEN CENTERPT MAJPT))) + ORIENTATION) + (RETURN (create GLOBALPART + COMMONGLOBALPART _ (create COMMONGLOBALPART + MAXSCALE _ MAXRAD + MINSCALE _ (QUOTIENT MAXRAD 3000.0)) + INDIVIDUALGLOBALPART _ + (create ELLIPSE + ORIENTATION _ (SETQ ORIENTATION (COMPUTE.ELLIPSE.ORIENTATION CENTERPT + MAJPT)) + BRUSH _ BRUSH + DASHING _ DASHING + ELLIPSECENTERLATLON _ CENTERPT + SEMIMINORLATLON _ (SK.COMPUTE.ELLIPSE.MINOR.RADIUS.PT CENTERPT MAJPT + MINPT ORIENTATION) + SEMIMAJORLATLON _ MAJPT + ELLIPSEINITSCALE _ INITSCALE]) (SK.UPDATE.ELLIPSE.AFTER.CHANGE + [LAMBDA (GELLIPSEELT) (* rrb " 7-Dec-85 19:54") + + (* updates the dependent fields of an ellipse element when a field changes.) + + (replace (ELLIPSE ELLIPSEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELLIPSEELT) + with NIL]) (ELLIPSE.REGIONFN + [LAMBDA (ELLIPSCRELT) (* rrb " 3-Oct-85 17:10") + (* returns the region occuppied by an + ellipse.) + (PROG ((LOCALELLIPSE (fetch (SCREENELT LOCALPART) of ELLIPSCRELT)) + MAJORRADPT CENTERX CENTERY BRUSHADJ HALFWID HALFHGHT RADRATIO DELTAX DELTAY) + (SETQ MAJORRADPT (fetch (LOCALELLIPSE MAJORRADIUSPOSITION) of LOCALELLIPSE)) + (SETQ CENTERY (fetch (LOCALELLIPSE ELLIPSECENTER) of LOCALELLIPSE)) + [SETQ RADRATIO (ABS (FQUOTIENT (fetch (LOCALELLIPSE SEMIMINORRADIUS) of LOCALELLIPSE) + (fetch (LOCALELLIPSE SEMIMAJORRADIUS) of LOCALELLIPSE] + [SETQ DELTAX (ABS (IDIFFERENCE (SETQ CENTERX (fetch (POSITION XCOORD) of CENTERY)) + (fetch (POSITION XCOORD) of MAJORRADPT] + [SETQ DELTAY (ABS (IDIFFERENCE (SETQ CENTERY (fetch (POSITION YCOORD) of CENTERY)) + (fetch (POSITION YCOORD) of MAJORRADPT] + (SETQ BRUSHADJ (LRSH (ADD1 (fetch (BRUSH BRUSHSIZE) of (fetch (LOCALELLIPSE + LOCALELLIPSEBRUSH) + of LOCALELLIPSE))) + 1)) + (SETQ HALFWID (FIXR (PLUS DELTAX (FTIMES RADRATIO DELTAY) + BRUSHADJ))) + (SETQ HALFHGHT (FIXR (PLUS DELTAY (FTIMES RADRATIO DELTAX) + BRUSHADJ))) + + (* use the rectangle that contains the rectangle made by the extreme points of + the ellipse. This gets more than is called for when the orientation isn't 0 or + 90.0) + + (RETURN (CREATEREGION (IDIFFERENCE CENTERX HALFWID) + (IDIFFERENCE CENTERY HALFHGHT) + (ITIMES HALFWID 2) + (ITIMES HALFHGHT 2]) (ELLIPSE.GLOBALREGIONFN + [LAMBDA (GELELT) (* rrb "20-Nov-85 16:09") + + (* returns the global region occupied by a global ellipse element.) + + (OR (fetch (ELLIPSE ELLIPSEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELELT)) + (PROG ((INDVELLIPSE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELELT)) + CENTERPT HALFBOXSIZE MAXRAD REGION) + (SETQ CENTERPT (fetch (ELLIPSE ELLIPSECENTERLATLON) of INDVELLIPSE)) + [SETQ MAXRAD (MAX (DISTANCEBETWEEN CENTERPT (fetch (ELLIPSE SEMIMAJORLATLON) + of INDVELLIPSE)) + (DISTANCEBETWEEN CENTERPT (fetch (ELLIPSE SEMIMINORLATLON) + of INDVELLIPSE] + [SETQ HALFBOXSIZE (PLUS MAXRAD (fetch (BRUSH BRUSHSIZE) of (fetch (ELLIPSE BRUSH) + of INDVELLIPSE] + + (* use a square about the center as wide as the largest radius. + This gets too much but is easy to calculate.) + + (SETQ REGION (CREATEREGION (DIFFERENCE (fetch (POSITION XCOORD) of CENTERPT) + HALFBOXSIZE) + (DIFFERENCE (fetch (POSITION YCOORD) of CENTERPT) + HALFBOXSIZE) + (ITIMES HALFBOXSIZE 2) + (ITIMES HALFBOXSIZE 2))) + (replace (ELLIPSE ELLIPSEREGION) of INDVELLIPSE with REGION) + (RETURN REGION]) (ELLIPSE.TRANSLATEFN + [LAMBDA (SKELT DELTAPOS) (* rrb "18-Oct-85 17:08") + + (* returns a global ellipse element which has been translated by DELTAPOS.) + + (PROG ((GLOBALEL (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKELT))) + (RETURN (create GLOBALPART + COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) of SKELT)) + INDIVIDUALGLOBALPART _ (create ELLIPSE using GLOBALEL ORIENTATION _ + (fetch (ELLIPSE ORIENTATION) + of GLOBALEL) + ELLIPSECENTERLATLON _ + (PTPLUS (fetch (ELLIPSE + ELLIPSECENTERLATLON + ) + of GLOBALEL) + DELTAPOS) + SEMIMINORLATLON _ + (PTPLUS (fetch (ELLIPSE + SEMIMINORLATLON + ) + of GLOBALEL) + DELTAPOS) + SEMIMAJORLATLON _ + (PTPLUS (fetch (ELLIPSE + SEMIMAJORLATLON + ) + of GLOBALEL) + DELTAPOS) + ELLIPSEREGION _ NIL]) (ELLIPSE.TRANSFORMFN + [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "26-Apr-85 16:21") + + (* returns a copy of the global ellipse element that has had each of its + control points transformed by transformfn. + TRANSFORMDATA is arbitrary data that is passed to tranformfn.) + + (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (RETURN (ELLIPSE.CREATE (SK.TRANSFORM.POINT (fetch (ELLIPSE ELLIPSECENTERLATLON) + of INDVPART) + TRANSFORMFN TRANSFORMDATA) + (SK.TRANSFORM.POINT (fetch (ELLIPSE SEMIMINORLATLON) of INDVPART) + TRANSFORMFN TRANSFORMDATA) + (SK.TRANSFORM.POINT (fetch (ELLIPSE SEMIMAJORLATLON) of INDVPART) + TRANSFORMFN TRANSFORMDATA) + (SK.TRANSFORM.BRUSH (fetch (ELLIPSE BRUSH) of INDVPART) + SCALEFACTOR) + (fetch (ELLIPSE DASHING) of INDVPART) + (fetch (ELLIPSE ELLIPSEINITSCALE) of INDVPART]) (ELLIPSE.TRANSLATEPTS + [LAMBDA (ELLIPSESPEC SELPTS GLOBALDELTA WINDOW) (* rrb " 5-May-85 16:41") + + (* returns a new global ellipse element which has the points on SELPTS moved by + a global distance.) + + (PROG ((LELLIPSE (fetch (SCREENELT LOCALPART) of ELLIPSESPEC)) + (GELLIPSE (fetch (SCREENELT INDIVIDUALGLOBALPART) of ELLIPSESPEC))) + (RETURN (ELLIPSE.CREATE (COND + ((MEMBER (fetch (LOCALELLIPSE ELLIPSECENTER) of LELLIPSE) + SELPTS) (* move the center) + (PTPLUS (fetch (ELLIPSE ELLIPSECENTERLATLON) of GELLIPSE) + GLOBALDELTA)) + (T (fetch (ELLIPSE ELLIPSECENTERLATLON) of GELLIPSE))) + (COND + ((MEMBER (fetch (LOCALELLIPSE MINORRADIUSPOSITION) of LELLIPSE) + SELPTS) (* move the radius point.) + (PTPLUS (fetch (ELLIPSE SEMIMINORLATLON) of GELLIPSE) + GLOBALDELTA)) + (T (fetch (ELLIPSE SEMIMINORLATLON) of GELLIPSE))) + (COND + ((MEMBER (fetch (LOCALELLIPSE MAJORRADIUSPOSITION) of LELLIPSE) + SELPTS) (* move the radius point.) + (PTPLUS (fetch (ELLIPSE SEMIMAJORLATLON) of GELLIPSE) + GLOBALDELTA)) + (T (fetch (ELLIPSE SEMIMAJORLATLON) of GELLIPSE))) + (fetch (ELLIPSE BRUSH) of GELLIPSE) + (fetch (ELLIPSE DASHING) of GELLIPSE) + (fetch (ELLIPSE ELLIPSEINITSCALE) of GELLIPSE]) (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]) (DISTANCEBETWEEN + [LAMBDA (P1 P2) (* rrb " 5-JAN-83 12:17") + (* returns the distance between two + points) + (SQRT (PLUS (SQUARE (DIFFERENCE (fetch (POSITION XCOORD) of P1) + (fetch (POSITION XCOORD) of P2))) + (SQUARE (DIFFERENCE (fetch (POSITION YCOORD) of P1) + (fetch (POSITION YCOORD) of P2]) (SK.DISTANCE.TO + [LAMBDA (X1 Y1 X2 Y2) (* rrb "15-Nov-85 14:17") + (* returns the distance between two + points) + (SQRT (PLUS (SQUARE (DIFFERENCE X1 X2)) + (SQUARE (DIFFERENCE Y1 Y2]) (SQUARE + [LAMBDA (X) + (TIMES X X]) (COMPUTE.ELLIPSE.ORIENTATION + [LAMBDA (CENTERPT MAJRADPT) (* rrb "19-Oct-85 12:44") + + (* computes the orientation of an ellipse from its center point and its major + radius point.) + + (PROG [(DELTAX (IDIFFERENCE (fetch (POSITION XCOORD) of MAJRADPT) + (fetch (POSITION XCOORD) of CENTERPT] + (RETURN (COND + ((ZEROP DELTAX) + 90.0) + (T (ARCTAN2 (IDIFFERENCE (fetch (POSITION YCOORD) of MAJRADPT) + (fetch (POSITION YCOORD) of CENTERPT)) + DELTAX]) (SK.COMPUTE.ELLIPSE.MINOR.RADIUS.PT + [LAMBDA (CENTER MAJORRADPT MINORPT ORIENTATION) (* rrb "19-Jul-85 14:23") + + (* computes the point that is on the minor radius of an ellipse about CENTER + with major radius and axis determined by MAJORRADPT and minor radius determines + by MINORPT.) + + (PROG ((SINOR (SIN ORIENTATION)) + (COSOR (COS ORIENTATION)) + (SEMIMINORRADIUS (DISTANCEBETWEEN CENTER MINORPT)) + (SEMIMAJORRADIUS (DISTANCEBETWEEN CENTER MAJORRADPT))) + (RETURN (CREATEPOSITION (DIFFERENCE (fetch (POSITION XCOORD) of CENTER) + (FTIMES SINOR SEMIMINORRADIUS)) + (PLUS (fetch (POSITION YCOORD) of CENTER) + (FTIMES COSOR SEMIMINORRADIUS]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD LOCALELLIPSE ((ELLIPSECENTER MINORRADIUSPOSITION MAJORRADIUSPOSITION) LOCALHOTREGION SEMIMINORRADIUS SEMIMAJORRADIUS LOCALELLIPSEBRUSH LOCALELLIPSEDASHING LOCALELLIPSEFILLING)) (TYPERECORD ELLIPSE (ELLIPSECENTERLATLON SEMIMINORLATLON SEMIMAJORLATLON ORIENTATION BRUSH DASHING ELLIPSEINITSCALE ELLIPSEFILLING ELLIPSEREGION)) ) ) (READVARS-FROM-STRINGS '(ELLIPSEICON) "({(READBITMAP)(20 12 %"@COL@@@@%" %"AOOOH@@@%" %"CN@GL@@@%" %"G@@@N@@@%" %"N@@@G@@@%" %"L@@@C@@@%" %"L@@@C@@@%" %"N@@@G@@@%" %"G@@@N@@@%" %"CN@GL@@@%" %"AOOOH@@@%" %"@COL@@@@%")}) ") (RPAQ ELLIPSE.CENTER (CURSORCREATE (QUOTE #*(16 16)@@@@@GL@AOO@CLGHG@ALF@@LN@@NL@@FL@@FL@@FN@@NF@@LG@ALCLGHAOO@@GL@ ) (QUOTE NIL) 7 7)) (RPAQ ELLIPSE.SEMI.MAJOR (CURSORCREATE (QUOTE #*(16 16)@@@L@@@D@@@F@@@B@@@C@@LA@@OA@@GMOOOO@@GM@@OA@@LC@@@B@@@F@@@D@@@L ) (QUOTE NIL) 15 7)) (RPAQ ELLIPSE.SEMI.MINOR (CURSORCREATE (QUOTE #*(16 16)@ON@CICHNCHNHCHC@GL@@GL@@ON@@MF@@A@@@A@@@A@@@A@@@A@@@A@@@A@@@A@@ ) (QUOTE NIL) 7 15)) (DEFINEQ (SKETCH.CREATE.OPEN.CURVE + [LAMBDA (POINTS BRUSH DASHING ARROWHEADS SCALE) (* rrb "16-Oct-85 17:14") + (* creates a sketch open curve + element.) + (SK.CURVE.CREATE (SK.INSURE.POINT.LIST POINTS) + NIL + (SK.INSURE.BRUSH BRUSH) + (SK.INSURE.DASHING DASHING) + (OR (NUMBERP SCALE) + 1.0) + (SK.INSURE.ARROWHEADS ARROWHEADS]) (OPENCURVE.INPUTFN + [LAMBDA (W) (* rrb "19-Mar-86 17:40") + (* reads a spline {series of points} + from the user.) + (PROG ((SKCONTEXT (WINDOWPROP W 'SKETCHCONTEXT)) + KNOTS) + (RETURN (SK.CURVE.CREATE (SETQ KNOTS (for PT in (READ.LIST.OF.POINTS W T) + collect (SK.MAP.INPUT.PT.TO.GLOBAL PT W))) + NIL + (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKCONTEXT) + (fetch (SKETCHCONTEXT SKETCHDASHING) of SKCONTEXT) + (SK.INPUT.SCALE W) + (SK.ARROWHEAD.CREATE W KNOTS]) (SK.CURVE.CREATE + [LAMBDA (GKNOTS CLOSED BRUSH DASHING INITSCALE ARROWHEADS) (* rrb "19-Mar-86 17:40") + (* creates a sketch element + representing a curve.) + (AND GKNOTS + (KNOT.SET.SCALE.FIELD (create GLOBALPART + INDIVIDUALGLOBALPART _ + (COND + (CLOSED (create CLOSEDCURVE + LATLONKNOTS _ GKNOTS + BRUSH _ BRUSH + DASHING _ DASHING + CLOSEDCURVEINITSCALE _ INITSCALE)) + (T (SET.OPENCURVE.ARROWHEAD.POINTS (create OPENCURVE + LATLONKNOTS _ + GKNOTS + BRUSH _ BRUSH + DASHING _ DASHING + OPENCURVEINITSCALE + _ INITSCALE + CURVEARROWHEADS _ + ARROWHEADS]) (MAXXEXTENT + [LAMBDA (PTS) (* rrb " 1-APR-83 17:24") + + (* returns the maximum width between any two points on pts) + + (COND + ((NULL PTS) + 0) + (T (PROG ((XMIN (fetch (POSITION XCOORD) of (CAR PTS))) + XMAX) + (SETQ XMAX XMIN) + [for PT in (CDR PTS) do (COND + ((GREATERP (SETQ PT (fetch (POSITION XCOORD) of PT)) + XMAX) + (SETQ XMAX PT))) + (COND + ((GREATERP XMIN PT) + (SETQ XMIN PT] + (RETURN (DIFFERENCE XMAX XMIN]) (MAXYEXTENT + [LAMBDA (PTS) (* rrb " 1-APR-83 17:24") + + (* returns the maximum height between any two points on pts) + + (COND + ((NULL PTS) + 0) + (T (PROG ((YMIN (fetch (POSITION YCOORD) of (CAR PTS))) + YMAX) + (SETQ YMAX YMIN) + [for PT in (CDR PTS) do (COND + ((GREATERP (SETQ PT (fetch (POSITION YCOORD) of PT)) + YMAX) + (SETQ YMAX PT))) + (COND + ((GREATERP YMIN PT) + (SETQ YMIN PT] + (RETURN (DIFFERENCE YMAX YMIN]) (KNOT.SET.SCALE.FIELD + [LAMBDA (GKNOTELT) (* rrb "31-Jan-85 18:22") + + (* updates the scale field after a change in the knots of a knotted element.) + + (PROG [(PTS (fetch (KNOTELT LATLONKNOTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GKNOTELT] + (replace (GLOBALPART MINSCALE) of GKNOTELT with 0.0) + + (* show it as long as it is two points wide or high.) + + (replace (GLOBALPART MAXSCALE) of GKNOTELT with (FQUOTIENT (MAX 8 (MAXXEXTENT PTS) + (MAXYEXTENT PTS)) + 2.0)) + (RETURN GKNOTELT]) (OPENCURVE.DRAWFN + [LAMBDA (CURVEELT WINDOW REGION) (* rrb " 6-May-86 17:42") + (* draws a curve figure element.) + (PROG ((GCURVE (fetch (SCREENELT INDIVIDUALGLOBALPART) of CURVEELT)) + (LCURVE (fetch (SCREENELT LOCALPART) of CURVEELT)) + BRUSH LOCALPTS LOCALARROWPTS GARROWSPECS) + (AND REGION (NOT (REGIONSINTERSECTP REGION (SK.ITEM.REGION CURVEELT))) + (RETURN)) + (SETQ GARROWSPECS (fetch (OPENCURVE CURVEARROWHEADS) of GCURVE)) + (SETQ LOCALARROWPTS (fetch (LOCALCURVE ARROWHEADPTS) of LCURVE)) + (SETQ LOCALPTS (\SK.ADJUST.FOR.ARROWHEADS (fetch (LOCALCURVE KNOTS) of LCURVE) + LOCALARROWPTS GARROWSPECS WINDOW)) + (DRAWCURVE LOCALPTS NIL (SETQ BRUSH (fetch (LOCALCURVE LOCALCURVEBRUSH) of LCURVE)) + (fetch (LOCALCURVE LOCALCURVEDASHING) of LCURVE) + WINDOW) + (DRAWARROWHEADS GARROWSPECS LOCALARROWPTS WINDOW BRUSH]) (OPENCURVE.EXPANDFN + [LAMBDA (GELT SCALE) (* rrb " 2-May-86 10:50") + + (* returns a local record which has the LATLONKNOTS field of the global element + GELT translated into window coordinats. Used for open curves) + + (PROG ((INDGELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) + LOCALKNOTS TMP) + [COND + ((fetch (OPENCURVE OPENCURVEINITSCALE) of INDGELT)) + (T + + (* old format didn't have an initial scale, default it to 1.0) + + (replace (GLOBALPART INDIVIDUALGLOBALPART) of GELT + with (SETQ INDGELT (create OPENCURVE using INDGELT OPENCURVEINITSCALE _ 1.0 + OPENCURVEREGION _ NIL] + (COND + ((AND (fetch (OPENCURVE CURVEARROWHEADS) of INDGELT) + (NOT (fetch (OPENCURVE OPENCURVEARROWHEADPOINTS) of INDGELT))) + (* old form didn't have global points, + update it) + (SET.OPENCURVE.ARROWHEAD.POINTS INDGELT))) + (SETQ LOCALKNOTS (for LATLONPT in (fetch (OPENCURVE LATLONKNOTS) of INDGELT) + collect (SK.SCALE.POSITION.INTO.VIEWER LATLONPT SCALE))) + (RETURN (create SCREENELT + LOCALPART _ + (create LOCALCURVE + KNOTS _ LOCALKNOTS + ARROWHEADPTS _ (SK.EXPAND.ARROWHEADS (fetch (OPENCURVE + OPENCURVEARROWHEADPOINTS + ) of INDGELT) + SCALE) + LOCALCURVEBRUSH _ + (SCALE.BRUSH (COND + ([NOT (NUMBERP (SETQ TMP (fetch (OPENCURVE BRUSH) + of INDGELT] + (* new format, old format had brush + width only.) + TMP) + (T [replace (OPENCURVE BRUSH) of INDGELT + with (SETQ TMP + (create BRUSH + BRUSHSIZE _ TMP + BRUSHSHAPE _ 'ROUND] + TMP)) + (fetch (OPENCURVE OPENCURVEINITSCALE) of INDGELT) + SCALE) + LOCALCURVEDASHING _ (fetch (OPENCURVE DASHING) of INDGELT)) + GLOBALPART _ GELT]) (OPENCURVE.READCHANGEFN + [LAMBDA (SKW SCRNELTS) (* rrb "17-Dec-85 16:22") + (* changefn for curves) + (PROG (ASPECT HOW) + (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU + (create MENU + CENTERFLG _ T + TITLE _ "Which aspect?" + ITEMS _ (APPEND (COND + [(SKETCHINCOLORP) + '((Color 'BRUSHCOLOR + "Changes the color of the curve." + ] + (T NIL)) + '((Arrowheads 'ARROW + "allows changing of arrow head charactistics." + ) + (Shape 'SHAPE + "changes the shape of the brush" + ) + (Size 'SIZE + "changes the size of the brush" + ) + (Dashing 'DASHING + "changes the dashing of the line." + ) + ("Add point" 'ADDPOINT + "adds a point to the curve." + ] + (SIZE (READSIZECHANGE "Change size how?")) + (SHAPE (READBRUSHSHAPE)) + (ARROW (READ.ARROW.CHANGE SCRNELTS)) + (DASHING (READ.DASHING.CHANGE)) + (BRUSHCOLOR [READ.COLOR.CHANGE "Change curve color how?" NIL + (fetch (BRUSH BRUSHCOLOR) + of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) + of (CAR SCRNELTS)) + 'BRUSH]) + (ADDPOINT (READ.POINT.TO.ADD (CAR SCRNELTS) + SKW)) + NIL)) + (RETURN (AND HOW (LIST ASPECT HOW]) (OPENCURVE.TRANSFORMFN + [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "19-Mar-86 17:40") + + (* returns a copy of the global OPENCURVE element that has had each of its + control points transformed by transformfn. + TRANSFORMDATA is arbitrary data that is passed to tranformfn.) + + (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (RETURN (KNOT.SET.SCALE.FIELD (create GLOBALPART + using GELT INDIVIDUALGLOBALPART _ + (SET.OPENCURVE.ARROWHEAD.POINTS + (create OPENCURVE using INDVPART LATLONKNOTS _ + (SK.TRANSFORM.POINT.LIST + (fetch (OPENCURVE + LATLONKNOTS) + of INDVPART) + TRANSFORMFN TRANSFORMDATA) + BRUSH _ + (SK.TRANSFORM.BRUSH + (fetch (OPENCURVE BRUSH) + of INDVPART) + SCALEFACTOR) + CURVEARROWHEADS _ + (SK.TRANSFORM.ARROWHEADS + (fetch (OPENCURVE + CURVEARROWHEADS + ) + of INDVPART) + SCALEFACTOR) + OPENCURVEREGION _ NIL]) (OPENCURVE.TRANSLATEFN + [LAMBDA (OCELT DELTAPOS) (* rrb "20-Mar-86 15:09") + (* translates an opencurve element) + (PROG ((NEWOCELT (KNOTS.TRANSLATEFN OCELT DELTAPOS))) + (SET.OPENCURVE.ARROWHEAD.POINTS (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWOCELT)) + (RETURN NEWOCELT]) (OPENCURVE.TRANSLATEPTSFN + [LAMBDA (KNOTELT SELPTS GDELTA WINDOW) (* rrb " 5-May-85 17:49") + + (* returns a curve element which has the knots that are members of SELPTS + translated by the global amount GDELTA.) + + (PROG ((GKNOTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of KNOTELT))) + (RETURN (SK.CURVE.CREATE (for PT in (fetch (LOCALCURVE KNOTS) of (fetch (SCREENELT + LOCALPART) + of KNOTELT)) + as LATLONPT in (fetch LATLONKNOTS of GKNOTELT) + collect (COND + ((MEMBER PT SELPTS) + (PTPLUS LATLONPT GDELTA)) + (T LATLONPT))) + NIL + (fetch (OPENCURVE BRUSH) of GKNOTELT) + (fetch (OPENCURVE DASHING) of GKNOTELT) + (fetch (OPENCURVE OPENCURVEINITSCALE) of GKNOTELT) + (fetch (OPENCURVE CURVEARROWHEADS) of GKNOTELT]) (SKETCH.CREATE.CLOSED.CURVE + [LAMBDA (POINTS BRUSH DASHING WILLBEFILLING SCALE) (* rrb "16-Oct-85 17:15") + (* creates a sketch closed curve + element.) + (SK.CURVE.CREATE (SK.INSURE.POINT.LIST POINTS) + T + (SK.INSURE.BRUSH BRUSH) + (SK.INSURE.DASHING DASHING) + (OR (NUMBERP SCALE) + 1.0]) (CLOSEDCURVE.DRAWFN + [LAMBDA (CURVEELT WINDOW REGION) (* rrb " 7-Dec-85 20:45") + (* draws a curve figure element.) + (PROG ((LCURVE (fetch (SCREENELT LOCALPART) of CURVEELT))) + + (* make sure this curve might be in the REGION of interest.) + + (AND REGION (NOT (REGIONSINTERSECTP REGION (SK.ITEM.REGION CURVEELT))) + (RETURN)) + (DRAWCURVE (fetch (LOCALCLOSEDCURVE LOCALCLOSEDCURVEKNOTS) of LCURVE) + T + (fetch (LOCALCLOSEDCURVE LOCALCLOSEDCURVEBRUSH) of LCURVE) + (fetch (LOCALCLOSEDCURVE LOCALCLOSEDCURVEDASHING) of LCURVE) + WINDOW]) (CLOSEDCURVE.EXPANDFN + [LAMBDA (GELT SCALE) (* rrb " 7-Dec-85 20:45") + + (* returns a local record which has the LATLONKNOTS field of the global element + GELT translated into window coordinats. Used for curves and wires.) + + (PROG ((INDVKNOTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) + BRSH) + [COND + ((fetch (CLOSEDCURVE CLOSEDCURVEINITSCALE) of INDVKNOTELT)) + (T + + (* old format didn't have an initial scale, default it to 1.0) + + (replace (GLOBALPART INDIVIDUALGLOBALPART) of GELT + with (SETQ INDVKNOTELT (create CLOSEDCURVE + using INDVKNOTELT CLOSEDCURVEINITSCALE _ 1.0 + CLOSEDCURVEREGION _ NIL] + (RETURN (create SCREENELT + LOCALPART _ + (create LOCALCLOSEDCURVE + LOCALCLOSEDCURVEKNOTS _ (for LATLONPT + in (fetch LATLONKNOTS of INDVKNOTELT) + collect (SK.SCALE.POSITION.INTO.VIEWER + LATLONPT SCALE)) + LOCALCLOSEDCURVEBRUSH _ + (SCALE.BRUSH (COND + ([NOT (NUMBERP (SETQ BRSH (fetch (CLOSEDCURVE BRUSH) + of INDVKNOTELT] + (* new format, old format had brush + width only.) + BRSH) + (T [replace (CLOSEDCURVE BRUSH) of INDVKNOTELT + with (SETQ BRSH + (create BRUSH + BRUSHSIZE _ BRSH + BRUSHSHAPE _ 'ROUND] + BRSH)) + (fetch (CLOSEDCURVE CLOSEDCURVEINITSCALE) of INDVKNOTELT) + SCALE) + LOCALCLOSEDCURVEFILLING _ (APPEND (fetch (CLOSEDCURVE + CLOSEDCURVEFILLING) + of INDVKNOTELT)) + LOCALCLOSEDCURVEDASHING _ (fetch (CLOSEDCURVE DASHING) of INDVKNOTELT + )) + GLOBALPART _ GELT]) (CLOSEDCURVE.REGIONFN + [LAMBDA (KNOTSCRELT) (* rrb " 2-Dec-85 20:40") + + (* returns the region occuppied by a list of knots which represent a curve.) + + (* uses the heuristic that the region containing the curve is not more than + 20% larger than the knots. This was determined empirically on several curves.) + + (INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS (fetch (SCREENELT HOTSPOTS) of KNOTSCRELT)) + 1.4) + (IQUOTIENT [ADD1 (SK.BRUSH.SIZE (fetch (LOCALCLOSEDCURVE LOCALCLOSEDCURVEBRUSH) + of (fetch (SCREENELT LOCALPART) of KNOTSCRELT] + 2]) (CLOSEDCURVE.GLOBALREGIONFN + [LAMBDA (GCLOSEDCURVEELT) (* rrb "18-Oct-85 16:37") + + (* returns the global region occupied by a global closed curve element.) + + (OR (fetch (CLOSEDCURVE CLOSEDCURVEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GCLOSEDCURVEELT)) + (PROG ((INDVCLOSEDCURVE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCLOSEDCURVEELT)) + REGION) + + (* uses the heuristic that the region containing the curve is not more than + 40% larger than the knots. This was determined empirically on several curves.) + + [SETQ REGION (INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS (fetch (CLOSEDCURVE + LATLONKNOTS) + of INDVCLOSEDCURVE + )) + 1.4) + (SK.BRUSH.SIZE (fetch (CLOSEDCURVE BRUSH) of INDVCLOSEDCURVE] + (replace (CLOSEDCURVE CLOSEDCURVEREGION) of INDVCLOSEDCURVE with REGION) + (RETURN REGION]) (READ.LIST.OF.POINTS + [LAMBDA (W ALLOWDUPS?) (* rrb "10-Jun-86 15:43") + (* reads a spline {series of points} + from the user.) + (PROG (PT PTS ERRSTAT) + (STATUSPRINT W " +" "Enter the points the curve goes through using the left button. +Click outside the window to stop.") + LP (COND + ((AND [SETQ ERRSTAT (ERSETQ (SETQ PT (SK.READ.POINT.WITH.FEEDBACK W POINTREADINGCURSOR + NIL NIL NIL NIL (AND SKETCH.USE.POSITION.PAD + 'MULTIPLE] + PT) (* add the point to the list and mark + it.) + [COND + ([OR ALLOWDUPS? (NOT (EQUAL (fetch (INPUTPT INPUT.POSITION) + of (CAR (LAST PTS))) + (fetch (INPUTPT INPUT.POSITION) of PT] + (SHOWSKETCHPOINT (fetch (INPUTPT INPUT.POSITION) of PT) + W PTS) + (SETQ PTS (NCONC1 PTS PT] + (GO LP))) (* erase point markers.) + (for PTTAIL on PTS do (SHOWSKETCHPOINT (fetch (INPUTPT INPUT.POSITION) of (CAR PTTAIL)) + W + (CDR PTTAIL))) + (CLOSEPROMPTWINDOW W) + (CLRPROMPT) + (COND + (ERRSTAT (* no error.) + (RETURN PTS)) + (T (* had an error, pass it on) + (ERROR!]) (CLOSEDCURVE.INPUTFN + [LAMBDA (W) (* rrb " 4-Sep-85 15:49") + (* reads a spline {series of points} + from the user.) + (SK.CURVE.CREATE (for PT in (READ.LIST.OF.POINTS W T) collect (SK.MAP.INPUT.PT.TO.GLOBAL PT W)) + T + (fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP W 'SKETCHCONTEXT)) + (fetch (SKETCHCONTEXT SKETCHDASHING) of (WINDOWPROP W 'SKETCHCONTEXT)) + (SK.INPUT.SCALE W]) (CLOSEDCURVE.READCHANGEFN + [LAMBDA (SKW SCRNELTS) (* rrb "20-Nov-85 11:09") + (* changefn for curves) + (PROG (ASPECT HOW) + (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU + (create MENU + CENTERFLG _ T + TITLE _ "select aspect of brush to change" + ITEMS _ (APPEND (COND + [(SKETCHINCOLORP) + '(("Color" 'BRUSHCOLOR + "changes the color of the brush" + ] + (T NIL)) + '((Shape 'SHAPE + "changes the shape of the brush" + ) + (Size 'SIZE + "changes the size of the brush" + ) + (Dashing 'DASHING + "changes the dashing of the line." + ) + ("Add point" 'ADDPOINT + "adds a point to the curve." + ] + (SIZE (READSIZECHANGE "Change size how?")) + (SHAPE (READBRUSHSHAPE)) + (DASHING (READ.DASHING.CHANGE)) + (BRUSHCOLOR [READ.COLOR.CHANGE "Change brush color how?" NIL + (fetch (BRUSH BRUSHCOLOR) + of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) + of (CAR SCRNELTS)) + 'BRUSH]) + (ADDPOINT (READ.POINT.TO.ADD (CAR SCRNELTS) + SKW)) + NIL)) + (RETURN (AND HOW (LIST ASPECT HOW]) (CLOSEDCURVE.TRANSFORMFN + [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "18-Oct-85 16:52") + + (* returns a copy of the global CLOSEDCURVE element that has had each of its + control points transformed by transformfn. + TRANSFORMDATA is arbitrary data that is passed to tranformfn.) + + (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (RETURN (KNOT.SET.SCALE.FIELD (create GLOBALPART using GELT INDIVIDUALGLOBALPART _ + (create CLOSEDCURVE + using INDVPART LATLONKNOTS _ + (SK.TRANSFORM.POINT.LIST + (fetch (CLOSEDCURVE + LATLONKNOTS) + of INDVPART) + TRANSFORMFN TRANSFORMDATA) + BRUSH _ + (SK.TRANSFORM.BRUSH + (fetch (CLOSEDCURVE BRUSH) + of INDVPART) + SCALEFACTOR) + CLOSEDCURVEREGION _ NIL]) (CLOSEDCURVE.TRANSLATEPTSFN + [LAMBDA (KNOTELT SELPTS GDELTA WINDOW) (* rrb " 5-May-85 18:35") + + (* returns a closed curve element which has the knots that are members of + SELPTS translated by the global amount GDELTA.) + + (PROG ((GKNOTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of KNOTELT))) + (RETURN (SK.CURVE.CREATE (for PT in (fetch (LOCALCURVE KNOTS) of (fetch (SCREENELT + LOCALPART) + of KNOTELT)) + as LATLONPT in (fetch LATLONKNOTS of GKNOTELT) + collect (COND + ((MEMBER PT SELPTS) + (PTPLUS LATLONPT GDELTA)) + (T LATLONPT))) + T + (fetch (CLOSEDCURVE BRUSH) of GKNOTELT) + (fetch (CLOSEDCURVE DASHING) of GKNOTELT) + (fetch (CLOSEDCURVE CLOSEDCURVEINITSCALE) of GKNOTELT) + NIL]) (INVISIBLEPARTP + [LAMBDA (WINDOW POINT) (* rrb "30-NOV-82 17:25") + + (* determines if POINT is in the visible part of a window.) + + (INSIDE? (DSPCLIPPINGREGION NIL WINDOW) + (fetch (POSITION XCOORD) of POINT) + (fetch (POSITION YCOORD) of POINT]) (SHOWSKETCHPOINT + [LAMBDA (NEWPT W PTS) (* rrb "12-May-85 18:50") + + (* puts down the marker for a new point unless it is already a member of + points.) + + (OR (MEMBER NEWPT PTS) + (MARKPOINT NEWPT W SPOTMARKER]) (SHOWSKETCHXY + [LAMBDA (X Y WINDOW) (* rrb " 2-Oct-85 09:58") + + (* puts down a marker for a point at position X,Y) + + (BITBLT SPOTMARKER NIL NIL WINDOW (IDIFFERENCE X (LRSH (fetch (BITMAP BITMAPWIDTH) of SPOTMARKER) + 1)) + (IDIFFERENCE Y (LRSH (fetch (BITMAP BITMAPHEIGHT) of SPOTMARKER) + 1)) + NIL NIL 'INPUT 'INVERT]) (KNOTS.REGIONFN + [LAMBDA (KNOTSCRELT) (* rrb "29-May-85 21:17") + (* returns the region occuppied by a + list of knots) + + (* increase by half the brush size plus 2 This has the nice property of + insuring that the region always has both height and width.) + + (INCREASEREGION (REGION.CONTAINING.PTS (fetch (SCREENELT HOTSPOTS) of KNOTSCRELT)) + (IPLUS 3 (QUOTIENT (fetch (BRUSH BRUSHSIZE) of (fetch (LOCALWIRE LOCALOPENWIREBRUSH) + of (fetch (SCREENELT LOCALPART) + of KNOTSCRELT))) + 2]) (OPENWIRE.GLOBALREGIONFN + [LAMBDA (GOPENWIREELT) (* rrb "23-Oct-85 11:30") + + (* returns the global region occupied by a global open curve element.) + + (OR (fetch (WIRE OPENWIREREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GOPENWIREELT)) + (PROG ((INDVOPENWIRE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GOPENWIREELT)) + REGION) + [SETQ REGION (INCREASEREGION (REGION.CONTAINING.PTS (fetch (WIRE LATLONKNOTS) + of INDVOPENWIRE)) + (SK.BRUSH.SIZE (fetch (WIRE BRUSH) of INDVOPENWIRE] + (replace (WIRE OPENWIREREGION) of INDVOPENWIRE with REGION) + (RETURN REGION]) (CURVE.REGIONFN + [LAMBDA (OPENCURVESCRELT) (* rrb "18-Oct-85 16:36") + + (* returns the region occuppied by a list of knots which represent a curve.) + + (* uses the heuristic that the region containing the curve is not more than + 40% larger than the knots. This was determined empirically on several curves.) + + (INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS (fetch (SCREENELT HOTSPOTS) of + OPENCURVESCRELT + )) + 1.4) + (IQUOTIENT [ADD1 (SK.BRUSH.SIZE (fetch (LOCALCURVE LOCALCURVEBRUSH) + of (fetch (SCREENELT LOCALPART) of OPENCURVESCRELT] + 2]) (OPENCURVE.GLOBALREGIONFN + [LAMBDA (GOPENCURVEELT) (* rrb "18-Oct-85 16:36") + + (* returns the global region occupied by a global open curve element.) + + (OR (fetch (OPENCURVE OPENCURVEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of + GOPENCURVEELT + )) + (PROG ((INDVOPENCURVE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GOPENCURVEELT)) + REGION) + + (* uses the heuristic that the region containing the curve is not more than + 40% larger than the knots. This was determined empirically on several curves.) + + [SETQ REGION (INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS (fetch (OPENCURVE + LATLONKNOTS) + of INDVOPENCURVE)) + 1.4) + (SK.BRUSH.SIZE (fetch (OPENCURVE BRUSH) of INDVOPENCURVE] + (replace (OPENCURVE OPENCURVEREGION) of INDVOPENCURVE with REGION) + (RETURN REGION]) (KNOTS.TRANSLATEFN + [LAMBDA (SKELT DELTAPOS) (* rrb " 4-Apr-86 11:31") + + (* replaces the knots field of the global part of a screen element with knots + that have been translated DELTAPOS.) + + (PROG [(GKNOTELT (APPEND (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKELT] + (replace (KNOTELT LATLONKNOTS) of GKNOTELT with (for PT in (fetch (KNOTELT LATLONKNOTS) + of GKNOTELT) + collect (PTPLUS PT DELTAPOS))) + (* clear the region cache.) + (replace (KNOTELT KNOTREGION) of GKNOTELT with NIL) + (RETURN (create GLOBALPART + COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) of SKELT)) + INDIVIDUALGLOBALPART _ GKNOTELT]) (REGION.CONTAINING.PTS + [LAMBDA (PTLST) (* rrb " 7-Sep-84 11:26") + + (* returns the region that contains all of the points on PTLST.) + + (AND PTLST (PROG ((XMIN (fetch (POSITION XCOORD) of (CAR PTLST))) + (XMAX (fetch (POSITION XCOORD) of (CAR PTLST))) + (YMIN (fetch (POSITION YCOORD) of (CAR PTLST))) + (YMAX (fetch (POSITION YCOORD) of (CAR PTLST))) + TMP) + [for PT in (CDR PTLST) do (COND + ((GREATERP (SETQ TMP (fetch (POSITION XCOORD) + of PT)) + XMAX) + (SETQ XMAX TMP)) + ((GREATERP XMIN TMP) + (SETQ XMIN TMP))) + (COND + ((GREATERP (SETQ TMP (fetch (POSITION YCOORD) + of PT)) + YMAX) + (SETQ YMAX TMP)) + ((GREATERP YMIN TMP) + (SETQ YMIN TMP] + (RETURN (CREATEREGION XMIN YMIN (DIFFERENCE XMAX XMIN) + (DIFFERENCE YMAX YMIN]) ) (DEFINEQ (CHANGE.ELTS.BRUSH.SIZE + [LAMBDA (HOWTOCHANGE ELTSWITHBRUSH SKW) (* rrb "10-Jan-85 14:00") + + (* * function that prompts for how the line thickness should change and changes + it for all elements in ELTSWITHBRUSH that have a brush size or thickness.) + + (* knows about the various types of sketch elements types and shouldn't.) + + (AND HOWTOCHANGE (for LINEDELT in ELTSWITHBRUSH collect (SK.CHANGE.BRUSH.SIZE LINEDELT + HOWTOCHANGE SKW]) (CHANGE.ELTS.BRUSH + [LAMBDA (CURVELTS SKW HOW) (* rrb " 4-Jan-85 14:55") + (* changefn for curves Actually makes + the change.) + (SELECTQ (CAR HOW) + (SIZE (CHANGE.ELTS.BRUSH.SIZE (CADR HOW) + CURVELTS SKW)) + (SHAPE (CHANGE.ELTS.BRUSH.SHAPE (CADR HOW) + CURVELTS SKW)) + NIL]) (CHANGE.ELTS.BRUSH.SHAPE + [LAMBDA (NEWSHAPE CURVELTS SKW) (* rrb "10-Jan-85 16:49") + + (* changes the brush shape of a list of curve elements. + Knows about the various sketch element types and shouldn't need to.) + + (AND NEWSHAPE (for CURVELT in CURVELTS collect (SK.CHANGE.BRUSH.SHAPE CURVELT NEWSHAPE SKW]) (SK.CHANGE.BRUSH.SHAPE + [LAMBDA (ELTWITHBRUSH HOW SKW) (* rrb "10-Mar-86 16:07") + (* changes the brush shape in the + element ELTWITHBRUSH.) + (PROG (GCURVELT BRUSH TYPE NEWELT NEWBRUSH) + (RETURN (COND + ((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHBRUSH)) + '(CLOSEDCURVE OPENCURVE ELLIPSE CIRCLE ARC CLOSEDWIRE WIRE)) + (* only works for things of curve + type.) + (SETQ GCURVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHBRUSH)) + (SETQ BRUSH (SELECTQ TYPE + (CIRCLE (fetch (CIRCLE BRUSH) of GCURVELT)) + (ARC (fetch (ARC ARCBRUSH) of GCURVELT)) + (ELLIPSE (fetch (ELLIPSE BRUSH) of GCURVELT)) + (WIRE (fetch (WIRE BRUSH) of GCURVELT)) + (CLOSEDWIRE (fetch (CLOSEDWIRE BRUSH) of GCURVELT)) + (fetch (OPENCURVE BRUSH) of GCURVELT))) + (COND + ((NEQ HOW (fetch (BRUSH BRUSHSHAPE) of BRUSH)) + (* new brush shape) + (SETQ NEWBRUSH (create BRUSH using BRUSH BRUSHSHAPE _ HOW)) + (SETQ NEWELT (SELECTQ TYPE + (CLOSEDCURVE (create CLOSEDCURVE + using GCURVELT BRUSH _ NEWBRUSH)) + (OPENCURVE (create OPENCURVE using GCURVELT BRUSH _ + NEWBRUSH)) + (CIRCLE (create CIRCLE using GCURVELT BRUSH _ NEWBRUSH)) + (ARC (create ARC using GCURVELT ARCBRUSH _ NEWBRUSH)) + (ELLIPSE (create ELLIPSE using GCURVELT BRUSH _ NEWBRUSH)) + (WIRE (create WIRE using GCURVELT BRUSH _ NEWBRUSH)) + (CLOSEDWIRE (create CLOSEDWIRE using GCURVELT BRUSH _ + NEWBRUSH)) + (SHOULDNT))) + (create SKHISTORYCHANGESPEC + OLDELT _ ELTWITHBRUSH + NEWELT _ (create GLOBALPART + COMMONGLOBALPART _ (fetch (GLOBALPART + COMMONGLOBALPART) + of ELTWITHBRUSH) + INDIVIDUALGLOBALPART _ NEWELT) + PROPERTY _ 'BRUSH + NEWVALUE _ NEWBRUSH + OLDVALUE _ BRUSH]) (SK.CHANGE.BRUSH.COLOR + [LAMBDA (ELTWITHLINE COLOR SKW) (* rrb " 8-Jan-86 17:25") + + (* changes the brush color of ELTWITHLINE if it has a brush) + + (* knows about the various types of sketch elements types and shouldn't.) + + (PROG ((GLINELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHLINE)) + TYPE BRUSH NEWBRUSH NEWELT) + (COND + [(MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHLINE)) + '(WIRE BOX CLOSEDWIRE CLOSEDCURVE OPENCURVE CIRCLE ELLIPSE TEXTBOX ARC)) + (* only works for things of wire type.) + + (* the brush is stored in the different place for all element types.) + + (SETQ BRUSH (SELECTQ TYPE + (CIRCLE (fetch (CIRCLE BRUSH) of GLINELT)) + (ELLIPSE (fetch (ELLIPSE BRUSH) of GLINELT)) + (TEXTBOX (fetch (TEXTBOX TEXTBOXBRUSH) of GLINELT)) + (CLOSEDCURVE (fetch (CLOSEDCURVE BRUSH) of GLINELT)) + (BOX (fetch (BOX BRUSH) of GLINELT)) + (ARC (fetch (ARC ARCBRUSH) of GLINELT)) + (fetch (OPENCURVE BRUSH) of GLINELT))) + (COND + ((NOT (EQUAL COLOR (fetch (BRUSH BRUSHCOLOR) of BRUSH))) + (SETQ NEWBRUSH (create BRUSH using BRUSH BRUSHCOLOR _ COLOR)) + (SETQ NEWELT (SELECTQ TYPE + (WIRE (create WIRE using GLINELT BRUSH _ NEWBRUSH)) + (BOX (create BOX using GLINELT BRUSH _ NEWBRUSH)) + (ARC (create ARC using GLINELT ARCBRUSH _ NEWBRUSH)) + (TEXTBOX (create TEXTBOX using GLINELT TEXTBOXBRUSH _ NEWBRUSH + TEXTCOLOR _ COLOR)) + (CLOSEDWIRE (create CLOSEDWIRE using GLINELT BRUSH _ NEWBRUSH)) + (CLOSEDCURVE (create CLOSEDCURVE using GLINELT BRUSH _ NEWBRUSH)) + (OPENCURVE (create OPENCURVE using GLINELT BRUSH _ NEWBRUSH)) + (CIRCLE (create CIRCLE using GLINELT BRUSH _ NEWBRUSH)) + (ELLIPSE (create ELLIPSE using GLINELT BRUSH _ NEWBRUSH)) + (SHOULDNT))) + (RETURN (create SKHISTORYCHANGESPEC + NEWELT _ (create GLOBALPART + COMMONGLOBALPART _ (fetch (GLOBALPART + COMMONGLOBALPART) + of ELTWITHLINE) + INDIVIDUALGLOBALPART _ NEWELT) + OLDELT _ ELTWITHLINE + PROPERTY _ 'BRUSH + NEWVALUE _ NEWBRUSH + OLDVALUE _ BRUSH] + ((EQ TYPE 'TEXT) (* change the color of text too.) + (COND + ((NOT (EQUAL COLOR (fetch (TEXT TEXTCOLOR) of GLINELT))) + (RETURN (create SKHISTORYCHANGESPEC + NEWELT _ (create GLOBALPART + COMMONGLOBALPART _ (fetch (GLOBALPART + COMMONGLOBALPART) + of ELTWITHLINE) + INDIVIDUALGLOBALPART _ + (create TEXT using GLINELT TEXTCOLOR _ COLOR)) + OLDELT _ ELTWITHLINE + PROPERTY _ 'TEXTCOLOR + NEWVALUE _ COLOR + OLDVALUE _ (fetch (TEXT TEXTCOLOR) of GLINELT]) (SK.CHANGE.BRUSH.SIZE + [LAMBDA (ELTWITHLINE HOW SKW) (* rrb "10-Jan-86 13:57") + + (* changes the line size of ELTWITHLINE if it has a brush size or thickness and + returns a change event.) + + (* knows about the various types of sketch elements types and shouldn't.) + + (PROG (SIZE GLINELT TYPE BRUSH NEWBRUSH NEWELT) + (COND + ((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHLINE)) + '(WIRE BOX CLOSEDWIRE CLOSEDCURVE OPENCURVE CIRCLE ELLIPSE TEXTBOX ARC)) + (SETQ GLINELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHLINE)) + (SETQ BRUSH (SELECTQ TYPE + (CIRCLE (fetch (CIRCLE BRUSH) of GLINELT)) + (ELLIPSE (fetch (ELLIPSE BRUSH) of GLINELT)) + (TEXTBOX (fetch (TEXTBOX TEXTBOXBRUSH) of GLINELT)) + (CLOSEDCURVE (fetch (CLOSEDCURVE BRUSH) of GLINELT)) + (BOX (fetch (BOX BRUSH) of GLINELT)) + (ARC (fetch (ARC ARCBRUSH) of GLINELT)) + (fetch (OPENCURVE BRUSH) of GLINELT))) + + (* the change to the brush size must take into account the current scale and + the scale at which the brush was entered.) + + (COND + ((GEQ [SETQ SIZE (COND + ((NUMBERP HOW) + HOW) + (T (SELECTQ HOW + (SMALLER (FQUOTIENT (fetch (BRUSH BRUSHSIZE) of BRUSH) + 2.0)) + (FTIMES (fetch (BRUSH BRUSHSIZE) of BRUSH) + 2.0] + 0) (* don't let the brush size go + negative.) + (SETQ NEWBRUSH (create BRUSH using BRUSH BRUSHSIZE _ SIZE)) + (SETQ NEWELT (SELECTQ TYPE + (WIRE (create WIRE using GLINELT BRUSH _ NEWBRUSH OPENWIREREGION _ + NIL)) + (BOX (create BOX using GLINELT BRUSH _ NEWBRUSH)) + (ARC (create ARC using GLINELT ARCBRUSH _ NEWBRUSH ARCREGION _ NIL + )) + (TEXTBOX + + (* since this may change the location of characters in the box, clear the + selection. Probably should happen somewhere else.) + + (SKED.CLEAR.SELECTION SKW) + (create TEXTBOX using GLINELT TEXTBOXBRUSH _ NEWBRUSH)) + (CLOSEDWIRE (create CLOSEDWIRE + using GLINELT BRUSH _ NEWBRUSH CLOSEDWIREREGION _ + NIL)) + (CLOSEDCURVE (create CLOSEDCURVE + using GLINELT BRUSH _ NEWBRUSH CLOSEDCURVEREGION _ + NIL)) + (OPENCURVE (create OPENCURVE + using GLINELT BRUSH _ NEWBRUSH OPENCURVEREGION _ NIL + )) + (CIRCLE (create CIRCLE using GLINELT BRUSH _ NEWBRUSH CIRCLEREGION + _ NIL)) + (ELLIPSE (create ELLIPSE using GLINELT BRUSH _ NEWBRUSH + ELLIPSEREGION _ NIL)) + (SHOULDNT))) + (RETURN (create SKHISTORYCHANGESPEC + NEWELT _ (create GLOBALPART + COMMONGLOBALPART _ (fetch (GLOBALPART + COMMONGLOBALPART) + of ELTWITHLINE) + INDIVIDUALGLOBALPART _ NEWELT) + OLDELT _ ELTWITHLINE + PROPERTY _ 'BRUSH + NEWVALUE _ NEWBRUSH + OLDVALUE _ BRUSH]) (SK.CHANGE.ANGLE + [LAMBDA (ELTWITHARC HOW SKW) (* rrb "20-Jun-86 17:18") + + (* changes the arc size of ELTWITHARC if it is an arc element) + + (PROG (GARCLT ARMANGLE RADIUS CENTERPT RADIUSPT CENTERX NEWANGLEPT CENTERY) + (COND + ((EQ (fetch (GLOBALPART GTYPE) of ELTWITHARC) + 'ARC) (* only works for things of arc type.) + (SETQ GARCLT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHARC)) + (SETQ CENTERPT (fetch (ARC ARCCENTERPT) of GARCLT)) + (SETQ CENTERX (fetch (POSITION XCOORD) of CENTERPT)) + (SETQ CENTERY (fetch (POSITION YCOORD) of CENTERPT)) + (SETQ RADIUSPT (fetch (ARC ARCRADIUSPT) of GARCLT)) + [SETQ ARMANGLE (COND + ((fetch (ARC ARCDIRECTION) of GARCLT) + (* clockwise direction) + (DIFFERENCE (SK.COMPUTE.SLOPE.OF.LINE CENTERPT RADIUSPT) + HOW)) + (T (* positive direction) + (PLUS (SK.COMPUTE.SLOPE.OF.LINE CENTERPT RADIUSPT) + HOW] + (SETQ RADIUS (DISTANCEBETWEEN CENTERPT RADIUSPT)) + + (* calculate a position on the circle the right number of degrees out.) + + [SETQ NEWANGLEPT (COND + ((OR (GEQ ARMANGLE 360.0) + (LEQ ARMANGLE -360.0))(* mark greater than 360 by T) + T) + (T (create POSITION + XCOORD _ [FIXR (PLUS CENTERX (TIMES RADIUS (COS ARMANGLE] + YCOORD _ (FIXR (PLUS CENTERY (TIMES RADIUS (SIN ARMANGLE] + (RETURN (create SKHISTORYCHANGESPEC + NEWELT _ + (create GLOBALPART + COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) + of ELTWITHARC) + INDIVIDUALGLOBALPART _ + (SET.ARC.ARROWHEAD.POINTS (create ARC + using GARCLT ARCANGLEPT _ NEWANGLEPT + ARCREGION _ NIL))) + OLDELT _ ELTWITHARC + PROPERTY _ '3RDCONTROLPT + NEWVALUE _ NEWANGLEPT + OLDVALUE _ (fetch (ARC ARCRADIUSPT) of GARCLT]) (SK.CHANGE.ARC.DIRECTION + [LAMBDA (ELTWITHARC HOW SKW) (* rrb "19-Mar-86 17:16") + + (* changes the direction around the circle that the arc element goes.) + + (PROG (GARCLT NOWDIRECTION) + (COND + ((EQ (fetch (GLOBALPART GTYPE) of ELTWITHARC) + 'ARC) (* only works for things of arc type.) + (SETQ GARCLT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHARC)) + (SETQ NOWDIRECTION (fetch (ARC ARCDIRECTION) of GARCLT)) + (COND + ((OR (AND (EQ HOW 'CLOCKWISE) + (NULL NOWDIRECTION)) + (AND (EQ HOW 'COUNTERCLOCKWISE) + NOWDIRECTION)) + + (* spec calls for one direction and it is currently going the other.) + + (RETURN (create SKHISTORYCHANGESPEC + NEWELT _ (create GLOBALPART + COMMONGLOBALPART _ (fetch (GLOBALPART + COMMONGLOBALPART) + of ELTWITHARC) + INDIVIDUALGLOBALPART _ + (SET.ARC.ARROWHEAD.POINTS (create ARC + using GARCLT + ARCDIRECTION _ + (NOT NOWDIRECTION + ) + ARCREGION _ NIL)) + ) + OLDELT _ ELTWITHARC + PROPERTY _ 'DIRECTION + NEWVALUE _ HOW + OLDVALUE _ (COND + (NOWDIRECTION 'CLOCKWISE) + (T 'COUNTERCLOCKWISE]) (SK.SET.DEFAULT.BRUSH.SIZE + [LAMBDA (NEWBRUSHSIZE SKW) (* rrb "12-Jan-85 10:13") + (* sets the default brush size to + NEWBRUSHSIZE) + (AND (NUMBERP NEWBRUSHSIZE) + (replace (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP SKW 'SKETCHCONTEXT) + with (create BRUSH using (fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP SKW + 'SKETCHCONTEXT)) + BRUSHSIZE _ NEWBRUSHSIZE]) (READSIZECHANGE + [LAMBDA (MENUTITLE ALLOWZEROFLG) (* rrb "14-May-86 19:26") + + (* interacts to get whether a line size should be increased or decreased.) + + (PROG [(NEWVALUE (\CURSOR.IN.MIDDLE.MENU (create MENU + TITLE _ MENUTITLE + ITEMS _ '(("smaller line" 'SMALLER + "decreases the line thickness by 1." + ) + ("LARGER LINE" 'LARGER + "increases the line thickness by 1." + ) + ("Set line size" 'SETSIZE + "sets the line thickness to an entered value." + )) + CENTERFLG _ T] + (RETURN (COND + ((EQ NEWVALUE 'SETSIZE) + (SETQ NEWVALUE (RNUMBER "Enter the new line thickness." NIL NIL NIL T T T T)) + (COND + ((AND (NULL ALLOWZEROFLG) + (EQ NEWVALUE 0)) + NIL) + ((GREATERP 0 NEWVALUE) (* don't allow negative values) + (MINUS NEWVALUE)) + (T NEWVALUE))) + (T NEWVALUE]) ) (DEFINEQ (SK.CHANGE.ELEMENT.KNOTS + [LAMBDA (ELTWITHKNOTS NEWKNOTS) (* rrb "19-Mar-86 17:50") + (* changes the knots in the element + ELTWITHKNOTS) + (PROG ((GCURVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHKNOTS)) + NEWELT) + (SETQ NEWELT (SELECTQ (fetch (INDIVIDUALGLOBALPART GTYPE) of GCURVELT) + (CLOSEDCURVE (create CLOSEDCURVE using GCURVELT LATLONKNOTS _ NEWKNOTS)) + (OPENCURVE (SET.OPENCURVE.ARROWHEAD.POINTS (create OPENCURVE + using GCURVELT LATLONKNOTS _ + NEWKNOTS))) + (WIRE (SET.WIRE.ARROWHEAD.POINTS (create WIRE using GCURVELT LATLONKNOTS _ + NEWKNOTS))) + (CLOSEDWIRE (create CLOSEDWIRE using GCURVELT LATLONKNOTS _ NEWKNOTS)) + (RETURN))) + (RETURN (KNOT.SET.SCALE.FIELD (create GLOBALPART + COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART + ) of ELTWITHKNOTS) + INDIVIDUALGLOBALPART _ NEWELT]) ) (DEFINEQ (SK.INSURE.POINT.LIST + [LAMBDA (POINTLST) (* rrb "16-Oct-85 17:01") + (* makes sure POINTLST is a list of + positions.) + (COND + ((LISTP POINTLST) + (AND (EVERY POINTLST (FUNCTION SK.INSURE.POSITION)) + POINTLST)) + (T (\ILLEGAL.ARG POINTLST]) (SK.INSURE.POSITION + [LAMBDA (POSITION) (* rrb "16-Oct-85 17:02") + (OR (POSITIONP POSITION) + (\ILLEGAL.ARG POSITION]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (TYPERECORD KNOTELT (LATLONKNOTS BRUSH DASHING NIL NIL KNOTREGION)) (RECORD LOCALCURVE (KNOTS LOCALHOTREGION ARROWHEADPTS LOCALCURVEBRUSH LOCALCURVEDASHING)) (TYPERECORD OPENCURVE (LATLONKNOTS BRUSH DASHING CURVEARROWHEADS OPENCURVEINITSCALE OPENCURVEREGION OPENCURVEARROWHEADPOINTS)) (TYPERECORD CLOSEDCURVE (LATLONKNOTS BRUSH DASHING CLOSEDCURVEINITSCALE CLOSEDCURVEFILLING CLOSEDCURVEREGION)) (RECORD LOCALCLOSEDCURVE (LOCALCLOSEDCURVEKNOTS LOCALCLOSEDCURVEHOTREGION LOCALCLOSEDCURVEBRUSH LOCALCLOSEDCURVEFILLING LOCALCLOSEDCURVEDASHING)) (RECORD LOCALCLOSEDWIRE (KNOTS LOCALHOTREGION LOCALCLOSEDWIREBRUSH LOCALCLOSEDWIREFILLING)) ) ) (READVARS-FROM-STRINGS '(OPENCURVEICON CLOSEDCURVEICON) "({(READBITMAP)(20 12 %"@@@@@@@@%" %"@L@@@@@@%" %"@L@@F@@@%" %"AL@@O@@@%" %"AH@@G@@@%" %"CH@@C@@@%" %"CH@@C@@@%" %"CH@@G@@@%" %"AN@@N@@@%" %"@OCLN@@@%" %"@COOL@@@%" %"@@NCH@@@%")} {(READBITMAP)(20 12 %"@@C@@@@@%" %"ALGO@@@@%" %"CNLOL@@@%" %"GCLAN@@@%" %"FAAHF@@@%" %"L@CLC@@@%" %"N@CFC@@@%" %"F@FFG@@@%" %"C@FGF@@@%" %"CLFCL@@@%" %"AON@H@@@%" %"@GL@@@@@%")}) ") (RPAQ CURVE.KNOT (CURSORCREATE (QUOTE #*(16 16)@GN@AOOHCLCLG@@NFDBFNJEGLEJCLBDCLBDCLEJCNJEGFDBFG@@NCLCLAOOH@GN@ ) (QUOTE NIL) 0 8)) (DEFINEQ (SKETCH.CREATE.WIRE + [LAMBDA (POINTS BRUSH DASHING ARROWHEADS SCALE) (* rrb "16-Oct-85 17:05") + (* creates a sketch wire element.) + (SK.WIRE.CREATE (SK.INSURE.POINT.LIST POINTS) + (SK.INSURE.BRUSH BRUSH) + (SK.INSURE.DASHING DASHING) + NIL + (OR (NUMBERP SCALE) + 1.0) + (SK.INSURE.ARROWHEADS ARROWHEADS) + NIL]) (CLOSEDWIRE.EXPANDFN + [LAMBDA (GELT SCALE) (* rrb " 2-Dec-85 20:42") + + (* returns a local record which has the LATLONKNOTS field of the global element + GELT translated into window coordinats. Used for closed wires.) + + (PROG ((INDVKNOTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) + BRSH) + [COND + ((fetch (CLOSEDWIRE CLOSEDWIREINITSCALE) of INDVKNOTELT)) + (T + + (* old format didn't have an initial scale, default it to 1.0) + + (replace (GLOBALPART INDIVIDUALGLOBALPART) of GELT + with (SETQ INDVKNOTELT (create CLOSEDWIRE + using INDVKNOTELT CLOSEDWIREINITSCALE _ 1.0 + CLOSEDWIREREGION _ NIL] + (RETURN (create SCREENELT + LOCALPART _ + (create LOCALCLOSEDWIRE + KNOTS _ (for LATLONPT in (fetch LATLONKNOTS of INDVKNOTELT) + collect (SK.SCALE.POSITION.INTO.VIEWER LATLONPT SCALE)) + LOCALCLOSEDWIREBRUSH _ + (SCALE.BRUSH (COND + ([NOT (NUMBERP (SETQ BRSH (fetch (CLOSEDWIRE BRUSH) + of INDVKNOTELT] + (* new format, old format had brush + width only.) + BRSH) + (T [replace (CLOSEDWIRE BRUSH) of INDVKNOTELT + with (SETQ BRSH + (create BRUSH + BRUSHSIZE _ BRSH + BRUSHSHAPE _ 'ROUND] + BRSH)) + (fetch (CLOSEDWIRE CLOSEDWIREINITSCALE) of INDVKNOTELT) + SCALE) + LOCALCLOSEDWIREFILLING _ (APPEND (fetch (CLOSEDWIRE CLOSEDWIREFILLING + ) of INDVKNOTELT))) + GLOBALPART _ GELT]) (KNOTS.INSIDEFN + [LAMBDA (KNOTELT WREG) (* rrb "21-Jan-87 09:37") + + (* determines if the global curve GCURVE is inside of WREG.) + + (* this should be broken down between wires and curves but isn't here so it + can be loaded as a patch.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of KNOTELT) + (WIRE (REGIONSINTERSECTP WREG (OPENWIRE.GLOBALREGIONFN KNOTELT))) + (CLOSEDWIRE (REGIONSINTERSECTP WREG (CLOSEDWIRE.GLOBALREGIONFN KNOTELT))) + (CLOSEDCURVE (REGIONSINTERSECTP WREG (CLOSEDCURVE.GLOBALREGIONFN KNOTELT))) + (REGIONSINTERSECTP WREG (OPENCURVE.GLOBALREGIONFN KNOTELT]) (OPEN.WIRE.DRAWFN + [LAMBDA (OPENWIREELT WIN REG OPERATION) (* rrb " 7-Dec-85 20:11") + (* draws an open wire element.) + (WB.DRAWLINE OPENWIREELT WIN REG OPERATION NIL (fetch (LOCALWIRE LOCALWIREDASHING) + of (fetch (SCREENELT LOCALPART) of OPENWIREELT) + ) + (fetch (LOCALWIRE LOCALOPENWIREBRUSH) of (fetch (SCREENELT LOCALPART) of OPENWIREELT]) (WIRE.EXPANDFN + [LAMBDA (GELT SCALE) (* rrb " 2-May-86 10:50") + + (* returns a local record which has the LATLONKNOTS field of the global element + GELT translated into window coordinats. Used for wires.) + + (PROG ((INDGELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) + LOCALKNOTS TMP) + [COND + ((fetch (WIRE OPENWIREINITSCALE) of INDGELT)) + (T + + (* old format didn't have an initial scale, default it to 1.0) + + (replace (GLOBALPART INDIVIDUALGLOBALPART) of GELT + with (SETQ INDGELT (create WIRE using INDGELT OPENWIREINITSCALE _ 1.0 + OPENWIREREGION _ NIL] + (COND + ((AND (fetch (WIRE WIREARROWHEADS) of INDGELT) + (NOT (fetch (WIRE OPENWIREARROWHEADPOINTS) of INDGELT))) + (* old form didn't have global points, + update it) + (SET.WIRE.ARROWHEAD.POINTS INDGELT))) + (SETQ LOCALKNOTS (for LATLONPT in (fetch (WIRE LATLONKNOTS) of INDGELT) + collect (SK.SCALE.POSITION.INTO.VIEWER LATLONPT SCALE))) + (RETURN (create SCREENELT + LOCALPART _ + (create LOCALWIRE + KNOTS _ LOCALKNOTS + ARROWHEADPTS _ (SK.EXPAND.ARROWHEADS (fetch (WIRE + OPENWIREARROWHEADPOINTS + ) of INDGELT) + SCALE) + LOCALOPENWIREBRUSH _ + (SCALE.BRUSH (COND + ([NOT (NUMBERP (SETQ TMP (fetch (WIRE BRUSH) + of INDGELT] + (* new format, old format had brush + width only.) + TMP) + (T [replace (WIRE BRUSH) of INDGELT + with (SETQ TMP + (create BRUSH + BRUSHSIZE _ TMP + BRUSHSHAPE _ 'ROUND] + TMP)) + (fetch (WIRE OPENWIREINITSCALE) of INDGELT) + SCALE) + LOCALWIREDASHING _ (fetch (WIRE OPENWIREDASHING) of INDGELT)) + GLOBALPART _ GELT]) (SK.UPDATE.WIRE.ELT.AFTER.CHANGE + [LAMBDA (GWIRELT) (* rrb "11-Dec-85 11:27") + + (* updates the dependent fields of a wire element after one of the fields + changes.) + (* clear the region cache) + (replace (OPENCURVE OPENCURVEREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GWIRELT) + with NIL) + (KNOT.SET.SCALE.FIELD GWIRELT]) (OPENWIRE.READCHANGEFN + [LAMBDA (SKW WIREELTS) (* rrb "17-Dec-85 16:22") + + (* * change function for line elements.) + + (PROG (ASPECT HOW) + (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU + (create MENU + CENTERFLG _ T + TITLE _ "Which aspect?" + ITEMS _ (APPEND (COND + [(SKETCHINCOLORP) + '(("Brush color" 'BRUSHCOLOR + "changes the color of the outline" + ] + (T NIL)) + '((Arrowheads 'ARROW + "allows changing of arrow head characteristics." + ) + (Size 'SIZE + "changes the size of the brush" + ) + (Dashing 'DASHING + "changes the dashing of the line." + ] + (SIZE (READSIZECHANGE "Change size how?")) + (ARROW (READ.ARROW.CHANGE WIREELTS)) + (DASHING (READ.DASHING.CHANGE)) + (BRUSHCOLOR [READ.COLOR.CHANGE "Change line color how?" NIL + (fetch (BRUSH BRUSHCOLOR) + of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) + of (CAR WIREELTS)) + 'BRUSH]) + NIL)) + (RETURN (AND HOW (LIST ASPECT HOW]) (OPENWIRE.TRANSFORMFN + [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "19-Mar-86 17:51") + + (* returns a copy of the global WIRE element that has had each of its control + points transformed by transformfn. TRANSFORMDATA is arbitrary data that is + passed to tranformfn.) + + (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (RETURN (KNOT.SET.SCALE.FIELD (create GLOBALPART + using GELT INDIVIDUALGLOBALPART _ + (SET.WIRE.ARROWHEAD.POINTS + (create WIRE using INDVPART LATLONKNOTS _ + (SK.TRANSFORM.POINT.LIST + (fetch (WIRE LATLONKNOTS) + of INDVPART) + TRANSFORMFN TRANSFORMDATA) + BRUSH _ + (SK.TRANSFORM.BRUSH + (fetch (WIRE BRUSH) + of INDVPART) + SCALEFACTOR) + WIREARROWHEADS _ + (SK.TRANSFORM.ARROWHEADS + (fetch (WIRE WIREARROWHEADS) + of INDVPART) + SCALEFACTOR) + OPENWIREREGION _ NIL]) (OPENWIRE.TRANSLATEFN + [LAMBDA (WIREELT DELTAPOS) (* rrb "20-Mar-86 15:08") + (* translates an open wire element) + (PROG ((NEWWIREELT (KNOTS.TRANSLATEFN WIREELT DELTAPOS))) + (SET.WIRE.ARROWHEAD.POINTS (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWWIREELT)) + (RETURN NEWWIREELT]) (OPENWIRE.TRANSLATEPTSFN + [LAMBDA (KNOTELT SELPTS GDELTA WINDOW) (* rrb "26-Sep-85 17:45") + + (* returns an open wire element which has the knots that are members of SELPTS + translated by the global amount GDELTA.) + + (PROG ((GKNOTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of KNOTELT))) + (RETURN (SK.WIRE.CREATE (for PT in (fetch (LOCALWIRE KNOTS) of (fetch (SCREENELT LOCALPART) + of KNOTELT)) as LATLONPT + in (fetch (WIRE LATLONKNOTS) of GKNOTELT) + collect (COND + ((MEMBER PT SELPTS) + (PTPLUS LATLONPT GDELTA)) + (T LATLONPT))) + (fetch (WIRE BRUSH) of GKNOTELT) + (fetch (WIRE OPENWIREDASHING) of GKNOTELT) + NIL + (fetch (WIRE OPENWIREINITSCALE) of GKNOTELT) + (fetch (WIRE WIREARROWHEADS) of GKNOTELT]) (WIRE.INPUTFN + [LAMBDA (W GPTLIST CLOSEDFLG BRUSH DEFSCALE DASHING FILLING) + (* rrb "15-Nov-85 11:39") + + (* creates a wire {a series of straight lines through a list of points} from a + list of points passed in or a list that is read from the user via mouse.) + + (PROG ((SKCONTEXT (WINDOWPROP W 'SKETCHCONTEXT)) + KNOTS) + (RETURN (SK.WIRE.CREATE [SETQ KNOTS (OR GPTLIST (for PT in (SK.READ.WIRE.POINTS W CLOSEDFLG + ) + collect (SK.MAP.INPUT.PT.TO.GLOBAL + PT W] + (COND + ((NUMBERP BRUSH) + + (* called with a number from the sketch stream drawline operation. + Make it a round brush.) + + (create BRUSH + BRUSHSIZE _ BRUSH + BRUSHSHAPE _ 'ROUND)) + (T (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKCONTEXT))) + (OR (DASHINGP DASHING) + (fetch (SKETCHCONTEXT SKETCHDASHING) of SKCONTEXT)) + CLOSEDFLG + (OR (NUMBERP DEFSCALE) + (SK.INPUT.SCALE W)) + (SK.ARROWHEAD.CREATE W KNOTS) + FILLING]) (SK.READ.WIRE.POINTS + [LAMBDA (SKW CLOSEDFLG) (* rrb "12-May-86 18:31") + (* reads a list of points for a wire.) + (SK.READ.POINTS.WITH.FEEDBACK SKW NIL (AND SKETCH.VERBOSE.FEEDBACK + (COND + (CLOSEDFLG (FUNCTION CLOSEDWIRE.FEEDBACKFN)) + (T (FUNCTION OPENWIRE.FEEDBACKFN]) (SK.READ.POINTS.WITH.FEEDBACK + [LAMBDA (W ALLOWDUPS? FEEDBACKFN) (* rrb "10-Jun-86 15:44") + (* reads a {series of points} from the + user.) + (PROG (PT PTS ERRSTAT) + (STATUSPRINT W " +" "Enter the points the curve goes through using the left button. +Click outside the window to stop.") + LP (COND + ((AND [SETQ ERRSTAT (ERSETQ (SETQ PT (SK.READ.POINT.WITH.FEEDBACK W POINTREADINGCURSOR + FEEDBACKFN PTS 'MIDDLE NIL + (AND SKETCH.USE.POSITION.PAD 'MULTIPLE] + PT) (* add the point to the list and mark + it.) + [COND + ([OR ALLOWDUPS? (NOT (EQUAL (fetch (INPUTPT INPUT.POSITION) + of (CAR (LAST PTS))) + (fetch (INPUTPT INPUT.POSITION) of PT] + (SHOWSKETCHPOINT (fetch (INPUTPT INPUT.POSITION) of PT) + W PTS) + + (* draw the line so it will remain displayed while the user adds other points. + This will not close it.) + + (AND PTS (DRAWBETWEEN (fetch (INPUTPT INPUT.POSITION) of (CAR (LAST PTS))) + (fetch (INPUTPT INPUT.POSITION) of PT) + 1 + 'INVERT W)) + (SETQ PTS (NCONC1 PTS PT] + (GO LP))) (* erase point markers.) + (for PTTAIL on PTS do (SHOWSKETCHPOINT (fetch (INPUTPT INPUT.POSITION) of (CAR PTTAIL)) + W + (CDR PTTAIL)) (* erase line) + (AND (CDR PTTAIL) + (DRAWBETWEEN (fetch (INPUTPT INPUT.POSITION) of (CAR PTTAIL)) + (fetch (INPUTPT INPUT.POSITION) of (CADR PTTAIL)) + 1 + 'INVERT W))) + (CLRPROMPT) + (CLOSEPROMPTWINDOW W) + (COND + (ERRSTAT (* no error.) + (RETURN PTS)) + (T (* had an error, pass it on) + (ERROR!]) (OPENWIRE.FEEDBACKFN + [LAMBDA (X Y WINDOW PREVPTS) (* rrb "15-Nov-85 11:32") + + (* provides the rubberbanding feedback for the user inputting a point for an + open wire.) + + (SHOWSKETCHXY X Y WINDOW) + (AND PREVPTS (PROG (LASTPT) + (RETURN (DRAWLINE [fetch (POSITION XCOORD) of (SETQ LASTPT + (fetch (INPUTPT INPUT.POSITION) + of (CAR (LAST PREVPTS] + (fetch (POSITION YCOORD) of LASTPT) + X Y 1 'INVERT WINDOW]) (CLOSEDWIRE.FEEDBACKFN + [LAMBDA (X Y WINDOW PREVPTS) (* rrb "15-Nov-85 11:31") + + (* provides the rubberbanding feedback for the user inputting a point for an + open wire.) + + (SHOWSKETCHXY X Y WINDOW) (* draw from the first pt to the new + pt) + (PROG (ENDPT) + (AND PREVPTS (DRAWLINE [fetch (POSITION XCOORD) of (SETQ ENDPT (fetch (INPUTPT + INPUT.POSITION + ) + of (CAR PREVPTS] + (fetch (POSITION YCOORD) of ENDPT) + X Y 1 'INVERT WINDOW)) (* draw from the last pt to the new pt) + (AND (CDR PREVPTS) + (DRAWLINE [fetch (POSITION XCOORD) of (SETQ ENDPT (fetch (INPUTPT INPUT.POSITION) + of (CAR (LAST PREVPTS] + (fetch (POSITION YCOORD) of ENDPT) + X Y 1 'INVERT WINDOW]) (CLOSEDWIRE.REGIONFN + [LAMBDA (KNOTSCRELT) (* rrb " 2-Jun-85 17:15") + (* returns the region occuppied by a + closed wire) + + (* increase by half the brush size plus 2 This has the nice property of + insuring that the region always has both height and width.) + + (INCREASEREGION (REGION.CONTAINING.PTS (fetch (SCREENELT HOTSPOTS) of KNOTSCRELT)) + (IPLUS 3 (QUOTIENT (fetch (BRUSH BRUSHSIZE) of (fetch (LOCALCLOSEDWIRE + LOCALCLOSEDWIREBRUSH) + of (fetch (SCREENELT LOCALPART) + of KNOTSCRELT))) + 2]) (CLOSEDWIRE.GLOBALREGIONFN + [LAMBDA (GCLOSEDWIREELT) (* rrb "23-Oct-85 11:30") + + (* returns the global region occupied by a global closed curve element.) + + (OR (fetch (CLOSEDWIRE CLOSEDWIREREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of + GCLOSEDWIREELT + )) + (PROG ((INDVCLOSEDWIRE (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GCLOSEDWIREELT)) + REGION) + [SETQ REGION (INCREASEREGION (REGION.CONTAINING.PTS (fetch (CLOSEDWIRE LATLONKNOTS) + of INDVCLOSEDWIRE)) + (SK.BRUSH.SIZE (fetch (CLOSEDWIRE BRUSH) of INDVCLOSEDWIRE] + (replace (CLOSEDWIRE CLOSEDWIREREGION) of INDVCLOSEDWIRE with REGION) + (RETURN REGION]) (SK.WIRE.CREATE + [LAMBDA (KNOTS BRUSH DASHING CLOSED SCALE ARROWHEADS FILLING) + (* rrb "19-Mar-86 17:51") + (* creates a wire sketch element.) + (AND KNOTS + (KNOT.SET.SCALE.FIELD (create GLOBALPART + INDIVIDUALGLOBALPART _ + (COND + (CLOSED (create CLOSEDWIRE + LATLONKNOTS _ KNOTS + BRUSH _ BRUSH + CLOSEDWIREDASHING _ DASHING + CLOSEDWIREINITSCALE _ SCALE + CLOSEDWIREFILLING _ FILLING)) + (T (SET.WIRE.ARROWHEAD.POINTS (create WIRE + LATLONKNOTS _ KNOTS + BRUSH _ BRUSH + WIREARROWHEADS _ + ARROWHEADS + OPENWIREDASHING _ + DASHING + OPENWIREINITSCALE _ + SCALE]) (WIRE.ADD.POINT.TO.END + [LAMBDA (WIREELT PT SKW) (* rrb "11-Jul-85 11:26") + + (* adds a point onto the end of a wire element.) + + (PROG ((NEWPOS (SK.MAP.INPUT.PT.TO.GLOBAL PT SKW)) + KNOTS GWIREELT) + (SETQ GWIREELT (fetch (SCREENELT GLOBALPART) of WIREELT)) + (SETQ KNOTS (fetch LATLONKNOTS of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GWIREELT))) + (RETURN (COND + ((EQUAL NEWPOS (CAR (LAST KNOTS))) (* don't add duplicate points) + WIREELT) + (T (* add point at the end.) + (SK.UPDATE.ELEMENT GWIREELT (WIRE.INPUTFN SKW (APPEND KNOTS (CONS NEWPOS)) + NIL) + SKW]) (READ.ARROW.CHANGE + [LAMBDA (SCRELTS SKW) + (DECLARE (GLOBALVARS SK.ARROW.EDIT.MENU)) (* rrb "17-Dec-85 17:09") + + (* gets a description of how to change the arrow heads of a wire or curve.) + + (OR (type? MENU SK.ARROW.EDIT.MENU) + (SETQ SK.ARROW.EDIT.MENU (create MENU + TITLE _ "specify change" + ITEMS _ (APPEND '((Add% Arrow 'ADD "Adds an arrow head.") + ("Remove Arrow" 'DELETE + "Removes the arrow head.") + ("Same as First" 'SAME + "Makes all of the arrowheads be the same as the first one selected." + ) + (Wider 'WIDER + "Makes the angle of the head wider." + ) + (Narrower 'NARROWER + "Makes the angle of the head smaller." + ) + (Larger 'LARGER + "Makes the arrow head larger.") + (Smaller 'SMALLER + "Makes the arrow head smaller.")) + (LIST (LIST VSHAPE.ARROWHEAD.BITMAP + ''OPEN + "Makes the head be the side lines only." + ) + (LIST CURVEDV.ARROWHEAD.BITMAP + ''OPENCURVE + "Makes the arrowhead have curved side lines." + ) + (LIST TRIANGLE.ARROWHEAD.BITMAP + ''CLOSED + "Makes the head be two sides and a base." + ) + (LIST SOLIDTRIANGLE.ARROWHEAD.BITMAP + ''SOLID + "makes a solid triangular arrowhead." + ))) + CENTERFLG _ T))) + (PROG (HOW) + (RETURN (LIST (OR (READ.ARROWHEAD.END) + (RETURN)) + (COND + ((EQ (SETQ HOW (\CURSOR.IN.MIDDLE.MENU SK.ARROW.EDIT.MENU)) + 'SAME) (* if the user chooses SAME, determine + the characteristics.) + (OR (bind NOWARROWS INDGELT for ELT in SCRELTS + do (SETQ INDGELT (fetch (SCREENELT INDIVIDUALGLOBALPART) + of ELT)) + [COND + ((SETQ NOWARROWS (SELECTQ (fetch (INDIVIDUALGLOBALPART + GTYPE) of INDGELT) + (OPENCURVE (fetch (OPENCURVE + CURVEARROWHEADS + ) of INDGELT)) + (ARC (fetch (ARC ARCARROWHEADS) + of INDGELT)) + (WIRE (fetch (WIRE WIREARROWHEADS) + of INDGELT)) + NIL)) + (COND + [(CAR NOWARROWS) + (RETURN (CONS 'SAME (CAR NOWARROWS] + ((CADR NOWARROWS) + (RETURN (CONS 'SAME (CADR NOWARROWS] + finally (STATUSPRINT SKW + "None of the selected elements have arrowheads.")) + (RETURN))) + (HOW) + (T (RETURN]) (CHANGE.ELTS.ARROWHEADS + [LAMBDA (CHANGESPEC ELTSWITHARROWS SKW) (* rrb "10-Jan-85 16:58") + + (* * function that changes the arrow characteristics for all elements in + ELTSWITHARROWS that can have arrows.) + + (AND CHANGESPEC (for ARROWELT in ELTSWITHARROWS collect (SK.CHANGE.ARROWHEADS ARROWELT CHANGESPEC + SKW]) ) (DEFINEQ (SKETCH.CREATE.CLOSED.WIRE + [LAMBDA (POINTS BRUSH DASHING FILLING SCALE) (* rrb "16-Oct-85 17:12") + (* creates a sketch closed wire + element.) + (SK.WIRE.CREATE (SK.INSURE.POINT.LIST POINTS) + (SK.INSURE.BRUSH BRUSH) + (SK.INSURE.DASHING DASHING) + T + (OR (NUMBERP SCALE) + 1.0) + NIL + (SK.INSURE.FILLING FILLING]) (CLOSED.WIRE.INPUTFN + [LAMBDA (W PTLIST) (* rrb "13-Dec-84 10:10") + + (* creates a closed wire {a series of straight lines through a list of points} + from a list of points passed in or a list that is read from the user via mouse.) + + (WIRE.INPUTFN W PTLIST T]) (CLOSED.WIRE.DRAWFN + [LAMBDA (CLOSEDWIREELT WIN REG OPERATION) (* ; "Edited 3-Mar-87 10:09 by rrb") + (* draws a closed wire element.) + (PROG ((GINDVELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of CLOSEDWIREELT)) + (LOCALPART (fetch (SCREENELT LOCALPART) of CLOSEDWIREELT)) + VARX) + (SETQ VARX (fetch (LOCALCLOSEDWIRE LOCALCLOSEDWIREFILLING) of LOCALPART)) + [COND + ((OR (fetch (SKFILLING FILLING.TEXTURE) of VARX) + (fetch (SKFILLING FILLING.COLOR) of VARX)) (* if there isn't any filling, don't + fill.) + (FILLPOLYGON (fetch (LOCALCLOSEDWIRE KNOTS) of LOCALPART) + [COND + (SKETCHINCOLORFLG VARX) + ((fetch (SKFILLING FILLING.TEXTURE) of VARX)) + (T (* simulate color) + (TEXTUREOFCOLOR (fetch (SKFILLING FILLING.COLOR) of VARX] + WIN + (COND + ((EQ (DSPOPERATION NIL WIN) + 'ERASE) (* if the stream is erasing, erase.) + 'ERASE) + (T (* otherwise use the element's mode.) + (fetch (SKFILLING FILLING.OPERATION) of VARX] + (OR (EQ (fetch (BRUSH BRUSHSIZE) of (SETQ VARX (fetch (LOCALCLOSEDWIRE LOCALCLOSEDWIREBRUSH + ) of LOCALPART))) + 0) + (WB.DRAWLINE CLOSEDWIREELT WIN REG OPERATION T (fetch (CLOSEDWIRE CLOSEDWIREDASHING) + of GINDVELT) + VARX]) (CLOSEDWIRE.READCHANGEFN + [LAMBDA (SKW SCRNELTS) (* rrb " 5-Mar-86 13:35") + + (* the users has selected SCRNELT to be changed this function reads a + specification of how the closed wire elements should change.) + + (PROG (ASPECT HOW) + (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU + (create MENU + CENTERFLG _ T + TITLE _ "Which aspect?" + ITEMS _ + (APPEND (COND + [(SKETCHINCOLORP) + '(("Brush color" 'BRUSHCOLOR + "changes the color of the outline" + ) + ("Filling color" 'FILLINGCOLOR + "changes the color of the filling" + ] + (T NIL)) + [COND + (FILLPOLYGONFLG + '((Filling 'FILLING + "allows changing of the filling texture of the box." + ] + [COND + (FILLINGMODEFLG + '(("Filling mode" 'FILLINGMODE + "changes how the filling effects the figures it covers." + ] + '((Shape 'SHAPE + "changes the shape of the brush") + (Size 'SIZE + "changes the size of the brush") + (Dashing 'DASHING + "changes the dashing of the line.") + ("Add point" 'ADDPOINT + "adds a point to the curve."] + (SIZE (READSIZECHANGE "Change size how?" T)) + (FILLING (READ.FILLING.CHANGE)) + (FILLINGMODE (READ.FILLING.MODE)) + (DASHING (READ.DASHING.CHANGE)) + (SHAPE (READBRUSHSHAPE)) + (BRUSHCOLOR [READ.COLOR.CHANGE "Change outline color how?" NIL + (fetch (BRUSH BRUSHCOLOR) + of (GETSKETCHELEMENTPROP (fetch + (SCREENELT GLOBALPART + ) + of (CAR + SCRNELTS + )) + 'BRUSH]) + (ADDPOINT (READ.POINT.TO.ADD (CAR SCRNELTS) + SKW)) + (FILLINGCOLOR [READ.COLOR.CHANGE "Change filling color how?" T + (fetch (SKFILLING FILLING.COLOR) + of (GETSKETCHELEMENTPROP (fetch + (SCREENELT + GLOBALPART) + of + (CAR SCRNELTS)) + 'FILLING]) + NIL)) + (RETURN (AND HOW (LIST ASPECT HOW]) (CLOSEDWIRE.TRANSFORMFN + [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "18-Oct-85 16:46") + + (* returns a copy of the global CLOSEDWIRE element that has had each of its + control points transformed by transformfn. + TRANSFORMDATA is arbitrary data that is passed to tranformfn.) + + (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (RETURN (KNOT.SET.SCALE.FIELD (create GLOBALPART using GELT INDIVIDUALGLOBALPART _ + (create CLOSEDWIRE + using INDVPART LATLONKNOTS _ + (SK.TRANSFORM.POINT.LIST + (fetch (CLOSEDWIRE + LATLONKNOTS) + of INDVPART) + TRANSFORMFN TRANSFORMDATA) + BRUSH _ + (SK.TRANSFORM.BRUSH + (fetch (CLOSEDWIRE BRUSH) + of INDVPART) + SCALEFACTOR) + CLOSEDWIREREGION _ NIL]) (CLOSEDWIRE.TRANSLATEPTSFN + [LAMBDA (KNOTELT SELPTS GDELTA WINDOW) (* rrb "27-Sep-85 18:58") + + (* returns a closed wire element which has the knots that are members of SELPTS + translated by the global amount GDELTA.) + + (PROG ((GKNOTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of KNOTELT))) + (RETURN (SK.WIRE.CREATE (for PT in (fetch (LOCALCLOSEDWIRE KNOTS) + of (fetch (SCREENELT LOCALPART) of KNOTELT)) + as LATLONPT in (fetch (CLOSEDWIRE LATLONKNOTS) of GKNOTELT) + collect (COND + ((MEMBER PT SELPTS) + (PTPLUS LATLONPT GDELTA)) + (T LATLONPT))) + (fetch (CLOSEDWIRE BRUSH) of GKNOTELT) + (fetch (CLOSEDWIRE CLOSEDWIREDASHING) of GKNOTELT) + T + (fetch (CLOSEDWIRE CLOSEDWIREINITSCALE) of GKNOTELT) + NIL + (fetch (CLOSEDWIRE CLOSEDWIREFILLING) of GKNOTELT]) ) (DEFINEQ (SK.EXPAND.ARROWHEADS + [LAMBDA (GARROWHEADPOINTS SCALE) (* rrb " 2-May-86 10:50") + + (* returns a list of local arrowhead points from the list of global arrowhead + points.) + + (for ARROWHEAD in GARROWHEADPOINTS collect (SK.EXPAND.ARROWHEAD ARROWHEAD SCALE]) (SK.COMPUTE.ARC.ARROWHEAD.POINTS + [LAMBDA (ARROWSPEC CENTERPT RADPT ARCANGLEPT DIRECTION) (* rrb "19-Mar-86 17:09") + + (* returns a list of global arrowhead points from the specs and points that + define an arc.) + + (PROG (SPEC) + (OR ARROWSPEC (RETURN NIL)) (* format keeps arrow specs as + (FIRST LAST T)%.) + (RETURN (LIST (AND (SETQ SPEC (CAR ARROWSPEC)) + (ARC.ARROWHEAD.POINTS CENTERPT RADPT DIRECTION (fetch (ARROWHEAD + ARROWANGLE) + of SPEC) + (fetch (ARROWHEAD ARROWLENGTH) of SPEC) + (fetch (ARROWHEAD ARROWTYPE) of SPEC))) + (AND (SETQ SPEC (CADR ARROWSPEC)) + (ARC.ARROWHEAD.POINTS CENTERPT ARCANGLEPT (NOT DIRECTION) + (fetch (ARROWHEAD ARROWANGLE) of SPEC) + (fetch (ARROWHEAD ARROWLENGTH) of SPEC) + (fetch (ARROWHEAD ARROWTYPE) of SPEC]) (ARC.ARROWHEAD.POINTS + [LAMBDA (CENTERPT ENDPT CLOCKWISEFLG HEAD.ANGLE HEAD.LENGTH HEAD.TYPE) + (* rrb "20-Mar-86 09:12") + + (* returns a list of arrowhead points for an arc. + If CLOCKWISEFLG is T, it is to go on the clockwise direction.) + + (ARROWHEAD.POINTS.LIST ENDPT HEAD.ANGLE HEAD.LENGTH (TIMES (COND + (CLOCKWISEFLG -1) + (T 1)) + (DIFFERENCE (fetch (POSITION YCOORD) + of ENDPT) + (fetch (POSITION YCOORD) + of CENTERPT))) + (TIMES (COND + (CLOCKWISEFLG 1) + (T -1)) + (DIFFERENCE (fetch (POSITION XCOORD) of ENDPT) + (fetch (POSITION XCOORD) of CENTERPT))) + HEAD.TYPE]) (SET.ARC.ARROWHEAD.POINTS + [LAMBDA (INDVDARCELT) (* rrb "20-Jun-86 13:56") + + (* * updates the global arrowhead points field of an element.) + + (PROG ((ARROWSPECS (fetch (ARC ARCARROWHEADS) of INDVDARCELT))) + [COND + (ARROWSPECS (SK.INSURE.HAS.LENGTH INDVDARCELT (SK.RECORD.LENGTH 'ARC) + 'ARC) + (replace (ARC ARCARROWHEADPOINTS) of INDVDARCELT + with (SK.COMPUTE.ARC.ARROWHEAD.POINTS ARROWSPECS (fetch (ARC ARCCENTERPT) + of INDVDARCELT) + (fetch (ARC ARCRADIUSPT) of INDVDARCELT) + (\SK.GET.ARC.ANGLEPT INDVDARCELT) + (fetch (ARC ARCDIRECTION) of INDVDARCELT] + (RETURN INDVDARCELT]) (SET.OPENCURVE.ARROWHEAD.POINTS + [LAMBDA (INDVOPENCURVEELT) (* rrb "20-Mar-86 14:30") + + (* * updates the global arrowhead points field of an element.) + + (PROG ((ARROWSPECS (fetch (OPENCURVE CURVEARROWHEADS) of INDVOPENCURVEELT))) + [COND + (ARROWSPECS (SK.INSURE.HAS.LENGTH INDVOPENCURVEELT (SK.RECORD.LENGTH 'OPENCURVE) + 'OPENCURVE) + (replace (OPENCURVE OPENCURVEARROWHEADPOINTS) of INDVOPENCURVEELT + with (SK.COMPUTE.CURVE.ARROWHEAD.POINTS ARROWSPECS (fetch (OPENCURVE + LATLONKNOTS) + of INDVOPENCURVEELT] + (RETURN INDVOPENCURVEELT]) (SK.COMPUTE.CURVE.ARROWHEAD.POINTS + [LAMBDA (ARROWSPEC KNOTS) (* rrb "19-Mar-86 17:32") + + (* returns a list of global arrowhead points from the specs and points that + define an curve.) + + (PROG (SPEC) + (OR ARROWSPEC (RETURN NIL)) (* format keeps arrow specs as + (FIRST LAST T)%.) + (RETURN (LIST (AND (SETQ SPEC (CAR ARROWSPEC)) + (CURVE.ARROWHEAD.POINTS KNOTS T (fetch (ARROWHEAD ARROWANGLE) + of SPEC) + (fetch (ARROWHEAD ARROWLENGTH) of SPEC) + (fetch (ARROWHEAD ARROWTYPE) of SPEC))) + (AND (SETQ SPEC (CADR ARROWSPEC)) + (CURVE.ARROWHEAD.POINTS KNOTS NIL (fetch (ARROWHEAD ARROWANGLE) + of SPEC) + (fetch (ARROWHEAD ARROWLENGTH) of SPEC) + (fetch (ARROWHEAD ARROWTYPE) of SPEC]) (SET.WIRE.ARROWHEAD.POINTS + [LAMBDA (INDVWIREELT) (* rrb "20-Mar-86 14:31") + + (* * updates the global arrowhead points field of an element.) + + (PROG ((ARROWSPECS (fetch (WIRE WIREARROWHEADS) of INDVWIREELT))) + [COND + (ARROWSPECS (SK.INSURE.HAS.LENGTH INDVWIREELT (SK.RECORD.LENGTH 'WIRE) + 'WIRE) + (replace (WIRE OPENWIREARROWHEADPOINTS) of INDVWIREELT + with (SK.COMPUTE.WIRE.ARROWHEAD.POINTS ARROWSPECS (fetch (WIRE LATLONKNOTS) + of INDVWIREELT] + (RETURN INDVWIREELT]) (SK.COMPUTE.WIRE.ARROWHEAD.POINTS + [LAMBDA (ARROWSPEC KNOTS) (* rrb "19-Mar-86 17:46") + + (* returns a list of global arrowhead points from the specs and points that + define an curve.) + + (PROG (SPEC) + (OR ARROWSPEC (RETURN NIL)) (* format keeps arrow specs as + (FIRST LAST T)%.) + (RETURN (LIST (AND (SETQ SPEC (CAR ARROWSPEC)) + (WIRE.ARROWHEAD.POINTS KNOTS T (fetch (ARROWHEAD ARROWANGLE) + of SPEC) + (fetch (ARROWHEAD ARROWLENGTH) of SPEC) + (fetch (ARROWHEAD ARROWTYPE) of SPEC))) + (AND (SETQ SPEC (CADR ARROWSPEC)) + (WIRE.ARROWHEAD.POINTS KNOTS NIL (fetch (ARROWHEAD ARROWANGLE) + of SPEC) + (fetch (ARROWHEAD ARROWLENGTH) of SPEC) + (fetch (ARROWHEAD ARROWTYPE) of SPEC]) (SK.EXPAND.ARROWHEAD + [LAMBDA (ARROWHEAD SCALE) (* rrb "11-Jul-86 15:54") + + (* expands an arrowhead to a given scale. + The format of Arrowhead points is (HEADPT ONESIDEENDPT OTHERSIDEENDPT) or + (HEADPT (SIDE1PT1 SIDE1PT2) (SIDE2PT1 SIDE2PT2))) + + (AND ARROWHEAD (CONS (SK.SCALE.POSITION.INTO.VIEWER (CAR ARROWHEAD) + SCALE) + (COND + ((POSITIONP (CADR ARROWHEAD)) + (for PT in (CDR ARROWHEAD) collect (SK.SCALE.POSITION.INTO.VIEWER PT + SCALE))) + (T (* form is (HEADPT (SIDE1PT1 SIDE1PT2) + (SIDE2PT1 SIDE2PT2))) + (for PTLST in (CDR ARROWHEAD) + collect (for PT in PTLST collect (SK.SCALE.POSITION.INTO.VIEWER + PT SCALE]) (CHANGED.ARROW + [LAMBDA (ARROW HOWTOCHANGE SCALE DEFARROW) (* rrb "17-Dec-85 17:04") + + (* * returns an arrow that has been changed according to the spec HOWTOCHANGE.) + + (COND + ((EQ HOWTOCHANGE 'ADD) (* if there already is one, leave it + alone.) + (OR ARROW (SK.CREATE.ARROWHEAD DEFARROW SCALE))) + ((OR (EQ HOWTOCHANGE 'DELETE) + (NULL ARROW)) + NIL) + ((EQ (CAR HOWTOCHANGE) + 'SAME) (* make it the same as the one given.) + (APPEND (CDR HOWTOCHANGE))) + (T (SELECTQ HOWTOCHANGE + (WIDER (create ARROWHEAD using ARROW ARROWANGLE _ (PLUS SK.ARROWHEAD.ANGLE.INCREMENT + (fetch (ARROWHEAD ARROWANGLE) + of ARROW)))) + (NARROWER (create ARROWHEAD using ARROW ARROWANGLE _ (DIFFERENCE (fetch (ARROWHEAD + ARROWANGLE) + of ARROW) + + SK.ARROWHEAD.ANGLE.INCREMENT + ))) + (LARGER (create ARROWHEAD using ARROW ARROWLENGTH _ (PLUS (TIMES + SK.ARROWHEAD.LENGTH.INCREMENT + SCALE) + (fetch (ARROWHEAD ARROWLENGTH + ) of ARROW)))) + (SMALLER (create ARROWHEAD using ARROW ARROWLENGTH _ (MAX (DIFFERENCE + (fetch (ARROWHEAD + ARROWLENGTH) + of ARROW) + (TIMES + SK.ARROWHEAD.LENGTH.INCREMENT + SCALE)) + SCALE))) + (OPEN (create ARROWHEAD using ARROW ARROWTYPE _ 'LINE)) + (CLOSED (create ARROWHEAD using ARROW ARROWTYPE _ 'CLOSEDLINE)) + (SOLID (create ARROWHEAD using ARROW ARROWTYPE _ 'SOLID)) + (OPENCURVE (create ARROWHEAD using ARROW ARROWTYPE _ 'CURVE)) + ARROW]) (SK.CHANGE.ARROWHEAD + [LAMBDA (ARROWELT HOW SKW) (* rrb " 1-May-86 16:27") + + (* changes the arrow heads of an element and returns the new element if any + actually occurred.) + + (SK.CHANGE.ARROWHEAD1 ARROWELT (CAR HOW) + (CADR HOW) + (SK.INPUT.SCALE SKW) + (fetch (SKETCHCONTEXT SKETCHARROWHEAD) of (WINDOWPROP SKW 'SKETCHCONTEXT]) (SK.CHANGE.ARROWHEAD1 + [LAMBDA (GARROWELT WHICHEND HOWTOCHANGE SCALE DEFAULTARROWHEAD) + (* rrb "20-Jun-86 13:57") + (PROG (INDGARROWELT NEWARROWS NOWARROWS CHANGEDFLG TYPE KNOTS) + (RETURN (COND + ((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of GARROWELT)) + '(WIRE OPENCURVE ARC)) (* only works for things of wire type.) + (SETQ INDGARROWELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARROWELT)) + [SETQ NOWARROWS (OR (SELECTQ TYPE + (OPENCURVE (fetch (OPENCURVE CURVEARROWHEADS) + of INDGARROWELT)) + (ARC (fetch (ARC ARCARROWHEADS) of INDGARROWELT)) + (fetch (WIRE WIREARROWHEADS) of INDGARROWELT)) + '(NIL NIL T] + (SETQ KNOTS (SELECTQ TYPE + (ARC (* calculate the knots for the left + most test) + (LIST (fetch (ARC ARCRADIUSPT) of INDGARROWELT) + (\SK.GET.ARC.ANGLEPT INDGARROWELT))) + (fetch LATLONKNOTS of INDGARROWELT))) + + (* the brush is stored in the same place for all element types.) + + (SETQ NEWARROWS (bind NEWARROW for ARROW in NOWARROWS as END + in '(FIRST LAST) + collect (SETQ NEWARROW (COND + ((SK.ARROWHEAD.END.TEST WHICHEND + END KNOTS) + (* change the spec) + (CHANGED.ARROW ARROW HOWTOCHANGE + SCALE DEFAULTARROWHEAD)) + (T ARROW))) + (COND + ((NOT (EQUAL NEWARROW ARROW)) + + (* keep track of whether or not any arrow was changed.) + + (SETQ CHANGEDFLG T))) + NEWARROW)) + (AND CHANGEDFLG + (create SKHISTORYCHANGESPEC + NEWELT _ + (create GLOBALPART + COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) + of GARROWELT) + INDIVIDUALGLOBALPART _ + (SELECTQ TYPE + (WIRE (SET.WIRE.ARROWHEAD.POINTS (create WIRE + using INDGARROWELT + WIREARROWHEADS + _ NEWARROWS))) + (ARC (SET.ARC.ARROWHEAD.POINTS (create ARC + using INDGARROWELT + ARCARROWHEADS _ + NEWARROWS))) + (OPENCURVE (SET.OPENCURVE.ARROWHEAD.POINTS (create + OPENCURVE + using + + INDGARROWELT + CURVEARROWHEADS + _ + NEWARROWS) + )) + (SHOULDNT))) + OLDELT _ GARROWELT + PROPERTY _ 'ARROWHEADS + NEWVALUE _ NEWARROWS + OLDVALUE _ NOWARROWS]) (SK.CREATE.ARROWHEAD + [LAMBDA (DEFAULTARROWHEAD SCALE) (* rrb " 5-May-85 17:39") + + (* creates a new arrowhead which is the default DEFAULTARROWHEAD scaled to + SCALE.) + + (create ARROWHEAD using DEFAULTARROWHEAD ARROWLENGTH _ (TIMES (fetch (ARROWHEAD ARROWLENGTH) + of DEFAULTARROWHEAD) + SCALE]) (SK.ARROWHEAD.CREATE + [LAMBDA (SKW KNOTS) (* rrb " 2-May-86 11:11") + + (* creates the arrowhead specs that go with a global element from the current + context.) + + (PROG ((SKCONTEXT (WINDOWPROP SKW 'SKETCHCONTEXT)) + ARROWHEADWHERE) + (SETQ ARROWHEADWHERE (fetch (SKETCHCONTEXT SKETCHUSEARROWHEAD) of SKCONTEXT)) + (RETURN (COND + ([NOT (MEMB ARROWHEADWHERE '(NIL NEITHER] + (* compute the arrowheads) + (* T is indicator of new format.) + (NCONC1 [for END in '(FIRST LAST) collect (COND + ((SK.ARROWHEAD.END.TEST + ARROWHEADWHERE END KNOTS) + (* change the spec) + (SK.CREATE.ARROWHEAD + (fetch (SKETCHCONTEXT + SKETCHARROWHEAD) + of SKCONTEXT) + (SK.INPUT.SCALE SKW] + T]) (SK.ARROWHEAD.END.TEST + [LAMBDA (WHICHENDS END KNOTS) (* rrb " 5-May-85 17:36") + + (* predicate which determines it END which is one of FIRST or LAST matches with + WHICHENDS which is one of (FIRST LAST BOTH RIGHT LEFT) on the series of points + KNOTS.) + + (OR (EQ WHICHENDS END) + (SELECTQ WHICHENDS + (BOTH T) + (LEFT (* determine if the specified end is + END) + [COND + ((LEFT.MOST.IS.BEGINP KNOTS) + (EQ END 'FIRST)) + ((EQ END 'LAST]) + (RIGHT [COND + ((LEFT.MOST.IS.BEGINP KNOTS) + (EQ END 'LAST)) + ((EQ END 'FIRST]) + NIL]) (READ.ARROWHEAD.END + [LAMBDA NIL (* rrb " 6-Nov-85 09:46") + + (* reads a specification of which end of a line or curve to put an arrowhead + on.) + + (\CURSOR.IN.MIDDLE.MENU (COND + ((type? MENU SK.ARROW.END.MENU) + SK.ARROW.END.MENU) + (T (SETQ SK.ARROW.END.MENU (create MENU + TITLE _ "Which end?" + ITEMS _ '((|Left | 'LEFT + "changes will affect the left (or upper) end of the line." + ) + (| Right| 'RIGHT + "changes will affect the right (or lower) end of the line." + ) + (Both 'BOTH + "changes will affect both ends of the line." + ) + (First 'FIRST + "changes will affect the end whose point was placed first." + ) + (Last 'LAST + "changes will affect the end placed last." + )) + CENTERFLG _ T]) (ARROW.HEAD.POSITIONS + [LAMBDA (TAIL.POSITION HEAD.POSITION HEAD.ANGLE HEAD.LENGTH) + (* edited%: "16-MAR-83 11:56") + (PROG (X0 Y0 X1 Y1 DX DY COS.THETA LL SIN.THETA COS.RHO SIN.RHO XP1 YP1 XP2 YP2) + (SETQ X0 (fetch (POSITION XCOORD) of TAIL.POSITION)) + (SETQ Y0 (fetch (POSITION YCOORD) of TAIL.POSITION)) + (SETQ X1 (fetch (POSITION XCOORD) of HEAD.POSITION)) + (SETQ Y1 (fetch (POSITION YCOORD) of HEAD.POSITION)) + (SETQ DX (IDIFFERENCE X1 X0)) + (SETQ DY (IDIFFERENCE Y1 Y0)) + [SETQ LL (SQRT (PLUS (TIMES DX DX) + (TIMES DY DY] + (SETQ COS.RHO (QUOTIENT DX LL)) + (SETQ SIN.RHO (QUOTIENT DY LL)) + (SETQ COS.THETA (COS HEAD.ANGLE)) + (SETQ SIN.THETA (SIN HEAD.ANGLE)) + [SETQ XP1 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES COS.RHO COS.THETA) + (TIMES SIN.RHO SIN.THETA] + [SETQ YP1 (TIMES HEAD.LENGTH (PLUS (TIMES SIN.RHO COS.THETA) + (TIMES SIN.THETA COS.RHO] + [SETQ XP2 (TIMES HEAD.LENGTH (PLUS (TIMES COS.RHO COS.THETA) + (TIMES SIN.RHO SIN.THETA] + [SETQ YP2 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES SIN.RHO COS.THETA) + (TIMES SIN.THETA COS.RHO] + (RETURN (CONS (create POSITION + XCOORD _ (IDIFFERENCE X1 (FIX XP1)) + YCOORD _ (IDIFFERENCE Y1 (FIX YP1))) + (create POSITION + XCOORD _ (IDIFFERENCE X1 (FIX XP2)) + YCOORD _ (IDIFFERENCE Y1 (FIX YP2]) (ARROWHEAD.POINTS.LIST + [LAMBDA (HEAD.POSITION HEAD.ANGLE HEAD.LENGTH DX DY HEAD.TYPE) + (* rrb " 1-May-86 16:15") + + (* * returns a list of end points for an arrowhead ending on HEAD.POSITION with + a slope of DX DY with an angle of HEAD.ANGLE and a length of HEAD.LENGTH If + HEAD.TYPE is LINE or CLOSEDLINE, the result is a list of + (HEADPT ONESIDEENDPT OTHERSIDEENDPT) If HEAD.TYPE is CURVE, the result is + (HEADPT (SIDE1PT1 SIDE1PT2) (SIDE2PT1 SIDE2PT2))) + + (PROG (X1 Y1 COS.THETA LL SIN.THETA COS.RHO SIN.RHO XP1 YP1 XP2 YP2 ENDPT1 ENDPT2) + (SETQ X1 (fetch (POSITION XCOORD) of HEAD.POSITION)) + (SETQ Y1 (fetch (POSITION YCOORD) of HEAD.POSITION)) + [SETQ LL (SQRT (PLUS (TIMES DX DX) + (TIMES DY DY] + (SETQ COS.RHO (QUOTIENT DX LL)) + (SETQ SIN.RHO (QUOTIENT DY LL)) + (SETQ COS.THETA (COS HEAD.ANGLE)) + (SETQ SIN.THETA (SIN HEAD.ANGLE)) + [SETQ XP1 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES COS.RHO COS.THETA) + (TIMES SIN.RHO SIN.THETA] + [SETQ YP1 (TIMES HEAD.LENGTH (PLUS (TIMES SIN.RHO COS.THETA) + (TIMES SIN.THETA COS.RHO] + [SETQ XP2 (TIMES HEAD.LENGTH (PLUS (TIMES COS.RHO COS.THETA) + (TIMES SIN.RHO SIN.THETA] + [SETQ YP2 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES SIN.RHO COS.THETA) + (TIMES SIN.THETA COS.RHO] + (SETQ ENDPT1 (create POSITION + XCOORD _ (DIFFERENCE X1 XP1) + YCOORD _ (DIFFERENCE Y1 YP1))) + (SETQ ENDPT2 (create POSITION + XCOORD _ (DIFFERENCE X1 XP2) + YCOORD _ (DIFFERENCE Y1 YP2))) + (RETURN (SELECTQ HEAD.TYPE + ((LINE CLOSEDLINE SOLID) + (LIST HEAD.POSITION ENDPT1 ENDPT2)) + (CURVE + + (* redo calculations with half the angle and half the length for a midpoint in + the curve.) + + (SETQ HEAD.ANGLE (QUOTIENT HEAD.ANGLE 1.5)) + (SETQ HEAD.LENGTH (QUOTIENT HEAD.LENGTH 2.0)) + (SETQ COS.THETA (COS HEAD.ANGLE)) + (SETQ SIN.THETA (SIN HEAD.ANGLE)) + [SETQ XP1 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES COS.RHO COS.THETA) + (TIMES SIN.RHO SIN.THETA] + [SETQ YP1 (TIMES HEAD.LENGTH (PLUS (TIMES SIN.RHO COS.THETA) + (TIMES SIN.THETA COS.RHO] + [SETQ XP2 (TIMES HEAD.LENGTH (PLUS (TIMES COS.RHO COS.THETA) + (TIMES SIN.RHO SIN.THETA] + [SETQ YP2 (TIMES HEAD.LENGTH (DIFFERENCE (TIMES SIN.RHO COS.THETA) + (TIMES SIN.THETA COS.RHO] + (LIST HEAD.POSITION (LIST (create POSITION + XCOORD _ (FIXR (DIFFERENCE X1 XP1)) + YCOORD _ (FIXR (DIFFERENCE Y1 YP1))) + ENDPT1) + (LIST (create POSITION + XCOORD _ (FIXR (DIFFERENCE X1 XP2)) + YCOORD _ (FIXR (DIFFERENCE Y1 YP2))) + ENDPT2))) + NIL]) (CURVE.ARROWHEAD.POINTS + [LAMBDA (KNOTS BEGFLG HEAD.ANGLE HEAD.LENGTH HEAD.TYPE) (* rrb "19-Mar-86 17:32") + + (* returns a list of arrowhead points for a curve. + If BEGFLG is T, it is to go on the first end.) + + (PROG [(SLOPE (\CURVESLOPE KNOTS (NOT BEGFLG] + (RETURN (ARROWHEAD.POINTS.LIST [COND + (BEGFLG (CAR KNOTS)) + (T (CAR (LAST KNOTS] + HEAD.ANGLE HEAD.LENGTH (COND + (BEGFLG (MINUS (CAR SLOPE))) + (T (CAR SLOPE))) + (COND + (BEGFLG (MINUS (CDR SLOPE))) + (T (CDR SLOPE))) + HEAD.TYPE]) (LEFT.MOST.IS.BEGINP + [LAMBDA (KNOTLST) (* rrb "30-Nov-84 16:55") + + (* * returns T if the beginning of the curve thru KNOTLST is to the left of its + end.) + + (COND + ((NULL (CDR (LISTP KNOTLST))) + (ERROR KNOTLST "should have at least two elements.")) + (T (PROG ((FIRST (CAR KNOTLST)) + (LAST (CAR (LAST KNOTLST))) + FIRSTX LASTX) + (RETURN (OR (GREATERP (SETQ LASTX (fetch (POSITION XCOORD) of LAST)) + (SETQ FIRSTX (fetch (POSITION XCOORD) of FIRST))) + (AND (EQP LASTX FIRSTX) + (GREATERP (fetch (POSITION YCOORD) of FIRST) + (fetch (POSITION YCOORD) of LAST]) (WIRE.ARROWHEAD.POINTS + [LAMBDA (KNOTS FIRSTFLG HEAD.ANGLE HEAD.LENGTH HEAD.TYPE) (* rrb "19-Mar-86 17:46") + + (* returns a list of arrowhead points for a wire. + If FIRSTFLG is T, it is to go on the first end.) + + (PROG (HEADPT TAILPT) + (COND + (FIRSTFLG (SETQ HEADPT (CAR KNOTS)) + (SETQ TAILPT (CADR KNOTS))) + ((CDR KNOTS) + (for KNOTTAIL on KNOTS when (NULL (CDDR KNOTTAIL)) do (SETQ TAILPT (CAR KNOTTAIL)) + (SETQ HEADPT (CADR KNOTTAIL)) + (RETURN))) + (T (* only one point, don't put on an + arrowhead.) + (RETURN))) + (RETURN (ARROWHEAD.POINTS.LIST HEADPT HEAD.ANGLE HEAD.LENGTH + (COND + (TAILPT (DIFFERENCE (fetch (POSITION XCOORD) of HEADPT) + (fetch (POSITION XCOORD) of TAILPT))) + (T 1)) + (COND + (TAILPT (DIFFERENCE (fetch (POSITION YCOORD) of HEADPT) + (fetch (POSITION YCOORD) of TAILPT))) + (T 0)) + HEAD.TYPE]) (DRAWARROWHEADS + [LAMBDA (ARROWSPECS ARROWPTS WINDOW SIZE OPERATION) (* rrb " 6-May-86 18:19") + + (* * draws the arrowhead from the specs in ARROWSPECS and the points in + ARROWPTS) + + (* PTS may be NIL in the case where an arrowhead was added to a closed knot + element that only has one point.) + + (bind ARROWTYPE for SPEC in ARROWSPECS as PTS in ARROWPTS when (AND SPEC PTS) + do (SELECTQ (SETQ ARROWTYPE (fetch (ARROWHEAD ARROWTYPE) of SPEC)) + (CURVE (* curve type. ARROWPTS format is + (headPt (side1pt1 side1pt2) + (side2pt1 side2pt2))) + (DRAWCURVE (CONS (CAR PTS) + (CADR PTS)) + NIL SIZE NIL WINDOW) + (DRAWCURVE (CONS (CAR PTS) + (CADDR PTS)) + NIL SIZE NIL WINDOW)) + (SOLID (* solid triangle) + (COND + ((IMAGESTREAMTYPEP WINDOW 'PRESS) (* PRESS doesn't implement filled + areas.) + (\SK.DRAW.TRIANGLE.ARROWHEAD PTS SIZE WINDOW T)) + (T (COND + ((OR (WINDOWP WINDOW) + (IMAGESTREAMTYPEP WINDOW 'DISPLAY)) + (* DISPLAY code doesn't fill out the + entire area.) + (\SK.DRAW.TRIANGLE.ARROWHEAD PTS SIZE WINDOW T))) + (FILLPOLYGON PTS BLACKSHADE WINDOW)))) + (LINE (* straight line form of arrow.) + (\SK.DRAW.TRIANGLE.ARROWHEAD PTS SIZE WINDOW NIL)) + (CLOSEDLINE (* triangle form of arrow.) + (\SK.DRAW.TRIANGLE.ARROWHEAD PTS SIZE WINDOW T)) + NIL]) (\SK.DRAW.TRIANGLE.ARROWHEAD + [LAMBDA (ARROWHEADPTS BRUSH STREAM CLOSED?) (* rrb " 6-May-86 18:15") + (* draws a triangle form arrowhead.) + + (* could be replaced with a drawpolygon call if this were implemented in + everybody.) + + (COND + ((OR [NOT (OR (WINDOWP STREAM) + (IMAGESTREAMTYPEP STREAM 'DISPLAY] + (EQ (SK.BRUSH.SIZE BRUSH) + 1)) + + (* call draw line instead because draw curve is off by 1 and makes arrowheads + look bad.) + + (DRAWBETWEEN (CAR ARROWHEADPTS) + (CADR ARROWHEADPTS) + (SK.BRUSH.SIZE BRUSH) + NIL STREAM) + (DRAWBETWEEN (CAR ARROWHEADPTS) + (CADDR ARROWHEADPTS) + (SK.BRUSH.SIZE BRUSH) + NIL STREAM) + (AND CLOSED? (DRAWBETWEEN (CADR ARROWHEADPTS) + (CADDR ARROWHEADPTS) + (SK.BRUSH.SIZE BRUSH) + NIL STREAM))) + (T (* use curve drawing because the end pts of the lines look better) + (DRAWCURVE (LIST (CAR ARROWHEADPTS) + (CADR ARROWHEADPTS)) + NIL BRUSH NIL STREAM) + (DRAWCURVE (LIST (CAR ARROWHEADPTS) + (CADDR ARROWHEADPTS)) + NIL BRUSH NIL STREAM) + (AND CLOSED? (DRAWCURVE (LIST (CADR ARROWHEADPTS) + (CADDR ARROWHEADPTS)) + NIL BRUSH NIL STREAM]) (\SK.ENDPT.OF.ARROW + [LAMBDA (LOCALARROWHEADPTS) (* rrb " 2-May-86 10:58") + + (* returns the point inside an arrowhead that the last point of the line should + hit.) + + (PROG ((LASTPT (CADDR LOCALARROWHEADPTS))) + + (* make it |1/4| of the way from the base mid point to the tip.) + + (RETURN (create POSITION + XCOORD _ (QUOTIENT (PLUS (fetch (POSITION XCOORD) of (CAR LOCALARROWHEADPTS) + ) + (TIMES (QUOTIENT (PLUS (fetch (POSITION XCOORD) + of (CADR + LOCALARROWHEADPTS + )) + (fetch (POSITION XCOORD) + of LASTPT)) + 2) + 3)) + 4) + YCOORD _ (QUOTIENT (PLUS (fetch (POSITION YCOORD) of (CAR LOCALARROWHEADPTS) + ) + (TIMES (QUOTIENT (PLUS (fetch (POSITION YCOORD) + of (CADR + LOCALARROWHEADPTS + )) + (fetch (POSITION YCOORD) + of LASTPT)) + 2) + 3)) + 4]) (\SK.ADJUST.FOR.ARROWHEADS + [LAMBDA (LOCALKNOTS LOCALARROWPTSLST GARROWHEADSPECS STREAM) + (* rrb " 6-May-86 17:43") + + (* returns a list of the knots that LOCALKNOTS should really be drawn through. + This is different when the arrowhead is solid because wide lines will make the + arrow look funny if they are run out all the way to the end.) + + [COND + ((IMAGESTREAMTYPEP STREAM 'PRESS) (* PRESS doesn't implement filled + areas.) + LOCALKNOTS) + (T (PROG (LASTFIXED X) + (SETQ LASTFIXED (COND + ((AND (CADR LOCALARROWPTSLST) + (EQ (fetch (ARROWHEAD ARROWTYPE) of (CADR GARROWHEADSPECS)) + 'SOLID)) + (RPLACA (LAST (SETQ X (APPEND LOCALKNOTS))) + (\SK.ENDPT.OF.ARROW (CADR LOCALARROWPTSLST))) + X) + (T LOCALKNOTS))) + (RETURN (COND + ((AND (CAR LOCALARROWPTSLST) + (EQ (fetch (ARROWHEAD ARROWTYPE) of (CAR GARROWHEADSPECS)) + 'SOLID)) + (CONS (\SK.ENDPT.OF.ARROW (CAR LOCALARROWPTSLST)) + (CDR LASTFIXED))) + (T LASTFIXED] + (PROG (LASTFIXED X) + (SETQ LASTFIXED (COND + ((AND (CADR LOCALARROWPTSLST) + (EQ (fetch (ARROWHEAD ARROWTYPE) of (CADR GARROWHEADSPECS)) + 'SOLID)) + (RPLACA (LAST (SETQ X (APPEND LOCALKNOTS))) + (\SK.ENDPT.OF.ARROW (CADR LOCALARROWPTSLST))) + X) + (T LOCALKNOTS))) + (RETURN (COND + ((AND (CAR LOCALARROWPTSLST) + (EQ (fetch (ARROWHEAD ARROWTYPE) of (CAR GARROWHEADSPECS)) + 'SOLID)) + (CONS (\SK.ENDPT.OF.ARROW (CAR LOCALARROWPTSLST)) + (CDR LASTFIXED))) + (T LASTFIXED]) (SK.SET.ARROWHEAD.LENGTH + [LAMBDA (W) (* rrb "14-May-86 19:27") + (* sets the size of the default + arrowhead.) + (PROG [NEWSIZE (NOWARROWHEAD (fetch (SKETCHCONTEXT SKETCHARROWHEAD) of (WINDOWPROP W ' + SKETCHCONTEXT] + (SETQ NEWSIZE (RNUMBER (CONCAT + "New arrowhead size in screen pts. Current arrowhead size is " + (MKSTRING (fetch (ARROWHEAD ARROWLENGTH) of NOWARROWHEAD))) + NIL NIL NIL T T T)) + (RETURN (COND + ((OR (NULL NEWSIZE) + (IGEQ 0 NEWSIZE)) + NIL) + (T (replace (SKETCHCONTEXT SKETCHARROWHEAD) of (WINDOWPROP W 'SKETCHCONTEXT) + with (create ARROWHEAD using NOWARROWHEAD ARROWLENGTH _ NEWSIZE]) (SK.SET.ARROWHEAD.ANGLE + [LAMBDA (W) (* rrb "14-May-86 19:27") + (* sets the angle of the default + arrowhead.) + (PROG [NEWSIZE (NOWARROWHEAD (fetch (SKETCHCONTEXT SKETCHARROWHEAD) of (WINDOWPROP W ' + SKETCHCONTEXT] + (SETQ NEWSIZE (RNUMBER (CONCAT "New head angle in degrees. Current arrowhead angle is " + (MKSTRING (fetch (ARROWHEAD ARROWANGLE) of NOWARROWHEAD))) + NIL NIL NIL T T T)) + (RETURN (COND + ((OR (NULL NEWSIZE) + (IGEQ 0 NEWSIZE)) + NIL) + (T (replace (SKETCHCONTEXT SKETCHARROWHEAD) of (WINDOWPROP W 'SKETCHCONTEXT) + with (create ARROWHEAD using NOWARROWHEAD ARROWANGLE _ NEWSIZE]) (SK.SET.ARROWHEAD.TYPE + [LAMBDA (W VALUE) (* rrb "19-Mar-86 10:25") + (* Sets the type of the default + arrowhead) + (PROG ([NEWSHAPE (COND + ((MEMB VALUE '(LINE CURVE CLOSEDLINE SOLID)) + VALUE) + (T (\CURSOR.IN.MIDDLE.MENU (create MENU + TITLE _ "Choose style" + ITEMS _ (LIST (LIST VSHAPE.ARROWHEAD.BITMAP + ''LINE + "arrowhead consists of two line segments." + ) + (LIST + CURVEDV.ARROWHEAD.BITMAP + ''CURVE + "arrowhead has curved side lines." + ) + (LIST + TRIANGLE.ARROWHEAD.BITMAP + ''CLOSEDLINE + "arrowhead consists of a triangle." + ) + (LIST + SOLIDTRIANGLE.ARROWHEAD.BITMAP + ''SOLID + "makes a solid triangular arrowhead." + )) + ITEMHEIGHT _ (PLUS 2 (BITMAPHEIGHT + VSHAPE.ARROWHEAD.BITMAP + )) + CENTERFLG _ T] + SKETCHCONTEXT) + (RETURN (AND NEWSHAPE (replace (SKETCHCONTEXT SKETCHARROWHEAD) of (SETQ SKETCHCONTEXT + (WINDOWPROP W + 'SKETCHCONTEXT)) + with (create ARROWHEAD using (fetch (SKETCHCONTEXT SKETCHARROWHEAD + ) of SKETCHCONTEXT) + ARROWTYPE _ NEWSHAPE]) (SK.SET.LINE.ARROWHEAD + [LAMBDA (W NEWVALUE) (* rrb " 6-Nov-85 09:50") + + (* sets whether or not the default line has an arrowhead.) + + (PROG [(ARROWHEADEND (COND + ((MEMB NEWVALUE '(FIRST LAST BOTH NEITHER LEFT RIGHT)) + NEWVALUE) + (T (\CURSOR.IN.MIDDLE.MENU (create MENU + TITLE _ "Which end?" + ITEMS _ '((First 'FIRST + "An arrowhead will be at the first point of any new lines or curves." + ) + (Last 'LAST + "An arrowhead will be at the last point of any new lines or curves." + ) + (Both 'BOTH + "Arrowheads will be both ends of any new lines or curves." + ) + (Neither 'NEITHER + "New lines will not have any arrowheads." + ) + (|Left | 'LEFT + "An arrowhead will be at the leftmost end of any new lines or curves." + ) + (| Right| 'RIGHT + "An arrowhead will be at the rightmost end of any new lines or curves." + )) + CENTERFLG _ T] + (RETURN (AND ARROWHEADEND (replace (SKETCHCONTEXT SKETCHUSEARROWHEAD) + of (WINDOWPROP W 'SKETCHCONTEXT) with ARROWHEADEND]) (SK.UPDATE.ARROWHEAD.FORMAT + [LAMBDA (GELT) (* rrb "25-Apr-85 10:28") + + (* makes sure that the element GELT is in new format.) + + (* the fields of this are first arrowhead, last arrowhead and new format + indicator. The old format had left arrowhead and right arrowhead.) + + (PROG ((INDGARROWELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) + NOWARROWS) + (SELECTQ (fetch (INDIVIDUALGLOBALPART GTYPE) of INDGARROWELT) + (OPENCURVE [AND (SETQ NOWARROWS (fetch (OPENCURVE CURVEARROWHEADS) of INDGARROWELT)) + (NULL (CDDR NOWARROWS)) + (replace (OPENCURVE CURVEARROWHEADS) of INDGARROWELT + with (COND + ((LEFT.MOST.IS.BEGINP (fetch LATLONKNOTS of INDGARROWELT)) + (LIST (CAR NOWARROWS) + (CADR NOWARROWS) + T)) + (T (LIST (CADR NOWARROWS) + (CAR NOWARROWS) + T]) + (WIRE [AND (SETQ NOWARROWS (fetch (WIRE WIREARROWHEADS) of INDGARROWELT)) + (NULL (CDDR NOWARROWS)) + (replace (WIRE WIREARROWHEADS) of INDGARROWELT + with (COND + ((LEFT.MOST.IS.BEGINP (fetch LATLONKNOTS of INDGARROWELT)) + (LIST (CAR NOWARROWS) + (CADR NOWARROWS) + T)) + (T (LIST (CADR NOWARROWS) + (CAR NOWARROWS) + T]) + NIL) + (RETURN GELT]) (SK.SET.LINE.LENGTH.MODE + [LAMBDA (W VAL?) (* rrb " 6-Nov-85 09:51") + + (* sets whether the lines drawn with the middle button connect e.g the next + segment begins where the last one left off or whether it takes two clicks to + get a single segment line.) + + (PROG [(LINEMODE (COND + ((MEMBER VAL? '(YES NO)) + VAL?) + (T (\CURSOR.IN.MIDDLE.MENU (create MENU + TITLE _ "Connect middle button lines?" + ITEMS _ '((Yes 'YES + "The lines drawn with the middle button will pick up where the last one left off." + ) + (No 'NO + "Sets the default so that two middle clicks make a line." + )) + CENTERFLG _ T] + (RETURN (AND LINEMODE (replace (SKETCHCONTEXT SKETCHLINEMODE) of (WINDOWPROP W ' + SKETCHCONTEXT) + with (EQ LINEMODE 'NO]) ) (DEFINEQ (SK.INSURE.ARROWHEADS + [LAMBDA (ARROWHEADSPECS) (* ; "Edited 8-Jan-87 19:46 by rrb") + + (* makes sure ARROWHEADSPECS is a legal list of two arrowhead specifications.) + + (* slap a T on the end of it so it will be recognized as the new format.) + + (COND + ((NULL ARROWHEADSPECS) + NIL) + ((SK.ARROWHEADP ARROWHEADSPECS) + + (* the user passed in only one spec, make it be the end.) + + (LIST NIL ARROWHEADSPECS T)) + ((APPEND [for SPEC in ARROWHEADSPECS + collect (COND + ((NULL SPEC) + NIL) + ((SK.ARROWHEADP SPEC)) + ((EQ SPEC T) + (create ARROWHEAD + ARROWTYPE _ SK.DEFAULT.ARROW.TYPE + ARROWANGLE _ SK.DEFAULT.ARROW.ANGLE + ARROWLENGTH _ SK.DEFAULT.ARROW.LENGTH)) + (T (\ILLEGAL.ARG ARROWHEADSPECS] + '(T]) (SK.ARROWHEADP + [LAMBDA (ARROWHEAD) (* rrb "16-Oct-85 16:24") + (* determines if ARROWHEAD is a legal + arrowhead specification.) + (AND (EQLENGTH ARROWHEAD 3) + (MEMB (fetch (ARROWHEAD ARROWTYPE) of ARROWHEAD) + SK.ARROWHEAD.TYPES) + (NUMBERP (fetch (ARROWHEAD ARROWANGLE) of ARROWHEAD)) + (NUMBERP (fetch (ARROWHEAD ARROWLENGTH) of ARROWHEAD)) + ARROWHEAD]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD LOCALWIRE (KNOTS LOCALHOTREGION ARROWHEADPTS LOCALOPENWIREBRUSH LOCALWIREDASHING)) (TYPERECORD WIRE (LATLONKNOTS BRUSH WIREARROWHEADS OPENWIREDASHING OPENWIREINITSCALE OPENWIREREGION OPENWIREARROWHEADPOINTS)) (TYPERECORD CLOSEDWIRE (LATLONKNOTS BRUSH CLOSEDWIREDASHING CLOSEDWIREINITSCALE CLOSEDWIREFILLING CLOSEDWIREREGION)) (RECORD LOCALCLOSEDWIRE (KNOTS LOCALHOTREGION LOCALCLOSEDWIREBRUSH LOCALCLOSEDWIREFILLING)) ) ) (DECLARE%: EVAL@COMPILE (RECORD ARROWHEAD (ARROWTYPE ARROWANGLE ARROWLENGTH)) ) (READVARS-FROM-STRINGS '(VSHAPE.ARROWHEAD.BITMAP TRIANGLE.ARROWHEAD.BITMAP SOLIDTRIANGLE.ARROWHEAD.BITMAP CURVEDV.ARROWHEAD.BITMAP) "({(READBITMAP)(24 18 %"@@@@@@@@%" %"@@L@@@@@%" %"@@C@@@@@%" %"@@@L@@@@%" %"@@@C@@@@%" %"@@@@L@@@%" %"@@@@C@@@%" %"@@@@@L@@%" %"@@@@@B@@%" %"OOOOOO@@%" %"@@@@@B@@%" %"@@@@@L@@%" %"@@@@C@@@%" %"@@@@L@@@%" %"@@@C@@@@%" %"@@@L@@@@%" %"@@C@@@@@%" %"@@L@@@@@%")} {(READBITMAP)(24 18 %"@@@@@@@@%" %"@@L@@@@@%" %"@@K@@@@@%" %"@@HL@@@@%" %"@@HC@@@@%" %"@@H@L@@@%" %"@@H@C@@@%" %"@@H@@L@@%" %"@@H@@B@@%" %"OOOOOO@@%" %"@@H@@B@@%" %"@@H@@L@@%" %"@@H@C@@@%" %"@@H@L@@@%" %"@@HC@@@@%" %"@@HL@@@@%" %"@@K@@@@@%" %"@@L@@@@@%")} {(READBITMAP)(24 18 %"@@@@@@@@%" %"@@L@@@@@%" %"@@O@@@@@%" %"@@OL@@@@%" %"@@OO@@@@%" %"@@OOL@@@%" %"@@OOO@@@%" %"@@OOOL@@%" %"@@OOON@@%" %"OOOOOO@@%" %"@@OOON@@%" %"@@OOOL@@%" %"@@OOO@@@%" %"@@OOL@@@%" %"@@OO@@@@%" %"@@OL@@@@%" %"@@O@@@@@%" %"@@L@@@@@%")} {(READBITMAP)(24 18 %"@@@@@@@@%" %"@@@@@@@@%" %"@A@@@@@@%" %"@@H@@@@@%" %"@@D@@@@@%" %"@@C@@@@@%" %"@@@N@@@@%" %"@@@AL@@@%" %"@@@@CH@@%" %"OOOOOO@@%" %"@@@@CH@@%" %"@@@AL@@@%" %"@@@N@@@@%" %"@@C@@@@@%" %"@@D@@@@@%" %"@@H@@@@@%" %"@A@@@@@@%" %"@@@@@@@@%")}) ") (READVARS-FROM-STRINGS '(WIREICON CLOSEDWIREICON) "({(READBITMAP)(20 12 %"@D@@@@@@%" %"@L@@@@@@%" %"AH@@@@@@%" %"C@GOL@@@%" %"F@OOL@@@%" %"L@L@L@@@%" %"LAH@L@@@%" %"FAHAH@@@%" %"CC@C@@@@%" %"AK@C@@@@%" %"@N@F@@@@%" %"@F@L@@@@%")} {(READBITMAP)(20 12 %"@G@GN@@@%" %"@OHON@@@%" %"AMMLN@@@%" %"CHOIL@@@%" %"G@GCH@@@%" %"N@@G@@@@%" %"G@@N@@@@%" %"CH@GH@@@%" %"AL@AN@@@%" %"@O@@F@@@%" %"@GOON@@@%" %"@COON@@@%")}) ") (RPAQ? SK.ARROWHEAD.ANGLE.INCREMENT 5) (RPAQ? SK.ARROWHEAD.LENGTH.INCREMENT 2) (ADDTOVAR SK.ARROWHEAD.TYPES LINE CLOSEDLINE CURVE SOLID) (RPAQ? SK.DEFAULT.ARROW.LENGTH 8) (RPAQ? SK.DEFAULT.ARROW.TYPE 'CURVE) (RPAQ? SK.DEFAULT.ARROW.ANGLE 18.0) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SK.DEFAULT.ARROW.LENGTH SK.DEFAULT.ARROW.TYPE SK.DEFAULT.ARROW.ANGLE SK.ARROWHEAD.TYPES) ) (RPAQ? SK.ARROW.END.MENU ) (RPAQ? SK.ARROW.EDIT.MENU ) (* ; "stuff to support the text element type.") (DEFINEQ (SKETCH.CREATE.TEXT + [LAMBDA (STRING POSITION FONT JUSTIFICATION COLOR SCALE) (* rrb " 4-Dec-85 20:51") + (* creates a text element.) + (CREATE.TEXT.ELEMENT (SK.INSURE.TEXT STRING) + (SK.INSURE.POSITION POSITION) + (OR (NUMBERP SCALE) + 1.0) + (SK.INSURE.STYLE JUSTIFICATION SK.DEFAULT.TEXT.ALIGNMENT) + (SK.INSURE.FONT FONT) + (SK.INSURE.COLOR COLOR]) (TEXT.CHANGEFN + [LAMBDA (SCRNELTS SKW HOW) (* rrb "10-Jan-85 16:58") + (* the users has selected SCRNELT to + be changed) + (for ELTWITHTEXT inside SCRNELTS collect (SK.CHANGE.TEXT ELTWITHTEXT HOW SKW]) (TEXT.READCHANGEFN + [LAMBDA (SKW SCRNELTS INTEXTBOXFLG) (* rrb " 3-Oct-86 15:26") + + (* the users has selected SCRNELT to be changed this function reads a + specification of how the text elements should change.) + + (PROG ((COMMAND (\CURSOR.IN.MIDDLE.MENU (create MENU + TITLE _ "Change text how?" + ITEMS _ + [APPEND (COND + [(SKETCHINCOLORP) + '(("Color" 'BRUSHCOLOR + "changes the color of the text" + ] + (T NIL)) + [COND + ((SCREENELEMENTP SCRNELTS) + NIL) + (T '(("look same" 'SAME + "makes the font characteristics the same as those of the first selected piece of text." + ] + [COND + ((AND (NULL INTEXTBOXFLG) + (SKETCH.ELEMENT.TYPEP 'TEXTBOX)) + '(("box the text" 'BOX + "makes the selected text into boxed text." + ] + [COND + ((DATATYPEP 'LOOKEDSTRING) + '(("Fancy format" 'LOOKEDSTRING + "changes to a form that can have complete character formatting." + ] + '(("different font" 'NEWFONT + "prompts for a new font family.") + ("smaller font" 'SMALLER + "Make the text smaller") + ("LARGER FONT" 'LARGER + "Make the text font larger.") + ("set font size" 'SETSIZE + "makes all fonts a prompted for size" + ) + ("set family & size" 'FAMILY&SIZE + "allows changing both the family and the size" + ) + ("BOLD" 'BOLD "makes the text bold.") + ("unbold" 'UNBOLD + "removes the bold look of text.") + ("italic" 'ITALIC + "makes the text italic.") + ("unitalic" 'UNITALIC + "removes the italic look of text." + ) + ("center justify" 'CENTER + "centers the text about its location" + ) + ("left justify " 'LEFT + "left justifies the text to its location" + ) + (" right justify" 'RIGHT + "right justifies the text to its location." + ) + ("top justify" 'TOP + "makes the location be the top of the text." + ) + ("bottom justify" 'BOTTOM + "makes the location be the bottom of the text." + ) + ("middle justify" 'MIDDLE + "makes the control point specify the mid-height of the text." + ) + ("baseline justify" 'BASELINE + "makes the control popint specify the baseline of the text." + ] + CENTERFLG _ T))) + FIRSTTEXTELT VAL) + (OR COMMAND (RETURN)) + (SKED.CLEAR.SELECTION SKW) + [SETQ VAL (SELECTQ COMMAND + (SETSIZE (* read the new font size once) + (\SK.READ.FONT.SIZE1 SCRNELTS SKW)) + (FAMILY&SIZE (* gets both a font size and a family) + (AND (SETQ VAL (SK.READFONTFAMILY SKW "New font family?")) + (\SK.READ.FONT.SIZE1 SCRNELTS SKW VAL))) + (SAME (* set the text characteristics from + the first selection.) + (AND (SETQ FIRSTTEXTELT (for SCRNELT inside SCRNELTS + when (MEMB (fetch (SCREENELT GTYPE) + of SCRNELT) + '(TEXTBOX TEXT)) + do (RETURN SCRNELT))) + (fetch (SCREENELT GLOBALPART) of FIRSTTEXTELT))) + (NEWFONT (* get a new font family) + (SK.READFONTFAMILY SKW "New font family?")) + (BRUSHCOLOR [READ.COLOR.CHANGE "Change text color how?" NIL + (fetch (BRUSH BRUSHCOLOR) + of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) + of (CAR SCRNELTS)) + 'BRUSH]) + (RETURN (LIST 'TEXT COMMAND] + (RETURN (AND VAL (LIST COMMAND VAL]) (\SK.READ.FONT.SIZE1 + [LAMBDA (SELECTEDELTS SKETCHW NEWFAMILY) (* rrb "14-Jul-86 13:43") + + (* reads a font size from the user. If NEWFONT is NIL, use the one of the first + selected element.) + + (PROG (FIRSTTEXTELT NEWSIZE NOWFONT NEWFONT) + (OR (SETQ FIRSTTEXTELT (for SCRNELT inside SELECTEDELTS + when (MEMB (fetch (SCREENELT GTYPE) of SCRNELT) + '(TEXTBOX TEXT)) do (RETURN SCRNELT))) + (RETURN)) + (SETQ FIRSTTEXTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of FIRSTTEXTELT)) + (SETQ NOWFONT (fetch (TEXT FONT) of FIRSTTEXTELT)) + (STATUSPRINT SKETCHW "Size of " (COND + ((SCREENELEMENTP SELECTEDELTS) + "text") + (T "first selected text")) + " is " + (FONTPROP NOWFONT 'SIZE)) + (SETQ NEWSIZE (SK.READFONTSIZE NIL [OR NEWFAMILY (SETQ NEWFAMILY (FONTPROP NOWFONT + 'FAMILY] + SKETCHW)) + (RETURN (COND + ((NULL NEWSIZE) + (CLOSE.PROMPT.WINDOW SKETCHW) + NIL) + ((NULL (SETQ NEWFONT (FONTCREATE NEWFAMILY NEWSIZE (FONTPROP NOWFONT + 'FACE) + NIL NIL T))) + (STATUSPRINT SKETCHW NEWFAMILY NEWSIZE " not found.") + NIL) + (T (CLOSE.PROMPT.WINDOW SKETCHW) + (SK.FONTNAMELIST NEWFONT]) (SK.TEXT.ELT.WITH.SAME.FIELDS + [LAMBDA (NEWONE ORGONE) (* rrb "18-Jul-85 14:16") + + (* returns an element of the type of ORGONE whose text fields are the same as + NEWONE.) + + (SELECTQ (fetch (INDIVIDUALGLOBALPART GTYPE) of ORGONE) + (TEXT (create TEXT + LOCATIONLATLON _ (fetch (TEXT LOCATIONLATLON) of ORGONE) + LISTOFCHARACTERS _ (fetch (TEXT LISTOFCHARACTERS) of ORGONE) + INITIALSCALE _ (fetch (TEXT INITIALSCALE) of NEWONE) + TEXTSTYLE _ (fetch (TEXT TEXTSTYLE) of NEWONE) + FONT _ (fetch (TEXT FONT) of NEWONE) + LISTOFREGIONS _ (fetch (TEXT LISTOFREGIONS) of NEWONE) + TEXTCOLOR _ (fetch (TEXT TEXTCOLOR) of NEWONE))) + (TEXTBOX (create TEXTBOX + TEXTBOXREGION _ (fetch (TEXTBOX TEXTBOXREGION) of ORGONE) + LISTOFCHARACTERS _ (fetch (TEXT LISTOFCHARACTERS) of ORGONE) + INITIALSCALE _ (fetch (TEXT INITIALSCALE) of NEWONE) + TEXTSTYLE _ (fetch (TEXT TEXTSTYLE) of NEWONE) + FONT _ (fetch (TEXT FONT) of NEWONE) + LISTOFREGIONS _ (fetch (TEXT LISTOFREGIONS) of NEWONE) + TEXTCOLOR _ (fetch (TEXT TEXTCOLOR) of NEWONE) + TEXTBOXBRUSH _ (fetch (TEXTBOX TEXTBOXBRUSH) of ORGONE))) + NIL]) (SK.READFONTFAMILY + [LAMBDA (SKW TITLE) (* rrb "21-Nov-85 11:28") + (* reads a font family name.) + (PROG ([KNOWNFAMILIES (UNION (for X in \FONTSONFILE collect (CAR X)) + (for X in \FONTSINCORE collect (CAR X] + FAMILY) (* offers a menu of possible choices.) + (COND + ((AND KNOWNFAMILIES (NEQ (SETQ FAMILY (\CURSOR.IN.MIDDLE.MENU + (create MENU + ITEMS _ + (APPEND '(("other" 'OTHER + "prompts for a family not on the menu." + )) KNOWNFAMILIES) + TITLE _ (OR TITLE "Choose font") + CENTERFLG _ T))) + 'OTHER)) + (RETURN FAMILY)) + (T (* grab the tty.) + (TTY.PROCESS (THIS.PROCESS)) + (RETURN (CAR (ERSETQ (MKATOM (U-CASE (PROMPTFORWORD "New family: " NIL NIL + (GETPROMPTWINDOW SKW]) (CLOSE.PROMPT.WINDOW + [LAMBDA (WINDOW) (* rrb "28-Oct-84 14:14") + (* gets rid of the prompt window.) + (PROG (PRMPTWIN) + (RETURN (COND + ((SETQ PRMPTWIN (GETPROMPTWINDOW WINDOW NIL NIL T)) + (DETACHWINDOW PRMPTWIN) + (CLOSEW PRMPTWIN]) (TEXT.DRAWFN + [LAMBDA (TEXTELT WINDOW) (* rrb " 9-Aug-85 09:38") + (* shows a text element) + (TEXT.DRAWFN1 (fetch (LOCALTEXT LOCALLISTOFCHARACTERS) of (fetch (SCREENELT LOCALPART) + of TEXTELT)) + (fetch (LOCALTEXT LINEREGIONS) of (fetch (SCREENELT LOCALPART) of TEXTELT)) + (fetch (LOCALTEXT LOCALFONT) of (fetch (SCREENELT LOCALPART) of TEXTELT)) + (fetch (TEXT TEXTCOLOR) of (fetch (SCREENELT INDIVIDUALGLOBALPART) of TEXTELT)) + WINDOW]) (TEXT.DRAWFN1 + [LAMBDA (STRS REGIONS FONT COLOR SKWINDOW OPERATION) (* ; "Edited 3-Oct-89 13:48 by rmk:") + (* ; "Edited 3-Oct-89 13:47 by rmk:") + (* rrb " 3-Mar-86 21:37") + + (* ;; "draws the image of a list of string in their local regions on a sketch window. It is broken out as a subfunction so that it can be called by the update function also.") + + (COND + ((AND COLOR (SKETCHINCOLORP)) + (DSPCOLOR COLOR SKWINDOW))) + (PROG (DESCENT OLDFONT) + (COND + ((NULL FONT) (* ; + "text is too small or too large to be at this scale.") + (RETURN)) + ((FONTP FONT) (* ; "font was found.") + (SETQ OLDFONT (DSPFONT FONT SKWINDOW)) (* ; "Install font, then refetch it from window/stream, in case there was device coercion, so descent will be right.") + (SETQ DESCENT (FONTPROP (DSPFONT NIL SKWINDOW) + 'DESCENT)) + (DSPOPERATION (PROG1 (DSPOPERATION OPERATION SKWINDOW) + (RESETFORM (SETTERMTABLE SKETCH.TERMTABLE) + (for REGION in REGIONS as CHARS in STRS + do (MOVETO (fetch (REGION LEFT) of REGION) + (PLUS (fetch (REGION BOTTOM) of + REGION) + DESCENT) + SKWINDOW) + (PRIN3 CHARS SKWINDOW)))) + SKWINDOW) (* ; + "return to original font so that messages come out ok.") + (DSPFONT OLDFONT SKWINDOW)) + (T (* ; + "if no font, just gray in regions") + +(* ;;; "This code was left by RRB on the theory that hardcopy can't support bitblt, which I think is wrong--RMK. (COND ((EQ (IMAGESTREAMTYPE SKWINDOW) 'DISPLAY) (for REGION in REGIONS do (BITBLT NIL NIL NIL SKWINDOW (fetch LEFT of REGION) (fetch BOTTOM of REGION) (fetch WIDTH of REGION) (IQUOTIENT (ADD1 (fetch HEIGHT of REGION)) 2) 'TEXTURE OPERATION INDICATE.TEXT.SHADE))) (T ; hardcopy can't support bitblt, draw a line instead. (bind MIDHGHT for REGION in REGIONS do (DRAWLINE (fetch LEFT of REGION) (SETQ MIDHGHT (PLUS (fetch BOTTOM of REGION) (IQUOTIENT (ADD1 (fetch HEIGHT of REGION)) 2))) (fetch RIGHT of REGION) MIDHGHT (fetch HEIGHT of REGION) OPERATION SKWINDOW))))") + + (for REGION in REGIONS + do (BITBLT NIL NIL NIL SKWINDOW (fetch LEFT of REGION) + (fetch BOTTOM of REGION) + (fetch WIDTH of REGION) + (IQUOTIENT (ADD1 (fetch HEIGHT of REGION)) + 2) + 'TEXTURE OPERATION INDICATE.TEXT.SHADE]) (TEXT.INSIDEFN + [LAMBDA (GTEXT WREG) (* rrb " 5-AUG-83 16:54") + + (* determines if the global text element is inside of WREG.) + + (for GREG in (fetch (TEXT LISTOFREGIONS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXT)) + when (REGIONSINTERSECTP GREG WREG) do (RETURN T]) (TEXT.EXPANDFN + [LAMBDA (GTEXTPART SCALE STREAM) (* rrb "19-Mar-86 15:59") + + (* creates a local text screen element from a global text element.) + + (PROG ((GTEXT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTPART)) + TEXTPOS LOCALFONT STYLE LINEREGIONS) + [COND + ((NLISTP (SETQ STYLE (fetch (TEXT TEXTSTYLE) of GTEXT))) + + (* old format had horizontal positioning only, now has vertical too. + Fill in old default.) + + (replace (TEXT TEXTSTYLE) of GTEXT with (SETQ STYLE '(CENTER CENTER] + (SETQ LOCALFONT (SK.CHOOSE.TEXT.FONT GTEXT SCALE STREAM)) + [SETQ LINEREGIONS (SK.TEXT.LINE.REGIONS (fetch (TEXT LISTOFCHARACTERS) of GTEXT) + (SETQ TEXTPOS (SK.SCALE.POSITION.INTO.VIEWER (fetch (TEXT + LOCATIONLATLON + ) + of GTEXT) + SCALE)) + (fetch (TEXT LISTOFREGIONS) of GTEXT) + LOCALFONT STYLE SCALE (COND + ((STREAMP STREAM)) + (T (WINDOWPROP STREAM 'DSP] + (RETURN (create SCREENELT + LOCALPART _ + (create LOCALTEXT + DISPLAYPOSITION _ TEXTPOS + LINEREGIONS _ LINEREGIONS + LOCALFONT _ LOCALFONT + LOCALLISTOFCHARACTERS _ (APPEND (fetch (TEXT LISTOFCHARACTERS) + of GTEXT))) + GLOBALPART _ GTEXTPART]) (SK.TEXT.LINE.REGIONS + [LAMBDA (LISTOFTEXT TEXTPOS GREGIONS LOCALFONT STYLE SCALE IMAGESTREAM) + (* rrb "19-Mar-86 15:44") + + (* calculates the list of regions that each line of text in LISTOFTEXT will + occupy. Used by both TEXT.EXPANDFN and TEXTBOX.EXPANDFN. + Captures those things which are common to the two elements.) + + (COND + [(FONTP LOCALFONT) + (LTEXT.LINE.REGIONS LISTOFTEXT TEXTPOS (COND + ((IMAGESTREAMTYPEP IMAGESTREAM 'HARDCOPY) + + (* actually make the font be the font of the stream so that the stream can be + passed to STRINGWIDTH to get hardcopy characteristics.) + + (DSPFONT LOCALFONT IMAGESTREAM) + IMAGESTREAM) + (T LOCALFONT)) + STYLE + (FIXR (TIMES (QUOTIENT (fetch (REGION HEIGHT) of (CAR GREGIONS)) + SCALE) + (LENGTH LISTOFTEXT] + (T (for GREG in GREGIONS collect (CREATEREGION (FIXR (QUOTIENT (fetch (REGION LEFT) + of GREG) + SCALE)) + (FIXR (QUOTIENT (fetch (REGION BOTTOM) of GREG) + SCALE)) + (FIXR (QUOTIENT (fetch (REGION WIDTH) of GREG) + SCALE)) + 1]) (TEXT.UPDATE.GLOBAL.REGIONS + [LAMBDA (GTEXTELT NEWGPOS OLDGPOS) (* rrb "12-Sep-84 11:36") + + (* updates the list of regions occupied by the text in the global coordinate + space.) + + (* this is used to determine the extent of a text element in a region.) + + (PROG ((XDIFF (DIFFERENCE (fetch (POSITION XCOORD) of NEWGPOS) + (fetch (POSITION XCOORD) of OLDGPOS))) + (YDIFF (DIFFERENCE (fetch (POSITION YCOORD) of NEWGPOS) + (fetch (POSITION YCOORD) of OLDGPOS))) + (INDTEXTGELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTELT))) + (replace (TEXT LISTOFREGIONS) of INDTEXTGELT with (for GREG + in (fetch (TEXT LISTOFREGIONS) + of INDTEXTGELT) + collect (REL.MOVE.REGION GREG XDIFF + YDIFF))) + (RETURN GTEXTELT]) (REL.MOVE.REGION + [LAMBDA (REGION DELTAX DELTAY) (* rrb "15-AUG-83 17:30") + (* moves a region by an amount DELTAX + DELTAY) + (CREATEREGION (PLUS DELTAX (fetch (REGION LEFT) of REGION)) + (PLUS DELTAY (fetch (REGION BOTTOM) of REGION)) + (fetch (REGION WIDTH) of REGION) + (fetch (REGION HEIGHT) of REGION]) (LTEXT.LINE.REGIONS + [LAMBDA (LINES LPOSITION STREAMORFONT STYLE TOTALHEIGHT) (* rrb " 4-Dec-85 11:51") + + (* returns the regions occupied by the lines of text LINES to format them in + STYLE in font FONT at position LPOSITION.) + + (AND STREAMORFONT + (PROG ((FONT (FONTCREATE STREAMORFONT)) + (TEXTXPOS (fetch (POSITION XCOORD) of LPOSITION)) + (TEXTYPOS (fetch (POSITION YCOORD) of LPOSITION)) + HEIGHT HEIGHTOFLOCALTEXT LINEWIDTH) + [SETQ HEIGHT (COND + ((STREAMP STREAMORFONT) + + (* use the line feed height because in hardcopy streams this is more correct.) + + (MINUS (DSPLINEFEED NIL STREAMORFONT))) + (T (FONTPROP FONT 'HEIGHT] + (SETQ HEIGHTOFLOCALTEXT (TIMES HEIGHT (LENGTH LINES))) + (RETURN (for CHARS in LINES as Y + from [PLUS TEXTYPOS (SELECTQ (CADR STYLE) + (BASELINE + + (* vertically center the baseline. The baseline alignment should probably be + independent of the top - + bottom alignment eventually.) + + [DIFFERENCE (DIFFERENCE (QUOTIENT + HEIGHTOFLOCALTEXT + 2.0) + HEIGHT) + (MINUS (FONTPROP FONT 'DESCENT]) + (CENTER (DIFFERENCE (QUOTIENT HEIGHTOFLOCALTEXT 2.0 + ) + HEIGHT)) + (TOP (DIFFERENCE 1 HEIGHT)) + (BOTTOM (DIFFERENCE HEIGHTOFLOCALTEXT HEIGHT)) + (ERROR "illegal vertical text style" (CADR STYLE] + by (IMINUS HEIGHT) + collect [SETQ LINEWIDTH (DIFFERENCE (STRINGWIDTH CHARS STREAMORFONT) + (COND + ((EQ (NTHCHARCODE CHARS -1) + (CHARCODE CR)) + (CHARWIDTH (CHARCODE CR) + STREAMORFONT)) + (T 0] + (CREATEREGION (SELECTQ (CAR STYLE) + (CENTER (DIFFERENCE TEXTXPOS (QUOTIENT LINEWIDTH + 2.0))) + (LEFT TEXTXPOS) + (DIFFERENCE TEXTXPOS LINEWIDTH)) + Y LINEWIDTH HEIGHT]) (TEXT.INPUTFN + [LAMBDA (WINDOW) (* rrb "12-Dec-84 11:44") + + (* reads text and a place to put it from the user and returns a TEXTELT that + represents it. Can return NIL if the user positions it outside of the window.) + + (TEXT.POSITION.AND.CREATE (READ.TEXT "Text to be added: ") + (fetch (SKETCHCONTEXT SKETCHFONT) of (WINDOWPROP WINDOW 'SKETCHCONTEXT)) + WINDOW "locate the text"]) (READ.TEXT + [LAMBDA (PRMPT) (* rrb " 9-AUG-83 12:42") + (PROG ([CLOSEWFLG (COND + ((EQ (TTYDISPLAYSTREAM) + \DEFAULTTTYDISPLAYSTREAM) + T) + ((AND (WFROMDS (TTYDISPLAYSTREAM)) + (NOT (OPENWP (TTYDISPLAYSTREAM] + LST) + (AND PRMPT (PRIN1 PRMPT T)) + (SETQ LST (CONS (READ T) + (READLINE))) + (AND CLOSEWFLG (CLOSEW (TTYDISPLAYSTREAM))) + (RETURN (APPLY (FUNCTION CONCAT) + (CONS (CAR LST) + (for WORD in (CDR LST) join (LIST '% WORD]) (TEXT.POSITION.AND.CREATE + [LAMBDA (TEXT FONT WINDOW PROMPTMSG) (* rrb "16-Oct-85 18:29") + + (* gets a position for a piece of text from the user and returns a text element + that represents it. The text location is the center position of the text.) + + (* later this should change the cursor to the image being placed.) + + (PROG [P1 LOCATION DISPLAYPOSITION (SCALE (SK.INPUT.SCALE WINDOW)) + NEW.BITMAP DSP (WDTH (STRINGWIDTH TEXT FONT)) + (HGHT (FONTHEIGHT FONT)) + (TEXTALIGNMENT (fetch (SKETCHCONTEXT SKETCHTEXTALIGNMENT) of (WINDOWPROP WINDOW + 'SKETCHCONTEXT] + (SETQ NEW.BITMAP (BITMAPCREATE WDTH HGHT)) + (SETQ DSP (DSPCREATE NEW.BITMAP)) + (DSPFONT FONT DSP) + (MOVETO 0 (FONTDESCENT FONT) + DSP) + (PRIN3 TEXT DSP) + [SETQ P1 (GET.BITMAP.POSITION WINDOW NEW.BITMAP 'PAINT PROMPTMSG + (IMINUS (SELECTQ (CAR TEXTALIGNMENT) + (CENTER (LRSH (ADD1 WDTH) + 1)) + (LEFT 0) + (SUB1 WDTH))) + (IMINUS (SELECTQ (CADR TEXTALIGNMENT) + (BASELINE (FONTPROP FONT 'DESCENT)) + (CENTER (LRSH (ADD1 HGHT) + 1)) + (TOP (SUB1 HGHT)) + 0] + + (* scale range goes from 20 to 1.0 Use FONT as an initial.) + + (RETURN (AND P1 (CREATE.TEXT.ELEMENT (CONS TEXT) + (SK.MAP.INPUT.PT.TO.GLOBAL P1 WINDOW) + SCALE TEXTALIGNMENT FONT (fetch (BRUSH BRUSHCOLOR) + of (fetch (SKETCHCONTEXT SKETCHBRUSH) + of (WINDOWPROP WINDOW ' + SKETCHCONTEXT]) (CREATE.TEXT.ELEMENT + [LAMBDA (STRLST GPOSITION SCALE JUSTIFICATION FONT COLOR) (* rrb " 4-Dec-85 20:50") + (* creates a text element for a sketch) + (SK.UPDATE.TEXT.AFTER.CHANGE (create GLOBALPART + INDIVIDUALGLOBALPART _ + (create TEXT + LOCATIONLATLON _ GPOSITION + LISTOFCHARACTERS _ STRLST + INITIALSCALE _ SCALE + TEXTSTYLE _ JUSTIFICATION + FONT _ FONT + TEXTCOLOR _ COLOR]) (SK.UPDATE.TEXT.AFTER.CHANGE + [LAMBDA (GTEXTELT) (* rrb " 4-Dec-85 20:50") + + (* updates the dependent fields in a text element that has had its text field + changed.) + + (TEXT.SET.GLOBAL.REGIONS (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTELT)) + (TEXT.SET.SCALES GTEXTELT) + GTEXTELT]) (SK.TEXT.FROM.TEXTBOX + [LAMBDA (TEXTBOXELT SKW) (* rrb "30-Sep-86 18:34") + + (* returns change event spec with a textbox that replaces GTEXTBOXELT.) + + (PROG ((INDTEXTBOXELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of TEXTBOXELT)) + TEXTSTYLE REGION NEWTEXTELT) + (SETQ TEXTSTYLE (fetch (TEXTBOX TEXTSTYLE) of INDTEXTBOXELT)) + (SETQ REGION (APPLY (FUNCTION SK.UNIONREGIONS) + (fetch (TEXTBOX LISTOFREGIONS) of INDTEXTBOXELT))) + (SETQ NEWTEXTELT (CREATE.TEXT.ELEMENT + (ADD.EOLS (fetch (TEXTBOX LISTOFCHARACTERS) of INDTEXTBOXELT)) + (MAP.GLOBAL.PT.ONTO.GRID [create POSITION + XCOORD _ + (SELECTQ (CAR TEXTSTYLE) + (LEFT (fetch (REGION LEFT) + of REGION)) + (RIGHT (fetch (REGION RIGHT) + of REGION)) + (PLUS (fetch (REGION LEFT) + of REGION) + (QUOTIENT (fetch (REGION WIDTH) + of REGION) + 2))) + YCOORD _ + (SELECTQ (CADR TEXTSTYLE) + (TOP (fetch (REGION TOP) of REGION)) + (BOTTOM (fetch (REGION BOTTOM) + of REGION)) + (PLUS (fetch (REGION BOTTOM) + of REGION) + (QUOTIENT (fetch (REGION HEIGHT + ) + of REGION) + 2] + SKW) + (fetch (TEXTBOX INITIALSCALE) of INDTEXTBOXELT) + (COND + ((EQ (CADR TEXTSTYLE) + 'CENTER) + + (* make center into baseline because it looks better and because it is + converted the other direction.) + + (LIST (CAR TEXTSTYLE) + 'BASELINE)) + (T TEXTSTYLE)) + (fetch (TEXTBOX FONT) of INDTEXTBOXELT) + (fetch (TEXTBOX TEXTCOLOR) of INDTEXTBOXELT))) + (RETURN (create SKHISTORYCHANGESPEC + NEWELT _ NEWTEXTELT + OLDELT _ TEXTBOXELT + PROPERTY _ 'HASBOX + NEWVALUE _ NEWTEXTELT + OLDVALUE _ TEXTBOXELT]) (TEXT.SET.GLOBAL.REGIONS + [LAMBDA (GTEXTELT) (* rrb "29-Jan-85 14:50") + + (* updates the list of regions occupied by the text in the global coordinate + space.) + + (* this is used to determine the extent of a text element in a region.) + + (PROG ((SCALE (fetch (TEXT INITIALSCALE) of GTEXTELT))) + (replace (TEXT LISTOFREGIONS) of GTEXTELT + with (for LREG in [LTEXT.LINE.REGIONS (fetch (TEXT LISTOFCHARACTERS) of GTEXTELT) + (SK.SCALE.POSITION.INTO.VIEWER (fetch (TEXT LOCATIONLATLON) + of GTEXTELT) + SCALE) + (fetch (TEXT FONT) of GTEXTELT) + (fetch (TEXT TEXTSTYLE) of GTEXTELT) + (ITIMES (FONTHEIGHT (fetch (TEXT FONT) of GTEXTELT)) + (LENGTH (fetch (TEXT LISTOFCHARACTERS) of GTEXTELT] + collect (UNSCALE.REGION LREG SCALE))) + (RETURN GTEXTELT]) (TEXT.REGIONFN + [LAMBDA (SCRTEXTELT) (* rrb " 2-Oct-84 16:36") + (* determines the local region covered + by TEXTELT.) + (PROG [REG (LINEREGIONS (fetch (LOCALTEXT LINEREGIONS) of (fetch (SCREENELT LOCALPART) + of SCRTEXTELT] + (RETURN (COND + ((NULL LINEREGIONS) + NIL) + (T (SETQ REG (CAR LINEREGIONS)) + (for LINEREG in (CDR LINEREGIONS) do (SETQ REG (UNIONREGIONS REG LINEREG))) + REG]) (TEXT.GLOBALREGIONFN + [LAMBDA (GTEXTELT) (* rrb "18-Oct-85 16:43") + + (* returns the global region occupied by a global text element.) + + (PROG [REG (LINEREGIONS (fetch (TEXT LISTOFREGIONS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GTEXTELT] + (RETURN (COND + ((NULL LINEREGIONS) + NIL) + (T (SETQ REG (CAR LINEREGIONS)) + (for LINEREG in (CDR LINEREGIONS) do (SETQ REG (UNIONREGIONS REG LINEREG))) + REG]) (TEXT.TRANSLATEFN + [LAMBDA (GTEXT DELTAPOS WINDOW) (* rrb "28-Apr-85 18:45") + (* moves a text figure element to a + new position.) + (PROG ((INDTEXTELT (COPY (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXT))) + NEWGPOS NEWTEXTELT) (* update the region positions.) + (TEXT.UPDATE.GLOBAL.REGIONS (SETQ NEWTEXTELT (create GLOBALPART + COMMONGLOBALPART _ + (APPEND (fetch (GLOBALPART + COMMONGLOBALPART) + of GTEXT)) + INDIVIDUALGLOBALPART _ INDTEXTELT)) + (SETQ NEWGPOS (PTPLUS DELTAPOS (fetch (TEXT LOCATIONLATLON) of INDTEXTELT))) + (fetch (TEXT LOCATIONLATLON) of INDTEXTELT)) + (replace (TEXT LOCATIONLATLON) of INDTEXTELT with NEWGPOS) + (RETURN NEWTEXTELT]) (TEXT.TRANSFORMFN + [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "16-Oct-85 18:30") + + (* returns a copy of the global TEXT element that has had each of its control + points transformed by transformfn. TRANSFORMDATA is arbitrary data that is + passed to tranformfn. SCALEFACTOR is the amount the transformation scales by + and is used to reset the size of the text.) + + (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (RETURN (CREATE.TEXT.ELEMENT (fetch (TEXT LISTOFCHARACTERS) of INDVPART) + (SK.TRANSFORM.POINT (fetch (TEXT LOCATIONLATLON) of INDVPART) + TRANSFORMFN TRANSFORMDATA) + (FTIMES (fetch (TEXT INITIALSCALE) of INDVPART) + SCALEFACTOR) + (fetch (TEXT TEXTSTYLE) of INDVPART) + (fetch (TEXT FONT) of INDVPART) + (fetch (TEXT TEXTCOLOR) of INDVPART]) (TEXT.TRANSLATEPTSFN + [LAMBDA (TEXTELT SELPTS GDELTA WINDOW) (* rrb " 5-May-85 18:05") + (* returns a text element that has its + position translated.) + + (* shouldn't ever happen because a text element only has one control pt and its + translatefn should get used.) + + (fetch (SCREENELT GLOBALPART) of TEXTELT]) (TEXT.UPDATEFN + [LAMBDA (OLDLOCALELT NEWGELT SKETCHW) (* rrb "11-Jul-86 15:51") + + (* update function for text. Tries to repaint only the lines of text that have + changed.) + + (PROG ((NEWTEXTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWGELT)) + (OLDTEXTELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of OLDLOCALELT)) + LOCALTEXT NEWSCREENELT) + (COND + ((AND (EQUAL (fetch (TEXT FONT) of NEWTEXTELT) + (fetch (TEXT FONT) of OLDTEXTELT)) + (EQUAL (fetch (TEXT TEXTSTYLE) of NEWTEXTELT) + (fetch (TEXT TEXTSTYLE) of OLDTEXTELT)) + (EQUAL (fetch (TEXT LOCATIONLATLON) of NEWTEXTELT) + (fetch (TEXT LOCATIONLATLON) of OLDTEXTELT)) + (EQUAL (fetch (TEXT INITIALSCALE) of NEWTEXTELT) + (fetch (TEXT INITIALSCALE) of OLDTEXTELT)) + (EQUAL (LENGTH (fetch (TEXT LISTOFCHARACTERS) of NEWTEXTELT)) + (LENGTH (fetch (TEXT LISTOFCHARACTERS) of OLDTEXTELT))) + (EQUAL (fetch (TEXT TEXTCOLOR) of NEWTEXTELT) + (fetch (TEXT TEXTCOLOR) of OLDTEXTELT))) + + (* if font, style or number of lines has changed, erase and redraw.) + + (SETQ LOCALTEXT (fetch (SCREENELT LOCALPART) of OLDLOCALELT)) + (SETQ NEWSCREENELT (SK.ADD.ITEM NEWGELT SKETCHW)) + (* update the screen display) + [PROG ((NEWSTRS (fetch (LOCALTEXT LOCALLISTOFCHARACTERS) of (fetch (SCREENELT LOCALPART + ) + of NEWSCREENELT))) + (OLDSTRS (fetch (LOCALTEXT LOCALLISTOFCHARACTERS) of LOCALTEXT)) + (NEWLOCALREGIONS (fetch (LOCALTEXT LINEREGIONS) of (fetch (SCREENELT LOCALPART) + of NEWSCREENELT))) + (OLDLOCALREGIONS (fetch (LOCALTEXT LINEREGIONS) of LOCALTEXT))) + (COND + ((NEQ (LENGTH NEWSTRS) + (LENGTH OLDSTRS)) + + (* creating the new element caused the line filling routines to change the + number of lines so the partial redrawing algorithms don't work and we have to + redraw the whole element. Do this by erasing the old one then drawing the new + one.) + + (SK.ERASE.ELT OLDLOCALELT SKETCHW) + (SK.DRAWFIGURE NEWSCREENELT SKETCHW NIL (VIEWER.SCALE SKETCHW)) + (RETURN NEWSCREENELT))) + LP (COND + ((OR NEWSTRS OLDSTRS) (* continue until both new and old are + exhausted.) + [COND + ([NOT (AND (EQUAL (CAR NEWSTRS) + (CAR OLDSTRS)) + (EQUAL (CAR NEWLOCALREGIONS) + (CAR OLDLOCALREGIONS] + (* this line is the different, redraw + it.) + (AND OLDLOCALREGIONS (DSPFILL (CAR OLDLOCALREGIONS) + BLACKSHADE + 'ERASE SKETCHW)) + (AND NEWSTRS (TEXT.DRAWFN1 (LIST (CAR NEWSTRS)) + (LIST (CAR NEWLOCALREGIONS)) + (fetch (LOCALTEXT LOCALFONT) of LOCALTEXT) + (fetch (TEXT TEXTCOLOR) of OLDTEXTELT) + SKETCHW] + (SETQ NEWSTRS (CDR NEWSTRS)) + (SETQ OLDSTRS (CDR OLDSTRS)) + (SETQ NEWLOCALREGIONS (CDR NEWLOCALREGIONS)) + (SETQ OLDLOCALREGIONS (CDR OLDLOCALREGIONS)) + (GO LP] + (RETURN NEWSCREENELT]) (SK.CHANGE.TEXT + [LAMBDA (ELTWITHTEXT HOW SKW) (* ; "Edited 7-Apr-87 13:41 by rrb") + (PROG ((COMMAND (CADR HOW)) + (PROPERTY 'FONT) + NEWVALUE GINDTEXTELT NEWGTEXT OLDVALUE OLDFACE GTYPE) + (OR HOW (RETURN)) (* take down the caret before any + change.) + (SKED.CLEAR.SELECTION SKW) + (COND + ((MEMB (SETQ GTYPE (fetch (GLOBALPART GTYPE) of ELTWITHTEXT)) + '(TEXTBOX TEXT)) + (SETQ GINDTEXTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHTEXT)) + + (* set the old value to the old font. In the case where the thing that changes + is the justification, this will get re-set) + + (SETQ OLDVALUE (fetch (TEXT FONT) of GINDTEXTELT)) + (SETQ NEWGTEXT + (SELECTQ (CAR HOW) + (TEXT (SELECTQ COMMAND + ((SMALLER LARGER) (* change the font) + [COND + [[SETQ NEWVALUE (SK.NEXTSIZEFONT COMMAND + (LIST (FONTPROP OLDVALUE 'FAMILY) + (FONTPROP OLDVALUE 'SIZE] + (* if there is an appropriate size + font, use it.) + [SETQ NEWVALUE (LIST (FONTPROP NEWVALUE 'FAMILY) + (FONTPROP NEWVALUE 'SIZE) + (FONTPROP OLDVALUE 'FACE] + (COND + ((EQ GTYPE 'TEXT) + (create TEXT using GINDTEXTELT FONT _ NEWVALUE)) + (T (create TEXTBOX using GINDTEXTELT FONT _ NEWVALUE] + (T (* otherwise just scale the area some.) + (SETQ NEWVALUE (FTIMES (SETQ OLDVALUE (fetch (TEXT + INITIALSCALE + ) + of GINDTEXTELT)) + (SELECTQ COMMAND + (LARGER 1.4) + 0.7142858))) + (SETQ PROPERTY 'SCALE) + (COND + ((EQ GTYPE 'TEXT) + (create TEXT using GINDTEXTELT INITIALSCALE _ NEWVALUE)) + (T (create TEXTBOX using GINDTEXTELT INITIALSCALE _ + NEWVALUE]) + ((CENTER LEFT RIGHT) (* change the horizontal justification) + [SETQ NEWVALUE (LIST COMMAND (CADR (SETQ OLDVALUE + (fetch (TEXT TEXTSTYLE) + of GINDTEXTELT] + (SETQ PROPERTY 'JUSTIFICATION) + (COND + ((EQ GTYPE 'TEXT) + (create TEXT using GINDTEXTELT TEXTSTYLE _ NEWVALUE)) + (T (create TEXTBOX using GINDTEXTELT TEXTSTYLE _ NEWVALUE)))) + ((TOP BOTTOM MIDDLE BASELINE) (* change the vertical justification) + [SETQ NEWVALUE (LIST (CAR (SETQ OLDVALUE (fetch (TEXT TEXTSTYLE) + of GINDTEXTELT))) + (COND + ((EQ COMMAND 'MIDDLE) + 'CENTER) + (T COMMAND] + (SETQ PROPERTY 'JUSTIFICATION) + (COND + ((EQ GTYPE 'TEXT) + (create TEXT using GINDTEXTELT TEXTSTYLE _ NEWVALUE)) + (T (create TEXTBOX using GINDTEXTELT TEXTSTYLE _ NEWVALUE)))) + ((BOLD UNBOLD ITALIC UNITALIC) (* change the face) + (SETQ OLDFACE (FONTPROP OLDVALUE 'FACE)) + [SETQ NEWVALUE (LIST (FONTPROP OLDVALUE 'FAMILY) + (FONTPROP OLDVALUE 'SIZE) + (LIST (SELECTQ COMMAND + (BOLD 'BOLD) + (UNBOLD 'MEDIUM) + (CAR OLDFACE)) + (SELECTQ COMMAND + (ITALIC 'ITALIC) + (UNITALIC 'REGULAR) + (CADR OLDFACE)) + (CADDR OLDFACE] + (COND + ((EQ GTYPE 'TEXT) + (create TEXT using GINDTEXTELT FONT _ NEWVALUE)) + (T (create TEXTBOX using GINDTEXTELT FONT _ NEWVALUE)))) + (BOX (* if it is a text element, BOX it) + [COND + ((EQ GTYPE 'TEXT) + (RETURN (SK.TEXTBOX.FROM.TEXT ELTWITHTEXT SKW]) + (UNBOX (* if it is a text box, unbox it.) + [COND + ((EQ GTYPE 'TEXTBOX) + (RETURN (SK.TEXT.FROM.TEXTBOX ELTWITHTEXT SKW]) + (LOOKEDSTRING [COND + ((EQ GTYPE 'TEXT) + (RETURN (SK.LOOKEDSTRING.FROM.TEXT ELTWITHTEXT SKW]) + (SHOULDNT))) + (SETSIZE (SETQ NEWVALUE COMMAND) + (COND + [(EQ (FONTPROP NEWVALUE 'FAMILY) + (FONTPROP OLDVALUE 'FAMILY)) + + (* if the families are the same, change them, otherwise don't as it isn't known + whether or not this family has the right size.) + + (COND + [(EQ GTYPE 'TEXT) + (create TEXT using GINDTEXTELT FONT _ (LIST (FONTPROP + OLDVALUE + 'FAMILY) + (FONTPROP + NEWVALUE + 'SIZE) + (FONTPROP + OLDVALUE + 'FACE] + (T (create TEXTBOX using GINDTEXTELT FONT _ + (LIST (FONTPROP OLDVALUE 'FAMILY) + (FONTPROP NEWVALUE 'SIZE) + (FONTPROP OLDVALUE 'FACE] + (T (RETURN)))) + (NEWFONT (* set the font family) + [SETQ NEWVALUE (LIST COMMAND (FONTPROP OLDVALUE 'SIZE) + (FONTPROP OLDVALUE 'FACE] + (COND + ((NULL (FONTCREATE NEWVALUE NIL NIL NIL NIL T)) + (STATUSPRINT SKW " Couldn't find " (CAR NEWVALUE) + " in size " + (CADR NEWVALUE)) + (RETURN))) + (COND + ((EQ GTYPE 'TEXT) + (create TEXT using GINDTEXTELT FONT _ NEWVALUE)) + (T (create TEXTBOX using GINDTEXTELT FONT _ NEWVALUE)))) + (FAMILY&SIZE (* set the font family and size) + [SETQ NEWVALUE (LIST (CAR COMMAND) + (CADR COMMAND) + (FONTPROP (fetch (TEXT FONT) of GINDTEXTELT) + 'FACE] + (COND + ((EQ GTYPE 'TEXT) + (create TEXT using GINDTEXTELT FONT _ NEWVALUE)) + (T (create TEXTBOX using GINDTEXTELT FONT _ NEWVALUE)))) + (SAME + + (* set all of the font characteristics from the first selected one.) + + (* set the variables to cause the right things to go into the change spec + event.) + + (SETQ OLDVALUE ELTWITHTEXT) + (SETQ PROPERTY 'LOOKSAME) + (SETQ NEWVALUE (SK.TEXT.ELT.WITH.SAME.FIELDS (fetch (GLOBALPART + INDIVIDUALGLOBALPART + ) of COMMAND) + GINDTEXTELT))) + (SHOULDNT))) + [SETQ NEWGTEXT (COND + [(EQ GTYPE 'TEXT) + + (* adjust the scales at which this appears because font or scale may have + changed.) + + (TEXT.SET.SCALES (create GLOBALPART + COMMONGLOBALPART _ (fetch (GLOBALPART + COMMONGLOBALPART + ) + of ELTWITHTEXT) + INDIVIDUALGLOBALPART _ ( + TEXT.SET.GLOBAL.REGIONS + NEWGTEXT] + (T + + (* scaling for text boxes depends on the box size which can't change in this + function.) + + (create GLOBALPART + COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) + of ELTWITHTEXT) + INDIVIDUALGLOBALPART _ (TEXTBOX.SET.GLOBAL.REGIONS NEWGTEXT + ] + (RETURN (create SKHISTORYCHANGESPEC + NEWELT _ NEWGTEXT + OLDELT _ ELTWITHTEXT + PROPERTY _ PROPERTY + NEWVALUE _ NEWVALUE + OLDVALUE _ OLDVALUE]) (TEXT.SET.SCALES + [LAMBDA (GTEXTELT) (* rrb "12-May-85 16:29") + + (* sets the min and max scale properties of a global text element. + Called after something about the text changes.) + + (PROG [(COMMONPART (fetch (GLOBALPART COMMONGLOBALPART) of GTEXTELT)) + (ORIGSCALE (fetch (TEXT INITIALSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GTEXTELT] + (replace (COMMONGLOBALPART MINSCALE) of COMMONPART with (QUOTIENT ORIGSCALE 20.0)) + (replace (COMMONGLOBALPART MAXSCALE) of COMMONPART + with (FTIMES (FONTHEIGHT (fetch (TEXT FONT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GTEXTELT))) + ORIGSCALE)) + (RETURN GTEXTELT]) (BREAK.AT.CARRIAGE.RETURNS + [LAMBDA (STRING) (* rrb "16-Oct-85 18:24") + + (* returns a list of strings breaking string at carriage returns.) + + (PROG (STRLST (STR (OR (STRINGP STRING) + (MKSTRING STRING))) + (PREV 0) + (WHERE 0)) + LP (COND + ((SETQ WHERE (STRPOS " +" STR (ADD1 WHERE))) + [SETQ STRLST (NCONC1 STRLST (COND + ((EQ WHERE (ADD1 PREV)) + "") + (T (SUBSTRING STR (ADD1 PREV) + (SUB1 WHERE] + (SETQ PREV WHERE) + (GO LP))) + (RETURN (NCONC1 STRLST (OR (SUBSTRING STR (ADD1 PREV) + -1) + ""]) ) (DEFINEQ (ADD.KNOWN.SKETCH.FONT [LAMBDA (FAMILY WID DEVICE FONT) (* ; "Edited 10-May-93 16:49 by rmk:") (* ; "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] FONT]) (SK.PICK.FONT [LAMBDA (WID STRING DEVICE DISPLAYGFONT) (* ; "Edited 10-May-93 17:11 by rmk:") (* ; "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)) (LET [STARTFONT FONTWIDTH SCALE CACHEDFONT SIZE (FAMILY (FONTPROP DISPLAYGFONT 'FAMILY] (IF [SETQ CACHEDFONT (ASSOC WID (ASSOC DEVICE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES] THEN (CDR CACHEDFONT) ELSE (SETQ STARTFONT (FONTCOPY DISPLAYGFONT 'DEVICE DEVICE)) NIL (SETQ SCALE (FONTPROP STARTFONT 'SCALE)) (SETQ SIZE (FONTPROP STARTFONT 'SIZE)) [SETQ FONTWIDTH (COND (SCALE (* ;; "IF THERE IS A SCALE, YOU MUST SCALE THE WIDTH.") (FIXR (QUOTIENT (STRINGWIDTH STRING STARTFONT) SCALE))) (T (STRINGWIDTH STRING STARTFONT] [SETQ CACHEDFONT (IF (IGREATERP FONTWIDTH WID) THEN (* ;; "Font width was too big, try smaller fonts in decreasing size.") [FOR FONT IN [CDR (FIND F ON [SORT (FONTSAVAILABLE FAMILY '* 'MRR 0 DEVICE T) (FUNCTION (LAMBDA (F1 F2) (IGREATERP (CADR F1) (CADR F2] SUCHTHAT (EQ SIZE (CADR F] WHEN (ILESSP [SETQ FONTWIDTH (COND (SCALE (* ;;  "IF THERE IS A SCALE, YOU MUST SCALE THE WIDTH.") (FIXR (QUOTIENT (STRINGWIDTH STRING FONT) SCALE))) (T (STRINGWIDTH STRING FONT] WID) DO (RETURN (ADD.KNOWN.SKETCH.FONT FAMILY WID DEVICE FONT)) FINALLY (RETURN (ADD.KNOWN.SKETCH.FONT FAMILY WID DEVICE (IF (GREATERP FONTWIDTH (TIMES 1.5 WID)) THEN 'SHADE ELSEIF (OR FONT STARTFONT] ELSEIF (IEQP FONTWIDTH WID) THEN (ADD.KNOWN.SKETCH.FONT FAMILY WID DEVICE STARTFONT) ELSE (* ;; "FONT width was too small, try bigger fonts.") (FOR FONT PREVFONT IN [CDR (FIND F ON [SORT (FONTSAVAILABLE FAMILY '* 'MRR 0 DEVICE T) (FUNCTION (LAMBDA (F1 F2) (ILESSP (CADR F1) (CADR F2] SUCHTHAT (EQ SIZE (CADR F] DO (IF (IGREATERP (COND (SCALE (* ;;  "IF THERE IS A SCALE, YOU MUST SCALE THE WIDTH.") (FIXR (QUOTIENT (STRINGWIDTH STRING FONT ) SCALE))) (T (STRINGWIDTH STRING FONT))) WID) THEN (RETURN (ADD.KNOWN.SKETCH.FONT FAMILY WID DEVICE PREVFONT))) (SETQ PREVFONT FONT) FINALLY (RETURN (ADD.KNOWN.SKETCH.FONT FAMILY WID DEVICE (OR FONT PREVFONT STARTFONT] (IF (FONTP CACHEDFONT) THEN (* ; "Could be SHADE") (FONTCOPY CACHEDFONT 'FACE (FONTPROP DISPLAYGFONT 'FACE)) ELSE CACHEDFONT]) (SK.CHOOSE.TEXT.FONT [LAMBDA (GTEXT SCALE VIEWER) (* ; "Edited 10-May-93 16:18 by rmk:") (* ; "Edited 1-Nov-91 16:56 by jds") (* ;; "returns the font that text in the individual global part of a text or textbox element GTEXT should be displayed in when shown in VIEWER.") (PROG ([VIEWERFONTCACHE (OR (AND (WINDOWP VIEWER) (WINDOWPROP VIEWER 'PICKFONTCACHE)) (AND (STREAMP VIEWER) (STREAMPROP VIEWER 'PICKFONTCACHE] (GFONT (fetch (TEXT FONT) of GTEXT)) LOCALFONT) [COND ((SETQ LOCALFONT (SASSOC GFONT VIEWERFONTCACHE))(* ;  "look in the viewer's font cache.") (RETURN (CDR LOCALFONT] (RETURN (PROG ((CANONICALTESTSTR "AWIaiw") CANONICALWIDTH DEVICE DISPLAYGFONT) [SETQ DEVICE (COND ((STREAMP VIEWER) (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM IMAGEOPS) of VIEWER))) (T 'DISPLAY] [COND ((EQUAL (TIMES SCALE (DSPSCALE NIL VIEWER)) (fetch (TEXT INITIALSCALE) of GTEXT)) (* ;; "special case scales being the same so there is not a large delay when first character is typed and to avoid font look up problems when hardcopying at scale 1") (SETQ LOCALFONT (FONTCREATE GFONT NIL NIL NIL DEVICE))) (T (* ;; "use a canonical string to determine the font size so that all strings of a given font at a given scale look the same. If font is determined by the width of the particular string, two different string will appear in different fonts. In particular, the string may change fonts as the user is typing into it.") (* ;; "don't use the face information when determining string width because in some cases HELVETICA 10, the bold is smaller than the regular.") (SETQ DISPLAYGFONT (FONTCREATE GFONT NIL NIL NIL 'DISPLAY)) [SETQ CANONICALWIDTH (FIXR (QUOTIENT (TIMES [STRINGWIDTH CANONICALTESTSTR (LIST (FONTPROP DISPLAYGFONT 'FAMILY) (FONTPROP DISPLAYGFONT 'SIZE] (fetch (TEXT INITIALSCALE) of GTEXT)) (TIMES SCALE (DSPSCALE NIL VIEWER] (* ; "calculate the local font.") (SETQ LOCALFONT (SK.PICK.FONT CANONICALWIDTH CANONICALTESTSTR DEVICE DISPLAYGFONT] [COND ((WINDOWP VIEWER) (WINDOWPROP VIEWER 'PICKFONTCACHE (CONS (CONS GFONT LOCALFONT) VIEWERFONTCACHE))) ((STREAMP VIEWER) (STREAMPROP VIEWER 'PICKFONTCACHE (CONS (CONS GFONT LOCALFONT) VIEWERFONTCACHE] (RETURN LOCALFONT]) (SK.NEXTSIZEFONT + [LAMBDA (WHICHDIR NOWFONT) (* rrb "14-Jul-86 13:43") + + (* returns the next sized font either SMALLER or LARGER that on of size FONT.) + + (PROG [(NOWSIZE (FONTPROP NOWFONT 'HEIGHT)) + (DECREASEFONTLST (SK.DECREASING.FONT.LIST (CAR NOWFONT) + 'DISPLAY] + (RETURN (COND + [(EQ WHICHDIR 'LARGER) + (COND + ((IGEQ NOWSIZE (FONTPROP (CAR DECREASEFONTLST) + 'HEIGHT)) (* nothing larger) + NIL) + (T (for FONTTAIL on DECREASEFONTLST + when [AND (CDR FONTTAIL) + (IGEQ NOWSIZE (FONTPROP (CADR FONTTAIL) + 'HEIGHT] + do (RETURN (SK.FONTNAMELIST (CAR FONTTAIL] + (T (for FONT in DECREASEFONTLST when (LESSP (FONTPROP FONT 'HEIGHT) + NOWSIZE) + do (RETURN (SK.FONTNAMELIST FONT]) (SK.DECREASING.FONT.LIST + [LAMBDA (FAMILY DEVICETYPE) (* ; + "Edited 12-Oct-92 12:39 by sybalsky:mv:envos") + + (* ;; "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.ALIST)) + 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]) (SK.GUESS.FONTSAVAILABLE + [LAMBDA (FAMILY HDCPYTYPE) (* rrb " 9-Oct-85 16:10") + + (* returns a list of all fonts of a FAMILY in decreasing order.) + + (PROG (FILEFONTS CACHE DISPLAYFONTSIZES) + (SETQ HDCPYTYPE (COND + ((NULL HDCPYTYPE) + (PRINTERTYPE)) + ((NLISTP HDCPYTYPE) + HDCPYTYPE) + (T HDCPYTYPE))) (* cache the file fonts.) + [COND + [[SETQ FILEFONTS (ASSOC HDCPYTYPE (CDR (ASSOC FAMILY \FONTSONFILE] + + (* note if a cache has been calculated. Use it even if it is NIL) + + (* \FONTSONFILE seems to group things such as CLASSICTHIN under CLASSIC so make + sure to remove anything that has the wrong family.) + + (SETQ FILEFONTS (SUBSET (CDR FILEFONTS) + (FUNCTION (LAMBDA (X) + (EQ (CAR X) + FAMILY] + (T (RESETFORM (CURSOR WAITINGCURSOR) + (SETQ FILEFONTS (FONTSAVAILABLE FAMILY '* '(MEDIUM REGULAR REGULAR) NIL + HDCPYTYPE T)) + + (* Since there is no way to determine the real sizes for PRESS fonts with size + of 0 {meaning the widths scale}, guess that they are available in 10) + + [COND + [(EQ HDCPYTYPE 'PRESS) + + (* make sure to look for anything that has a display font.) + + (SETQ DISPLAYFONTSIZES (for FONT + in (FONTSAVAILABLE FAMILY '* + '(MEDIUM REGULAR REGULAR) NIL + 'DISPLAY) collect (CADR FONT))) + (SETQ FILEFONTS + (for FONT in FILEFONTS + join (COND + [(EQ (CADR FONT) + 0) + (for SIZE + in (UNION DISPLAYFONTSIZES + '(36 30 24 18 14 12 10 8 6)) + when (FONTCREATE (CAR FONT) + SIZE NIL NIL 'DISPLAY T) + collect (CONS (CAR FONT) + (CONS SIZE (CDDR FONT] + (T (CONS FONT] + ((EQ HDCPYTYPE 'DISPLAY) + + (* patch around the bug in FONTSAVAILABLE. + Remove after J release.) + + (SETQ FILEFONTS (SUBSET FILEFONTS (FUNCTION (LAMBDA (FONT) + (EQUAL (CADDR FONT) + '(MEDIUM REGULAR + REGULAR] + (* remove duplicates and sort) + [SETQ FILEFONTS (SORT (INTERSECTION FILEFONTS FILEFONTS) + (FUNCTION (LAMBDA (A B) + (GREATERP (CADR A) + (CADR B] + (COND + ((NULL (SETQ CACHE (ASSOC FAMILY \FONTSONFILE))) + (SETQ \FONTSONFILE (CONS (LIST FAMILY (CONS HDCPYTYPE FILEFONTS)) + \FONTSONFILE))) + (T (NCONC1 CACHE (CONS HDCPYTYPE FILEFONTS] + + (* reget the fonts in core since they may have changed since last time.) + + (RETURN (SORT (UNION (FONTSAVAILABLE FAMILY '* NIL NIL HDCPYTYPE) + FILEFONTS) + (FUNCTION (LAMBDA (A B) + (COND + ((EQ (CADR A) + (CADR B)) + + (* in case both TIMESROMAN and TIMESROMAND for example make it in.) + + (ALPHORDER (CADR A) + (CADR B))) + (T (GREATERP (CADR A) + (CADR B]) ) (RPAQ? \KNOWN.SKETCH.FONTSIZES ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \KNOWN.SKETCH.FONTSIZES) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (TYPERECORD TEXT (LOCATIONLATLON LISTOFCHARACTERS INITIALSCALE TEXTSTYLE FONT LISTOFREGIONS TEXTCOLOR)) (RECORD LOCALTEXT ((DISPLAYPOSITION) LOCALHOTREGION LINEREGIONS LOCALFONT LOCALLISTOFCHARACTERS)) ) ) (DEFINEQ (SK.SET.FONT + [LAMBDA (W NEWFONT) (* rrb " 2-Oct-85 14:55") + + (* sets the entire default font. Used when a sketch stream is created. + or any of the defaults are changed. NEWFONT is a list of + (FAMILY SIZE FACE)) + + (COND + (NEWFONT (COND + ((FONTCREATE NEWFONT NIL NIL NIL NIL T) + + (* clear the cache of looked up fonts. This provides the user a way of clearing + the cache that shouldn't happen too much and is documented.) + + (AND (FASSOC (CAR NEWFONT) + \FONTSONFILE) + (SETQ \FONTSONFILE (for BUCKET in \FONTSONFILE + when (NEQ (CAR BUCKET) + (CAR NEWFONT)) collect BUCKET))) + (replace (SKETCHCONTEXT SKETCHFONT) of (WINDOWPROP W 'SKETCHCONTEXT) with NEWFONT + )) + (T (STATUSPRINT W (CAR NEWFONT) + " " + (CADR NEWFONT) + " " + (SELECTQ (CAR (CADDR NEWFONT)) + (BOLD 'BOLD) + "") + (SELECTQ (CADR (CADDR NEWFONT)) + (ITALIC 'ITALIC) + "") + " not found"]) (SK.SET.TEXT.FONT + [LAMBDA (W) (* rrb " 4-Oct-85 16:21") + (* sets the size of the default + arrowhead.) + (PROG [NEWFONT NOWFONT (SKCONTEXT (WINDOWPROP W 'SKETCHCONTEXT] + (SETQ NEWFONT (SK.READFONTFAMILY W (PACK* "now: " (CAR (SETQ NOWFONT (fetch (SKETCHCONTEXT + SKETCHFONT) + of SKCONTEXT))) + " " + (CADR NOWFONT) + ". New?"))) + (COND + (NEWFONT (SK.SET.FONT W (LIST NEWFONT (CADR NOWFONT) + (CADDR NOWFONT]) (SK.SET.TEXT.SIZE + [LAMBDA (W) (* rrb " 2-Oct-85 14:36") + (* sets the size of the default font.) + (PROG (NEWSIZE (SKCONTEXT (WINDOWPROP W 'SKETCHCONTEXT)) + NOWFONT) + (SETQ NOWFONT (fetch (SKETCHCONTEXT SKETCHFONT) of SKCONTEXT)) + (SETQ NEWSIZE (SK.READFONTSIZE NIL (FONTPROP NOWFONT 'FAMILY) + W)) + (COND + (NEWSIZE (SK.SET.FONT W (LIST (CAR NOWFONT) + NEWSIZE + (CADDR NOWFONT]) (SK.SET.TEXT.HORIZ.ALIGN + [LAMBDA (SKW NEWALIGN) (* rrb " 6-Nov-85 09:51") + + (* * reads a new value for the horizontal justification) + + (PROG ([NEWJUST (COND + ((MEMB NEWALIGN '(CENTER LEFT RIGHT)) + NEWALIGN) + (T (\CURSOR.IN.MIDDLE.MENU (create MENU + ITEMS _ '((" Center " 'CENTER + "New text will be centered around its position" + ) + ("Left " 'LEFT + "the left edge of the text will be at its position." + ) + (" Right" 'RIGHT + "the right edge of the text will be at its position." + ] + SKCONTEXT) + (RETURN (AND NEWJUST (replace (SKETCHCONTEXT SKETCHTEXTALIGNMENT) + of (SETQ SKCONTEXT (WINDOWPROP SKW 'SKETCHCONTEXT)) + with (CONS NEWJUST (CDR (fetch (SKETCHCONTEXT SKETCHTEXTALIGNMENT) + of SKCONTEXT]) (SK.READFONTSIZE + [LAMBDA (TITLE FONTFAMILY SKW) (* rrb " 6-Nov-85 09:51") + + (* * gets a legal known font size from the user.) + + (* this should have MENUROWS _ 1 when title height bug in menu package gets + fixed.) + + (PROG ((FONTSIZES (SK.COLLECT.FONT.SIZES FONTFAMILY)) + NEWSIZE) + (COND + ((NULL FONTSIZES) + (GO MORE))) + (SETQ NEWSIZE (\CURSOR.IN.MIDDLE.MENU (create MENU + TITLE _ (COND + (TITLE) + (FONTFAMILY (CONCAT "new " + FONTFAMILY + " size?")) + (T "New font size?")) + ITEMS _ (CONS '(More 'MORE + "will look on font directories to find more sizes." + ) FONTSIZES) + CENTERFLG _ T))) + (COND + ((NEQ NEWSIZE 'MORE) + (RETURN NEWSIZE))) + MORE + (* do longer search of files) + (SETQ NEWSIZE (SK.COLLECT.FONT.SIZES FONTFAMILY T)) + (COND + ((NULL NEWSIZE) (* could not find any fonts of that + family) + (RETURN NIL)) + ((EQUAL NEWSIZE FONTSIZES) (* not new ones found) + (STATUSPRINT SKW " +No more font sizes found."))) + (RETURN (MENU (create MENU + TITLE _ (OR TITLE "New font size?") + ITEMS _ NEWSIZE + CENTERFLG _ T]) (SK.COLLECT.FONT.SIZES + [LAMBDA (FAMILY FILESTOOFLG) (* rrb " 2-Oct-85 10:43") + + (* collects all of the sizes that are known. + If FAMILY is given, gets just those sizes.) + + (PROG (INCORESIZES FILESIZES) + [COND + [FAMILY (for TYPEBUCKET in (CDR (FASSOC FAMILY \FONTSONFILE)) + do (for FFONT in (CDR TYPEBUCKET) do (OR (MEMB (CADR FFONT) + INCORESIZES) + (SETQ INCORESIZES + (CONS (CADR FFONT) + INCORESIZES] + (T (* look at all fonts) + (for FAMILYBUCKET in \FONTSONFILE + do (for TYPEBUCKET in (CDR FAMILYBUCKET) + do (for FFONT in (CDR TYPEBUCKET) do (OR (MEMB (CADR FFONT) + INCORESIZES) + (SETQ INCORESIZES + (CONS (CADR FFONT) + INCORESIZES] + (RETURN (SORT (UNION INCORESIZES + (COND + [FILESTOOFLG + + (* wants those on files too, Flip the cursor to note wait.) + + (RESETFORM (CURSOR WAITINGCURSOR) + (bind SIZES for FONT + in (FONTSAVAILABLE (OR FAMILY '*) + '* NIL NIL 'DISPLAY T) + do (OR (MEMB (FONTPROP FONT 'SIZE) + SIZES) + (SETQ SIZES (CONS (FONTPROP FONT 'SIZE) + SIZES))) + finally (RETURN SIZES] + (T (bind SIZES for FONT in (FONTSAVAILABLE (OR FAMILY '*) + '* NIL NIL 'DISPLAY FILESTOOFLG) + do (OR (MEMB (FONTPROP FONT 'SIZE) + SIZES) + (SETQ SIZES (CONS (FONTPROP FONT 'SIZE) + SIZES))) finally (RETURN SIZES]) (SK.SET.TEXT.VERT.ALIGN + [LAMBDA (SKW NEWALIGN) (* rrb " 6-Nov-85 09:52") + + (* * reads a new value for the vertical justification) + + (PROG ([NEWJUST (COND + ((MEMB NEWALIGN '(TOP CENTER BASELINE BOTTOM)) + NEWALIGN) + (T (\CURSOR.IN.MIDDLE.MENU (create MENU + TITLE _ "New vertical alignment?" + ITEMS _ '(("Top" 'TOP + "the top of new text's vertical extent will be at its position" + ) + ("Center" 'CENTER + "New text's vertical extent will be centered around its position" + ) + ("Baseline" 'BASELINE + "The baseline of new text will be at its position." + ) + ("Bottom" 'BOTTOM + "the bottom of new text's vertical extent will be at its position" + )) + CENTERFLG _ T] + SKCONTEXT) + (RETURN (AND NEWJUST (replace (SKETCHCONTEXT SKETCHTEXTALIGNMENT) + of (SETQ SKCONTEXT (WINDOWPROP SKW 'SKETCHCONTEXT)) + with (LIST (CAR (fetch (SKETCHCONTEXT SKETCHTEXTALIGNMENT) + of SKCONTEXT)) + NEWJUST]) (SK.SET.TEXT.LOOKS + [LAMBDA (W) (* rrb " 6-Nov-85 09:52") + + (* * reads a new value for the looks of default text) + + (SK.SET.DEFAULT.TEXT.FACE (\CURSOR.IN.MIDDLE.MENU (create MENU + ITEMS _ + '((regular '(MEDIUM REGULAR REGULAR) + "new text will be neither bold nor italic." + ) + (bold '(BOLD REGULAR REGULAR) + "new text will be bold.") + (italic '(MEDIUM ITALIC REGULAR) + "new text will be italic.") + (bold/italic '(BOLD ITALIC REGULAR) + "new text will be bold and italic." + )) + TITLE _ "New default look" + CENTERFLG _ T)) + W]) (SK.SET.DEFAULT.TEXT.FACE + [LAMBDA (NEWDEFAULTFACE SKW) (* rrb " 4-Oct-85 16:24") + (* changes the default text face to + NEWDEFAULTFACE.) + (PROG [(NOWFONT (fetch (SKETCHCONTEXT SKETCHFONT) of (WINDOWPROP SKW 'SKETCHCONTEXT] + (RETURN (AND NEWDEFAULTFACE (SK.SET.FONT SKW (LIST (CAR NOWFONT) + (CADR NOWFONT) + NEWDEFAULTFACE]) ) (DEFINEQ (CREATE.SKETCH.TERMTABLE + [LAMBDA NIL (* rrb " 2-Oct-85 10:40") + + (* returns a terminal table that has most characters printing as REAL) + + (* it is used by TEXT.DRAWFN1 to print strings in sketch.) + + (PROG ((TTBL (COPYTERMTABLE NIL))) + (for I from 128 to 255 do (AND (EQ (ECHOCHAR I NIL TTBL) + 'INDICATE) + (ECHOCHAR I 'REAL TTBL))) + (RETURN TTBL]) ) (DEFINEQ (SK.FONT.LIST + [LAMBDA (FONTDESCRIPTOR) (* rrb " 2-Oct-85 14:41") + + (* returns the font family, and size of a font descriptor) + + (LIST (FONTPROP FONTDESCRIPTOR 'FAMILY) + (FONTPROP FONTDESCRIPTOR 'SIZE) + (FONTPROP FONTDESCRIPTOR 'FACE]) (SK.INSURE.FONT + [LAMBDA (FONT) (* rrb "16-Oct-85 17:46") + + (* checks the validity of a font argument for a sketch element.) + + (COND + [(NULL FONT) + (SK.FONT.LIST (OR (AND SK.DEFAULT.FONT (FONTCREATE SK.DEFAULT.FONT)) + (DEFAULTFONT 'DISPLAY] + ((FONTP FONT) + (SK.FONT.LIST FONT)) + ((FONTCREATE FONT) + (SK.FONT.LIST (FONTCREATE FONT))) + (T (\ILLEGAL.ARG FONT]) (SK.INSURE.STYLE + [LAMBDA (STYLE DEFAULT) (* rrb "16-Oct-85 17:51") + + (* checks the validity of a STYLE argument for a sketch element) + + (COND + ((NULL STYLE) + DEFAULT) + ((AND (LISTP STYLE) + (MEMB (CAR STYLE) + SK.HORIZONTAL.STYLES) + (MEMB (CAR (LISTP (CDR STYLE))) + SK.VERTICAL.STYLES) + (NULL (CDDR STYLE))) + STYLE) + (T (\ILLEGAL.ARG STYLE]) (SK.INSURE.TEXT + [LAMBDA (TEXTTHING) (* rrb " 4-Nov-85 18:53") + + (* puts something in the form necessary for a text list of characters.) + + (COND + ((NLISTP TEXTTHING) + (BREAK.AT.CARRIAGE.RETURNS TEXTTHING)) + (T (for X in TEXTTHING join (BREAK.AT.CARRIAGE.RETURNS X]) ) (RPAQQ INDICATE.TEXT.SHADE 23130) (RPAQ? SK.DEFAULT.FONT ) (RPAQ? SK.DEFAULT.TEXT.ALIGNMENT '(CENTER BASELINE)) (RPAQ? \FONTSONFILE NIL) (ADDTOVAR SK.HORIZONTAL.STYLES LEFT RIGHT CENTER) (ADDTOVAR SK.VERTICAL.STYLES TOP CENTER BASELINE BOTTOM) (RPAQ SKETCH.TERMTABLE (CREATE.SKETCH.TERMTABLE)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SKETCH.TERMTABLE SK.DEFAULT.TEXT.ALIGNMENT INDICATE.TEXT.SHADE \FONTSONFILE SK.HORIZONTAL.STYLES SK.VERTICAL.STYLES) ) (* ; "stuff for supporting the TEXTBOX sketch element.") (DEFINEQ (SKETCH.CREATE.TEXTBOX + [LAMBDA (STRING REGION FONT JUSTIFICATION BOXBRUSH BOXDASHING FILLING TEXTCOLOR SCALE) + (* rrb " 6-Aug-86 17:06") + (* creates a sketch box element.) + (PROG ((XBRUSH (SK.INSURE.BRUSH BOXBRUSH)) + [XTEXT (COND + ((NLISTP STRING) + (BREAK.AT.CARRIAGE.RETURNS STRING)) + (T (for X in STRING join (BREAK.AT.CARRIAGE.RETURNS X] + (XFONT (SK.INSURE.FONT FONT)) + (XJUSTIFICATION (SK.INSURE.STYLE JUSTIFICATION SK.DEFAULT.TEXTBOX.ALIGNMENT)) + XREGION) + + (* calculate the region the textbox is to have. + This is complicated in the case where REGION is a position because all of the + other parameters must be know to calculate the region.) + + [SETQ XREGION (COND + ((REGIONP REGION)) + ((POSITIONP REGION) + (SK.COMPUTE.TEXTBOX.REGION.FOR.STRING REGION XTEXT XFONT XBRUSH + XJUSTIFICATION)) + (T (\ILLEGAL.ARG REGION] + (RETURN (SK.TEXTBOX.CREATE1 XREGION XBRUSH XTEXT (OR (NUMBERP SCALE) + 1.0) + XJUSTIFICATION XFONT (SK.INSURE.DASHING BOXDASHING) + (SK.INSURE.FILLING FILLING) + (SK.INSURE.COLOR TEXTCOLOR]) (SK.COMPUTE.TEXTBOX.REGION.FOR.STRING + [LAMBDA (POSITION STRLST FONT BRUSH JUSTIFICATION) (* rrb "30-Jul-86 14:30") + + (* returns the region of the box around STRLST whose control point is POSITION.) + + (PROG ((TEXTWIDTH (bind NOWWIDTH (WIDTH _ 0) for STR in STRLST + do (COND + ((GREATERP (SETQ NOWWIDTH (STRINGWIDTH STR FONT)) + WIDTH) + (SETQ WIDTH NOWWIDTH))) finally (RETURN WIDTH))) + (TEXTHEIGHT (TIMES (LENGTH STRLST) + (FONTHEIGHT FONT))) + (MARGIN (SK.BRUSH.SIZE BRUSH))) + + (* leave two extra points for the width because it looks better.) + + (SETQ TEXTWIDTH (PLUS MARGIN MARGIN TEXTWIDTH 2)) + (SETQ TEXTHEIGHT (PLUS MARGIN MARGIN TEXTHEIGHT)) + (RETURN (CREATEREGION (DIFFERENCE (fetch (POSITION XCOORD) of POSITION) + (SELECTQ (CAR JUSTIFICATION) + (LEFT 0) + (RIGHT TEXTWIDTH) + (CENTER (QUOTIENT TEXTWIDTH 2.0)) + (SHOULDNT))) + (DIFFERENCE (fetch (POSITION YCOORD) of POSITION) + (SELECTQ (CADR JUSTIFICATION) + (BASELINE (PLUS (QUOTIENT (DIFFERENCE TEXTHEIGHT (FONTHEIGHT + FONT)) + 2.0) + (FONTPROP FONT 'DESCENT))) + (TOP TEXTHEIGHT) + (BOTTOM 0) + (CENTER (QUOTIENT TEXTHEIGHT 2.0)) + (SHOULDNT))) + TEXTWIDTH TEXTHEIGHT]) (SK.BREAK.INTO.LINES + [LAMBDA (STRLST FONT WIDTH) (* rrb "14-Jun-85 18:04") + + (* returns a list of lines {as strings} of the text stored on STRLST broken so + that as many words as possible fit on a line WIDTH wide.) + + (COND + [(OR (FONTP FONT) + (WINDOWP FONT)) + (PROG ((SPACEWIDTH (CHARWIDTH (CHARCODE % ) + FONT)) + (REMAINING WIDTH) + THISLINE NEWLST PREVCHARCR) + (for STR in STRLST + do (PROG ((BEGPTR 1) + (CHPTR 1) + (CHARSWID 0) + (LIMITPTR (ADD1 (NCHARS STR))) + CHCODE ENDPTR) + CHLP + (COND + ((EQ CHPTR LIMITPTR) (* ran out of characters.) + (COND + ((EQ LIMITPTR 1) (* empty line, ignore it.) + (RETURN)) + [(ILEQ CHARSWID REMAINING) (* this whole thing fits.) + (SETQ THISLINE (CONS [COND + ((EQ BEGPTR 1) + (* save substring call.) + STR) + (T (* put substring in.) + (SUBSTRING STR BEGPTR (SUB1 CHPTR] + (COND + (THISLINE + (* put a space in) + (CONS " " THISLINE] + (ENDPTR + + (* found a word or words that will fit, put them on this line and finish this + line.) + + (SETQ NEWLST (CONS [CONS (COND + ((EQ ENDPTR 0) + (* line began with a space and only it + fit) + " ") + (T (SUBSTRING STR BEGPTR ENDPTR)) + ) + (COND + (THISLINE + (* put a space in) + (CONS " " THISLINE] + NEWLST)) + (SETQ THISLINE (CONS (OR (SUBSTRING STR (PLUS ENDPTR 2) + (SUB1 CHPTR)) + ""))) + (SETQ REMAINING WIDTH)) + (T + + (* the remainder of this string goes on the next line.) + + (AND THISLINE (SETQ NEWLST (CONS THISLINE NEWLST))) + [SETQ THISLINE (CONS (COND + ((EQ BEGPTR 1) + (* save substring call.) + STR) + (T + (* put substring in.) + (SUBSTRING STR BEGPTR (SUB1 CHPTR] + (SETQ REMAINING WIDTH))) (* decrement space remaining.) + (SETQ REMAINING (IDIFFERENCE REMAINING (IPLUS CHARSWID SPACEWIDTH))) + (RETURN) + + (* put the part of this line that didn't fit on the next line.) + + ) + ((EQ (CHARCODE % ) + (SETQ CHCODE (NTHCHARCODE STR CHPTR))) + (* got to a space) + [COND + ((ILEQ CHARSWID REMAINING) (* mark the end of something that we + know fits.) + (* decrement space remaining.) + (SETQ REMAINING (DIFFERENCE REMAINING CHARSWID))) + (ENDPTR + + (* found a word or words that will fit, put them on this line and finish this + line.) + + (SETQ NEWLST (CONS [CONS (OR (SUBSTRING STR BEGPTR ENDPTR) + "") + (COND + (THISLINE + (* put a space in) + (CONS " " THISLINE] + NEWLST)) + (* reset the pointers to note this + beginning.) + (SETQ THISLINE NIL) + + (* ENDPTR is always just before a space, put the beginning at the character + following the space.) + + (SETQ BEGPTR (PLUS ENDPTR 2)) + (SETQ REMAINING (DIFFERENCE WIDTH CHARSWID))) + (T + + (* the rest of the current string goes on the next line.) + + (COND + (THISLINE (SETQ NEWLST (CONS THISLINE NEWLST)) + (SETQ THISLINE NIL))) + (SETQ REMAINING (DIFFERENCE WIDTH CHARSWID] + (SETQ ENDPTR (SUB1 CHPTR)) + (SETQ CHARSWID 0)) + ((EQ CHCODE (CHARCODE EOL)) (* CR, end a line.) + [COND + ((GREATERP CHARSWID REMAINING) + + (* the last word before the CR doesn't fit on this line.) + + (COND + (ENDPTR (* put some of it on the previous line) + (SETQ NEWLST (CONS [CONS (OR (SUBSTRING STR BEGPTR ENDPTR + ) + "") + (COND + (THISLINE + (* put a space in) + (CONS " " THISLINE] + NEWLST)) + (SETQ THISLINE NIL) + (SETQ BEGPTR (PLUS ENDPTR 2))) + (T + + (* end the previous line and put this stuff on a new one.) + + (COND + (THISLINE (SETQ NEWLST (CONS THISLINE NEWLST)) + (SETQ THISLINE NIL] + [SETQ THISLINE (CONS (COND + ((AND (EQ (ADD1 CHPTR) + LIMITPTR) + (EQ BEGPTR 1)) + (* last character of str, save + substring call. for efficiency) + STR) + (T (* put substring in.) + (SUBSTRING STR BEGPTR CHPTR))) + (COND + (THISLINE + (* put a space in) + (CONS " " THISLINE] + (SETQ NEWLST (CONS THISLINE NEWLST)) + (SETQ THISLINE NIL) + (SETQ CHARSWID 0) + (SETQ REMAINING WIDTH) + (COND + ((EQ (ADD1 CHPTR) + LIMITPTR) + (SETQ PREVCHARCR T) + (RETURN)) + (T (SETQ BEGPTR (ADD1 CHPTR)) + (SETQ ENDPTR))) + (SETQ CHPTR (ADD1 CHPTR)) + (GO CHLP))) + (SETQ CHARSWID (PLUS CHARSWID (CHARWIDTH CHCODE FONT))) + (SETQ CHPTR (ADD1 CHPTR)) + (SETQ PREVCHARCR NIL) + (GO CHLP))) + (RETURN (for LINE in [REVERSE (COND + (THISLINE (CONS THISLINE NEWLST)) + (NEWLST (COND + (PREVCHARCR + + (* if end of last line was a CR, put an empty line in so cursor shows there.) + + (CONS "" NEWLST)) + (T NEWLST))) + (T (LIST ""] + collect (APPLY (FUNCTION CONCAT) + (REVERSE LINE] + (T (* if there isn't any font, it is probably SHADE. + Just leave the strings alone) + STRLST]) (SK.BRUSH.SIZE + [LAMBDA (SKBRUSH) (* rrb "30-Dec-84 13:38") + + (* returns the size of a brush. This is used in places where the brush can be + either an instance of the record BRUSH or a thickness.) + + (COND + ((NUMBERP SKBRUSH)) + (T (fetch (BRUSH BRUSHSIZE) of SKBRUSH]) (SK.TEXTBOX.CREATE + [LAMBDA (SKETCHREGION BRUSH SCALE WINDOW) (* rrb "16-Oct-85 17:59") + + (* * creates a sketch element from a region) + + (PROG [(CONTEXT (WINDOWPROP WINDOW 'SKETCHCONTEXT] + (RETURN (SK.TEXTBOX.CREATE1 SKETCHREGION BRUSH (LIST "") + SCALE + (fetch (SKETCHCONTEXT SKETCHTEXTBOXALIGNMENT) of CONTEXT) + (fetch (SKETCHCONTEXT SKETCHFONT) of CONTEXT) + (fetch (SKETCHCONTEXT SKETCHDASHING) of CONTEXT) + (fetch (SKETCHCONTEXT SKETCHFILLING) of CONTEXT) + (fetch (BRUSH BRUSHCOLOR) of (fetch (SKETCHCONTEXT SKETCHBRUSH) of CONTEXT]) (SK.TEXTBOX.CREATE1 + [LAMBDA (SKETCHREGION BRUSH LSTOFSTRS INITSCALE STYLE INITFONT DASHING FILLING TEXTCOLOR) + (* rrb " 4-Dec-85 20:45") + (SK.UPDATE.TEXTBOX.AFTER.CHANGE (create GLOBALPART + INDIVIDUALGLOBALPART _ + (create TEXTBOX + TEXTBOXREGION _ SKETCHREGION + LISTOFCHARACTERS _ LSTOFSTRS + INITIALSCALE _ INITSCALE + TEXTSTYLE _ STYLE + FONT _ INITFONT + TEXTCOLOR _ TEXTCOLOR + TEXTBOXBRUSH _ BRUSH + TEXTBOXDASHING _ DASHING + TEXTBOXFILLING _ FILLING]) (SK.UPDATE.TEXTBOX.AFTER.CHANGE + [LAMBDA (GTEXTBOXELT) (* rrb " 4-Dec-85 21:51") + + (* updates the dependent fields in a textbox element that has had its text + field changed.) + + (PROG ((INDELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTBOXELT))) + (TEXTBOX.SET.GLOBAL.REGIONS INDELT) + (BOX.SET.SCALES (fetch (TEXTBOX TEXTBOXREGION) of INDELT) + GTEXTBOXELT) + (RETURN GTEXTBOXELT]) (SK.TEXTBOX.POSITION.IN.BOX + [LAMBDA (REGION STYLE FONT BRUSHWIDTH) (* rrb "31-Jul-86 15:43") + + (* returns the position that the text should be put at to have it look right + within box REGION, sytle STYLE in font FONT) + + (create POSITION + XCOORD _ (SELECTQ (CAR STYLE) + (LEFT (PLUS (fetch (REGION LEFT) of REGION) + BRUSHWIDTH)) + (RIGHT (DIFFERENCE (fetch (REGION RIGHT) of REGION) + BRUSHWIDTH)) + (CENTER (PLUS (fetch (REGION LEFT) of REGION) + (QUOTIENT (fetch (REGION WIDTH) of REGION) + 2.0))) + (SHOULDNT)) + YCOORD _ (SELECTQ (CADR STYLE) + (TOP (DIFFERENCE (fetch (REGION TOP) of REGION) + BRUSHWIDTH)) + (BOTTOM (PLUS (fetch (REGION BOTTOM) of REGION) + BRUSHWIDTH)) + (CENTER (PLUS (fetch (REGION BOTTOM) of REGION) + (QUOTIENT (fetch (REGION HEIGHT) of REGION) + 2.0))) + (BASELINE [PLUS (fetch (REGION BOTTOM) of REGION) + (PLUS (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) + of REGION) + (FONTPROP FONT 'HEIGHT)) + 2.0) + (FONTPROP FONT 'DESCENT]) + (SHOULDNT]) (TEXTBOX.CHANGEFN + [LAMBDA (SCRNELTS SKW HOW) (* rrb " 6-Jan-85 19:03") + (* the users has selected SCRNELT to + be changed) + (SELECTQ (CAR HOW) + (TEXT (TEXT.CHANGEFN SCRNELTS SKW HOW)) + (SIZE (CHANGE.ELTS.BRUSH.SIZE (CADR HOW) + SCRNELTS SKW)) + NIL]) (TEXTBOX.DRAWFN + [LAMBDA (TEXTBOXELT WINDOW WINREG OPERATION) (* rrb " 3-Mar-86 21:38") + (* draws a text box element.) + (PROG ((LOCALPART (fetch (SCREENELT LOCALPART) of TEXTBOXELT)) + FILLING BRUSH ELTOPERATION) + (OR (NULL WINREG) + (REGIONSINTERSECTP WINREG (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION) of LOCALPART)) + (RETURN)) + (SETQ BRUSH (fetch (LOCALTEXTBOX LOCALTEXTBOXBRUSH) of LOCALPART)) + (SETQ FILLING (fetch (LOCALTEXTBOX LOCALTEXTBOXFILLING) of LOCALPART)) + (SETQ ELTOPERATION (fetch (SKFILLING FILLING.OPERATION) of FILLING)) + (* just put texture where there won't + be any text.) + (SK.TEXTURE.AROUND.REGIONS (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION) of LOCALPART) + (fetch (LOCALTEXTBOX LINEREGIONS) of LOCALPART) + (fetch (SKFILLING FILLING.TEXTURE) of FILLING) + WINDOW + (fetch (SKFILLING FILLING.COLOR) of FILLING) + ELTOPERATION + (fetch (BRUSH BRUSHSIZE) of BRUSH)) + (BOX.DRAWFN1 (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION) of LOCALPART) + (fetch (BRUSH BRUSHSIZE) of BRUSH) + WINDOW WINREG ELTOPERATION (fetch (LOCALTEXTBOX LOCALTEXTBOXDASHING) of LOCALPART) + NIL + (fetch (BRUSH BRUSHCOLOR) of BRUSH)) + (TEXT.DRAWFN1 (fetch (LOCALTEXTBOX LOCALLISTOFCHARACTERS) of LOCALPART) + (fetch (LOCALTEXTBOX LINEREGIONS) of LOCALPART) + (fetch (LOCALTEXTBOX LOCALFONT) of LOCALPART) + (fetch (BRUSH BRUSHCOLOR) of BRUSH) + WINDOW ELTOPERATION]) (SK.TEXTURE.AROUND.REGIONS + [LAMBDA (BOXREGION INREGIONS TEXTURE STREAM COLOR OPERATION BRUSHSIZE) + (* ; "Edited 29-Sep-92 23:18 by jds") + + (* ;; "puts texture inside of a box but not in a collection of interior regions. Assumes INREGIONS are in order from top to bottom and abut in the Y direction.") + + (* ;; " JDS 9/29/92 -- CHANGED TO AVOID DOING THIS WHEN TEXTURE IS NIL, THE MOST COMMON CASE IN TEXTBOXES. This speeds up PostScript printing something fierce.") + + (AND TEXTURE (PROG (BOXLEFT BOXRIGHT BOXTOP BOXBOTTOM X Y (MARGIN (TIMES 2 (DSPSCALE NIL STREAM)) + ) + (USEOP (SK.TRANSLATE.MODE OPERATION STREAM))) + [SETQ BOXLEFT (PLUS (fetch (REGION LEFT) of BOXREGION) + (ADD1 (IQUOTIENT BRUSHSIZE 2] + [SETQ BOXBOTTOM (PLUS (fetch (REGION BOTTOM) of BOXREGION) + (ADD1 (IQUOTIENT BRUSHSIZE 2] + (SETQ BOXTOP (DIFFERENCE (fetch (REGION TOP) of BOXREGION) + (IQUOTIENT (ADD1 BRUSHSIZE) + 2))) + (SETQ BOXRIGHT (DIFFERENCE (fetch (REGION RIGHT) of BOXREGION) + (IQUOTIENT (ADD1 BRUSHSIZE) + 2))) + (COND + ((OR (NULL INREGIONS) + (ALL.EMPTY.REGIONS INREGIONS)) + (DSPFILL (CREATEREGION BOXLEFT BOXBOTTOM (ADD1 (DIFFERENCE BOXRIGHT + BOXLEFT)) + (ADD1 (DIFFERENCE BOXTOP BOXBOTTOM))) + TEXTURE USEOP STREAM) + (RETURN))) + (COND + ([GREATERP BOXTOP (SETQ X (fetch (REGION TOP) of (CAR INREGIONS] + (* ; + "fill area above the first region") + (BLTSHADE TEXTURE STREAM BOXLEFT (ADD1 X) + (ADD1 (DIFFERENCE BOXRIGHT BOXLEFT)) + (DIFFERENCE BOXTOP X) + USEOP NIL COLOR))) + [for LEAVEREGION in INREGIONS + do (COND + ((ZEROP (fetch (REGION WIDTH) of LEAVEREGION)) + (* ; + "this line doesn't have any characters, just fill all the way across.") + (BLTSHADE TEXTURE STREAM BOXLEFT (fetch (REGION BOTTOM) + of LEAVEREGION) + (ADD1 (DIFFERENCE BOXRIGHT BOXLEFT)) + (fetch (REGION HEIGHT) of LEAVEREGION) + USEOP NIL COLOR)) + (T (* ; + "look for the part before and after the characters on this line.") + (COND + ((GREATERP (SETQ X (DIFFERENCE (fetch (REGION LEFT) + of LEAVEREGION) + MARGIN)) + BOXLEFT) (* ; + "fill area to the left of this region") + (BLTSHADE TEXTURE STREAM BOXLEFT (fetch (REGION BOTTOM + ) + of LEAVEREGION) + (DIFFERENCE X BOXLEFT) + (fetch (REGION HEIGHT) of LEAVEREGION) + USEOP NIL COLOR))) + (COND + ((GREATERP BOXRIGHT (SETQ X (PLUS (fetch (REGION RIGHT) + of LEAVEREGION) + MARGIN))) + (* ; + "fill area to the right of this region") + (BLTSHADE TEXTURE STREAM (ADD1 X) + (fetch (REGION BOTTOM) of LEAVEREGION) + (DIFFERENCE BOXRIGHT X) + (fetch (REGION HEIGHT) of LEAVEREGION) + USEOP NIL COLOR] + (COND + ((GREATERP [SETQ X (fetch (REGION BOTTOM) of (CAR (LAST INREGIONS] + BOXBOTTOM) (* ; "fill area below the last region") + (BLTSHADE TEXTURE STREAM BOXLEFT BOXBOTTOM (ADD1 (DIFFERENCE BOXRIGHT + BOXLEFT)) + (DIFFERENCE X BOXBOTTOM) + USEOP NIL COLOR]) (ALL.EMPTY.REGIONS + [LAMBDA (REGIONLST) (* rrb " 3-Mar-86 20:42") + (* returns T if REGIONLST contains + nothing but empty regions.) + (for REG in REGIONLST always (OR (ZEROP (fetch (REGION WIDTH) of REG)) + (ZEROP (fetch (REGION HEIGHT) of REG]) (TEXTBOX.EXPANDFN + [LAMBDA (GTEXTBOXELT SCALE STREAM) (* rrb "30-Jul-86 15:23") + + (* creates a local textbox screen element from a global text box element) + + (PROG ((GTEXTBOX (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTBOXELT)) + (CANONICALTESTSTR "AWIaiw") + LREG TEXTPOS LOCALFONT STYLE IMAGESTREAM LINEREGIONS BRUSHWIDTH NEWLISTOFSTRS LOCALBRUSH) + (* calculate the local brush) + (SETQ LOCALBRUSH (SCALE.BRUSH (COND + ([NOT (NUMBERP (SETQ LOCALBRUSH (fetch (TEXTBOX + TEXTBOXBRUSH + ) + of GTEXTBOX] + (* new format, old format had brush + width only.) + LOCALBRUSH) + (T [replace (TEXTBOX TEXTBOXBRUSH) of GTEXTBOX + with (SETQ LOCALBRUSH + (create BRUSH + BRUSHSIZE _ LOCALBRUSH + BRUSHSHAPE _ 'ROUND] + LOCALBRUSH)) + (fetch (TEXTBOX INITIALSCALE) of GTEXTBOX) + SCALE)) + [COND + ((TEXTUREP (fetch (TEXTBOX TEXTBOXFILLING) of GTEXTBOX)) + + (* old format, update to new one which has a list of + (texture color)) + + (replace (TEXTBOX TEXTBOXFILLING) of GTEXTBOX with (create SKFILLING + FILLING.TEXTURE _ + (fetch (TEXTBOX + TEXTBOXFILLING) + of GTEXTBOX) + FILLING.COLOR _ NIL] + (* calculate the local region for the + text box.) + (SETQ BRUSHWIDTH (ADD1 (QUOTIENT (fetch (BRUSH BRUSHSIZE) of LOCALBRUSH) + 2))) + (SETQ LREG (SK.SCALE.REGION (fetch (TEXTBOX TEXTBOXREGION) of GTEXTBOX) + SCALE)) (* calculate the local font.) + (SETQ LOCALFONT (SK.CHOOSE.TEXT.FONT GTEXTBOX SCALE STREAM)) + + (* recalculate the line breaks for the particular stream given. + This is necessary because the difference between display and hardcopy must be + taken into account.) + + [SETQ IMAGESTREAM (COND + ((STREAMP STREAM)) + (T (WINDOWPROP STREAM 'DSP] + [SETQ NEWLISTOFSTRS (COND + [(FONTP LOCALFONT) + (SK.BREAK.INTO.LINES (fetch (TEXTBOX LISTOFCHARACTERS) of GTEXTBOX) + (COND + ((IMAGESTREAMTYPEP IMAGESTREAM 'HARDCOPY) + IMAGESTREAM) + (T LOCALFONT)) + (COND + [(IMAGESTREAMTYPEP IMAGESTREAM 'HARDCOPY) + + (* do the split on the basis of the hardcopy font) + + (FIXR (TIMES (IDIFFERENCE (fetch (REGION WIDTH) + of LREG) + (ITIMES BRUSHWIDTH 2)) + (PROGN + + (* the scale should be a parameter of the hardcopy font, maybe font widths + scale. but for now assume widths are in micas.) + + MICASPERPT] + (T (IDIFFERENCE (fetch (REGION WIDTH) of LREG) + (ITIMES BRUSHWIDTH 2] + (T (* if not local font, leave line + breaks alone.) + (fetch (TEXTBOX LISTOFCHARACTERS) of GTEXTBOX] + (SETQ STYLE (fetch (TEXTBOX TEXTSTYLE) of GTEXTBOX)) + (SETQ LINEREGIONS (SK.TEXT.LINE.REGIONS (OR NEWLISTOFSTRS '("")) + (SK.TEXTBOX.POSITION.IN.BOX LREG STYLE (OR LOCALFONT + (fetch (TEXTBOX FONT) + of GTEXTBOX)) + BRUSHWIDTH) + (fetch (TEXTBOX LISTOFREGIONS) of GTEXTBOX) + LOCALFONT STYLE SCALE IMAGESTREAM)) + (RETURN (create SCREENELT + LOCALPART _ + (create LOCALTEXTBOX + TEXTBOXLL _ (create POSITION + XCOORD _ (fetch (REGION LEFT) of LREG) + YCOORD _ (fetch (REGION BOTTOM) of LREG)) + TEXTBOXUR _ (create POSITION + XCOORD _ (fetch (REGION PRIGHT) of LREG) + YCOORD _ (fetch (REGION PTOP) of LREG)) + LINEREGIONS _ LINEREGIONS + LOCALFONT _ LOCALFONT + LOCALTEXTBOXREGION _ LREG + LOCALLISTOFCHARACTERS _ NEWLISTOFSTRS + LOCALTEXTBOXBRUSH _ LOCALBRUSH + LOCALTEXTBOXFILLING _ (APPEND (fetch (TEXTBOX TEXTBOXFILLING) + of GTEXTBOX)) + LOCALTEXTBOXDASHING _ (fetch (TEXTBOX TEXTBOXDASHING) of GTEXTBOX)) + GLOBALPART _ GTEXTBOXELT]) (TEXTBOX.INPUTFN + [LAMBDA (W LREGION) (* rrb "11-Jul-86 15:48") + + (* creates a box element for a sketch window. + Prompts the user for one if none is given.) + + (PROG (LOCALREG) + (COND + ((REGIONP LREGION) + (SETQ LOCALREG LREGION)) + [(NULL LREGION) + (COND + [[SETQ LOCALREG (CAR (ERSETQ (GETWREGION W (FUNCTION SK.BOX.GETREGIONFN) + W] + + (* WINDOWPROP will get exterior of window which should really be reduced to the + interior.) + (* make sure the last selected point + wasn't outside.) + (COND + ((OR (NOT (SUBREGIONP (DSPCLIPPINGREGION NIL W) + LOCALREG)) + (AND (EQ (fetch (REGION WIDTH) of LOCALREG) + 0) + (EQ (fetch (REGION HEIGHT) of LOCALREG) + 0))) + (RETURN] + (T (RETURN] + (T (\ILLEGAL.ARG LREGION))) + (RETURN (SK.TEXTBOX.CREATE (UNSCALE.REGION.TO.GRID LOCALREG (VIEWER.SCALE W)) + (fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP W 'SKETCHCONTEXT)) + (SK.INPUT.SCALE W) + W]) (TEXTBOX.INSIDEFN + [LAMBDA (GTEXTBOX WREG) (* rrb "30-Dec-84 17:23") + + (* determines if the global TEXTBOX GTEXTBOX is inside of WREG.) + + (REGIONSINTERSECTP (fetch (TEXTBOX TEXTBOXREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GTEXTBOX)) + WREG]) (TEXTBOX.REGIONFN + [LAMBDA (TEXTBOXSCRELT) (* rrb " 3-May-85 16:47") + (* returns the region occuppied by a + box.) + + (* is increased by the brush size This has the nice property of insuring that + the region always has both height and width.) + + (INCREASEREGION (fetch (LOCALTEXTBOX LOCALTEXTBOXREGION) of (fetch (SCREENELT LOCALPART) + of TEXTBOXSCRELT)) + (SK.BRUSH.SIZE (fetch (TEXTBOX TEXTBOXBRUSH) of (fetch (SCREENELT INDIVIDUALGLOBALPART) + of TEXTBOXSCRELT]) (TEXTBOX.GLOBALREGIONFN + [LAMBDA (GTEXTBOXELT) (* rrb "18-Oct-85 17:11") + + (* returns the global region occupied by a global textbox element.) + + (fetch (TEXTBOX TEXTBOXREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GTEXTBOXELT]) (TEXTBOX.SET.GLOBAL.REGIONS + [LAMBDA (GTEXTBOXELT) (* rrb "30-Jul-86 14:48") + + (* updates the list of characters and list of regions occupied by the textbox + in the global coordinate space.) + + (* this is used to determine the extent of a text element in a region.) + + (PROG [(SCALE (fetch (TEXTBOX INITIALSCALE) of GTEXTBOXELT)) + (FONT (fetch (TEXTBOX FONT) of GTEXTBOXELT)) + (LISTOFSTRS (fetch (TEXTBOX LISTOFCHARACTERS) of GTEXTBOXELT)) + (TEXTSTYLE (fetch (TEXTBOX TEXTSTYLE) of GTEXTBOXELT)) + (REGION (fetch (TEXTBOX TEXTBOXREGION) of GTEXTBOXELT)) + (BRUSHWIDTH (SK.BRUSH.SIZE (fetch (TEXTBOX TEXTBOXBRUSH) of GTEXTBOXELT] + (replace (TEXTBOX LISTOFREGIONS) of GTEXTBOXELT + with (for LREG in (LTEXT.LINE.REGIONS LISTOFSTRS (SK.TEXTBOX.POSITION.IN.BOX REGION + TEXTSTYLE FONT BRUSHWIDTH) + FONT TEXTSTYLE (ITIMES (FONTHEIGHT FONT) + (LENGTH LISTOFSTRS))) collect LREG)) + (RETURN GTEXTBOXELT]) (TEXTBOX.TRANSLATEFN + [LAMBDA (SKELT DELTAPOS) (* rrb "28-Apr-85 18:46") + + (* * returns a textbox element which has been translated by DELTAPOS) + + (PROG ((GTEXTBOXELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKELT)) + OLDREG NEWREG) + (SETQ NEWREG (REL.MOVE.REGION (SETQ OLDREG (fetch (TEXTBOX TEXTBOXREGION) of GTEXTBOXELT)) + (fetch (POSITION XCOORD) of DELTAPOS) + (fetch (POSITION YCOORD) of DELTAPOS))) + (RETURN (TEXT.UPDATE.GLOBAL.REGIONS (create GLOBALPART + COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART + + COMMONGLOBALPART + ) + of SKELT)) + INDIVIDUALGLOBALPART _ + (create TEXTBOX using GTEXTBOXELT TEXTBOXREGION + _ NEWREG)) + (create POSITION + XCOORD _ (fetch (REGION LEFT) of NEWREG) + YCOORD _ (fetch (REGION BOTTOM) of NEWREG)) + (create POSITION + XCOORD _ (fetch (REGION LEFT) of OLDREG) + YCOORD _ (fetch (REGION BOTTOM) of OLDREG]) (TEXTBOX.TRANSLATEPTSFN + [LAMBDA (TEXTBOXELT SELPTS GDELTA WINDOW) (* rrb "16-Oct-85 17:59") + + (* returns a closed wire element which has the knots that are members of SELPTS + translated by the global amount GDELTA.) + + (PROG ((GTEXTBOXELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of TEXTBOXELT)) + OLDGLOBALREGION LLX LLY URX URY) + (SETQ OLDGLOBALREGION (fetch (TEXTBOX TEXTBOXREGION) of GTEXTBOXELT)) + [COND + [(MEMBER (fetch (LOCALTEXTBOX TEXTBOXLL) of (fetch (SCREENELT LOCALPART) of TEXTBOXELT)) + SELPTS) (* lower left point is moving.) + (SETQ LLX (PLUS (fetch (REGION LEFT) of OLDGLOBALREGION) + (fetch (POSITION XCOORD) of GDELTA))) + (SETQ LLY (PLUS (fetch (REGION BOTTOM) of OLDGLOBALREGION) + (fetch (POSITION YCOORD) of GDELTA] + (T (SETQ LLX (fetch (REGION LEFT) of OLDGLOBALREGION)) + (SETQ LLY (fetch (REGION BOTTOM) of OLDGLOBALREGION] + [COND + [(MEMBER (fetch (LOCALTEXTBOX TEXTBOXUR) of (fetch (SCREENELT LOCALPART) of TEXTBOXELT)) + SELPTS) (* upper right point) + (SETQ URX (PLUS (fetch (REGION PRIGHT) of OLDGLOBALREGION) + (fetch (POSITION XCOORD) of GDELTA))) + (SETQ URY (PLUS (fetch (REGION PTOP) of OLDGLOBALREGION) + (fetch (POSITION YCOORD) of GDELTA] + (T (SETQ URX (fetch (REGION PRIGHT) of OLDGLOBALREGION)) + (SETQ URY (fetch (REGION PTOP) of OLDGLOBALREGION] + (RETURN (SK.TEXTBOX.CREATE1 (CREATEREGION (MIN LLX URX) + (MIN LLY URY) + (ABS (DIFFERENCE LLX URX)) + (ABS (DIFFERENCE LLY URY))) + (fetch (TEXTBOX TEXTBOXBRUSH) of GTEXTBOXELT) + (fetch (TEXTBOX LISTOFCHARACTERS) of GTEXTBOXELT) + (fetch (TEXTBOX INITIALSCALE) of GTEXTBOXELT) + (fetch (TEXTBOX TEXTSTYLE) of GTEXTBOXELT) + (fetch (TEXTBOX FONT) of GTEXTBOXELT) + (fetch (TEXTBOX TEXTBOXDASHING) of GTEXTBOXELT) + (fetch (TEXTBOX TEXTBOXFILLING) of GTEXTBOXELT) + (fetch (TEXTBOX TEXTCOLOR) of GTEXTBOXELT]) (TEXTBOX.TRANSFORMFN + [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "16-Oct-85 17:59") + + (* returns a copy of the global TEXTBOX element that has had each of its + control points transformed by transformfn. + TRANSFORMDATA is arbitrary data that is passed to tranformfn. + SCALEFACTOR is how much the transformation scales the figure and is used to + determine the size of the font.) + + (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + + (* transform the font by changing the scale according to how much the width of + the box around the first line of text changes from the transformation.) + + (RETURN (SK.TEXTBOX.CREATE1 (SK.TRANSFORM.REGION (fetch (TEXTBOX TEXTBOXREGION) + of INDVPART) + TRANSFORMFN TRANSFORMDATA) + (fetch (TEXTBOX TEXTBOXBRUSH) of INDVPART) + (fetch (TEXTBOX LISTOFCHARACTERS) of INDVPART) + (FTIMES (fetch (TEXTBOX INITIALSCALE) of INDVPART) + SCALEFACTOR) + (fetch (TEXTBOX TEXTSTYLE) of INDVPART) + (fetch (TEXTBOX FONT) of INDVPART) + (fetch (TEXTBOX TEXTBOXDASHING) of INDVPART) + (fetch (TEXTBOX TEXTBOXFILLING) of INDVPART) + (fetch (TEXTBOX TEXTCOLOR) of INDVPART]) (TEXTBOX.UPDATEFN + [LAMBDA (OLDLOCALELT NEWGELT SKETCHW) (* rrb " 5-Dec-85 18:02") + + (* update function for text inside of textboxes. + Tries to repaint only the lines of text that have changed.) + + (* takes advantage of the fact that all relevant text fields are in the same + place in TEXT and TEXTBOX records.) + + (* if the box size has changed, reprint the whole thing anyway.) + + (PROG ((NEWTB (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWGELT)) + (OLDTB (fetch (SCREENELT INDIVIDUALGLOBALPART) of OLDLOCALELT)) + (OLDLOCALTB (fetch (SCREENELT LOCALPART) of OLDLOCALELT))) + (RETURN (COND + ((AND (EQUAL (fetch (TEXTBOX TEXTBOXBRUSH) of NEWTB) + (fetch (TEXTBOX TEXTBOXBRUSH) of OLDTB)) + (EQUAL (fetch (TEXTBOX TEXTBOXDASHING) of NEWTB) + (fetch (LOCALTEXTBOX LOCALTEXTBOXDASHING) of OLDLOCALTB)) + (EQUAL (fetch (TEXTBOX TEXTBOXFILLING) of NEWTB) + (fetch (LOCALTEXTBOX LOCALTEXTBOXFILLING) of OLDLOCALTB)) + (EQUAL (fetch (TEXTBOX TEXTCOLOR) of NEWTB) + (fetch (TEXTBOX TEXTCOLOR) of OLDTB))) + (DSPOPERATION (PROG1 (DSPOPERATION 'REPLACE SKETCHW) + (* change to replace mode to erase + background.) + (SETQ NEWTB (TEXT.UPDATEFN OLDLOCALELT NEWGELT SKETCHW))) + SKETCHW) + NEWTB]) (TEXTBOX.READCHANGEFN + [LAMBDA (SKW SCRNELTS) (* rrb " 5-Mar-86 13:33") + (* reads how the user wants to change + a textbox.) + (PROG ((COMMAND (\CURSOR.IN.MIDDLE.MENU (create MENU + TITLE _ "Change which part?" + ITEMS _ + [APPEND (COND + [(SKETCHINCOLORP) + '(("Outline color" 'BRUSHCOLOR + "changes the color of the outline" + ) + ("Filling color" 'FILLINGCOLOR + "changes the color of the filling" + ] + (T NIL)) + '(("The text" 'TEXT + "allows changing the properties of the text." + ) + ("Box thickness" 'SIZE + "changes the size of the brush") + (Dashing 'DASHING + "changes the dashing of the box.") + ("Unbox the text" '(TEXT UNBOX) + "takes the text out of any selected text boxes." + ) + (Filling 'FILLING + "allows changing of the filling texture of the box." + )) + (COND + (FILLINGMODEFLG + '(("Filling mode" 'FILLINGMODE + "changes how the filling effects the figures it covers." + ] + CENTERFLG _ T))) + HOW) + (RETURN (SELECTQ COMMAND + (TEXT (TEXT.READCHANGEFN SKW SCRNELTS T)) + (COND + ((LISTP COMMAND) + COMMAND) + ((SETQ HOW (SELECTQ COMMAND + (FILLING (READ.FILLING.CHANGE)) + (FILLINGMODE (READ.FILLING.MODE)) + (SIZE (READSIZECHANGE "Change size how?" T)) + (DASHING (READ.DASHING.CHANGE)) + (BRUSHCOLOR [READ.COLOR.CHANGE + "Change outline color how?" NIL + (fetch (BRUSH BRUSHCOLOR) + of (GETSKETCHELEMENTPROP (fetch (SCREENELT + GLOBALPART) + of (CAR SCRNELTS) + ) + 'BRUSH]) + (FILLINGCOLOR [READ.COLOR.CHANGE + "Change filling color how?" T + (fetch (SKFILLING FILLING.COLOR) + of (GETSKETCHELEMENTPROP + (fetch (SCREENELT GLOBALPART) + of (CAR SCRNELTS)) + 'FILLING]) + COMMAND)) + (LIST COMMAND HOW]) (SK.TEXTBOX.TEXT.POSITION + [LAMBDA (GTEXTBOXELT) + + (* returns the position of the text in a text box element.) + + (create POSITION + XCOORD _ (fetch (REGION LEFT) of (SETQ GTEXTBOXELT (fetch (TEXTBOX TEXTBOXREGION) + of GTEXTBOXELT))) + YCOORD _ (fetch (REGION TOP) of GTEXTBOXELT]) (SK.TEXTBOX.FROM.TEXT + [LAMBDA (TEXTELT SKW) (* rrb "30-Sep-86 18:34") + (* returns a textbox that replaces + GTEXTELT.) + (PROG ((INDTEXTELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of TEXTELT)) + BRUSH STYLE CONTEXT NEWTEXTBOXELT) + [SETQ BRUSH (fetch (SKETCHCONTEXT SKETCHBRUSH) of (SETQ CONTEXT (WINDOWPROP SKW + 'SKETCHCONTEXT] + (SETQ NEWTEXTBOXELT (SK.TEXTBOX.CREATE1 (INCREASEREGION + (APPLY (FUNCTION SK.UNIONREGIONS) + (fetch (TEXT LISTOFREGIONS) of INDTEXTELT)) + (IQUOTIENT (ADD1 (SK.BRUSH.SIZE + (fetch (BRUSH BRUSHSIZE) + of BRUSH))) + 2)) + BRUSH + (fetch (TEXT LISTOFCHARACTERS) of INDTEXTELT) + (fetch (TEXT INITIALSCALE) of INDTEXTELT) + (COND + ((EQ (CADR (SETQ STYLE (fetch (TEXT TEXTSTYLE) of INDTEXTELT) + )) + 'BASELINE) + + (* change from baseline to center because this usually looks better.) + + (LIST (CAR STYLE) + 'CENTER)) + (T STYLE)) + (fetch (TEXT FONT) of INDTEXTELT) + (fetch (SKETCHCONTEXT SKETCHDASHING) of CONTEXT) + (fetch (SKETCHCONTEXT SKETCHFILLING) of CONTEXT) + (fetch (BRUSH BRUSHCOLOR) of BRUSH))) + (RETURN (create SKHISTORYCHANGESPEC + NEWELT _ NEWTEXTBOXELT + OLDELT _ TEXTELT + PROPERTY _ 'HASBOX + NEWVALUE _ NEWTEXTBOXELT + OLDVALUE _ TEXTELT]) (ADD.EOLS + [LAMBDA (STRLST) (* rrb "22-Jul-86 15:23") + + (* adds an eol to every string in STRLST that doesn't end in one.) + + (for STRTAIL on STRLST collect (COND + ((EQ (CHARCODE EOL) + (NTHCHARCODE (CAR STRTAIL) + -1)) + (CAR STRTAIL)) + ((CDR STRTAIL) (* don't put a cr after the last line.) + (CONCAT (CAR STRTAIL) + " +")) + (T (CAR STRTAIL]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD LOCALTEXTBOX ((TEXTBOXLL TEXTBOXUR) LOCALHOTREGION LINEREGIONS LOCALFONT LOCALLISTOFCHARACTERS LOCALTEXTBOXREGION LOCALTEXTBOXBRUSH LOCALTEXTBOXFILLING LOCALTEXTBOXDASHING)) (TYPERECORD TEXTBOX (TEXTBOXREGION LISTOFCHARACTERS INITIALSCALE TEXTSTYLE FONT LISTOFREGIONS TEXTCOLOR TEXTBOXBRUSH TEXTBOXDASHING TEXTBOXFILLING)) ) ) (* ; "stuff to handle default alignment for text boxes") (DEFINEQ (SK.SET.TEXTBOX.VERT.ALIGN + [LAMBDA (SKW) (* rrb " 6-Nov-85 09:52") + + (* * reads a new value for the vertical justification default for text boxes) + + (PROG ((NEWJUST (\CURSOR.IN.MIDDLE.MENU (create MENU + TITLE _ "New vertical alignment?" + ITEMS _ '(("Top" 'TOP + "the top of new text's vertical extent will be at its position" + ) + ("Center" 'CENTER + "New text's vertical extent will be centered around its position" + ) + ("Baseline" 'BASELINE + "The baseline of new text will be at its position." + ) + ("Bottom" 'BOTTOM + "the bottom of new text's vertical extent will be at its position" + )) + CENTERFLG _ T))) + SKCONTEXT) + (RETURN (AND NEWJUST (replace (SKETCHCONTEXT SKETCHTEXTBOXALIGNMENT) + of (SETQ SKCONTEXT (WINDOWPROP SKW 'SKETCHCONTEXT)) + with (LIST (CAR (fetch (SKETCHCONTEXT SKETCHTEXTBOXALIGNMENT) + of SKCONTEXT)) + NEWJUST]) (SK.SET.TEXTBOX.HORIZ.ALIGN + [LAMBDA (SKW NEWALIGN) (* rrb " 6-Nov-85 09:52") + + (* * reads a new value for the horizontal justification default for text boxes) + + (PROG ([NEWJUST (OR NEWALIGN (\CURSOR.IN.MIDDLE.MENU (create MENU + ITEMS _ '((" Center " 'CENTER + "New text will be centered around its position" + ) + ("Left " 'LEFT + "the left edge of the text will be at its position." + ) + (" Right" 'RIGHT + "the right edge of the text will be at its position." + ] + SKCONTEXT) + (RETURN (AND NEWJUST (replace (SKETCHCONTEXT SKETCHTEXTBOXALIGNMENT) + of (SETQ SKCONTEXT (WINDOWPROP SKW 'SKETCHCONTEXT)) + with (CONS NEWJUST (CDR (fetch (SKETCHCONTEXT + SKETCHTEXTBOXALIGNMENT) + of SKCONTEXT]) ) (RPAQQ TEXTBOXICON #*(36 12)OOOOOOOOO@@@OOOOOOOOO@@@L@@@@@@@C@@@ML@@@N@@C@@@LIMELIBEC@@@LIDHHOEBC@@@LILHHIEBC@@@LIADHIEEC@@@LIMDHNBEC@@@L@@@@@@@C@@@OOOOOOOOO@@@OOOOOOOOO@@@ ) (RPAQ? SK.DEFAULT.TEXTBOX.ALIGNMENT '(CENTER CENTER)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SK.DEFAULT.TEXTBOX.ALIGNMENT) ) (* ; "functions to implement the box sketch element.") (DEFINEQ (SKETCH.CREATE.BOX + [LAMBDA (REGION BRUSH DASHING FILLING SCALE) (* rrb "16-Oct-85 17:31") + (* creates a sketch box element.) + (SK.BOX.CREATE (OR (REGIONP REGION) + (\ILLEGAL.ARG REGION)) + (SK.INSURE.BRUSH BRUSH) + (SK.INSURE.DASHING DASHING) + (OR (NUMBERP SCALE) + 1.0) + (SK.INSURE.FILLING FILLING]) (SK.BOX.DRAWFN + [LAMBDA (BOXELT WIN WINREG) (* rrb "21-Feb-86 11:36") + (* draws a box from its sketch + element.) + (PROG ((LOCALBOXELT (fetch (SCREENELT LOCALPART) of BOXELT)) + FILLING BRUSH) + (SETQ FILLING (fetch (LOCALBOX LOCALBOXFILLING) of LOCALBOXELT)) + (RETURN (BOX.DRAWFN1 (fetch (LOCALBOX LOCALREGION) of LOCALBOXELT) + (fetch (BRUSH BRUSHSIZE) of (SETQ BRUSH (fetch (LOCALBOX LOCALBOXBRUSH) + of LOCALBOXELT))) + WIN WINREG (fetch (SKFILLING FILLING.OPERATION) of FILLING) + (fetch (LOCALBOX LOCALBOXDASHING) of LOCALBOXELT) + (fetch (SKFILLING FILLING.TEXTURE) of FILLING) + (fetch (BRUSH BRUSHCOLOR) of BRUSH) + (fetch (SKFILLING FILLING.COLOR) of FILLING]) (BOX.DRAWFN1 + [LAMBDA (REG SIZE WIN WINREG OPERATION DASHING TEXTURE OUTLINECOLOR FILLINGCOLOR) + (* rrb " 5-Mar-86 14:27") + + (* draws a box. Used by both box and text box elements.) + + (COND + ((OR (NULL WINREG) + (REGIONSINTERSECTP WINREG REG)) + (COND + ((AND SKETCHINCOLORFLG (OR FILLINGCOLOR TEXTURE)) (* call the filling routine that does + color.) + (FILLPOLYGON (KNOTS.OF.REGION REG SIZE) + (create SKFILLING + FILLING.TEXTURE _ TEXTURE + FILLING.COLOR _ FILLINGCOLOR) + WIN)) + (TEXTURE (DSPFILL REG (COND + ((EQ (DSPOPERATION NIL WIN) + 'ERASE) + + (* use black in case the window moved because of texture to window alignment + bug.) + + BLACKSHADE) + (T TEXTURE)) + (SK.TRANSLATE.MODE OPERATION WIN) + WIN)) + (FILLINGCOLOR (* if no texture, use the color.) + (DSPFILL REG (TEXTUREOFCOLOR FILLINGCOLOR) + OPERATION WIN))) + + (* code to fix white space bug in Interpress. + It works but Masters are larger and the one I tried wouldn't print. + (SELECTQ (IMAGESTREAMTYPE WIN) ((NIL DISPLAY PRESS) + (* special case DISPLAY for speed and PRESS because rounded corners don't work + for large brushes.) (SK.DRAWAREABOX (fetch + (REGION LEFT) of REG) (fetch (REGION BOTTOM) of REG) + (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG) SIZE OPERATION WIN + DASHING OUTLINECOLOR)) (PROG ((LFT (fetch + (REGION LEFT) of REG)) (BTM (fetch (REGION BOTTOM) of REG)) + (TOP (fetch (REGION TOP) of REG)) (RGHT (fetch + (REGION RIGHT) of REG))) (DRAWCURVE (LIST + (CREATEPOSITION LFT BTM) (CREATEPOSITION LFT TOP) + (CREATEPOSITION RIGHT TOP) (CREATEPOSITION RIGHT BTM)) T + (create BRUSH BRUSHSHAPE _ (QUOTE ROUND) BRUSHSIZE _ SIZE BRUSHCOLOR _ + OUTLINECOLOR) DASHING WIN)))) + + (SK.DRAWAREABOX (fetch (REGION LEFT) of REG) + (fetch (REGION BOTTOM) of REG) + (fetch (REGION WIDTH) of REG) + (fetch (REGION HEIGHT) of REG) + SIZE + (SK.TRANSLATE.MODE OPERATION WIN) + WIN DASHING OUTLINECOLOR]) (KNOTS.OF.REGION + [LAMBDA (REGION BORDER) (* rrb "18-Jul-85 09:49") + + (* returns the knots of the interior rectangle of a region.) + + (PROG (LFT BTM TP RGHT (HLFBORDER (FQUOTIENT BORDER 2.0))) + (SETQ LFT (PLUS (fetch (REGION LEFT) of REGION) + HLFBORDER)) + (SETQ BTM (PLUS (fetch (REGION BOTTOM) of REGION) + HLFBORDER)) + (SETQ TP (DIFFERENCE (fetch (REGION TOP) of REGION) + HLFBORDER)) + (SETQ RGHT (DIFFERENCE (fetch (REGION RIGHT) of REGION) + HLFBORDER)) + (RETURN (LIST (create POSITION + XCOORD _ LFT + YCOORD _ BTM) + (create POSITION + XCOORD _ LFT + YCOORD _ TP) + (create POSITION + XCOORD _ RGHT + YCOORD _ TP) + (create POSITION + XCOORD _ RGHT + YCOORD _ BTM]) (SK.DRAWAREABOX + [LAMBDA (LEFT BOTTOM WIDTH HEIGHT BORDER OP W DASHING COLOR) + (* rrb "16-Sep-86 16:12") + + (* draws lines along the region. Copied from the function DRAWAREABOX in + GRAPHER and changed to be the same as drawing lines between the corner points.) + + (COND + [[OR DASHING (AND COLOR (NEQ COLOR 'BLACK] + + (* start a line at each corner so that the corners will have black on them.) + + (COND + ((OR (IMAGESTREAMTYPEP W 'PRESS) + (IMAGESTREAMTYPEP W 'INTERPRESS)) (* both these use BUTT, overlap the + lines) + (PROG (BIG/HALF SM/HALF TOP RIGHT) + (SETQ BIG/HALF (LRSH (ADD1 BORDER) + 1)) + (SETQ SM/HALF (DIFFERENCE BORDER BIG/HALF)) + (SETQ TOP (PLUS BOTTOM HEIGHT)) + (SETQ RIGHT (PLUS LEFT WIDTH)) (* draw left edge) + (DRAWLINE LEFT (DIFFERENCE BOTTOM SM/HALF) + LEFT + (PLUS TOP BIG/HALF) + BORDER OP W COLOR DASHING) (* draw top.) + (DRAWLINE (IDIFFERENCE LEFT SM/HALF) + TOP + (IPLUS RIGHT BIG/HALF) + TOP BORDER OP W COLOR DASHING) (* draw right edge) + (DRAWLINE RIGHT (PLUS TOP BIG/HALF) + RIGHT + (DIFFERENCE BOTTOM SM/HALF) + BORDER OP W COLOR DASHING) (* draw bottom) + (DRAWLINE (IPLUS RIGHT BIG/HALF) + BOTTOM + (IDIFFERENCE LEFT SM/HALF) + BOTTOM BORDER OP W COLOR DASHING))) + (T (PROG (TOP RIGHT HALFBORDER) + (SETQ TOP (PLUS BOTTOM HEIGHT)) + (SETQ RIGHT (PLUS LEFT WIDTH)) (* draw left edge) + (DRAWLINE LEFT BOTTOM LEFT TOP BORDER OP W COLOR DASHING) + (* draw top) + (DRAWLINE LEFT TOP RIGHT TOP BORDER OP W COLOR DASHING) + (* draw right edge) + (DRAWLINE RIGHT TOP RIGHT BOTTOM BORDER OP W COLOR DASHING) + (* draw bottom) + (DRAWLINE RIGHT BOTTOM LEFT BOTTOM BORDER OP W COLOR DASHING] + ((IMAGESTREAMTYPEP W 'PRESS) (* overlap the ends of the lines.) + (PROG (BIG/HALF SM/HALF TOP HORIZLEFT HORIZRIGHT RIGHT) + (SETQ BIG/HALF (LRSH (ADD1 BORDER) + 1)) + (SETQ SM/HALF (DIFFERENCE BORDER BIG/HALF)) + (SETQ TOP (PLUS BOTTOM HEIGHT)) + (SETQ RIGHT (PLUS LEFT WIDTH)) (* draw left edge) + (DRAWLINE LEFT (DIFFERENCE BOTTOM SM/HALF) + LEFT + (PLUS TOP BIG/HALF) + BORDER OP W COLOR DASHING) (* draw top.) + (DRAWLINE (SETQ HORIZLEFT (IPLUS LEFT BIG/HALF)) + TOP + (SETQ HORIZRIGHT (SUB1 (IDIFFERENCE RIGHT SM/HALF))) + TOP BORDER OP W COLOR DASHING) (* draw right edge) + (DRAWLINE RIGHT (DIFFERENCE BOTTOM SM/HALF) + RIGHT + (PLUS TOP BIG/HALF) + BORDER OP W COLOR DASHING) (* draw bottom) + (DRAWLINE HORIZLEFT BOTTOM HORIZRIGHT BOTTOM BORDER OP W COLOR DASHING))) + ((IMAGESTREAMTYPEP W 'INTERPRESS) + + (* kludge for interpress in koto because BLTSHADE rounds down so brushes of 1 + don't show, Drawline is always BUTT and DRAWPOLYGON isn't implemented.) + + (PROG (BIG/HALF SM/HALF TOP HORIZLEFT HORIZRIGHT RIGHT) + (SETQ BIG/HALF (LRSH (ADD1 BORDER) + 1)) + (SETQ SM/HALF (DIFFERENCE BORDER BIG/HALF)) + (SETQ TOP (PLUS BOTTOM HEIGHT)) + (SETQ RIGHT (PLUS LEFT WIDTH)) (* draw left edge) + (DRAWLINE LEFT (DIFFERENCE BOTTOM SM/HALF) + LEFT + (PLUS TOP BIG/HALF) + BORDER OP W COLOR DASHING) + + (* draw top. 9 is to fix an error on the 8044 which may be from rounding to its + pixel size.) + + (DRAWLINE (SETQ HORIZLEFT (DIFFERENCE (IPLUS LEFT BIG/HALF) + 9)) + TOP + (SETQ HORIZRIGHT (SUB1 (IDIFFERENCE RIGHT SM/HALF))) + TOP BORDER OP W COLOR DASHING) (* draw right edge) + (DRAWLINE RIGHT (DIFFERENCE BOTTOM SM/HALF) + RIGHT + (PLUS TOP BIG/HALF) + BORDER OP W COLOR DASHING) (* draw bottom) + (DRAWLINE HORIZLEFT BOTTOM HORIZRIGHT BOTTOM BORDER OP W COLOR DASHING))) + (T (* do other cases with bitblt) + (PROG (BIG/HALF SM/HALF HORIZLEFT BOXBOTTOM SIDEWIDTH SIDEHEIGHT) + (SETQ BIG/HALF (LRSH BORDER 1)) + (SETQ SM/HALF (SUB1 (DIFFERENCE BORDER BIG/HALF))) + (* draw left edge) + (BLTSHADE BLACKSHADE W (DIFFERENCE LEFT SM/HALF) + (SETQ BOXBOTTOM (DIFFERENCE BOTTOM SM/HALF)) + BORDER + (SETQ SIDEHEIGHT (PLUS HEIGHT BORDER)) + OP) (* draw right edge) + (BLTSHADE BLACKSHADE W (DIFFERENCE (PLUS LEFT WIDTH) + SM/HALF) + BOXBOTTOM BORDER SIDEHEIGHT OP) (* draw top) + (BLTSHADE BLACKSHADE W (SETQ HORIZLEFT (ADD1 (PLUS LEFT BIG/HALF))) + (DIFFERENCE (PLUS BOTTOM HEIGHT) + SM/HALF) + (SETQ SIDEWIDTH (DIFFERENCE WIDTH BORDER)) + BORDER OP) + (BLTSHADE BLACKSHADE W HORIZLEFT BOXBOTTOM SIDEWIDTH BORDER OP]) (SK.DRAWBOX + [LAMBDA (BOXLEFT BOXBOTTOM BOXWIDTH BOXHEIGHT BORDER OP W TEXTURE) + (* rrb "14-Jul-86 13:51") + (* draws lines inside the region.) + (OR TEXTURE (SETQ TEXTURE BLACKSHADE)) (* draw left edge) + (BITBLT NIL NIL NIL W BOXLEFT BOXBOTTOM BORDER BOXHEIGHT 'TEXTURE OP TEXTURE) + (* draw top) + (BITBLT NIL NIL NIL W (PLUS BOXLEFT BORDER) + (DIFFERENCE (PLUS BOXBOTTOM BOXHEIGHT) + BORDER) + (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) + BORDER + 'TEXTURE OP TEXTURE) (* draw bottom) + (BITBLT NIL NIL NIL W (PLUS BOXLEFT BORDER) + BOXBOTTOM + (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) + BORDER + 'TEXTURE OP TEXTURE) (* draw right edge) + (BITBLT NIL NIL NIL W (DIFFERENCE (PLUS BOXLEFT BOXWIDTH) + BORDER) + BOXBOTTOM BORDER BOXHEIGHT 'TEXTURE OP TEXTURE]) (SK.BOX.EXPANDFN + [LAMBDA (GBOX SCALE) (* rrb "11-Jul-86 15:56") + + (* returns a local record which has the region field of the global element GELT + translated into window coordinats.) + + (* for now only allow to move the left-bottom or right-top corner.) + + (PROG ((INDGELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GBOX)) + LREG) + [COND + ((fetch (BOX BOXINITSCALE) of INDGELT)) + (T + + (* old format didn't have an initial scale, default it to 1.0) + + (replace (GLOBALPART INDIVIDUALGLOBALPART) of GBOX + with (SETQ INDGELT (create BOX using INDGELT BOXINITSCALE _ 1.0] + [COND + ((TEXTUREP (fetch (BOX BOXFILLING) of INDGELT)) + + (* old format, update to new one which has a list of + (texture color)) + + (replace (BOX BOXFILLING) of INDGELT with (create SKFILLING + FILLING.TEXTURE _ (fetch (BOX + BOXFILLING + ) + of INDGELT) + FILLING.COLOR _ NIL] + (SETQ LREG (SK.SCALE.REGION (fetch (BOX GLOBALREGION) of INDGELT) + SCALE)) + (RETURN (create SCREENELT + LOCALPART _ + (create LOCALBOX + BOXLL _ (create POSITION + XCOORD _ (fetch (REGION LEFT) of LREG) + YCOORD _ (fetch (REGION BOTTOM) of LREG)) + BOXUR _ (create POSITION + XCOORD _ (fetch (REGION PRIGHT) of LREG) + YCOORD _ (fetch (REGION PTOP) of LREG)) + LOCALREGION _ LREG + LOCALBOXBRUSH _ + (SCALE.BRUSH (COND + ([NOT (NUMBERP (SETQ LREG (fetch (BOX BRUSH) + of INDGELT] + (* new format, old format had brush + width only.) + LREG) + (T [replace (BOX BRUSH) of INDGELT + with (SETQ LREG + (create BRUSH + BRUSHSIZE _ LREG + BRUSHSHAPE _ 'ROUND] + LREG)) + (fetch (BOX BOXINITSCALE) of INDGELT) + SCALE) + LOCALBOXFILLING _ (APPEND (fetch (BOX BOXFILLING) of INDGELT)) + LOCALBOXDASHING _ (fetch (BOX BOXDASHING) of INDGELT)) + GLOBALPART _ GBOX]) (SK.BOX.GETREGIONFN + [LAMBDA (FIXPT MOVINGPT W) (* rrb "12-May-86 18:38") + + (* getregion fn that generates an error if a point is clicked outside of + window. Also puts things on the window grid.) + + (SKETCHW.UPDATE.LOCATORS W) + (COND + [MOVINGPT + + (* this test the fixed pt every time which is unnecessary but does allow us to + catch button down.) + + (PROG [(REG (WINDOWPROP W 'REGION] + (RETURN (COND + ((INSIDEP REG FIXPT) + (COND + ((INSIDEP REG MOVINGPT) + (MAP.SCREEN.POSITION.ONTO.GRID MOVINGPT W (LASTMOUSESTATE MIDDLE) + )) + (T + + (* if the cursor is outside, return the fixed point so the feedback box + disappears.) + + FIXPT))) + (T (ERROR!] + (T (MAP.SCREEN.POSITION.ONTO.GRID FIXPT W (LASTMOUSESTATE RIGHT]) (BOX.SET.SCALES + [LAMBDA (GREG GBOXELT) (* rrb " 7-Feb-85 12:30") + + (* updates the scale field after a change in the region of a box element.) + + (* removed the part of the scale that was limiting it to defaults. + If it has to go back in, please leave a note as to why.) + + (PROG (WIDTH HEIGHT) + (replace (GLOBALPART MINSCALE) of GBOXELT with (FQUOTIENT (MIN (SETQ WIDTH + (fetch (REGION WIDTH) + of GREG)) + (SETQ HEIGHT + (fetch (REGION HEIGHT) + of GREG))) + 1000.0)) + (replace (GLOBALPART MAXSCALE) of GBOXELT with (FQUOTIENT (MAX WIDTH HEIGHT) + 2.0)) + (RETURN GBOXELT]) (SK.BOX.INPUTFN + [LAMBDA (W LREGION) (* rrb "11-Jul-86 15:48") + + (* creates a box element for a sketch window. + Prompts the user for one if none is given.) + + (PROG (LOCALREG SKCONTEXT) + (COND + ((REGIONP LREGION) + (SETQ LOCALREG LREGION)) + [(NULL LREGION) + (COND + [[SETQ LOCALREG (CAR (ERSETQ (GETWREGION W (FUNCTION SK.BOX.GETREGIONFN) + W] + + (* WINDOWPROP will get exterior of window which should really be reduced to the + interior.) + (* make sure the last selected point + wasn't outside.) + (COND + ((OR (NOT (SUBREGIONP (DSPCLIPPINGREGION NIL W) + LOCALREG)) + (AND (EQ (fetch (REGION WIDTH) of LOCALREG) + 0) + (EQ (fetch (REGION HEIGHT) of LOCALREG) + 0))) + (RETURN] + (T (RETURN] + (T (\ILLEGAL.ARG LREGION))) + (RETURN (SK.BOX.CREATE (UNSCALE.REGION.TO.GRID LOCALREG (VIEWER.SCALE W)) + [fetch (SKETCHCONTEXT SKETCHBRUSH) of (SETQ SKCONTEXT (WINDOWPROP + W + 'SKETCHCONTEXT] + (fetch (SKETCHCONTEXT SKETCHDASHING) of SKCONTEXT) + (SK.INPUT.SCALE W) + (fetch (SKETCHCONTEXT SKETCHFILLING) of SKCONTEXT]) (SK.BOX.CREATE + [LAMBDA (SKETCHREGION BRUSH DASHING INITSCALE FILLING) (* rrb "12-Dec-85 14:33") + + (* * creates a sketch element from a region) + + (SK.UPDATE.BOX.AFTER.CHANGE (create GLOBALPART + INDIVIDUALGLOBALPART _ + (create BOX + GLOBALREGION _ SKETCHREGION + BRUSH _ BRUSH + BOXDASHING _ DASHING + BOXINITSCALE _ INITSCALE + BOXFILLING _ FILLING]) (SK.UPDATE.BOX.AFTER.CHANGE + [LAMBDA (GBOXELT) (* rrb "12-Dec-85 14:33") + (* changes dependent fields after a + box element changes.) + (BOX.SET.SCALES (fetch (BOX GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GBOXELT)) + GBOXELT]) (SK.BOX.INSIDEFN + [LAMBDA (GBOX WREG) (* rrb " 5-AUG-83 16:04") + + (* determines if the global BOX GBOX is inside of WREG.) + + (REGIONSINTERSECTP (fetch (BOX GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GBOX)) + WREG]) (SK.BOX.REGIONFN + [LAMBDA (BOXSCRLET) (* rrb " 7-Dec-85 19:41") + (* returns the region occupied by a + box.) + (INCREASEREGION (fetch (LOCALBOX LOCALREGION) of (fetch (SCREENELT LOCALPART) of BOXSCRLET)) + (fetch (BRUSH BRUSHSIZE) of (fetch (LOCALBOX LOCALBOXBRUSH) of (fetch (SCREENELT LOCALPART + ) + of BOXSCRLET]) (SK.BOX.GLOBALREGIONFN + [LAMBDA (GBOXELT) (* ; "Edited 20-Feb-87 16:20 by rrb") + + (* returns the global region occupied by a global box element.) + + (INCREASEREGION (fetch (BOX GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GBOXELT)) + (QUOTIENT (fetch (BRUSH BRUSHSIZE) of (fetch (BOX BRUSH) of (fetch (GLOBALPART + INDIVIDUALGLOBALPART + ) of GBOXELT))) + 2]) (SK.BOX.READCHANGEFN + [LAMBDA (SKW SCRNELTS) (* rrb " 5-Mar-86 13:35") + + (* the users has selected SCRNELT to be changed this function reads a + specification of how the box elements should change.) + + (PROG (ASPECT HOW) + (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU + (create MENU + CENTERFLG _ T + TITLE _ "Which aspect?" + ITEMS _ + (APPEND (COND + [(SKETCHINCOLORP) + '(("Outline color" 'BRUSHCOLOR + "changes the color of the outline" + ) + ("Filling color" 'FILLINGCOLOR + "changes the color of the filling" + ] + (T NIL)) + [COND + (FILLINGMODEFLG + '(("Filling mode" 'FILLINGMODE + "changes how the filling effects the figures it covers." + ] + '((Filling 'FILLING + "allows changing of the filling texture of the box." + ) + ("Outline size" 'SIZE + "changes the size of the brush") + ("Outline dashing" 'DASHING + "changes the dashing of the line."] + (SIZE (READSIZECHANGE "Change size how?" T)) + (FILLING (READ.FILLING.CHANGE)) + (FILLINGMODE (READ.FILLING.MODE)) + (DASHING (READ.DASHING.CHANGE)) + (BRUSHCOLOR [READ.COLOR.CHANGE "Change outline color how?" NIL + (fetch (BRUSH BRUSHCOLOR) + of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) + of (CAR SCRNELTS)) + 'BRUSH]) + (FILLINGCOLOR [READ.COLOR.CHANGE "Change filling color how?" T + (fetch (SKFILLING FILLING.COLOR) + of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART + ) + of (CAR SCRNELTS)) + 'FILLING]) + NIL)) + (RETURN (AND HOW (LIST ASPECT HOW]) (SK.CHANGE.FILLING + [LAMBDA (ELTWITHFILLING HOW SKW) (* rrb " 9-Jan-86 16:57") + (* changes the texture in the element + ELTWITHFILLING.) + (PROG (GFILLEDELT TEXTURE OLDFILLING NEWFILLING TYPE NEWELT) + (AND (EQ HOW 'NONE) + (SETQ HOW NIL)) + (RETURN (COND + ((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHFILLING)) + '(BOX TEXTBOX CLOSEDWIRE CIRCLE)) + + (* only works for things that have a filling, for now just boxes and polygons) + + (SETQ GFILLEDELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHFILLING)) + [SETQ TEXTURE (fetch (SKFILLING FILLING.TEXTURE) + of (SETQ OLDFILLING (SELECTQ TYPE + (BOX (fetch (BOX BOXFILLING) + of GFILLEDELT)) + (TEXTBOX (fetch (TEXTBOX + TEXTBOXFILLING) + of GFILLEDELT)) + (CLOSEDWIRE (fetch (CLOSEDWIRE + CLOSEDWIREFILLING + ) + of GFILLEDELT)) + (CIRCLE (fetch (CIRCLE CIRCLEFILLING) + of GFILLEDELT)) + (SHOULDNT] + (COND + ((NOT (EQUAL HOW TEXTURE)) (* new filling) + (SETQ NEWFILLING (create SKFILLING using OLDFILLING FILLING.TEXTURE _ HOW)) + (SETQ NEWELT (SELECTQ TYPE + (BOX (create BOX using GFILLEDELT BOXFILLING _ NEWFILLING)) + (TEXTBOX (create TEXTBOX using GFILLEDELT TEXTBOXFILLING _ + NEWFILLING)) + (CLOSEDWIRE (create CLOSEDWIRE using GFILLEDELT + CLOSEDWIREFILLING _ + NEWFILLING)) + (CIRCLE (create CIRCLE using GFILLEDELT CIRCLEFILLING _ + NEWFILLING)) + (SHOULDNT))) + (create SKHISTORYCHANGESPEC + NEWELT _ (create GLOBALPART + COMMONGLOBALPART _ (fetch (GLOBALPART + COMMONGLOBALPART) + of ELTWITHFILLING) + INDIVIDUALGLOBALPART _ NEWELT) + OLDELT _ ELTWITHFILLING + PROPERTY _ 'FILLING + NEWVALUE _ NEWFILLING + OLDVALUE _ OLDFILLING]) (SK.CHANGE.FILLING.COLOR + [LAMBDA (ELTWITHFILLING HOW SKW) (* rrb " 9-Jan-86 19:42") + (* changes the texture in the element + ELTWITHFILLING.) + (PROG (GFILLEDELT COLOR FILLING NEWFILLING TYPE NEWELT) + (AND (EQ HOW 'NONE) + (SETQ HOW NIL)) + (RETURN (COND + ((MEMB (SETQ TYPE (fetch (GLOBALPART GTYPE) of ELTWITHFILLING)) + '(BOX TEXTBOX CLOSEDWIRE CIRCLE)) + + (* only works for things that have a filling, for now just boxes and polygons) + + (SETQ GFILLEDELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHFILLING)) + [SETQ COLOR (fetch (SKFILLING FILLING.COLOR) + of (SETQ FILLING (SELECTQ TYPE + (BOX (fetch (BOX BOXFILLING) of GFILLEDELT)) + (TEXTBOX (fetch (TEXTBOX TEXTBOXFILLING) + of GFILLEDELT)) + (CIRCLE (fetch (CIRCLE CIRCLEFILLING) + of GFILLEDELT)) + (CLOSEDWIRE (fetch (CLOSEDWIRE + CLOSEDWIREFILLING + ) of GFILLEDELT)) + (SHOULDNT] + (COND + ((NOT (EQUAL HOW COLOR)) (* new filling) + (SETQ NEWFILLING (create SKFILLING using FILLING FILLING.COLOR _ HOW)) + (SETQ NEWELT (SELECTQ TYPE + (BOX (create BOX using GFILLEDELT BOXFILLING _ NEWFILLING)) + (TEXTBOX (create TEXTBOX using GFILLEDELT TEXTBOXFILLING _ + NEWFILLING)) + (CLOSEDWIRE (create CLOSEDWIRE using GFILLEDELT + CLOSEDWIREFILLING _ + NEWFILLING)) + (CIRCLE (create CIRCLE using GFILLEDELT CIRCLEFILLING _ + NEWFILLING)) + (SHOULDNT))) + (create SKHISTORYCHANGESPEC + NEWELT _ (create GLOBALPART + COMMONGLOBALPART _ (fetch (GLOBALPART + COMMONGLOBALPART) + of ELTWITHFILLING) + INDIVIDUALGLOBALPART _ NEWELT) + OLDELT _ ELTWITHFILLING + PROPERTY _ 'FILLING + NEWVALUE _ NEWFILLING + OLDVALUE _ FILLING]) (SK.BOX.TRANSLATEFN + [LAMBDA (SKELT DELTAPOS) (* rrb "28-Apr-85 18:46") + + (* * returns a curve element which has the box translated by DELTAPOS) + + (PROG ((GBOXELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKELT))) + (RETURN (create GLOBALPART + COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) of SKELT)) + INDIVIDUALGLOBALPART _ (create BOX using GBOXELT GLOBALREGION _ + (REL.MOVE.REGION + (fetch (BOX GLOBALREGION) + of GBOXELT) + (fetch (POSITION XCOORD) + of DELTAPOS) + (fetch (POSITION YCOORD) + of DELTAPOS]) (SK.BOX.TRANSFORMFN + [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "12-Jul-85 17:16") + + (* returns a copy of the global BOX element that has had each of its control + points transformed by transformfn. TRANSFORMDATA is arbitrary data that is + passed to tranformfn.) + + (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (RETURN (SK.BOX.CREATE (SK.TRANSFORM.REGION (fetch (BOX GLOBALREGION) of INDVPART) + TRANSFORMFN TRANSFORMDATA) + (SK.TRANSFORM.BRUSH (fetch (BOX BRUSH) of INDVPART) + SCALEFACTOR) + (fetch (BOX BOXDASHING) of INDVPART) + (fetch (BOX BOXINITSCALE) of INDVPART) + (fetch (BOX BOXFILLING) of INDVPART]) (SK.BOX.TRANSLATEPTSFN + [LAMBDA (BOXELT SELPTS GDELTA WINDOW) (* rrb "12-Jul-85 17:55") + + (* returns a closed wire element which has the knots that are members of SELPTS + translated by the global amount GDELTA.) + + (PROG ((GBOXELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of BOXELT)) + OLDGLOBALREGION LLX LLY URX URY) + (SETQ OLDGLOBALREGION (fetch (BOX GLOBALREGION) of GBOXELT)) + [COND + [(MEMBER (fetch (LOCALBOX BOXLL) of (fetch (SCREENELT LOCALPART) of BOXELT)) + SELPTS) (* lower left point is moving.) + (SETQ LLX (PLUS (fetch (REGION LEFT) of OLDGLOBALREGION) + (fetch (POSITION XCOORD) of GDELTA))) + (SETQ LLY (PLUS (fetch (REGION BOTTOM) of OLDGLOBALREGION) + (fetch (POSITION YCOORD) of GDELTA] + (T (SETQ LLX (fetch (REGION LEFT) of OLDGLOBALREGION)) + (SETQ LLY (fetch (REGION BOTTOM) of OLDGLOBALREGION] + [COND + [(MEMBER (fetch (LOCALBOX BOXUR) of (fetch (SCREENELT LOCALPART) of BOXELT)) + SELPTS) (* upper right point) + (SETQ URX (PLUS (fetch (REGION PRIGHT) of OLDGLOBALREGION) + (fetch (POSITION XCOORD) of GDELTA))) + (SETQ URY (PLUS (fetch (REGION PTOP) of OLDGLOBALREGION) + (fetch (POSITION YCOORD) of GDELTA] + (T (SETQ URX (fetch (REGION PRIGHT) of OLDGLOBALREGION)) + (SETQ URY (fetch (REGION PTOP) of OLDGLOBALREGION] + (RETURN (SK.BOX.CREATE (CREATEREGION (MIN LLX URX) + (MIN LLY URY) + (ABS (DIFFERENCE LLX URX)) + (ABS (DIFFERENCE LLY URY))) + (fetch (BOX BRUSH) of GBOXELT) + (fetch (BOX BOXDASHING) of GBOXELT) + (fetch (BOX BOXINITSCALE) of GBOXELT) + (fetch (BOX BOXFILLING) of GBOXELT]) (UNSCALE.REGION.TO.GRID + [LAMBDA (REGION SCALE GRIDSIZE) (* rrb "25-Oct-84 12:53") + + (* scales a region from a window region to the larger coordinate space.) + + (PROG [(LFT (TIMES SCALE (fetch (REGION LEFT) of REGION))) + (BTM (TIMES SCALE (fetch (REGION BOTTOM) of REGION))) + (WDTH (TIMES SCALE (fetch (REGION WIDTH) of REGION))) + (HGHT (TIMES SCALE (fetch (REGION HEIGHT) of REGION] + [COND + (GRIDSIZE + + (* move X and Y to nearest point on the grid) + + (SETQ LFT (NEAREST.ON.GRID LFT GRIDSIZE)) + (SETQ BTM (NEAREST.ON.GRID BTM GRIDSIZE)) + (SETQ WDTH (NEAREST.ON.GRID WDTH GRIDSIZE)) + (SETQ HGHT (NEAREST.ON.GRID HGHT GRIDSIZE] + (RETURN (CREATEREGION LFT BTM WDTH HGHT]) (INCREASEREGION + [LAMBDA (REGION BYAMOUNT) (* rrb " 9-Sep-84 19:58") + + (* * increases a region by a fixed amount in all directions.) + + (CREATEREGION (DIFFERENCE (fetch (REGION LEFT) of REGION) + BYAMOUNT) + (DIFFERENCE (fetch (REGION BOTTOM) of REGION) + BYAMOUNT) + (PLUS (fetch (REGION WIDTH) of REGION) + (TIMES BYAMOUNT 2)) + (PLUS (fetch (REGION HEIGHT) of REGION) + (TIMES BYAMOUNT 2]) (INSUREREGIONSIZE + [LAMBDA (REGION MINSIZE) (* rrb " 5-Dec-84 11:27") + + (* * makes sure the height and width of REGION are at least MINSIZE.) + + (PROG (X) + (COND + ((GREATERP MINSIZE (SETQ X (fetch (REGION WIDTH) of REGION))) + (replace (REGION LEFT) of REGION with (DIFFERENCE (fetch (REGION LEFT) of REGION) + (QUOTIENT (DIFFERENCE MINSIZE X) + 2))) + (replace (REGION WIDTH) of REGION with MINSIZE))) + (COND + ((GREATERP MINSIZE (SETQ X (fetch (REGION HEIGHT) of REGION))) + (replace (REGION BOTTOM) of REGION with (DIFFERENCE (fetch (REGION BOTTOM) of REGION) + (QUOTIENT (DIFFERENCE MINSIZE X) + 2))) + (replace (REGION HEIGHT) of REGION with MINSIZE))) + (RETURN REGION]) (EXPANDREGION + [LAMBDA (REGION BYFACTOR) (* rrb "30-Nov-84 10:43") + + (* * expands a region by a factor.) + + (PROG ((WIDTH (fetch (REGION WIDTH) of REGION)) + (HEIGHT (fetch (REGION HEIGHT) of REGION)) + NEWWIDTH NEWHEIGHT) + (SETQ NEWWIDTH (TIMES WIDTH BYFACTOR)) + (SETQ NEWHEIGHT (TIMES HEIGHT BYFACTOR)) + (RETURN (CREATEREGION (DIFFERENCE (fetch (REGION LEFT) of REGION) + (QUOTIENT (IDIFFERENCE NEWWIDTH WIDTH) + 2)) + (DIFFERENCE (fetch (REGION BOTTOM) of REGION) + (QUOTIENT (IDIFFERENCE NEWHEIGHT HEIGHT) + 2)) + NEWWIDTH NEWHEIGHT]) (REGION.FROM.COORDINATES + [LAMBDA (X1 Y1 X2 Y2) (* rrb "11-Sep-84 16:27") + + (* * returns the region for which { X1 Y1 } and { X2 Y2} are the corners.) + + (CREATEREGION (MIN X1 X2) + (MIN Y1 Y2) + (ADD1 (ABS (IDIFFERENCE X2 X1))) + (ADD1 (ABS (IDIFFERENCE Y2 Y1]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (TYPERECORD BOX (GLOBALREGION BRUSH BOXDASHING BOXINITSCALE BOXFILLING)) (RECORD LOCALBOX ((BOXLL BOXUR) LOCALHOTREGION LOCALREGION LOCALBOXBRUSH LOCALBOXFILLING LOCALBOXDASHING)) ) ) (READVARS-FROM-STRINGS '(BOXICON) "({(READBITMAP)(20 12 %"@@@@@@@@%" %"GOOON@@@%" %"GOOON@@@%" %"F@@@F@@@%" %"F@@@F@@@%" %"F@@@F@@@%" %"F@@@F@@@%" %"F@@@F@@@%" %"F@@@F@@@%" %"GOOON@@@%" %"GOOON@@@%" %"@@@@@@@@%")}) ") (* ; "fns for the arc sketch element type") (DEFINEQ (SKETCH.CREATE.ARC + [LAMBDA (CENTERPT RADIUSPT ANGLEPT BRUSH DASHING ARROWHEADS DIRECTION SCALE) + (* rrb " 7-Jul-86 14:49") + (* creates a sketch arc element.) + (ARC.CREATE (SK.INSURE.POSITION CENTERPT) + (SK.INSURE.POSITION RADIUSPT) + (COND + ((NUMBERP ANGLEPT) + (SK.COMPUTE.ARC.ANGLE.PT.FROM.ANGLE CENTERPT RADIUSPT ANGLEPT)) + (T (SK.INSURE.POSITION ANGLEPT))) + (SK.INSURE.BRUSH BRUSH) + (SK.INSURE.DASHING DASHING) + (OR (NUMBERP SCALE) + 1.0) + (SK.INSURE.ARROWHEADS ARROWHEADS) + (SK.INSURE.DIRECTION DIRECTION]) (ARC.DRAWFN + [LAMBDA (ARCELT WINDOW REGION) (* rrb "20-Jun-86 17:12") + (* draws a arc from a arc element.) + (PROG ((GARC (fetch (SCREENELT INDIVIDUALGLOBALPART) of ARCELT)) + (LARC (fetch (SCREENELT LOCALPART) of ARCELT)) + BRUSH DASHING LOCALPTS LOCALARROWPTS GARROWSPECS) + (AND REGION (NOT (REGIONSINTERSECTP REGION (SK.ITEM.REGION ARCELT))) + (RETURN)) + (SETQ GARROWSPECS (fetch (ARC ARCARROWHEADS) of GARC)) + (SETQ LOCALARROWPTS (fetch (LOCALARC LOCALARCARROWHEADPTS) of LARC)) + (SETQ BRUSH (fetch (LOCALARC LOCALARCBRUSH) of LARC)) + (SETQ DASHING (fetch (LOCALARC LOCALARCDASHING) of LARC)) + (COND + [(EQ T (fetch (ARC ARCANGLEPT) of GARC)) (* T means greater than 360) + (PROG ((CPT (fetch (LOCALARC LOCALARCCENTERPT) of LARC)) + (RPT (fetch (LOCALARC LOCALARCRADIUSPT) of LARC))) + (RETURN (\CIRCLE.DRAWFN1 CPT RPT (DISTANCEBETWEEN CPT RPT) + BRUSH DASHING WINDOW] + (T (SETQ LOCALPTS (\SK.ADJUST.FOR.ARROWHEADS (fetch (LOCALARC LOCALARCKNOTS) + of LARC) + LOCALARROWPTS GARROWSPECS WINDOW)) + (* draw the curve from the knots) + (DRAWCURVE LOCALPTS NIL BRUSH DASHING WINDOW))) + (DRAWARROWHEADS GARROWSPECS LOCALARROWPTS WINDOW BRUSH]) (ARC.EXPANDFN + [LAMBDA (GARC SCALE) (* rrb "20-Jun-86 13:58") + + (* returns a screen elt that has a arc screen element calculated from the + global part.) + + (PROG ((INDGARC (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARC)) + CENTER RADIUSPT ANGLEPT LOCALKNOTS LOCALARROWHEADS) + (SETQ CENTER (SK.SCALE.POSITION.INTO.VIEWER (fetch (ARC ARCCENTERPT) of INDGARC) + SCALE)) + (SETQ RADIUSPT (SK.SCALE.POSITION.INTO.VIEWER (fetch (ARC ARCRADIUSPT) of INDGARC) + SCALE)) + (SETQ ANGLEPT (SK.SCALE.POSITION.INTO.VIEWER (\SK.GET.ARC.ANGLEPT INDGARC) + SCALE)) + (SETQ LOCALKNOTS (SK.COMPUTE.ARC.PTS CENTER RADIUSPT ANGLEPT (fetch (ARC ARCDIRECTION) + of INDGARC))) + (COND + ((AND (fetch (ARC ARCARROWHEADS) of INDGARC) + (NOT (fetch (ARC ARCARROWHEADPOINTS) of INDGARC))) + + (* check to make sure the global arrowhead points have been calculated. + Old form didn't have them.) + + (SET.ARC.ARROWHEAD.POINTS INDGARC))) + (SETQ LOCALARROWHEADS (SK.EXPAND.ARROWHEADS (fetch (ARC ARCARROWHEADPOINTS) of INDGARC) + SCALE)) + (RETURN (create SCREENELT + LOCALPART _ + (create LOCALARC + LOCALARCCENTERPT _ CENTER + LOCALARCRADIUSPT _ RADIUSPT + LOCALARCANGLEPT _ ANGLEPT + LOCALARCARROWHEADPTS _ LOCALARROWHEADS + LOCALARCBRUSH _ (SCALE.BRUSH (fetch (ARC ARCBRUSH) of INDGARC) + (fetch (ARC ARCINITSCALE) of INDGARC) + SCALE) + LOCALARCKNOTS _ LOCALKNOTS + LOCALARCDASHING _ (fetch (ARC ARCDASHING) of INDGARC)) + GLOBALPART _ GARC]) (ARC.INPUTFN + [LAMBDA (WINDOW) (* rrb "20-May-86 10:53") + + (* reads three points from the user and returns the arc figure element that it + represents.) + + (PROG [CENTER RADPT ANGLEPT DIRECTION (SKCONTEXT (WINDOWPROP WINDOW 'SKETCHCONTEXT] + (SETQ DIRECTION (fetch (SKETCHCONTEXT SKETCHARCDIRECTION) of SKCONTEXT)) + (STATUSPRINT WINDOW " +" "Indicate center of the arc") + (COND + ((SETQ CENTER (SK.READ.POINT.WITH.FEEDBACK WINDOW ELLIPSE.CENTER NIL NIL NIL NIL + SKETCH.USE.POSITION.PAD)) + (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER) + NIL WINDOW)) + (T (CLOSEPROMPTWINDOW WINDOW) + (RETURN NIL))) + (STATUSPRINT WINDOW " +" "Indicate end of the arc") + (COND + [(SETQ RADPT (SK.READ.CIRCLE.POINT WINDOW (fetch (INPUTPT INPUT.POSITION) of CENTER) + (COND + (DIRECTION + + (* use a cursor that shows the arc going in the correct direction.) + + CW.ARC.RADIUS.CURSOR) + (T ARC.RADIUS.CURSOR] + (T (* erase center pt on way out) + (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER) + NIL WINDOW) + (CLOSEPROMPTWINDOW WINDOW) + (RETURN NIL))) + (COND + ((NEQ SKETCH.VERBOSE.FEEDBACK 'ALWAYS) (* if feedback in medium mode, put up + circle) + (SK.INVERT.CIRCLE CENTER RADPT WINDOW)) + (T + + (* if feedback is in very verbose mode, just put up the radius pt.) + + (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of RADPT) + NIL WINDOW))) + (STATUSPRINT WINDOW " +" "Indicate the angle of the arc") + (SETQ ANGLEPT (SK.READ.ARC.ANGLE.POINT WINDOW (COND + (DIRECTION CW.ARC.ANGLE.CURSOR) + (T ARC.ANGLE.CURSOR)) + (fetch (INPUTPT INPUT.POSITION) of CENTER) + (fetch (INPUTPT INPUT.POSITION) of RADPT) + DIRECTION)) + (CLOSEPROMPTWINDOW WINDOW) (* erase the point marks.) + (COND + ((NEQ SKETCH.VERBOSE.FEEDBACK 'ALWAYS) (* if feedback in medium mode, put up + circle) + (SK.INVERT.CIRCLE CENTER RADPT WINDOW)) + (T + + (* if feedback is in very verbose mode, just put up the radius pt.) + + (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of RADPT) + NIL WINDOW))) + (MARK.SPOT (fetch (INPUTPT INPUT.POSITION) of CENTER) + NIL WINDOW) + (OR ANGLEPT (RETURN NIL)) + + (* the list of knots passed to SK.ARROWHEAD.CREATE is only used to determine + right and left so don't bother to create a good one. + Actually this introduces a bug when the angle point is not on the same side of + the radius point as the end of the arc is. + should fix.) + + (RETURN (ARC.CREATE (SK.MAP.INPUT.PT.TO.GLOBAL CENTER WINDOW) + (SK.MAP.INPUT.PT.TO.GLOBAL RADPT WINDOW) + (SK.MAP.INPUT.PT.TO.GLOBAL ANGLEPT WINDOW) + (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKCONTEXT) + (fetch (SKETCHCONTEXT SKETCHDASHING) of SKCONTEXT) + (SK.INPUT.SCALE WINDOW) + (SK.ARROWHEAD.CREATE WINDOW (LIST RADPT ANGLEPT)) + DIRECTION]) (SK.INVERT.CIRCLE + [LAMBDA (CENTERIPT RADIUSIPT SKW) (* rrb "18-Nov-85 14:36") + + (* draws a circle as feedback while the user in inputting the angle point of an + arc.) + + (PROG ((PREVOP (DSPOPERATION 'INVERT SKW))) + (RETURN (PROG1 (SK.SHOW.CIRCLE (fetch (POSITION XCOORD) of (fetch (INPUTPT INPUT.POSITION) + of RADIUSIPT)) + (fetch (POSITION YCOORD) of (fetch (INPUTPT INPUT.POSITION) + of RADIUSIPT)) + SKW + (fetch (INPUTPT INPUT.POSITION) of CENTERIPT)) + (DSPOPERATION PREVOP SKW]) (SK.READ.ARC.ANGLE.POINT + [LAMBDA (WINDOW CURSOR CENTERPT RADIUSPT DIRECTION) (* rrb "20-May-86 10:48") + + (* reads a point from the user prompting them with an arc that follows the + cursor) + + (SK.READ.POINT.WITH.FEEDBACK WINDOW CURSOR (AND (EQ SKETCH.VERBOSE.FEEDBACK 'ALWAYS) + (FUNCTION SK.SHOW.ARC)) + (LIST CENTERPT RADIUSPT DIRECTION) + 'MIDDLE NIL SKETCH.USE.POSITION.PAD]) (SK.SHOW.ARC + [LAMBDA (X Y WINDOW ARCARGS) (* rrb "15-Nov-85 14:32") + + (* draws an arc as feedback for reading the angle point of an arc.) + (* Mark the point too.) + (SHOWSKETCHXY X Y WINDOW) + (DRAWCURVE (SK.COMPUTE.ARC.PTS (CAR ARCARGS) + (CADR ARCARGS) + (create POSITION + XCOORD _ X + YCOORD _ Y) + (CADDR ARCARGS)) + NIL 1 NIL WINDOW]) (ARC.CREATE + [LAMBDA (CENTERPT RADPT ANGLEPT BRUSH DASHING INITSCALE ARROWHEADS DIRECTION) + (* rrb "19-Mar-86 17:19") + (* creates a global arc element.) + (PROG ((ARCANGLEPT (SK.COMPUTE.ARC.ANGLE.PT CENTERPT RADPT ANGLEPT))) + (RETURN (SET.ARC.SCALES (create GLOBALPART + INDIVIDUALGLOBALPART _ + (SET.ARC.ARROWHEAD.POINTS (create ARC + ARCCENTERPT _ CENTERPT + ARCRADIUSPT _ RADPT + ARCBRUSH _ BRUSH + ARCDASHING _ DASHING + ARCINITSCALE _ INITSCALE + ARCARROWHEADS _ ARROWHEADS + ARCANGLEPT _ ARCANGLEPT + ARCDIRECTION _ DIRECTION]) (SK.UPDATE.ARC.AFTER.CHANGE + [LAMBDA (GARCELT) (* rrb " 7-Dec-85 19:52") + + (* updates the dependent fields of a arc element when a field changes.) + + (replace (ARC ARCREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARCELT) with NIL]) (ARC.MOVEFN + [LAMBDA (ARCELT SELPOS NEWPOS WINDOW) (* rrb "15-Dec-86 15:19") + + (* returns a global arc element which has the part SELPOS moved to NEWPOS.) + + (PROG ((LOCALEL (fetch (SCREENELT LOCALPART) of ARCELT)) + (GLOBALEL (fetch (SCREENELT INDIVIDUALGLOBALPART) of ARCELT)) + CENTERPT ANGLEPT RADPT PTSCALE) + (SETQ CENTERPT (fetch (ARC ARCCENTERPT) of GLOBALEL)) + (SETQ ANGLEPT (fetch (ARC ARCANGLEPT) of GLOBALEL)) + (SETQ RADPT (fetch (ARC ARCRADIUSPT) of GLOBALEL)) (* find the point that has moved and + change it.) + [COND + ((EQUAL SELPOS (fetch (LOCALARC LOCALARCCENTERPT) of LOCALEL)) + (SETQ CENTERPT (SK.MAP.FROM.WINDOW.TO.GLOBAL.GRID NEWPOS WINDOW))) + ((EQUAL SELPOS (fetch (LOCALARC LOCALARCANGLEPT) of LOCALEL)) + (SETQ ANGLEPT (SK.MAP.FROM.WINDOW.TO.GLOBAL.GRID NEWPOS WINDOW))) + ((EQUAL SELPOS (fetch (LOCALARC LOCALARCRADIUSPT) of LOCALEL)) + (SETQ RADPT (SK.MAP.FROM.WINDOW.TO.GLOBAL.GRID NEWPOS WINDOW] + + (* return a new global elt because the orientation changes but is needed to + erase the one that is already on the screen.) + + (RETURN (SK.CREATE.ARC.USING CENTERPT RADPT ANGLEPT (fetch (SCREENELT GLOBALPART) + of ARCELT]) (ARC.TRANSLATEPTS + [LAMBDA (ARCELT SELPTS GLOBALDELTA WINDOW) (* rrb "15-Dec-86 15:19") + + (* returns a new global arc element which has the points on SELPTS moved by a + global distance.) + + (PROG ((LOCALEL (fetch (SCREENELT LOCALPART) of ARCELT)) + (GLOBALEL (fetch (SCREENELT INDIVIDUALGLOBALPART) of ARCELT)) + CENTERPT ANGLEPT RADPT PTSCALE) + (SETQ CENTERPT (fetch (ARC ARCCENTERPT) of GLOBALEL)) + (SETQ ANGLEPT (fetch (ARC ARCANGLEPT) of GLOBALEL)) + (SETQ RADPT (fetch (ARC ARCRADIUSPT) of GLOBALEL)) (* find the point that has moved and + change it.) + [COND + ((MEMBER (fetch (LOCALARC LOCALARCCENTERPT) of LOCALEL) + SELPTS) + (SETQ CENTERPT (PTPLUS CENTERPT GLOBALDELTA] + [COND + ((MEMBER (fetch (LOCALARC LOCALARCRADIUSPT) of LOCALEL) + SELPTS) + (SETQ RADPT (PTPLUS RADPT GLOBALDELTA] + [COND + ((MEMBER (fetch (LOCALARC LOCALARCANGLEPT) of LOCALEL) + SELPTS) + (COND + [(EQ ANGLEPT T) + + (* user moved the point that is both the radius pt and the angle pt. + If it was the only point moved, don't move the angle pt, just the radius pt.) + + (COND + ((NULL (CDR SELPTS)) + (SETQ ANGLEPT (fetch (ARC ARCRADIUSPT) of GLOBALEL] + (T (SETQ ANGLEPT (PTPLUS ANGLEPT GLOBALDELTA] + (RETURN (SK.CREATE.ARC.USING CENTERPT RADPT ANGLEPT (fetch (SCREENELT GLOBALPART) + of ARCELT]) (ARC.INSIDEFN + [LAMBDA (GARC WREG) (* rrb "20-Jan-87 14:44") + + (* determines if the global arc GARC is inside of WREG.) + + (REGIONSINTERSECTP WREG (ARC.GLOBALREGIONFN GARC]) (ARC.REGIONFN + [LAMBDA (ARCSCRELT) (* rrb "30-May-85 12:23") + (* returns the region occuppied by an + arc.) + + (* uses the heuristic that the region containing the curve is not more than + 10% larger than the knots. This was determined empirically on several curves.) + + (INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS (fetch (LOCALARC LOCALARCKNOTS) + of (fetch (SCREENELT LOCALPART) + of ARCSCRELT))) + 1.1) + (IQUOTIENT [ADD1 (SK.BRUSH.SIZE (fetch (LOCALARC LOCALARCBRUSH) of (fetch (SCREENELT + LOCALPART) + of ARCSCRELT] + 2]) (ARC.GLOBALREGIONFN + [LAMBDA (GARCELT) (* rrb "20-Jun-86 14:04") + + (* returns the global region occupied by a global arc element.) + + (OR (fetch (ARC ARCREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARCELT)) + (PROG ((INDVARC (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARCELT)) + REGION) + + (* uses the heuristic that the region containing the curve is not more than + 10% larger than the knots. This was determined empirically on several curves.) + + [SETQ REGION (INCREASEREGION (EXPANDREGION (REGION.CONTAINING.PTS + (SK.COMPUTE.ARC.PTS (fetch (ARC ARCCENTERPT + ) + of INDVARC) + (fetch (ARC ARCRADIUSPT) + of INDVARC) + (\SK.GET.ARC.ANGLEPT INDVARC) + (fetch (ARC ARCDIRECTION) + of INDVARC))) + 1.1) + (SK.BRUSH.SIZE (fetch (ARC ARCBRUSH) of INDVARC] + (replace (ARC ARCREGION) of INDVARC with REGION) + (RETURN REGION]) (ARC.TRANSLATE + [LAMBDA (GARCELT DELTAPOS) (* rrb "15-Dec-86 15:20") + + (* returns a global arc element which has the arc translated by DELTAPOS.) + + (PROG ((GLOBALEL (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GARCELT))) + (RETURN (SK.CREATE.ARC.USING (PTPLUS (fetch (ARC ARCCENTERPT) of GLOBALEL) + DELTAPOS) + (PTPLUS (fetch (ARC ARCRADIUSPT) of GLOBALEL) + DELTAPOS) + (COND + ((POSITIONP (fetch (ARC ARCANGLEPT) of GLOBALEL)) + (PTPLUS (fetch (ARC ARCANGLEPT) of GLOBALEL) + DELTAPOS)) + (T (* T marks greater than 360) + T)) + GARCELT]) (ARC.TRANSFORMFN + [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "15-Dec-86 15:20") + + (* returns a copy of the global element that has had each of its control points + transformed by transformfn. TRANSFORMDATA is arbitrary data that is passed to + tranformfn.) + + (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) + NEWGELT) + (SETQ NEWGELT (SK.CREATE.ARC.USING (SK.TRANSFORM.POINT (fetch (ARC ARCCENTERPT) + of INDVPART) + TRANSFORMFN TRANSFORMDATA) + (SK.TRANSFORM.POINT (fetch (ARC ARCRADIUSPT) of INDVPART) + TRANSFORMFN TRANSFORMDATA) + (COND + ((POSITIONP (fetch (ARC ARCANGLEPT) of INDVPART)) + (SK.TRANSFORM.POINT (fetch (ARC ARCANGLEPT) of INDVPART) + TRANSFORMFN TRANSFORMDATA)) + (T (* T marks greater than 360) + T)) + GELT)) (* update the brush too.) + (replace (ARC ARCBRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWGELT) + with (SK.TRANSFORM.BRUSH (fetch (ARC ARCBRUSH) of INDVPART) + SCALEFACTOR)) + (replace (ARC ARCARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWGELT) + with (SK.TRANSFORM.ARROWHEADS (fetch (ARC ARCARROWHEADS) of INDVPART) + SCALEFACTOR)) + (SET.ARC.ARROWHEAD.POINTS (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWGELT)) + [AND (EQ TRANSFORMFN 'SK.APPLY.AFFINE.TRANSFORM) + (COND + ([COND + [(GREATERP 0.0 (fetch (AFFINETRANSFORMATION Ax) of TRANSFORMDATA)) + + (* x coord is reflected, switch direction unless Y is reflected also.) + + (NOT (GREATERP 0.0 (fetch (AFFINETRANSFORMATION Ey) of TRANSFORMDATA] + (T (GREATERP 0.0 (fetch (AFFINETRANSFORMATION Ey) + TRANSFORMDATA] (* change the direction if the + transformation reflects.) + (replace (ARC ARCDIRECTION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of NEWGELT) + with (NOT (fetch (ARC ARCDIRECTION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART] + (RETURN NEWGELT]) (ARC.READCHANGEFN + [LAMBDA (SKW SCRNELTS) (* rrb "17-Dec-85 16:22") + (* changefn for arcs) + (PROG (ASPECT HOW) + (SETQ HOW (SELECTQ [SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU + (create MENU + CENTERFLG _ T + TITLE _ "Which aspect?" + ITEMS _ (APPEND [COND + ((SKETCHINCOLORP) + '((Color 'BRUSHCOLOR + "changes the color of the outline" + ] + '((Arrowheads 'ARROW + "allows changing of arrow head charactistics." + ) + (Size 'SIZE + "changes the size of the brush" + ) + (Angle 'ANGLE + "changes the amount of angle in the arc." + ) + (Dashing 'DASHING + "changes the dashing of the line." + ) + (Direction 'DIRECTION + "changes which way around the circle the arc is drawn." + ] + (SIZE (READSIZECHANGE "Change size how?")) + (ANGLE (READANGLE)) + (ARROW (READ.ARROW.CHANGE SCRNELTS)) + (DASHING (READ.DASHING.CHANGE)) + (DIRECTION (READARCDIRECTION)) + (BRUSHCOLOR [READ.COLOR.CHANGE "Change color how?" NIL + (fetch (BRUSH BRUSHCOLOR) + of (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) + of (CAR SCRNELTS)) + 'BRUSH]) + NIL)) + (RETURN (AND HOW (LIST ASPECT HOW]) ) (DEFINEQ (SK.COMPUTE.ARC.ANGLE.PT + [LAMBDA (CENTERPT RADPT ANGLEPT) (* rrb "26-Jun-86 17:04") + + (* computes the intersection of the line CENTERPT ANGLEPT with the circle with + center CENTERPT that goes through RADPT.) + + (COND + ((EQ ANGLEPT T) (* used to mark more than 360.0) + T) + (T (PROG ((RADIUS (DISTANCEBETWEEN CENTERPT RADPT)) + (ARCANGLE (SK.COMPUTE.SLOPE.OF.LINE CENTERPT ANGLEPT))) + (RETURN (create POSITION + XCOORD _ (PLUS (fetch (POSITION XCOORD) of CENTERPT) + (TIMES RADIUS (COS ARCANGLE))) + YCOORD _ (PLUS (fetch (POSITION YCOORD) of CENTERPT) + (TIMES RADIUS (SIN ARCANGLE]) (SK.COMPUTE.ARC.ANGLE.PT.FROM.ANGLE + [LAMBDA (CENTERPT RADPT ANGLE) (* rrb " 7-Jul-86 14:49") + + (* computes the point on the circle with center CENTERPT that goes through + RADPT that is angle ANGLE from RADPT.) + + (COND + ((OR (GEQ ANGLE 360.0) + (LEQ ANGLE -360.0)) (* T denotes all the way around.) + T) + (T (PROG ((RADIUS (DISTANCEBETWEEN CENTERPT RADPT)) + (DELTA (PLUS (SK.COMPUTE.SLOPE.OF.LINE CENTERPT RADPT) + ANGLE))) + (RETURN (create POSITION + XCOORD _ (PLUS (fetch (POSITION XCOORD) of CENTERPT) + (TIMES RADIUS (COS DELTA))) + YCOORD _ (PLUS (fetch (POSITION YCOORD) of CENTERPT) + (TIMES RADIUS (SIN DELTA]) (SK.COMPUTE.ARC.PTS + [LAMBDA (CENTERPT RADIUSPT ARCPT DIRECTION) (* DECLARATIONS%: FLOATING) + (* rrb " 5-May-86 14:11") + + (* computes a list of knots that a spline goes through to make an arc) + + (PROG ((RADIUS (DISTANCEBETWEEN CENTERPT RADIUSPT)) + (ALPHA (SK.COMPUTE.SLOPE.OF.LINE CENTERPT RADIUSPT)) + (OMEGA (SK.COMPUTE.SLOPE.OF.LINE CENTERPT ARCPT)) + (CENTERX (fetch (POSITION XCOORD) of CENTERPT)) + (CENTERY (fetch (POSITION YCOORD) of CENTERPT)) + PTLST ANGLEINCR DEGREESARC) + [COND + [DIRECTION (* if non-NIL go in a counterclockwise + direction.) + (COND + ((GREATERP OMEGA ALPHA) + (SETQ OMEGA (DIFFERENCE OMEGA 360.0] + (T (COND + ((GREATERP ALPHA OMEGA) (* angle crosses angle change point, + correct.) + (SETQ OMEGA (PLUS OMEGA 360.0] + + (* calculate an increment close to 10.0 that is exact but always have at least + 5 knots and don't have more than a knot every 5 pts) + + [SETQ ANGLEINCR (FQUOTIENT (SETQ DEGREESARC (DIFFERENCE OMEGA ALPHA)) + (IMIN (IMAX (ABS (FIX (FQUOTIENT DEGREESARC 10.0))) + 5) + (PROGN (* don't have more than a knot every 5 + pts) + (IMAX (ABS (FIX (QUOTIENT (TIMES RADIUS 6.3 + (QUOTIENT DEGREESARC + 360.0)) + 4))) + 3] + + (* go from initial point to just past the last point. + The just past (PLUS OMEGA (QUOTIENT ANGLEINCR 5.0)) picks up the case where the + floating pt rounding error accumulates to be greater than the last point when + it is very close to it.) + + [SETQ PTLST (for ANGLE from ALPHA to (PLUS OMEGA (QUOTIENT ANGLEINCR 5.0)) by ANGLEINCR + collect (create POSITION + XCOORD _ (PLUS CENTERX (TIMES RADIUS (COS ANGLE))) + YCOORD _ (PLUS CENTERY (TIMES RADIUS (SIN ANGLE] + (* add first and last points exactly. + (CONS RADIUSPT (NCONC1 PTLST + (create POSITION XCOORD _ + (FIXR (PLUS CENTERX (TIMES RADIUS + (COS OMEGA)))) YCOORD _ + (FIXR (PLUS CENTERY (TIMES RADIUS + (SIN OMEGA)))))))) + (RETURN PTLST]) (SK.SET.ARC.DIRECTION + [LAMBDA (SKW NEWDIR) (* rrb "31-May-85 17:29") + + (* * reads a value of arc direction and makes it the default) + + (PROG [(LOCALNEWDIR (OR NEWDIR (READARCDIRECTION "Which way should new arcs go?"] + (RETURN (AND LOCALNEWDIR (replace (SKETCHCONTEXT SKETCHARCDIRECTION) + of (WINDOWPROP SKW 'SKETCHCONTEXT) with (EQ LOCALNEWDIR + 'CLOCKWISE]) (SK.SET.ARC.DIRECTION.CW + [LAMBDA (SKW) (* sets the default to clockwise) + (SK.SET.ARC.DIRECTION SKW 'CLOCKWISE]) (SK.SET.ARC.DIRECTION.CCW + [LAMBDA (SKW) (* sets the default direction of arcs + to counterclockwise) + (SK.SET.ARC.DIRECTION SKW 'COUNTERCLOCKWISE]) (SK.COMPUTE.SLOPE.OF.LINE + [LAMBDA (PT1 PT2) (* rrb "31-May-85 12:26") + (* computes the angle of a line) + (SK.COMPUTE.SLOPE (DIFFERENCE (fetch (POSITION XCOORD) of PT2) + (fetch (POSITION XCOORD) of PT1)) + (DIFFERENCE (fetch (POSITION YCOORD) of PT2) + (fetch (POSITION YCOORD) of PT1]) (SK.CREATE.ARC.USING + [LAMBDA (CENTERPT RADPT ANGLEPT GARCELT) (* rrb "15-Dec-86 15:20") + + (* creates an arc global element that is like another one but has different + positions.) + + (SET.ARC.SCALES (create GLOBALPART + COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) + of GARCELT)) + INDIVIDUALGLOBALPART _ + (SET.ARC.ARROWHEAD.POINTS (create ARC + using (fetch (GLOBALPART INDIVIDUALGLOBALPART + ) of GARCELT) + ARCCENTERPT _ CENTERPT ARCRADIUSPT _ + RADPT ARCANGLEPT _ + (SK.COMPUTE.ARC.ANGLE.PT CENTERPT RADPT + ANGLEPT) + ARCREGION _ NIL]) (SET.ARC.SCALES + [LAMBDA (GARCELT) (* rrb "30-May-85 11:33") + + (* updates the scale fields of an arc. Called upon creation and when a point is + moved.) + + (PROG [(RAD (DISTANCEBETWEEN (fetch (ARC ARCCENTERPT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GARCELT)) + (fetch (ARC ARCRADIUSPT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GARCELT] + (replace (GLOBALPART MAXSCALE) of GARCELT with RAD) + (replace (GLOBALPART MINSCALE) of GARCELT with (QUOTIENT RAD 3000.0)) + (RETURN GARCELT]) ) (DEFINEQ (SK.INSURE.DIRECTION + [LAMBDA (DIR) (* rrb "16-Oct-85 16:11") + + (* decodes a DIRECTION spec which indicates whether an arc goes clockwise or + counterclockwise. T is CLOCKWISE. NIL is COUNTERCLOCKWISE.) + + (SELECTQ DIR + ((NIL COUNTERCLOCKWISE) + NIL) + ((T CLOCKWISE) + T) + (\ILLEGAL.ARC DIR]) ) (RPAQ? SK.NUMBER.OF.POINTS.IN.ARC 8) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SK.NUMBER.OF.POINTS.IN.ARC) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (TYPERECORD ARC (ARCCENTERPT ARCRADIUSPT ARCBRUSH ARCDASHING ARCINITSCALE ARCARROWHEADS ARCANGLEPT ARCDIRECTION ARCREGION ARCARROWHEADPOINTS)) (RECORD LOCALARC ((LOCALARCCENTERPT LOCALARCRADIUSPT LOCALARCANGLEPT) LOCALHOTREGION LOCALARCARROWHEADPTS LOCALARCBRUSH LOCALARCKNOTS LOCALARCDASHING )) ) ) (RPAQ ARC.RADIUS.CURSOR (CURSORCREATE (QUOTE #*(16 16)@@@L@@@D@@@F@@@B@@@C@@LA@@OA@@CMOOOO@@CL@@O@@@L@@@@@@@@@@@@@@@@@ ) (QUOTE NIL) 15 7)) (RPAQ ARC.ANGLE.CURSOR (CURSORCREATE (QUOTE #*(16 16)@AN@@ACL@CHG@CHA@GL@@GL@@MF@@MF@@A@@@A@@@A@@@A@@@A@@@A@@@A@@@A@@ ) (QUOTE NIL) 7 15)) (RPAQ CW.ARC.ANGLE.CURSOR (CURSORCREATE (QUOTE #*(16 16)@O@@GI@@LCH@@CH@@GL@@GL@@MF@@MF@@A@@@A@@@A@@@A@@@A@@@A@@@A@@@A@@ ) (QUOTE NIL) 7 15)) (RPAQ CW.ARC.RADIUS.CURSOR (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@L@@@O@@@CLOOOO@@CM@@OA@@LC@@@B@@@F@@@L@@AH ) (QUOTE NIL) 15 7)) (READVARS-FROM-STRINGS '(ARCICON) "({(READBITMAP)(20 13 %"@@@@@@@@%" %"@AOH@@@@%" %"@COL@@@@%" %"@G@N@@@@%" %"@F@F@@@@%" %"@N@G@@@@%" %"@L@C@@@@%" %"@@@C@@@@%" %"@@@G@@@@%" %"@@@F@@@@%" %"@@@N@@@@%" %"@@@L@@@@%" %"@@@@@@@@%")}) ") (* ; "property getting and setting stuff") (DEFINEQ (GETSKETCHELEMENTPROP + [LAMBDA (ELEMENT PROPERTY) (* rrb "26-Jun-86 14:16") + (* gets the property from a sketch + element.) + + (* knows about and sets the system ones specially. + All others go to the elements property list.) + + (SELECTQ PROPERTY + (TYPE (fetch (GLOBALPART GTYPE) of ELEMENT)) + (SCALE (\SKELT.GET.SCALE ELEMENT)) + (REGION (SK.ELEMENT.GLOBAL.REGION ELEMENT)) + ((POSITION 1STCONTROLPT) + (\SK.GET.1STCONTROLPT ELEMENT)) + (2NDCONTROLPT (\SK.GET.2NDCONTROLPT ELEMENT)) + (3RDCONTROLPT (\SK.GET.3RDCONTROLPT ELEMENT)) + (DATA (\SKELT.GET.DATA ELEMENT)) + (BRUSH (\SK.GET.BRUSH ELEMENT)) + (FILLING (\SK.GET.FILLING ELEMENT)) + (DASHING (\SK.GET.DASHING ELEMENT)) + (ARROWHEADS (\SK.GET.ARROWHEADS ELEMENT)) + (FONT (\SK.GET.FONT ELEMENT)) + (JUSTIFICATION (\SK.GET.JUSTIFICATION ELEMENT)) + (DIRECTION (\SK.GET.DIRECTION ELEMENT)) + (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of ELEMENT) + PROPERTY]) (\SK.GET.ARC.ANGLEPT + [LAMBDA (INDVARCELT) (* rrb "20-Jun-86 13:54") + + (* returns the arc point of an individual arc element. + Special because T is used to denote arcs of greater than 360 degrees.) + + (COND + ((POSITIONP (fetch (ARC ARCANGLEPT) of INDVARCELT))) + (T (* for arcs of greater than 360 degrees, the radiuspt is T and is marked as + being the same as the radius pt.) + (fetch (ARC ARCRADIUSPT) of INDVARCELT]) (\GETSKETCHELEMENTPROP1 + [LAMBDA (ELEMENT PROPERTY) + + (* * version of GETSKETCHELEMENTPROP that doesn't look for system properties.) + + (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of ELEMENT) + PROPERTY]) (\SK.GET.BRUSH + [LAMBDA (GELT) (* rrb " 7-Dec-85 19:52") + + (* gets the brush field from a global sketch element instance.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE BOX) + (fetch (WIRE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + ((CIRCLE ARC) + (fetch (CIRCLE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (ELLIPSE (fetch (ELLIPSE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (TEXTBOX (fetch (TEXTBOX TEXTBOXBRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT))) + (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + 'BRUSH]) (\SK.GET.FILLING + [LAMBDA (GELT) (* rrb " 7-Dec-85 18:58") + + (* gets the filling field from a global sketch element instance.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + ((CLOSEDWIRE CLOSEDCURVE BOX) + (fetch (CLOSEDWIRE CLOSEDWIREFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT))) + (CIRCLE (fetch (CIRCLE CIRCLEFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT))) + (ELLIPSE (fetch (ELLIPSE ELLIPSEFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT))) + (TEXTBOX (fetch (TEXTBOX TEXTBOXFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT))) + (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + 'FILLING]) (\SK.GET.ARROWHEADS + [LAMBDA (GELT) (* rrb " 7-Dec-85 19:17") + + (* gets the arrowhead field from a global sketch element instance.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + (WIRE (fetch (WIRE WIREARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (OPENCURVE (fetch (OPENCURVE CURVEARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT))) + (ARC (fetch (ARC ARCARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + 'ARROWHEADS]) (\SK.GET.FONT + [LAMBDA (GELT) (* rrb " 7-Dec-85 19:22") + + (* gets the font field from a global sketch element instance.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + ((TEXT TEXTBOX) + (fetch (TEXT FONT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + 'FONT]) (\SK.GET.JUSTIFICATION + [LAMBDA (GELT) (* ; "Edited 8-Jan-87 19:46 by rrb") + + (* gets the justification field from a global sketch element instance.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + ((TEXT TEXTBOX) + (fetch (TEXT TEXTSTYLE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + 'JUSTIFICATION]) (\SK.GET.DIRECTION + [LAMBDA (GELT) (* rrb " 7-Dec-85 19:21") + + (* gets the direction field from a global sketch element instance.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + (ARC (fetch (ARC ARCDIRECTION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + 'DIRECTION]) (\SK.GET.DASHING + [LAMBDA (GELT) (* rrb " 7-Dec-85 20:05") + + (* gets the dashing field from a global sketch element instance.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + ((WIRE CIRCLE ARC) + (fetch (WIRE OPENWIREDASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + ((CLOSEDWIRE OPENCURVE CLOSEDCURVE BOX) + (fetch (CLOSEDWIRE CLOSEDWIREDASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT))) + (ELLIPSE (fetch (ELLIPSE DASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (TEXTBOX (fetch (TEXTBOX TEXTBOXDASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT))) + (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + 'DASHING]) (PUTSKETCHELEMENTPROP + [LAMBDA (ELEMENT PROPERTY VALUE SKETCHTOUPDATE) (* rrb "26-Jun-86 16:46") + (* puts the property from a sketch + element.) + + (* knows about and sets the system ones specially. + All others go to the elements property list.) + (* mostly not implemented yet.) + (PROG1 (GETSKETCHELEMENTPROP ELEMENT PROPERTY) + (AND (SELECTQ PROPERTY + (TYPE (ERROR "Can't change types")) + (SCALE (\SKELT.PUT.SCALE ELEMENT VALUE) + T) + (REGION (ERROR "Not implemented yet")) + ((POSITION 1STCONTROLPT) + (\SK.PUT.1STCONTROLPT ELEMENT VALUE)) + (2NDCONTROLPT (\SK.PUT.2NDCONTROLPT ELEMENT VALUE)) + (3RDCONTROLPT (\SK.PUT.3RDCONTROLPT ELEMENT VALUE)) + (DATA (\SKELT.PUT.DATA ELEMENT VALUE SKETCHTOUPDATE)) + (BRUSH (\SK.PUT.BRUSH ELEMENT VALUE SKETCHTOUPDATE)) + (FILLING (\SK.PUT.FILLING ELEMENT VALUE)) + (DASHING (\SK.PUT.DASHING ELEMENT VALUE)) + (ARROWHEADS (\SK.PUT.ARROWHEADS ELEMENT VALUE)) + (FONT (\SK.PUT.FONT ELEMENT VALUE)) + (JUSTIFICATION (\SK.PUT.JUSTIFICATION ELEMENT VALUE)) + (DIRECTION (\SK.PUT.DIRECTION ELEMENT VALUE)) + (PROG ((PLIST (fetch (GLOBALPART SKELEMENTPROPLIST) of ELEMENT))) + [COND + (PLIST (LISTPUT PLIST PROPERTY VALUE)) + (T (replace (GLOBALPART SKELEMENTPROPLIST) of ELEMENT + with (LIST PROPERTY VALUE] + + (* if it wasn't a system recognized property, return NIL so it won't be + redisplayed.) + + (RETURN NIL))) + SKETCHTOUPDATE + (SKETCH.UPDATE SKETCHTOUPDATE ELEMENT]) (\SK.PUT.FILLING + [LAMBDA (GELT NEWVALUE) (* rrb "26-Jun-86 16:44") + + (* sets the filling field from a global sketch element instance.) + + (OR (SKFILLINGP NEWVALUE) + (\ILLEGAL.ARG NEWVALUE)) + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + ((CLOSEDWIRE CLOSEDCURVE BOX) + (replace (CLOSEDWIRE CLOSEDWIREFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT) with NEWVALUE)) + (CIRCLE (replace (CIRCLE CIRCLEFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT) with NEWVALUE)) + (ELLIPSE (replace (ELLIPSE ELLIPSEFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT) with NEWVALUE)) + (TEXTBOX (replace (TEXTBOX TEXTBOXFILLING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT) with NEWVALUE)) + (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + 'FILLING NEWVALUE)) + T]) (ADDSKETCHELEMENTPROP + [LAMBDA (ELEMENT PROPERTY VALUE SKETCHTOUPDATE) (* rrb "11-Dec-85 15:17") + + (* adds a value to the list of values for a property of a sketch element.) + + (PROG ((NOWVALUE (GETSKETCHELEMENTPROP ELEMENT PROPERTY))) + (RETURN (PUTSKETCHELEMENTPROP ELEMENT PROPERTY [COND + ((NULL NOWVALUE) + (LIST VALUE)) + ((NLISTP NOWVALUE) + (LIST NOWVALUE VALUE)) + (T (APPEND NOWVALUE (CONS VALUE] + SKETCHTOUPDATE]) (REMOVESKETCHELEMENTPROP + [LAMBDA (ELEMENT PROPERTY VALUE SKETCHTOUPDATE) (* rrb "11-Dec-85 15:17") + + (* removes a value to the list of values for a property of a sketch element.) + + (PROG ((NOWVALUE (GETSKETCHELEMENTPROP ELEMENT PROPERTY))) + (RETURN (PUTSKETCHELEMENTPROP ELEMENT PROPERTY (COND + ((EQ NOWVALUE VALUE) + NIL) + ((NLISTP NOWVALUE) + NOWVALUE) + (T (REMOVE VALUE NOWVALUE))) + SKETCHTOUPDATE]) (\SK.PUT.FONT + [LAMBDA (GELT NEWVALUE) (* rrb "26-Jun-86 17:04") + + (* sets the font field from a global sketch element instance.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + (TEXT (replace (TEXT FONT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) + with (SK.INSURE.TEXT NEWVALUE)) + (SK.UPDATE.TEXT.AFTER.CHANGE GELT)) + (TEXTBOX (replace (TEXTBOX FONT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) + with (SK.INSURE.TEXT NEWVALUE)) + (SK.UPDATE.TEXTBOX.AFTER.CHANGE GELT)) + (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + 'FONT NEWVALUE)) + T]) (\SK.PUT.JUSTIFICATION + [LAMBDA (GELT NEWVALUE) (* rrb "26-Jun-86 16:45") + + (* sets the justification field from a global sketch element instance.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + (TEXT (replace (TEXT TEXTSTYLE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) + with (SK.INSURE.STYLE NEWVALUE SK.DEFAULT.TEXT.ALIGNMENT)) + (SK.UPDATE.TEXT.AFTER.CHANGE GELT)) + (TEXTBOX (replace (TEXTBOX TEXTSTYLE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT) with (SK.INSURE.STYLE NEWVALUE + SK.DEFAULT.TEXT.ALIGNMENT)) + (SK.UPDATE.TEXTBOX.AFTER.CHANGE GELT)) + (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + 'JUSTIFICATION NEWVALUE)) + T]) (\SK.PUT.DIRECTION + [LAMBDA (GELT NEWVALUE) (* rrb "26-Jun-86 16:45") + + (* puts the direction field from a global sketch element instance.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + (ARC (replace (ARC ARCDIRECTION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) + with (SK.INSURE.DIRECTION NEWVALUE)) + (SK.UPDATE.ARC.AFTER.CHANGE GELT)) + (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + 'DIRECTION NEWVALUE)) + T]) (\SK.PUT.DASHING + [LAMBDA (GELT NEWVALUE) (* rrb "26-Jun-86 16:44") + (* sets the dashing field of a global + sketch element.) + (OR (NULL NEWVALUE) + (DASHINGP NEWVALUE) + (\ILLEGAL.ARG NEWVALUE)) + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + ((WIRE CIRCLE ARC) + (replace (WIRE OPENWIREDASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) + with NEWVALUE)) + ((CLOSEDWIRE OPENCURVE CLOSEDCURVE BOX) + (replace (CLOSEDWIRE CLOSEDWIREDASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT) with NEWVALUE)) + (ELLIPSE (replace (ELLIPSE DASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) + with NEWVALUE)) + (TEXTBOX (replace (TEXTBOX TEXTBOXDASHING) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT) with NEWVALUE)) + (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + 'DASHING NEWVALUE)) + T]) (\SK.PUT.BRUSH + [LAMBDA (GELT NEWVALUE SKETCHTOUPDATE) (* rrb "26-Jun-86 16:44") + + (* sets the brush field from a global sketch element instance.) + + (COND + [(NUMBERP NEWVALUE) + (SETQ NEWVALUE (create BRUSH + BRUSHSIZE _ NEWVALUE + BRUSHSHAPE _ 'ROUND] + ((BRUSHP NEWVALUE)) + (T (\ILLEGAL.ARG NEWVALUE))) + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE) + (replace (WIRE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE + ) + (SK.UPDATE.WIRE.ELT.AFTER.CHANGE GELT)) + (BOX (replace (BOX BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) with NEWVALUE)) + (CIRCLE (replace (CIRCLE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) + with NEWVALUE) + (SK.UPDATE.CIRCLE.AFTER.CHANGE GELT)) + (ARC (replace (ARC ARCBRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) + with NEWVALUE) + (SK.UPDATE.ARC.AFTER.CHANGE GELT)) + (ELLIPSE (replace (ELLIPSE BRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT) + with NEWVALUE) + (SK.UPDATE.ELLIPSE.AFTER.CHANGE GELT)) + (TEXTBOX (AND SKETCHTOUPDATE (SKETCH.CLEANUP SKETCHTOUPDATE)) + (replace (TEXTBOX TEXTBOXBRUSH) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT) with NEWVALUE) + (SK.UPDATE.TEXTBOX.AFTER.CHANGE GELT)) + (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + 'BRUSH NEWVALUE)) + T]) (\SK.PUT.ARROWHEADS + [LAMBDA (GELT NEWVALUE) (* rrb "26-Jun-86 16:45") + + (* sets the arrowhead field from a global sketch element instance.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + (WIRE (replace (WIRE WIREARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT + with (SK.INSURE.ARROWHEADS NEWVALUE))) + (SET.WIRE.ARROWHEAD.POINTS (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (OPENCURVE (replace (OPENCURVE CURVEARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT with (SK.INSURE.ARROWHEADS + NEWVALUE))) + (SET.OPENCURVE.ARROWHEAD.POINTS (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT))) + (ARC (replace (ARC ARCARROWHEADS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT + with (SK.INSURE.ARROWHEADS NEWVALUE))) + (SET.ARC.ARROWHEAD.POINTS (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + 'ARROWHEADS NEWVALUE)) + T]) (SK.COPY.ELEMENT.PROPERTY.LIST + [LAMBDA (ELEMENT OLDELEMENT) (* rrb " 6-May-86 11:01") + + (* copies the property list of an element from OLDELEMENT if it is given, from + itself otherwise.) + + (replace (GLOBALPART SKELEMENTPROPLIST) of ELEMENT with (APPEND (fetch (GLOBALPART + SKELEMENTPROPLIST) + of (OR OLDELEMENT ELEMENT]) (SKETCH.UPDATE + [LAMBDA (SKETCH ELEMENTS) (* rrb " 6-Dec-85 14:40") + (* updates all or part of a sketch.) + (PROG ((SKSTRUC (INSURE.SKETCH SKETCH)) + ALLVIEWERS) + (SETQ ALLVIEWERS (ALL.SKETCH.VIEWERS SKSTRUC)) + (COND + ((NULL ELEMENTS) + (for SKW in ALLVIEWERS do (SK.UPDATE.AFTER.SCALE.CHANGE SKW))) + ((GLOBALELEMENTP ELEMENTS) + (SKETCH.UPDATE1 ELEMENTS ALLVIEWERS)) + ((LISTP ELEMENTS) + (for ELT in ELEMENTS do (SKETCH.UPDATE1 ELT ALLVIEWERS))) + (T (\ILLEGAL.ARG ELEMENTS]) (SKETCH.UPDATE1 + [LAMBDA (GELT VIEWERS) (* rrb "26-Sep-86 14:49") + (* updates the element GELT in the + sketch viewers VIEWERS.) + (bind SELECTION for SKW in VIEWERS do (COND + ((AND [SCREENELEMENTP (SETQ SELECTION + (fetch (TEXTELTSELECTION + SKTEXTELT) + of (WINDOWPROP SKW + 'SELECTION] + (EQ GELT (fetch (SCREENELT GLOBALPART) + of SELECTION))) + + (* if the element being updated is the current text selection, clear the + selection.) + + (SKED.CLEAR.SELECTION SKW))) + (SK.UPDATE.ELEMENT1 GELT GELT SKW T]) (\SKELT.GET.SCALE + [LAMBDA (GELT) (* rrb "29-Oct-85 13:44") + + (* gets the scale field from a global sketch element instance.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + ((TEXT TEXTBOX SKIMAGEOBJ BITMAPELT) + (fetch (TEXT INITIALSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + ((WIRE OPENCURVE CIRCLE ARC) + (fetch (WIRE OPENWIREINITSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + ((CLOSEDWIRE CLOSEDCURVE BOX) + (fetch (CLOSEDWIRE CLOSEDWIREINITSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT))) + (ELLIPSE (fetch (ELLIPSE ELLIPSEINITSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT))) + NIL]) (\SKELT.PUT.SCALE + [LAMBDA (GELT NEWVALUE) (* rrb "16-Oct-85 21:24") + + (* sets the scale field of a global sketch element instance.) + + (COND + ((NUMBERP NEWVALUE) + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + ((TEXT TEXTBOX SKIMAGEOBJ BITMAPELT) + (replace (TEXT INITIALSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT) with NEWVALUE)) + ((WIRE OPENCURVE CIRCLE ARC) + (replace (WIRE OPENWIREINITSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT) with NEWVALUE)) + ((CLOSEDWIRE CLOSEDCURVE BOX) + (replace (CLOSEDWIRE CLOSEDWIREINITSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART + ) of GELT) with NEWVALUE)) + (ELLIPSE (replace (ELLIPSE ELLIPSEINITSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT) with NEWVALUE)) + NIL)) + (T (\ILLEGAL.ARG NEWVALUE]) (\SKELT.PUT.DATA + [LAMBDA (GELT NEWVALUE SKETCHTOUPDATE) (* rrb "26-Jun-86 16:40") + (* changes the data of a sketch + element.) + + (* this is harder than it seems because all of the dependent fields must be + updated also - + lots of grubby details duplicated.) + + (PROG ((INDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + (GROUP (COND + ([OR (NLISTP NEWVALUE) + (NOT (EVERY NEWVALUE (FUNCTION GLOBALELEMENTP] + (\ILLEGAL.ARG NEWVALUE))) + (replace (GROUP LISTOFGLOBALELTS) of INDVELT with NEWVALUE) + (SK.UPDATE.GROUP.AFTER.CHANGE GELT)) + ((TEXT TEXTBOX) + + (* before changing the text element, make sure any interactive editing is + closed off.) + + (AND SKETCHTOUPDATE (SKETCH.CLEANUP SKETCHTOUPDATE)) + (SK.REPLACE.TEXT.IN.ELEMENT GELT (SK.INSURE.TEXT NEWVALUE))) + (BITMAPELT (replace (BITMAPELT SKBITMAP) of INDVELT with NEWVALUE)) + (SKIMAGEOBJ (replace (SKIMAGEOBJ SKIMAGEOBJ) of INDVELT with NEWVALUE) + (SK.UPDATE.IMAGEOBJECT.AFTER.CHANGE GELT)) + ((WIRE OPENCURVE CLOSEDWIRE CLOSEDCURVE) + (replace (WIRE LATLONKNOTS) of INDVELT with NEWVALUE) + (SK.UPDATE.WIRE.ELT.AFTER.CHANGE GELT)) + (RETURN NIL)) + (RETURN T]) (SK.REPLACE.TEXT.IN.ELEMENT + [LAMBDA (GTEXTELT NEWSTRS) (* rrb "15-Dec-85 18:00") + (* changes the characters in a text or + textbox element.) + (SELECTQ (fetch (GLOBALPART GTYPE) of GTEXTELT) + (TEXTBOX (replace (TEXTBOX LISTOFCHARACTERS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GTEXTELT) with (OR NEWSTRS (CONS ""))) + (SK.UPDATE.TEXTBOX.AFTER.CHANGE GTEXTELT)) + (TEXT (replace (TEXT LISTOFCHARACTERS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GTEXTELT) with NEWSTRS) + (SK.UPDATE.TEXT.AFTER.CHANGE GTEXTELT)) + (\ILLEGAL.ARG GTEXTELT)) + GTEXTELT]) (\SKELT.GET.DATA + [LAMBDA (GELT) (* rrb " 6-Dec-85 14:52") + (* changes the data of a sketch + element.) + (PROG ((INDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + (RETURN (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + (GROUP (fetch (GROUP LISTOFGLOBALELTS) of INDVELT)) + ((TEXT TEXTBOX) + (fetch (TEXT LISTOFCHARACTERS) of INDVELT)) + (BITMAPELT (fetch (BITMAPELT SKBITMAP) of INDVELT)) + (SKIMAGEOBJ (fetch (SKIMAGEOBJ SKIMAGEOBJ) of INDVELT)) + ((WIRE OPENCURVE CLOSEDWIRE CLOSEDCURVE) + (fetch (WIRE LATLONKNOTS) of INDVELT)) + (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + 'DATA]) (\SK.GET.1STCONTROLPT + [LAMBDA (GELT PROPERTY) (* rrb " 9-Dec-85 11:33") + + (* gets the first control point field from a global sketch element instance.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + ((TEXT CIRCLE ARC ELLIPSE) + (fetch (TEXT LOCATIONLATLON) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + ((TEXTBOX BOX) + (LOWERLEFTCORNER (fetch (BOX GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT)))) + ((BITMAPELT SKIMAGEOBJ) + (LOWERLEFTCORNER (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of (fetch (GLOBALPART + INDIVIDUALGLOBALPART + ) + of GELT)))) + ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE) + (CAR (fetch (WIRE LATLONKNOTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))) + (GROUP (fetch (GROUP GROUPCONTROLPOINT) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT))) + (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + PROPERTY]) (\SK.PUT.1STCONTROLPT + [LAMBDA (GELT NEWPOSITION) (* rrb "26-Jun-86 16:22") + + (* changes the first control point field from a global sketch element instance.) + + (OR (POSITIONP NEWPOSITION) + (\ILLEGAL.ARG NEWPOSITION)) + (PROG ((INDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) + X) + (SELECTQ (CAR INDVELT) + (TEXT (replace (TEXT LOCATIONLATLON) of INDVELT with NEWPOSITION) + (SK.UPDATE.TEXT.AFTER.CHANGE GELT)) + (CIRCLE (replace (CIRCLE CENTERLATLON) of INDVELT with NEWPOSITION) + (SK.UPDATE.CIRCLE.AFTER.CHANGE GELT)) + (ARC (replace (ARC ARCCENTERPT) of INDVELT with NEWPOSITION) + (SK.UPDATE.ARC.AFTER.CHANGE GELT)) + (ELLIPSE (replace (ELLIPSE ELLIPSECENTERLATLON) of INDVELT with NEWPOSITION) + (SK.UPDATE.ELLIPSE.AFTER.CHANGE GELT)) + (TEXTBOX (replace (TEXTBOX TEXTBOXREGION) of INDVELT with (create REGION + using (fetch (BOX + GLOBALREGION + ) + of INDVELT) + LEFT _ + (fetch (POSITION + XCOORD) + of NEWPOSITION) + BOTTOM _ + (fetch (POSITION + YCOORD) + of NEWPOSITION))) + (SK.UPDATE.TEXTBOX.AFTER.CHANGE GELT)) + (BOX (replace (BOX GLOBALREGION) of INDVELT with (create REGION + using (fetch (BOX GLOBALREGION) + of INDVELT) + LEFT _ (fetch (POSITION + XCOORD) + of NEWPOSITION) + BOTTOM _ (fetch (POSITION + YCOORD) + of NEWPOSITION))) + (SK.UPDATE.BOX.AFTER.CHANGE GELT)) + (SKIMAGEOBJ (replace (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of INDVELT + with (create REGION using (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) + of INDVELT) + LEFT _ (fetch (POSITION XCOORD) of NEWPOSITION + ) + BOTTOM _ (fetch (POSITION YCOORD) of + NEWPOSITION + ))) + (SK.UPDATE.IMAGEOBJECT.AFTER.CHANGE GELT)) + (BITMAPELT (replace (BITMAPELT SKBITMAPREGION) of INDVELT + with (create REGION using (fetch (BITMAPELT SKBITMAPREGION) of INDVELT) + LEFT _ (fetch (POSITION XCOORD) of NEWPOSITION) + BOTTOM _ (fetch (POSITION YCOORD) of + NEWPOSITION + )))) + ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE) + [COND + ((SETQ X (fetch (WIRE LATLONKNOTS) of INDVELT)) + (* there is at least one knot) + (RPLACA X NEWPOSITION)) + (T (replace (WIRE LATLONKNOTS) of INDVELT with (CONS NEWPOSITION] + (SK.UPDATE.WIRE.ELT.AFTER.CHANGE GELT)) + (GROUP + + (* change the position of the control point without changing the group.) + + (replace (GROUP GROUPCONTROLPOINT) of INDVELT with NEWPOSITION)) + (RETURN NIL)) + (RETURN T]) (\SK.GET.2NDCONTROLPT + [LAMBDA (GELT) (* rrb " 9-Dec-85 11:32") + + (* gets the second control point field from a global sketch element instance.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + ((CIRCLE ARC ELLIPSE) + (fetch (CIRCLE RADIUSLATLON) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + ((TEXTBOX BOX) + (UPPERRIGHTCORNER (fetch (BOX GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT)))) + ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE) + (CADR (fetch (WIRE LATLONKNOTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)))) + (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + '2NDCONTROLPT]) (\SK.PUT.2NDCONTROLPT + [LAMBDA (GELT NEWPOSITION) (* rrb "26-Jun-86 16:38") + + (* changes the second control point field from a global sketch element + instance.) + + (OR (POSITIONP NEWPOSITION) + (\ILLEGAL.ARG NEWPOSITION)) + (PROG ((INDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) + X) + (SELECTQ (CAR INDVELT) + (CIRCLE (replace (CIRCLE RADIUSLATLON) of INDVELT with NEWPOSITION) + (SK.UPDATE.CIRCLE.AFTER.CHANGE GELT)) + (ARC (replace (ARC ARCRADIUSPT) of INDVELT with NEWPOSITION) + (SK.UPDATE.ARC.AFTER.CHANGE GELT)) + (ELLIPSE (replace (ELLIPSE SEMIMINORLATLON) of INDVELT with NEWPOSITION) + (SK.UPDATE.ELLIPSE.AFTER.CHANGE GELT)) + (BOX (SETQ X (fetch (BOX GLOBALREGION) of INDVELT)) + [replace (BOX GLOBALREGION) of INDVELT with (create REGION + using X WIDTH _ + (DIFFERENCE + (fetch (POSITION XCOORD) + of NEWPOSITION) + (fetch (REGION LEFT) + of X)) + HEIGHT _ + (DIFFERENCE + (fetch (POSITION YCOORD) + of NEWPOSITION) + (fetch (REGION BOTTOM) + of X] + (SK.UPDATE.BOX.AFTER.CHANGE GELT)) + (TEXTBOX (SETQ X (fetch (TEXTBOX TEXTBOXREGION) of INDVELT)) + [replace (TEXTBOX TEXTBOXREGION) of INDVELT + with (create REGION using X WIDTH _ (DIFFERENCE (fetch (POSITION XCOORD) + of NEWPOSITION) + (fetch (REGION LEFT) + of X)) + HEIGHT _ (DIFFERENCE (fetch (POSITION YCOORD) + of NEWPOSITION) + (fetch (REGION BOTTOM) + of X] + (SK.UPDATE.TEXTBOX.AFTER.CHANGE GELT)) + ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE) + (COND + ((NULL (SETQ X (fetch (WIRE LATLONKNOTS) of INDVELT))) + + (* doesn't have a first knot, give it one at 0 . 0) + + (replace (WIRE LATLONKNOTS) of INDVELT with (LIST '(0 . 0) NEWPOSITION))) + ((NULL (CDR X)) + (replace (WIRE LATLONKNOTS) of INDVELT with (LIST (CAR X) + NEWPOSITION))) + (T (* there is at least one knot) + (RPLACA (CDR X) + NEWPOSITION))) + (SK.UPDATE.WIRE.ELT.AFTER.CHANGE GELT)) + (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + '2NDCONTROLPT NEWPOSITION)) + (RETURN T]) (\SK.GET.3RDCONTROLPT + [LAMBDA (GELT) (* rrb "20-Jun-86 13:55") + + (* gets the third control point field from a global sketch element instance.) + + (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) + (ELLIPSE (fetch (ELLIPSE SEMIMAJORLATLON) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT))) + (ARC (\SK.GET.ARC.ANGLEPT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) + ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE) + (CADDR (fetch (WIRE LATLONKNOTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) + of GELT)))) + (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + '3RDCONTROLPT]) (\SK.PUT.3RDCONTROLPT + [LAMBDA (GELT NEWPOSITION) (* rrb "10-Jul-86 11:15") + + (* changes the third control point field from a global sketch element instance.) + + (PROG ((INDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) + X) + (RETURN (COND + ((EQ (CAR INDVELT) + 'ARC) + + (* handle ARC specially because it will convert the number of degrees to a + point.) + + (COND + ((POSITIONP NEWPOSITION) + (replace (ARC ARCANGLEPT) of INDVELT with (SK.COMPUTE.ARC.ANGLE.PT + (fetch (ARC ARCCENTERPT) + of INDVELT) + (fetch (ARC ARCRADIUSPT) + of INDVELT) + NEWPOSITION))) + ((NUMBERP NEWPOSITION) + (replace (ARC ARCANGLEPT) of INDVELT with ( + SK.COMPUTE.ARC.ANGLE.PT.FROM.ANGLE + (fetch (ARC ARCCENTERPT) + of INDVELT) + (fetch (ARC ARCRADIUSPT) + of INDVELT) + NEWPOSITION))) + (T (\ILLEGAL.ARG NEWPOSITION))) + (SK.UPDATE.ARC.AFTER.CHANGE GELT) + T) + (T (OR (POSITIONP NEWPOSITION) + (\ILLEGAL.ARG NEWPOSITION)) + (SELECTQ (CAR INDVELT) + (ELLIPSE (replace (ELLIPSE SEMIMAJORLATLON) of INDVELT with NEWPOSITION) + (SK.UPDATE.ELLIPSE.AFTER.CHANGE GELT)) + ((WIRE CLOSEDWIRE OPENCURVE CLOSEDCURVE) + (COND + ((NULL (SETQ X (fetch (WIRE LATLONKNOTS) of INDVELT))) + + (* doesn't have a first knot, give it one at 0 . 0) + + (replace (WIRE LATLONKNOTS) of INDVELT + with (LIST '(0 . 0) '(0 . 0) NEWPOSITION))) + ((NULL (CDR X)) + (replace (WIRE LATLONKNOTS) of INDVELT + with (LIST (CAR X) + '(0 . 0) NEWPOSITION))) + ((NULL (CDDR X)) + (replace (WIRE LATLONKNOTS) of INDVELT + with (LIST (CAR X) + (CADR X) + NEWPOSITION))) + (T (* there is at least one knot) + (RPLACA (CDDR X) + NEWPOSITION))) + (SK.UPDATE.WIRE.ELT.AFTER.CHANGE GELT)) + (LISTPUT (fetch (GLOBALPART SKELEMENTPROPLIST) of GELT) + '3RDCONTROLPT NEWPOSITION)) + T]) ) (DEFINEQ (LOWERLEFTCORNER + [LAMBDA (REGION) + + (* returns a position which is the lower left corner of a region.) + + (CREATEPOSITION (FETCH (REGION LEFT) OF REGION) + (FETCH (REGION BOTTOM) OF REGION]) (UPPERRIGHTCORNER + [LAMBDA (REGION) (* rrb "16-Oct-85 21:10") + + (* returns a position which is the lower left corner of a region.) + + (CREATEPOSITION (fetch (REGION RIGHT) of REGION) + (fetch (REGION TOP) of REGION]) ) (PUTPROPS SKETCHELEMENTS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1991 1992 1993 2000)) (DECLARE%: DONTCOPY (FILEMAP (NIL (14396 24810 (INIT.SKETCH.ELEMENTS 14406 . 21969) (CREATE.SKETCH.ELEMENT.TYPE 21971 . 23497) (SKETCH.ELEMENT.TYPEP 23499 . 23887) (SKETCH.ELEMENT.NAMEP 23889 . 24152) ( \CURSOR.IN.MIDDLE.MENU 24154 . 24808)) (24851 25528 (SKETCHINCOLORP 24861 . 25181) (READ.COLOR.CHANGE 25183 . 25526)) (26037 28816 (SK.CREATE.DEFAULT.FILLING 26047 . 26348) (SKFILLINGP 26350 . 26983) ( SK.INSURE.FILLING 26985 . 28413) (SK.INSURE.COLOR 28415 . 28814)) (28817 34427 (SK.TRANSLATE.MODE 28827 . 29609) (SK.CHANGE.FILLING.MODE 29611 . 33194) (READ.FILLING.MODE 33196 . 34425)) (34428 65102 (SKETCH.CREATE.CIRCLE 34438 . 35250) (CIRCLE.EXPANDFN 35252 . 38624) (CIRCLE.DRAWFN 38626 . 41627) ( \CIRCLE.DRAWFN1 41629 . 44224) (CIRCLE.INPUTFN 44226 . 46075) (SK.UPDATE.CIRCLE.AFTER.CHANGE 46077 . 46436) (SK.READ.CIRCLE.POINT 46438 . 46909) (SK.SHOW.CIRCLE 46911 . 47557) (CIRCLE.INSIDEFN 47559 . 47824) (CIRCLE.REGIONFN 47826 . 49507) (CIRCLE.GLOBALREGIONFN 49509 . 51027) (CIRCLE.TRANSLATE 51029 . 52890) (CIRCLE.READCHANGEFN 52892 . 57508) (CIRCLE.TRANSFORMFN 57510 . 59363) (CIRCLE.TRANSLATEPTS 59365 . 60979) (SK.CIRCLE.CREATE 60981 . 61824) (SET.CIRCLE.SCALE 61826 . 62592) (SK.BRUSH.READCHANGE 62594 . 65100)) (65103 65832 (SK.INSURE.BRUSH 65113 . 65507) (SK.INSURE.DASHING 65509 . 65830)) (67084 96578 (SKETCH.CREATE.ELLIPSE 67094 . 67693) (ELLIPSE.EXPANDFN 67695 . 71307) (ELLIPSE.DRAWFN 71309 . 75486) (ELLIPSE.INPUTFN 75488 . 77928) (SK.READ.ELLIPSE.MAJOR.PT 77930 . 78509) ( SK.SHOW.ELLIPSE.MAJOR.RADIUS 78511 . 79266) (SK.READ.ELLIPSE.MINOR.PT 79268 . 79961) ( SK.SHOW.ELLIPSE.MINOR.RADIUS 79963 . 80795) (ELLIPSE.INSIDEFN 80797 . 81067) (ELLIPSE.CREATE 81069 . 82444) (SK.UPDATE.ELLIPSE.AFTER.CHANGE 82446 . 82814) (ELLIPSE.REGIONFN 82816 . 85016) ( ELLIPSE.GLOBALREGIONFN 85018 . 86831) (ELLIPSE.TRANSLATEFN 86833 . 89379) (ELLIPSE.TRANSFORMFN 89381 . 90658) (ELLIPSE.TRANSLATEPTS 90660 . 92701) (MARK.SPOT 92703 . 93954) (DISTANCEBETWEEN 93956 . 94551) (SK.DISTANCE.TO 94553 . 94938) (SQUARE 94940 . 94982) (COMPUTE.ELLIPSE.ORIENTATION 94984 . 95703) (SK.COMPUTE.ELLIPSE.MINOR.RADIUS.PT 95705 . 96576)) (97703 138759 (SKETCH.CREATE.OPEN.CURVE 97713 . 98266) (OPENCURVE.INPUTFN 98268 . 99136) (SK.CURVE.CREATE 99138 . 100883) (MAXXEXTENT 100885 . 101744) (MAXYEXTENT 101746 . 102606) (KNOT.SET.SCALE.FIELD 102608 . 103410) (OPENCURVE.DRAWFN 103412 . 104543) (OPENCURVE.EXPANDFN 104545 . 107860) (OPENCURVE.READCHANGEFN 107862 . 111064) ( OPENCURVE.TRANSFORMFN 111066 . 113564) (OPENCURVE.TRANSLATEFN 113566 . 113988) ( OPENCURVE.TRANSLATEPTSFN 113990 . 115371) (SKETCH.CREATE.CLOSED.CURVE 115373 . 115879) ( CLOSEDCURVE.DRAWFN 115881 . 116665) (CLOSEDCURVE.EXPANDFN 116667 . 119780) (CLOSEDCURVE.REGIONFN 119782 . 120579) (CLOSEDCURVE.GLOBALREGIONFN 120581 . 122014) (READ.LIST.OF.POINTS 122016 . 123995) ( CLOSEDCURVE.INPUTFN 123997 . 124642) (CLOSEDCURVE.READCHANGEFN 124644 . 127539) ( CLOSEDCURVE.TRANSFORMFN 127541 . 129341) (CLOSEDCURVE.TRANSLATEPTSFN 129343 . 130688) (INVISIBLEPARTP 130690 . 131043) (SHOWSKETCHPOINT 131045 . 131350) (SHOWSKETCHXY 131352 . 131870) (KNOTS.REGIONFN 131872 . 132773) (OPENWIRE.GLOBALREGIONFN 132775 . 133639) (CURVE.REGIONFN 133641 . 134582) ( OPENCURVE.GLOBALREGIONFN 134584 . 135991) (KNOTS.TRANSLATEFN 135993 . 137036) (REGION.CONTAINING.PTS 137038 . 138757)) (138760 161036 (CHANGE.ELTS.BRUSH.SIZE 138770 . 139380) (CHANGE.ELTS.BRUSH 139382 . 139899) (CHANGE.ELTS.BRUSH.SHAPE 139901 . 140302) (SK.CHANGE.BRUSH.SHAPE 140304 . 143816) ( SK.CHANGE.BRUSH.COLOR 143818 . 148264) (SK.CHANGE.BRUSH.SIZE 148266 . 153224) (SK.CHANGE.ANGLE 153226 . 156206) (SK.CHANGE.ARC.DIRECTION 156208 . 158587) (SK.SET.DEFAULT.BRUSH.SIZE 158589 . 159288) ( READSIZECHANGE 159290 . 161034)) (161037 162656 (SK.CHANGE.ELEMENT.KNOTS 161047 . 162654)) (162657 163304 (SK.INSURE.POINT.LIST 162667 . 163120) (SK.INSURE.POSITION 163122 . 163302)) (164684 197007 ( SKETCH.CREATE.WIRE 164694 . 165184) (CLOSEDWIRE.EXPANDFN 165186 . 167874) (KNOTS.INSIDEFN 167876 . 168597) (OPEN.WIRE.DRAWFN 168599 . 169191) (WIRE.EXPANDFN 169193 . 172440) ( SK.UPDATE.WIRE.ELT.AFTER.CHANGE 172442 . 172963) (OPENWIRE.READCHANGEFN 172965 . 175458) ( OPENWIRE.TRANSFORMFN 175460 . 177583) (OPENWIRE.TRANSLATEFN 177585 . 178009) (OPENWIRE.TRANSLATEPTSFN 178011 . 179290) (WIRE.INPUTFN 179292 . 180923) (SK.READ.WIRE.POINTS 180925 . 181456) ( SK.READ.POINTS.WITH.FEEDBACK 181458 . 184225) (OPENWIRE.FEEDBACKFN 184227 . 184981) ( CLOSEDWIRE.FEEDBACKFN 184983 . 186339) (CLOSEDWIRE.REGIONFN 186341 . 187326) ( CLOSEDWIRE.GLOBALREGIONFN 187328 . 188380) (SK.WIRE.CREATE 188382 . 190145) (WIRE.ADD.POINT.TO.END 190147 . 191063) (READ.ARROW.CHANGE 191065 . 196541) (CHANGE.ELTS.ARROWHEADS 196543 . 197005)) (197008 208014 (SKETCH.CREATE.CLOSED.WIRE 197018 . 197579) (CLOSED.WIRE.INPUTFN 197581 . 197936) ( CLOSED.WIRE.DRAWFN 197938 . 199983) (CLOSEDWIRE.READCHANGEFN 199985 . 204890) (CLOSEDWIRE.TRANSFORMFN 204892 . 206686) (CLOSEDWIRE.TRANSLATEPTSFN 206688 . 208012)) (208015 260721 (SK.EXPAND.ARROWHEADS 208025 . 208375) (SK.COMPUTE.ARC.ARROWHEAD.POINTS 208377 . 209758) (ARC.ARROWHEAD.POINTS 209760 . 210983) (SET.ARC.ARROWHEAD.POINTS 210985 . 211966) (SET.OPENCURVE.ARROWHEAD.POINTS 211968 . 212869) ( SK.COMPUTE.CURVE.ARROWHEAD.POINTS 212871 . 214141) (SET.WIRE.ARROWHEAD.POINTS 214143 . 214896) ( SK.COMPUTE.WIRE.ARROWHEAD.POINTS 214898 . 216163) (SK.EXPAND.ARROWHEAD 216165 . 217348) (CHANGED.ARROW 217350 . 220522) (SK.CHANGE.ARROWHEAD 220524 . 220977) (SK.CHANGE.ARROWHEAD1 220979 . 226234) ( SK.CREATE.ARROWHEAD 226236 . 226756) (SK.ARROWHEAD.CREATE 226758 . 228332) (SK.ARROWHEAD.END.TEST 228334 . 229258) (READ.ARROWHEAD.END 229260 . 231285) (ARROW.HEAD.POSITIONS 231287 . 233127) ( ARROWHEAD.POINTS.LIST 233129 . 237101) (CURVE.ARROWHEAD.POINTS 237103 . 237966) (LEFT.MOST.IS.BEGINP 237968 . 238849) (WIRE.ARROWHEAD.POINTS 238851 . 240377) (DRAWARROWHEADS 240379 . 242749) ( \SK.DRAW.TRIANGLE.ARROWHEAD 242751 . 244411) (\SK.ENDPT.OF.ARROW 244413 . 246670) ( \SK.ADJUST.FOR.ARROWHEADS 246672 . 249177) (SK.SET.ARROWHEAD.LENGTH 249179 . 250323) ( SK.SET.ARROWHEAD.ANGLE 250325 . 251421) (SK.SET.ARROWHEAD.TYPE 251423 . 254712) (SK.SET.LINE.ARROWHEAD 254714 . 257127) (SK.UPDATE.ARROWHEAD.FORMAT 257129 . 259239) (SK.SET.LINE.LENGTH.MODE 259241 . 260719)) (260722 262523 (SK.INSURE.ARROWHEADS 260732 . 261914) (SK.ARROWHEADP 261916 . 262521)) ( 265327 327653 (SKETCH.CREATE.TEXT 265337 . 265851) (TEXT.CHANGEFN 265853 . 266245) (TEXT.READCHANGEFN 266247 . 274318) (\SK.READ.FONT.SIZE1 274320 . 276216) (SK.TEXT.ELT.WITH.SAME.FIELDS 276218 . 277858) (SK.READFONTFAMILY 277860 . 279406) (CLOSE.PROMPT.WINDOW 279408 . 279832) (TEXT.DRAWFN 279834 . 280555 ) (TEXT.DRAWFN1 280557 . 284059) (TEXT.INSIDEFN 284061 . 284450) (TEXT.EXPANDFN 284452 . 286577) ( SK.TEXT.LINE.REGIONS 286579 . 288453) (TEXT.UPDATE.GLOBAL.REGIONS 288455 . 289687) (REL.MOVE.REGION 289689 . 290226) (LTEXT.LINE.REGIONS 290228 . 293646) (TEXT.INPUTFN 293648 . 294158) (READ.TEXT 294160 . 294908) (TEXT.POSITION.AND.CREATE 294910 . 297221) (CREATE.TEXT.ELEMENT 297223 . 298041) ( SK.UPDATE.TEXT.AFTER.CHANGE 298043 . 298445) (SK.TEXT.FROM.TEXTBOX 298447 . 302253) ( TEXT.SET.GLOBAL.REGIONS 302255 . 303548) (TEXT.REGIONFN 303550 . 304320) (TEXT.GLOBALREGIONFN 304322 . 305010) (TEXT.TRANSLATEFN 305012 . 306327) (TEXT.TRANSFORMFN 306329 . 307452) (TEXT.TRANSLATEPTSFN 307454 . 307971) (TEXT.UPDATEFN 307973 . 312629) (SK.CHANGE.TEXT 312631 . 325719) (TEXT.SET.SCALES 325721 . 326689) (BREAK.AT.CARRIAGE.RETURNS 326691 . 327651)) (327654 346178 (ADD.KNOWN.SKETCH.FONT 327664 . 328655) (SK.PICK.FONT 328657 . 334189) (SK.CHOOSE.TEXT.FONT 334191 . 338139) (SK.NEXTSIZEFONT 338141 . 339408) (SK.DECREASING.FONT.LIST 339410 . 341283) (SK.GUESS.FONTSAVAILABLE 341285 . 346176)) (346605 360748 (SK.SET.FONT 346615 . 348182) (SK.SET.TEXT.FONT 348184 . 349186) (SK.SET.TEXT.SIZE 349188 . 349875) (SK.SET.TEXT.HORIZ.ALIGN 349877 . 351451) (SK.READFONTSIZE 351453 . 353683) ( SK.COLLECT.FONT.SIZES 353685 . 356603) (SK.SET.TEXT.VERT.ALIGN 356605 . 358647) (SK.SET.TEXT.LOOKS 358649 . 360106) (SK.SET.DEFAULT.TEXT.FACE 360108 . 360746)) (360749 361335 (CREATE.SKETCH.TERMTABLE 360759 . 361333)) (361336 363102 (SK.FONT.LIST 361346 . 361672) (SK.INSURE.FONT 361674 . 362196) ( SK.INSURE.STYLE 362198 . 362716) (SK.INSURE.TEXT 362718 . 363100)) (363672 420965 ( SKETCH.CREATE.TEXTBOX 363682 . 365324) (SK.COMPUTE.TEXTBOX.REGION.FOR.STRING 365326 . 367403) ( SK.BREAK.INTO.LINES 367405 . 378591) (SK.BRUSH.SIZE 378593 . 378974) (SK.TEXTBOX.CREATE 378976 . 379773) (SK.TEXTBOX.CREATE1 379775 . 380839) (SK.UPDATE.TEXTBOX.AFTER.CHANGE 380841 . 381381) ( SK.TEXTBOX.POSITION.IN.BOX 381383 . 383294) (TEXTBOX.CHANGEFN 383296 . 383770) (TEXTBOX.DRAWFN 383772 . 385808) (SK.TEXTURE.AROUND.REGIONS 385810 . 391883) (ALL.EMPTY.REGIONS 391885 . 392375) ( TEXTBOX.EXPANDFN 392377 . 399533) (TEXTBOX.INPUTFN 399535 . 401148) (TEXTBOX.INSIDEFN 401150 . 401563) (TEXTBOX.REGIONFN 401565 . 402419) (TEXTBOX.GLOBALREGIONFN 402421 . 402749) ( TEXTBOX.SET.GLOBAL.REGIONS 402751 . 404082) (TEXTBOX.TRANSLATEFN 404084 . 405925) ( TEXTBOX.TRANSLATEPTSFN 405927 . 408710) (TEXTBOX.TRANSFORMFN 408712 . 410380) (TEXTBOX.UPDATEFN 410382 . 412275) (TEXTBOX.READCHANGEFN 412277 . 417166) (SK.TEXTBOX.TEXT.POSITION 417168 . 417589) ( SK.TEXTBOX.FROM.TEXT 417591 . 420196) (ADD.EOLS 420198 . 420963)) (421533 425034 ( SK.SET.TEXTBOX.VERT.ALIGN 421543 . 423423) (SK.SET.TEXTBOX.HORIZ.ALIGN 423425 . 425032)) (425417 469892 (SKETCH.CREATE.BOX 425427 . 425910) (SK.BOX.DRAWFN 425912 . 427071) (BOX.DRAWFN1 427073 . 429912) (KNOTS.OF.REGION 429914 . 431148) (SK.DRAWAREABOX 431150 . 437751) (SK.DRAWBOX 437753 . 438942 ) (SK.BOX.EXPANDFN 438944 . 442692) (SK.BOX.GETREGIONFN 442694 . 443880) (BOX.SET.SCALES 443882 . 445122) (SK.BOX.INPUTFN 445124 . 447057) (SK.BOX.CREATE 447059 . 447760) (SK.UPDATE.BOX.AFTER.CHANGE 447762 . 448273) (SK.BOX.INSIDEFN 448275 . 448665) (SK.BOX.REGIONFN 448667 . 449380) ( SK.BOX.GLOBALREGIONFN 449382 . 450120) (SK.BOX.READCHANGEFN 450122 . 453843) (SK.CHANGE.FILLING 453845 . 457793) (SK.CHANGE.FILLING.COLOR 457795 . 461451) (SK.BOX.TRANSLATEFN 461453 . 462632) ( SK.BOX.TRANSFORMFN 462634 . 463579) (SK.BOX.TRANSLATEPTSFN 463581 . 465949) (UNSCALE.REGION.TO.GRID 465951 . 466876) (INCREASEREGION 466878 . 467469) (INSUREREGIONSIZE 467471 . 468642) (EXPANDREGION 468644 . 469524) (REGION.FROM.COORDINATES 469526 . 469890)) (470432 496787 (SKETCH.CREATE.ARC 470442 . 471251) (ARC.DRAWFN 471253 . 472980) (ARC.EXPANDFN 472982 . 475315) (ARC.INPUTFN 475317 . 479535) ( SK.INVERT.CIRCLE 479537 . 480397) (SK.READ.ARC.ANGLE.POINT 480399 . 480906) (SK.SHOW.ARC 480908 . 481518) (ARC.CREATE 481520 . 482875) (SK.UPDATE.ARC.AFTER.CHANGE 482877 . 483217) (ARC.MOVEFN 483219 . 484802) (ARC.TRANSLATEPTS 484804 . 486689) (ARC.INSIDEFN 486691 . 486941) (ARC.REGIONFN 486943 . 488079) (ARC.GLOBALREGIONFN 488081 . 489803) (ARC.TRANSLATE 489805 . 490787) (ARC.TRANSFORMFN 490789 . 493739) (ARC.READCHANGEFN 493741 . 496785)) (496788 505867 (SK.COMPUTE.ARC.ANGLE.PT 496798 . 497724 ) (SK.COMPUTE.ARC.ANGLE.PT.FROM.ANGLE 497726 . 498719) (SK.COMPUTE.ARC.PTS 498721 . 502293) ( SK.SET.ARC.DIRECTION 502295 . 502869) (SK.SET.ARC.DIRECTION.CW 502871 . 503045) ( SK.SET.ARC.DIRECTION.CCW 503047 . 503320) (SK.COMPUTE.SLOPE.OF.LINE 503322 . 503814) ( SK.CREATE.ARC.USING 503816 . 505053) (SET.ARC.SCALES 505055 . 505865)) (505868 506313 ( SK.INSURE.DIRECTION 505878 . 506311)) (507715 553096 (GETSKETCHELEMENTPROP 507725 . 509033) ( \SK.GET.ARC.ANGLEPT 509035 . 509596) (\GETSKETCHELEMENTPROP1 509598 . 509852) (\SK.GET.BRUSH 509854 . 510778) (\SK.GET.FILLING 510780 . 511878) (\SK.GET.ARROWHEADS 511880 . 512659) (\SK.GET.FONT 512661 . 513141) (\SK.GET.JUSTIFICATION 513143 . 513667) (\SK.GET.DIRECTION 513669 . 514146) (\SK.GET.DASHING 514148 . 515167) (PUTSKETCHELEMENTPROP 515169 . 517438) (\SK.PUT.FILLING 517440 . 518710) ( ADDSKETCHELEMENTPROP 518712 . 519517) (REMOVESKETCHELEMENTPROP 519519 . 520308) (\SK.PUT.FONT 520310 . 521124) (\SK.PUT.JUSTIFICATION 521126 . 522137) (\SK.PUT.DIRECTION 522139 . 522746) ( \SK.PUT.DASHING 522748 . 524083) (\SK.PUT.BRUSH 524085 . 526004) (\SK.PUT.ARROWHEADS 526006 . 527494) (SK.COPY.ELEMENT.PROPERTY.LIST 527496 . 528072) (SKETCH.UPDATE 528074 . 528804) (SKETCH.UPDATE1 528806 . 530094) (\SKELT.GET.SCALE 530096 . 531084) (\SKELT.PUT.SCALE 531086 . 532393) (\SKELT.PUT.DATA 532395 . 534192) (SK.REPLACE.TEXT.IN.ELEMENT 534194 . 535147) (\SKELT.GET.DATA 535149 . 536216) ( \SK.GET.1STCONTROLPT 536218 . 537730) (\SK.PUT.1STCONTROLPT 537732 . 543205) (\SK.GET.2NDCONTROLPT 543207 . 544122) (\SK.PUT.2NDCONTROLPT 544124 . 548312) (\SK.GET.3RDCONTROLPT 548314 . 549192) ( \SK.PUT.3RDCONTROLPT 549194 . 553094)) (553097 553678 (LOWERLEFTCORNER 553107 . 553353) ( UPPERRIGHTCORNER 553355 . 553676))))) STOP \ No newline at end of file diff --git a/library/SKETCHOBJ b/library/SKETCHOBJ new file mode 100644 index 00000000..7a436b40 --- /dev/null +++ b/library/SKETCHOBJ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "20-Jan-93 14:48:59" {DSK}lde>lispcore>library>SKETCHOBJ.;2 55463 changes to%: (RECORDS SKETCHIMAGEOBJ SKETCHDOCUMENTINFO LOCALSKIMAGEOBJ SKIMAGEOBJ ANNO) previous date%: "12-Jun-90 15:07:54" {DSK}lde>lispcore>library>SKETCHOBJ.;1) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SKETCHOBJCOMS) (RPAQQ SKETCHOBJCOMS [[COMS (* the stuff to support sketch images in documents.) (FNS MAKE.IMAGE.OBJECT.OF.SKETCH SK.ELEMENT.FROM.IMAGEOBJ SKETCHIMAGEOBJ.FROM.VIEWER SKETCH.IMAGEOBJ SKETCH.DISPLAYFN SKETCH.BITMAP.IMAGE SKIO.IMAGEBOXFN SKIO.GETFN.2 SKIO.UPDATE.FROM.OLD.FORM SKIO.GETFN SKIO.PUTFN SKIO.COPYFN SKIO.BUTTONEVENTINFN TRANSLATE.REGION UPDATE.IMAGE.IN.DOCUMENT SK.COPY.IMAGEOBJ COPY.IMAGE.OBJECT \CREATE.SKETCH.IMAGEFNS \SKIO.IN.TOO.SMALL.TEDITP SKETCH.VIEWER.GRID SKETCH.VIEWER.SCALE) (DECLARE%: DONTCOPY DOEVAL@COMPILE (RECORDS SKETCHIMAGEOBJ SKETCHDOCUMENTINFO)) (P (\CREATE.SKETCH.IMAGEFNS)) (ADDVARS (IMAGEOBJGETFNS (SKIO.GETFN] (COMS (* stuff to support image objects as elements in a sketch) (FNS SKETCH.IMAGE.OBJECT.ELEMENT SKETCH.IMAGEOBJ.OF.ELEMENT SKETCH.SCALE.OF.ELEMENT SKETCH.POSITION.OF.ELEMENT CREATE.SKIMAGEOBJ.TYPE IMAGEBOXSIZE SK.UPDATE.IMAGEOBJECT.AFTER.CHANGE SKETCH.CREATE.IMAGE.OBJECT SKETCH.CREATE.IMAGE.OBJECT1) (FNS SK.IMAGEOBJ.DRAWFN SK.IMAGEOBJ.REGIONFN SK.IMAGEOBJ.GLOBALREGIONFN SK.IMAGEOBJ.TRANSLATEFN SK.IMAGEOBJ.EXPANDFN SK.IMAGEOBJ.INSIDEFN SK.IMAGEOBJ.MOVEFN SK.IMAGEOBJ.CHANGEFN SK.IMAGEOBJ.READCHANGEFN SK.IMAGEOBJ.TRANSFORMFN) (RECORDS LOCALSKIMAGEOBJ SKIMAGEOBJ ANNO) (P (CREATE.SKIMAGEOBJ.TYPE]) (* the stuff to support sketch images in documents.) (DEFINEQ (MAKE.IMAGE.OBJECT.OF.SKETCH [LAMBDA (SKETCH REGION SCALE GRIDSIZE) (* ; "Edited 18-Nov-87 17:50 by rrb") (* Returns a sketch image object. REGION is the region in sketch coordinates  that the image object will show. SCALE is the scale at which it will be  shown. GRIDSIZE is the grid size of the sketch.  If SKETCH is a viewer, any of the other arguments that are NIL will be filled  in from the values in the viewer. If SKETCH is a sketch, REGION defaults to  the extent of the sketch, SCALE defaults to 1.0 and GRIDSIZE defaults to  |8.0.|) (SKETCH.IMAGEOBJ (INSURE.SKETCH SKETCH) (COND ((REGIONP REGION)) (REGION (ERROR REGION " illegal argument.")) (T (SKETCH.REGION.VIEWED SKETCH))) (COND ((NUMBERP SCALE)) ((WINDOWP SKETCH) (VIEWER.SCALE SKETCH)) (T 1.0)) (COND ((NUMBERP GRIDSIZE)) ((WINDOWP SKETCH) (SK.GRIDFACTOR SKETCH)) (T 8.0]) (SK.ELEMENT.FROM.IMAGEOBJ [LAMBDA (IMAGEOBJ SKETCHW ORGPOS) (* rrb "11-Jul-86 15:48") (* * returns a sketch element for an image object.) (SKETCH.IMAGE.OBJECT.ELEMENT IMAGEOBJ (VIEWER.SCALE SKETCHW) ORGPOS SKETCHW]) (SKETCHIMAGEOBJ.FROM.VIEWER [LAMBDA (SKETCHW) (* rrb "11-Jul-86 15:51") (* * returns a SKETCH image object which describes the contents of a window.) (SKETCH.IMAGEOBJ (INSURE.SKETCH (SKETCH.FROM.VIEWER SKETCHW)) (SKETCH.REGION.VIEWED SKETCHW) (VIEWER.SCALE SKETCHW) (SK.GRIDFACTOR SKETCHW]) (SKETCH.IMAGEOBJ [LAMBDA (SKETCH REGION SCALE GRID) (* rrb "29-Jan-86 11:54") (DECLARE (GLOBALVARS SKETCHIMAGEFNS)) (* * returns an image obj which gives the functional information for a sketch  object in a tedit file.) (IMAGEOBJCREATE (create SKETCHIMAGEOBJ SKIO.SKETCH _ SKETCH SKIO.REGION _ (COND ((REGIONP REGION)) (T (SKETCH.REGION.OF.SKETCH SKETCH))) SKIO.SCALE _ (OR (NUMBERP SCALE) 1.0) SKIO.GRID _ (OR (NUMBERP GRID) 8.0)) SKETCHIMAGEFNS]) (SKETCH.DISPLAYFN [LAMBDA (SKETCHIMAGEOBJ STREAM) (* ; "Edited 27-Feb-87 18:15 by rrb") (* * display function for a sketch image object) (PROG ((SKIO (IMAGEOBJPROP SKETCHIMAGEOBJ 'OBJECTDATUM)) REGION TYPE) (SETQ REGION (fetch (SKETCHIMAGEOBJ SKIO.REGION) of SKIO)) (COND ((EQMEMB 'DISPLAY (SETQ TYPE (IMAGESTREAMTYPE STREAM))) (* This is being displayed on the  screen) (BITBLT [COND ((fetch (SKETCHIMAGEOBJ SKIO.LOCALSPECS) of SKIO)) (T (* SKIO.LOCALSPECS is used to cache the local bitmap of the sketch as it is  being display now.) (replace (SKETCHIMAGEOBJ SKIO.LOCALSPECS) of SKIO with (SKETCH.BITMAP.IMAGE (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of SKIO) REGION (fetch (SKETCHIMAGEOBJ SKIO.SCALE) of SKIO] 0 0 STREAM (DSPXPOSITION NIL STREAM) (DSPYPOSITION NIL STREAM))) (T (PROG ((SKSCALE (fetch (SKETCHIMAGEOBJ SKIO.SCALE) of SKIO)) (STRMSCALE (DSPSCALE NIL STREAM)) SKTOSTRMSCALE SKXOFFSET SKYOFFSET) (* the TRANSLATE.SKETCH is to move the sketch to the right place on the page.  When all streams support tranlation, this should be taken out.) (SETQ SKTOSTRMSCALE (QUOTIENT SKSCALE STRMSCALE)) (SETQ SKXOFFSET (DIFFERENCE (TIMES (DSPXPOSITION NIL STREAM) SKTOSTRMSCALE) (fetch (REGION LEFT) of REGION))) (SETQ SKYOFFSET (DIFFERENCE (TIMES (DSPYPOSITION NIL STREAM) SKTOSTRMSCALE) (fetch (REGION BOTTOM) of REGION))) (* save and restore the font as Tedit assumes that it is preserved over the  call.) (RETURN (DSPFONT (PROG1 (DSPFONT NIL STREAM) (DRAW.LOCAL.SKETCH (MAKE.LOCAL.SKETCH (TRANSLATE.SKETCH (COPY (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of SKIO)) (IMINUS SKXOFFSET) (IMINUS SKYOFFSET)) (SETQ REGION (TRANSLATE.REGION REGION SKXOFFSET SKYOFFSET)) SKTOSTRMSCALE STREAM) STREAM (SK.SCALE.REGION REGION SKTOSTRMSCALE))) STREAM]) (SKETCH.BITMAP.IMAGE [LAMBDA (SKETCH REGION SCALE) (* rrb "21-Jan-86 15:56") (* Returns a bitmap that has the sketch image in it.) (SETQ SKETCH (INSURE.SKETCH SKETCH)) (OR (REGIONP REGION) (SETQ REGION (SKETCH.REGION.OF.SKETCH SKETCH))) (OR (NUMBERP SCALE) (SETQ SCALE 1.0)) (PROG (BITMAP DSP) (* make the bitmap image 1 bit larger than might be absolutely necessary to  allow a one bit slop for floating pt roundoff.) (SETQ BITMAP (BITMAPCREATE (IPLUS (QUOTIENT (fetch (REGION WIDTH) of REGION) SCALE) 1) (IPLUS (QUOTIENT (fetch (REGION HEIGHT) of REGION) SCALE) 1))) (SETQ DSP (DSPCREATE BITMAP)) (* adjust the offsets of the stream so that the sketch does not have to be  translated.) (DSPXOFFSET (IMINUS (QUOTIENT (fetch (REGION LEFT) of REGION) SCALE)) DSP) (DSPYOFFSET (IMINUS (QUOTIENT (fetch (REGION BOTTOM) of REGION) SCALE)) DSP) (RESETFORM (CURSOR WAITINGCURSOR) (DRAW.LOCAL.SKETCH (MAKE.LOCAL.SKETCH SKETCH REGION SCALE DSP T) DSP (DSPCLIPPINGREGION NIL DSP) SCALE)) (RETURN BITMAP]) (SKIO.IMAGEBOXFN [LAMBDA (IMAGEOBJ STREAM) (* ; "Edited 27-Feb-87 18:04 by rrb") (* size function for a sketch image  object.) (PROG ((SKOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) SKREG SKW SKH SCALEFACTOR) (* determine the scale between the sketch specs and the stream.) (SETQ SCALEFACTOR (QUOTIENT (fetch (SKETCHIMAGEOBJ SKIO.SCALE) of SKOBJ) (DSPSCALE NIL STREAM))) (SETQ SKW (FIXR (FQUOTIENT (fetch (REGION WIDTH) of (SETQ SKREG (fetch (SKETCHIMAGEOBJ SKIO.REGION) of SKOBJ))) SCALEFACTOR))) (SETQ SKH (FIXR (FQUOTIENT (fetch (REGION HEIGHT) of SKREG) SCALEFACTOR))) (RETURN (COND ((\SKIO.IN.TOO.SMALL.TEDITP STREAM SKH) (* special check for displaying in a Tedit window that is less than the height  of the sketch. leave enough height for a few lines of text too.) (create IMAGEBOX XSIZE _ SKW YSIZE _ (IMAX 12 (DIFFERENCE (fetch (REGION HEIGHT) of (DSPCLIPPINGREGION NIL STREAM)) 24)) YDESC _ 0 XKERN _ 0)) (T (create IMAGEBOX XSIZE _ SKW YSIZE _ SKH YDESC _ 0 XKERN _ 0]) (SKIO.GETFN.2 [LAMBDA (STREAM) (* rrb "18-Oct-85 16:11") (* Get a description of a sketch object from the file.) (SKETCH.IMAGEOBJ [PROG ((READSKETCH (HREAD STREAM))) (RETURN (SK.CHECK.SKETCH.VERSION (COND ((NLISTP (CAR READSKETCH)) (* pre property list format, update  it.) (SKIO.UPDATE.FROM.OLD.FORM READSKETCH )) (T (* values of all properties and sketch elements were written out as a LIST.) (create SKETCH ALLSKETCHPROPS _ (CAR READSKETCH) SKETCHELTS _ (CDR READSKETCH ] (READ STREAM) (READ STREAM) (READ STREAM]) (SKIO.UPDATE.FROM.OLD.FORM [LAMBDA (OLDSKETCH) (* rrb "18-Jul-85 17:24") (* converts a sketch from old form to  new form.) (* update the arrowhead format to the  new form.) (MAPGLOBALSKETCHELEMENTS (CDR OLDSKETCH) (FUNCTION SK.UPDATE.ARROWHEAD.FORMAT)) (create SKETCH SKETCHNAME _ (CAR OLDSKETCH) SKETCHELTS _ (CDR OLDSKETCH]) (SKIO.GETFN [LAMBDA (STREAM) (* rrb " 7-May-85 11:21") (* Get a description of a sketch object from the file.  This is an old version left around in case old format object still exist.) (printout T "This file contains sketch that is in an old format. " "To update it to the new format, " "load this file into a Harmony sysout and do a 'Put' from there.") (ERROR "old format Sketch object"]) (SKIO.PUTFN [LAMBDA (IMAGEOBJ STREAM) (* rrb "12-May-85 18:34") (* Put a description of a sketch object into the file.) (PROG ((SKETCHIMAGEOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) SKETCH) (SETQ SKETCH (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of SKETCHIMAGEOBJ)) (* can't print sketch directly because it contains a TCONC cell which must be  reconstructed on reading in.) (HPRINT (CONS (fetch (SKETCH ALLSKETCHPROPS) of SKETCH) (fetch (SKETCH SKETCHELTS) of SKETCH)) STREAM T) (PRINT (fetch (SKETCHIMAGEOBJ SKIO.REGION) of SKETCHIMAGEOBJ) STREAM) (PRINT (fetch (SKETCHIMAGEOBJ SKIO.SCALE) of SKETCHIMAGEOBJ) STREAM) (PRINT (fetch (SKETCHIMAGEOBJ SKIO.GRID) of SKETCHIMAGEOBJ) STREAM]) (SKIO.COPYFN [LAMBDA (IMAGEOBJ) (* rrb "26-Oct-84 10:27") (* makes a copy of a sketch image  object.) (PROG [(SKETCHOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (RETURN (SKETCH.IMAGEOBJ (COPY (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of SKETCHOBJ)) (COPY (fetch (SKETCHIMAGEOBJ SKIO.REGION) of SKETCHOBJ)) (fetch (SKETCHIMAGEOBJ SKIO.SCALE) of SKETCHOBJ) (fetch (SKETCHIMAGEOBJ SKIO.GRID) of SKETCHOBJ]) (SKIO.BUTTONEVENTINFN [LAMBDA (IMAGEOBJ WINDOW) (* rrb "31-Jul-86 10:24") (* the user has pressed a button inside the sketch object IMAGEOBJ.  Offer a chance to edit it in a separate window.) (PROG [(OBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM] (SELECTQ [MENU (create MENU ITEMS _ '((Edit% sketch 'EDIT "opens a window in which this sketch can be changed." ] (EDIT (* user wants to edit it) [PROG ((SKREG (fetch (SKETCHIMAGEOBJ SKIO.REGION) of OBJ)) (SCALE (fetch (SKETCHIMAGEOBJ SKIO.SCALE) of OBJ)) (SKETCH (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of OBJ)) SKW TITLE) (* give the sketch a new name so that it doesn't get confused about the real  sketch on the property list. The whole idea of names should probably be  scrapped) (SETQ SKW (SKETCHW.CREATE (create SKETCH using SKETCH SKETCHNAME _ [SETQ TITLE (COND ((SETQ TITLE (WINDOWPROP WINDOW 'TEDIT.ICON.TITLE)) (CONCAT "figure from " TITLE)) (T ' |a figure from a document| ] SKETCHPROPS _ (COPY (fetch (SKETCH SKETCHPROPS ) of SKETCH)) SKETCHELTS _ (COPY (fetch (SKETCH SKETCHELTS ) of SKETCH))) SKREG (GETBOXREGION (WIDTHIFWINDOW (FIXR (FQUOTIENT (fetch (REGION WIDTH) of SKREG) SCALE))) (HEIGHTIFWINDOW (FIXR (FQUOTIENT (fetch (REGION HEIGHT) of SKREG) SCALE)) T)) TITLE SCALE T (fetch (SKETCHIMAGEOBJ SKIO.GRID) of OBJ))) (* keep track of enough information to find this sketch in the document if the  user closes the window.) (WINDOWPROP SKW 'DOCUMENTINFO (create SKETCHDOCUMENTINFO FROMIMAGEOBJ _ IMAGEOBJ FROMTEDITWINDOW _ WINDOW)) (* give this process the tty so that it will stay on top.) (TTY.PROCESS (WINDOWPROP SKW 'PROCESS)) (* add a process to bring this window to the top after TEdit has cleared its  selection which brings it up on top again.  Yech!!) (ADD.PROCESS (LIST 'TOTOPW (KWOTE SKW]) NIL]) (TRANSLATE.REGION [LAMBDA (REGION NEWLEFT NEWBOTTOM) (* rrb "20-Sep-84 14:12") (* translates a region so that its new lower left corner is at NEWLEFT  NEWBOTTOM) (CREATEREGION (PLUS (fetch (REGION LEFT) of REGION) NEWLEFT) (PLUS (fetch (REGION BOTTOM) of REGION) NEWBOTTOM) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION]) (UPDATE.IMAGE.IN.DOCUMENT [LAMBDA (SKW) (* rrb "26-Sep-86 10:16") (* * this sketch window was the result of editting a sketch from a document.  Ask if the user wants to put it back and if so, do it.) (SELECTQ (\CURSOR.IN.MIDDLE.MENU (create MENU TITLE _ "Put changes back into Document?" 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 (PROG ((DOCINFO (WINDOWPROP SKW 'DOCUMENTINFO)) TEXTOBJ OLDIMAGEOBJ POS) (COND ([NOT (SETQ TEXTOBJ (TEXTOBJ (fetch (SKETCHDOCUMENTINFO FROMTEDITWINDOW) of DOCINFO] (PROMPTPRINT "Can't find the edit window for the source document.") (RETURN))) (COND ([NOT (SETQ POS (TEDIT.FIND.OBJECT TEXTOBJ (SETQ OLDIMAGEOBJ (fetch (SKETCHDOCUMENTINFO FROMIMAGEOBJ) of DOCINFO] (PROMPTPRINT "Can't find this sketch in the document it came from.") (* later should allow the user to  specify where.) (RETURN))) (TEDIT.DELETE (SETQ TEXTOBJ (TEXTSTREAM TEXTOBJ)) POS 1) (TEDIT.INSERT.OBJECT (SKETCHIMAGEOBJ.FROM.VIEWER SKW) TEXTOBJ POS))) (NIL (* if the user clicks outside, stop  the close.) 'DON'T) (NO NIL) NIL]) (SK.COPY.IMAGEOBJ [LAMBDA (GELT WINDOW CALLWHENCOPIEDFN) (* rrb "29-Jun-87 14:22") (* * makes a copy of a image object sketch element.  Has to call the image objects copyfn. Calls its its WHENCOPIEDFN if  CALLWHENCOPIEDFN is not NIL This is normally NIL because the WHENINSERTEDFN  is used instead.) (PROG ((INDVGELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) IMAGEOBJ FN NEWSKELT) [SETQ NEWSKELT (create GLOBALPART INDIVIDUALGLOBALPART _ [create SKIMAGEOBJ using INDVGELT SKIMAGEOBJ _ (COPY.IMAGE.OBJECT (SETQ IMAGEOBJ (fetch (SKIMAGEOBJ SKIMAGEOBJ) of INDVGELT] COMMONGLOBALPART _ (COPY (fetch (GLOBALPART COMMONGLOBALPART) of GELT] (COND ((AND CALLWHENCOPIEDFN (SETQ FN (IMAGEOBJPROP IMAGEOBJ 'WHENCOPIEDFN)) (NEQ FN 'NILL)) (* documentation calls for passing text streams as well but there aren't any.) (APPLY* FN IMAGEOBJ WINDOW))) (RETURN NEWSKELT]) (COPY.IMAGE.OBJECT [LAMBDA (IMAGEOBJ) (* rrb "29-Jun-87 14:22") (* copies an image object calling  its copyfn if possible.) (PROG (FN) (RETURN (COND ((AND (SETQ FN (IMAGEOBJPROP IMAGEOBJ 'COPYFN)) (NEQ FN 'NILL)) (APPLY* FN IMAGEOBJ)) (T (COPY IMAGEOBJ]) (\CREATE.SKETCH.IMAGEFNS [LAMBDA NIL (* rrb "23-Oct-85 11:03") (DECLARE (GLOBALVARS SKETCHIMAGEFNS)) (* creates the IMAGEFNS vector for the  sketch image object.) (COND ((IMAGEFNSP SKETCHIMAGEFNS)) (T (SETQ SKETCHIMAGEFNS (IMAGEFNSCREATE (FUNCTION SKETCH.DISPLAYFN) (FUNCTION SKIO.IMAGEBOXFN) (FUNCTION SKIO.PUTFN) (FUNCTION SKIO.GETFN.2) (FUNCTION SKIO.COPYFN) (FUNCTION SKIO.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL]) (\SKIO.IN.TOO.SMALL.TEDITP [LAMBDA (STREAM HEIGHT) (* ; "Edited 7-Oct-88 12:21 by rmk:") (* ; "Edited 27-Feb-87 18:19 by rrb") (* is this stream a TEDIT window  that is smaller than height?) (AND (DISPLAYSTREAMP STREAM) (EQ (DSPDESTINATION NIL STREAM) (SCREENBITMAP)) (WINDOWPROP (WFROMDS STREAM) 'TEXTOBJ) (GREATERP HEIGHT (fetch (REGION HEIGHT) of (DSPCLIPPINGREGION NIL STREAM]) (SKETCH.VIEWER.GRID [LAMBDA (VIEWER NEWGRID) (* ; "Edited 18-Nov-87 17:51 by rrb") (* returns and optionally sets the grid size of a sketch.  VIEWER can be a viewer or a sketch image object.) (COND [(IMAGEOBJP VIEWER) (* it is a sketch image object) (PROG [(SKINFO (LISTP (IMAGEOBJPROP VIEWER 'OBJECTDATUM] (COND [(type? SKETCH (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of SKINFO)) (RETURN (PROG1 (fetch (SKETCHIMAGEOBJ SKIO.GRID) of SKINFO) (COND (NEWGRID (COND ((NUMBERP NEWGRID) (replace (SKETCHIMAGEOBJ SKIO.GRID) of SKINFO with NEWGRID)) (T (\ILLEGAL.ARG NEWGRID] (T (ERROR "not a sketch image object" VIEWER] ((WINDOWP VIEWER) (SK.GRIDFACTOR VIEWER NEWGRID)) (T (\ILLEGAL.ARG VIEWER]) (SKETCH.VIEWER.SCALE [LAMBDA (VIEWER NEWSCALE) (* rrb "21-Apr-87 12:25") (* returns and optionally sets the  scale of a viewer.) (COND [(IMAGEOBJP VIEWER) (* it is a sketch image object) (PROG [(SKINFO (LISTP (IMAGEOBJPROP VIEWER 'OBJECTDATUM] (COND [(type? SKETCH (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of SKINFO)) (RETURN (PROG1 (fetch (SKETCHIMAGEOBJ SKIO.SCALE) of SKINFO) (COND (NEWSCALE (COND ((SK.INSURE.SCALE NEWSCALE) (replace (SKETCHIMAGEOBJ SKIO.SCALE) of SKINFO with NEWSCALE)) (T (\ILLEGAL.ARG NEWSCALE] (T (ERROR "not a sketch image object" VIEWER] [(WINDOWP VIEWER) (PROG1 (WINDOWPROP VIEWER 'SCALE) (COND (NEWSCALE (COND ((SK.INSURE.SCALE NEWSCALE) (WINDOWPROP VIEWER 'SCALE NEWSCALE) (SK.UPDATE.AFTER.SCALE.CHANGE VIEWER] (T (\ILLEGAL.ARG VIEWER]) ) (DECLARE%: DONTCOPY DOEVAL@COMPILE (DECLARE%: EVAL@COMPILE (RECORD SKETCHIMAGEOBJ (SKIO.SKETCH SKIO.REGION SKIO.SCALE SKIO.LOCALSPECS SKIO.GRID)) (RECORD SKETCHDOCUMENTINFO (FROMIMAGEOBJ FROMTEDITWINDOW)) ) ) (\CREATE.SKETCH.IMAGEFNS) (ADDTOVAR IMAGEOBJGETFNS (SKIO.GETFN)) (* stuff to support image objects as elements in a sketch) (DEFINEQ (SKETCH.IMAGE.OBJECT.ELEMENT [LAMBDA (IMAGEOBJ SCALE GLOBALPOS VIEWER) (* rrb " 8-Jul-86 12:38") (* internal function for creating a global imageobj sketch element.  Called during copy select insert and during editting.) (SK.UPDATE.IMAGEOBJECT.AFTER.CHANGE (SKETCH.CREATE.IMAGE.OBJECT1 IMAGEOBJ GLOBALPOS SCALE) VIEWER]) (SKETCH.IMAGEOBJ.OF.ELEMENT [LAMBDA (ELEMENT) (* rrb "14-Aug-85 16:38") (* returns the image object from an image object sketch element.) (fetch (SKIMAGEOBJ SKIMAGEOBJ) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELEMENT]) (SKETCH.SCALE.OF.ELEMENT [LAMBDA (ELEMENT) (* rrb "14-Aug-85 16:39") (* returns the scale from an image  object sketch element.) (fetch (SKIMAGEOBJ SKIMOBJ.ORIGSCALE) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELEMENT]) (SKETCH.POSITION.OF.ELEMENT [LAMBDA (ELEMENT) (* rrb "14-Aug-85 16:42") (* returns the position from an image  object sketch element.) (PROG [(REG (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELEMENT] (RETURN (CREATEPOSITION (fetch (REGION LEFT) of REG) (fetch (REGION BOTTOM) of REG]) (CREATE.SKIMAGEOBJ.TYPE [LAMBDA NIL (* rrb "18-Oct-85 10:33") (* create a sketch type that allows image objects to appear in sketches.) (COND ((NOT (SKETCH.ELEMENT.TYPEP 'SKIMAGEOBJ)) (CREATE.SKETCH.ELEMENT.TYPE 'SKIMAGEOBJ NIL "functions for using image objects in sketches" (FUNCTION SK.IMAGEOBJ.DRAWFN) (FUNCTION SK.IMAGEOBJ.EXPANDFN) 'OBSOLETE (FUNCTION SK.IMAGEOBJ.CHANGEFN) (FUNCTION NILL) (FUNCTION SK.IMAGEOBJ.INSIDEFN) (FUNCTION SK.IMAGEOBJ.REGIONFN) (FUNCTION SK.IMAGEOBJ.TRANSLATEFN) (FUNCTION NILL) (FUNCTION SK.IMAGEOBJ.READCHANGEFN) (FUNCTION SK.IMAGEOBJ.TRANSFORMFN) NIL (FUNCTION SK.IMAGEOBJ.GLOBALREGIONFN]) (IMAGEBOXSIZE [LAMBDA (IMAGEOBJ IMAGESTREAM) (* rrb " 4-Feb-86 14:41") (* returns the size of an imageobj) (APPLY* (fetch (IMAGEFNS IMAGEBOXFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ)) IMAGEOBJ IMAGESTREAM]) (SK.UPDATE.IMAGEOBJECT.AFTER.CHANGE [LAMBDA (IMOBJELT VIEWER) (* rrb " 4-Feb-86 15:04") (* updates the dependent fields of a sketch image object element after the  image object changes.) (PROG (IMOBJSIZE IMAGEOBJ SCALE) (SETQ IMOBJSIZE (IMAGEBOXSIZE (fetch (SKIMAGEOBJ SKIMAGEOBJ) of (SETQ IMAGEOBJ (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of IMOBJELT))) VIEWER)) (SETQ SCALE (fetch (SKIMAGEOBJ SKIMOBJ.ORIGSCALE) of IMAGEOBJ)) (replace (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of IMAGEOBJ with (create REGION using (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of IMAGEOBJ) WIDTH _ (TIMES (fetch (IMAGEBOX XSIZE) of IMOBJSIZE) SCALE) HEIGHT _ (TIMES (fetch (IMAGEBOX YSIZE) of IMOBJSIZE) SCALE))) (replace (SKIMAGEOBJ SKIMOBJ.OFFSETPOS) of IMAGEOBJ with (create POSITION XCOORD _ (fetch (IMAGEBOX XKERN) of IMOBJSIZE) YCOORD _ (fetch (IMAGEBOX YDESC) of IMOBJSIZE))) (RETURN IMOBJELT]) (SKETCH.CREATE.IMAGE.OBJECT [LAMBDA (IMAGEOBJ POSITION SCALE) (* rrb " 8-Jul-86 12:38") (* creates a sketch element from an  image object.) (* calls update object with NIL viewer because no viewer is known.  The image object must get called to calculate the size which should be in  DISPLAY coordinates. Maybe could create a dummy display stream and pass that  down.) (SK.UPDATE.IMAGEOBJECT.AFTER.CHANGE (SKETCH.CREATE.IMAGE.OBJECT1 IMAGEOBJ POSITION SCALE) NIL]) (SKETCH.CREATE.IMAGE.OBJECT1 [LAMBDA (IMAGEOBJ POSITION SCALE) (* rrb " 8-Jul-86 12:12") (* creates a sketch element from an  image object.) (COND ((NUMBERP SCALE)) ((NULL SCALE) (SETQ SCALE 1.0)) (T (\ILLEGAL.ARG SCALE))) (COND ((NULL POSITION)) ((POSITIONP POSITION)) (T (\ILLEGAL.ARG POSITION))) (create GLOBALPART INDIVIDUALGLOBALPART _ (create SKIMAGEOBJ SKIMAGEOBJ _ IMAGEOBJ SKIMOBJ.GLOBALREGION _ (CREATEREGION (COND (POSITION (fetch (POSITION XCOORD ) of POSITION)) (T 0)) (COND (POSITION (fetch (POSITION YCOORD ) of POSITION)) (T 0)) 1 1) SKIMOBJ.ORIGSCALE _ SCALE) COMMONGLOBALPART _ (create COMMONGLOBALPART MAXSCALE _ (TIMES SCALE MINIMUM.VISIBLE.SCALE.FACTOR) MINSCALE _ (QUOTIENT SCALE DEFAULT.VISIBLE.SCALE.FACTOR]) ) (DEFINEQ (SK.IMAGEOBJ.DRAWFN [LAMBDA (IMAGEOBJELT WINDOW REGION) (* rrb "25-Oct-84 10:27") (* shows an image object element) (PROG ((IMAGEOBJ (fetch (SKIMAGEOBJ SKIMAGEOBJ) of (fetch (SCREENELT INDIVIDUALGLOBALPART) of IMAGEOBJELT))) (LOCALIMOBJ (fetch (SCREENELT LOCALPART) of IMAGEOBJELT)) LOCALPOS LOCALOFFSET) (SETQ LOCALPOS (fetch (LOCALSKIMAGEOBJ SKIMOBJLOCALPOS) of LOCALIMOBJ)) (SETQ LOCALOFFSET (fetch (LOCALSKIMAGEOBJ SKIMOBJLOCALOFFSETPOS) of LOCALIMOBJ)) (* move stream to correct position.) (MOVETO (PLUS (fetch (POSITION XCOORD) of LOCALPOS) (fetch (POSITION XCOORD) of LOCALOFFSET)) (PLUS (fetch (POSITION YCOORD) of LOCALPOS) (fetch (POSITION YCOORD) of LOCALOFFSET)) WINDOW) (COND ((type? ANNO (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)) (* handle annotations specially so  they get the scale.) (ANNO.DISPLAYFN IMAGEOBJ WINDOW (IMAGESTREAMTYPE WINDOW) NIL (fetch (LOCALSKIMAGEOBJ SKIMOBJLOCALSCALE) of LOCALIMOBJ))) (T (APPLY* (IMAGEOBJPROP IMAGEOBJ 'DISPLAYFN) IMAGEOBJ WINDOW]) (SK.IMAGEOBJ.REGIONFN [LAMBDA (IMAGEOJBELT) (* rrb " 4-Oct-84 13:34") (* determines the local region covered  by image object elt.) (fetch (LOCALSKIMAGEOBJ SKIMOBJLOCALREGION) of (fetch (SCREENELT LOCALPART) of IMAGEOJBELT]) (SK.IMAGEOBJ.GLOBALREGIONFN [LAMBDA (GIMOBJELT) (* rrb "18-Oct-85 10:33") (* returns the global region occupied by a global image object element.) (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GIMOBJELT ]) (SK.IMAGEOBJ.TRANSLATEFN [LAMBDA (GIMAGEOBJ DELTAPOS WINDOW) (* rrb "15-Dec-86 15:34") (* moves a imageobj figure element to  a new position.) (PROG ((INDIMAGEOBJELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GIMAGEOBJ)) IMAGEOBJ FN) (COND ((AND (SETQ FN (IMAGEOBJPROP (SETQ IMAGEOBJ (fetch (SKIMAGEOBJ SKIMAGEOBJ) of INDIMAGEOBJELT )) 'WHENMOVEDFN)) (NEQ FN 'NILL)) (* documentation calls for passing text streams as well but there aren't any.) (APPLY* FN IMAGEOBJ WINDOW WINDOW))) (* update the region positions.) (RETURN (create GLOBALPART COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) of GIMAGEOBJ )) INDIVIDUALGLOBALPART _ (create SKIMAGEOBJ using INDIMAGEOBJELT SKIMOBJ.GLOBALREGION _ (TRANSLATE.REGION (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION ) of INDIMAGEOBJELT) (fetch (POSITION XCOORD) of DELTAPOS) (fetch (POSITION YCOORD) of DELTAPOS]) (SK.IMAGEOBJ.EXPANDFN [LAMBDA (GIMAGEOBJPART SCALE) (* rrb "11-Jul-86 15:55") (* creates a local imageobject screen element from a global imageobject  element.) (PROG ((GIMAGEOBJ (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GIMAGEOBJPART)) LOCALREG LOCALPOS IMAGESIZE) (SETQ LOCALREG (SK.SCALE.REGION (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of GIMAGEOBJ) SCALE)) (RETURN (create SCREENELT LOCALPART _ (create LOCALSKIMAGEOBJ SKIMOBJLOCALPOS _ (create POSITION XCOORD _ (fetch (REGION LEFT) of LOCALREG) YCOORD _ (fetch (REGION BOTTOM) of LOCALREG)) SKIMOBJLOCALSCALE _ (QUOTIENT SCALE (fetch (SKIMAGEOBJ SKIMOBJ.ORIGSCALE ) of GIMAGEOBJ)) SKIMOBJLOCALREGION _ LOCALREG SKIMOBJLOCALOFFSETPOS _ (SK.SCALE.POSITION.INTO.VIEWER (fetch (SKIMAGEOBJ SKIMOBJ.OFFSETPOS) of GIMAGEOBJ) SCALE)) GLOBALPART _ GIMAGEOBJPART]) (SK.IMAGEOBJ.INSIDEFN [LAMBDA (GIMAGEOBJ WREG) (* rrb "31-Mar-84 09:15") (* determines if the global annotation element is inside of WREG.) (REGIONSINTERSECTP (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GIMAGEOBJ)) WREG]) (SK.IMAGEOBJ.MOVEFN [LAMBDA (IMAGEOBJELT SELPOS NEWINPUTPT WINDOW) (* rrb "11-Jul-86 15:51") (* moves a annotation element to a new  position.) (PROG ((GIMOBJ (fetch (SCREENELT GLOBALPART) of IMAGEOBJELT)) (SCALEDNEWPOS (SK.MAP.INPUT.PT.TO.GLOBAL NEWINPUTPT (VIEWER.SCALE WINDOW))) GREG GINDV FN IMAGEOBJ) (* update the position) [SETQ GREG (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of (SETQ GINDV (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GIMOBJ] (replace (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of GINDV with (CREATEREGION (fetch (POSITION XCOORD) of SCALEDNEWPOS) (fetch (POSITION YCOORD) of SCALEDNEWPOS) (fetch (REGION WIDTH) of GREG) (fetch (REGION HEIGHT) of GREG))) (COND ((AND (SETQ FN (IMAGEOBJPROP (SETQ IMAGEOBJ (fetch (SKIMAGEOBJ SKIMAGEOBJ) of GINDV)) 'WHENMOVEDFN)) (NEQ FN 'NILL)) (* documentation calls for passing text streams as well but there aren't any.) (APPLY* FN IMAGEOBJ WINDOW))) (RETURN GIMOBJ]) (SK.IMAGEOBJ.CHANGEFN [LAMBDA (IMAGEOBJELTS WINDOW HOW) (* rrb " 4-Feb-86 14:58") (* * user has indicated that they want to change the image object in  IMAGEOBJELT) (* HOW is always T because  SK.IMAGEOBJ.READCHANGEFN always  returns T) (* for now only work on the first one.) (PROG (FN (IMAGEOBJELT (CAR IMAGEOBJELTS)) SKIMOBJELT NEWIMAGEOBJ IMAGEOBJ OLDREG) (SETQ SKIMOBJELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of IMAGEOBJELT)) (SETQ IMAGEOBJ (fetch (SKIMAGEOBJ SKIMAGEOBJ) of SKIMOBJELT)) (* call the BUTTONEVENTINFN even though this may not work because much  information is unavailable.) (COND ((AND (SETQ FN (IMAGEOBJPROP IMAGEOBJ 'BUTTONEVENTINFN)) (NEQ FN 'NILL)) (AND (SETQ NEWIMAGEOBJ (APPLY* (IMAGEOBJPROP IMAGEOBJ 'BUTTONEVENTINFN) IMAGEOBJ WINDOW)) (RETURN (LIST (create SKHISTORYCHANGESPEC NEWELT _ (SKETCH.IMAGE.OBJECT.ELEMENT (COND ((type? IMAGEOBJ NEWIMAGEOBJ) NEWIMAGEOBJ) (T IMAGEOBJ)) (fetch (SKIMAGEOBJ SKIMOBJ.ORIGSCALE) of SKIMOBJELT ) (create POSITION XCOORD _ (fetch (REGION LEFT) of (SETQ OLDREG (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION ) of SKIMOBJELT ))) YCOORD _ (fetch (REGION BOTTOM) of OLDREG)) WINDOW) OLDELT _ (fetch (SCREENELT GLOBALPART) of IMAGEOBJELT) PROPERTY _ 'DATA NEWVALUE _ NEWIMAGEOBJ OLDVALUE _ IMAGEOBJ]) (SK.IMAGEOBJ.READCHANGEFN [LAMBDA (SKW) (* return T so SK.IMAGE.OBJ.CHANGEFN  will always be called.) T]) (SK.IMAGEOBJ.TRANSFORMFN [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "15-Dec-86 15:35") (* * returns a copy of the global SKIMAGEOBJ element that has its region  transformed by transformfn. TRANSFORMDATA is arbitrary data that is passed to  tranformfn.) (PROG ((INDVPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT))) (RETURN (create GLOBALPART COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) of GELT)) INDIVIDUALGLOBALPART _ (create SKIMAGEOBJ using INDVPART SKIMOBJ.GLOBALREGION _ (SK.TRANSFORM.REGION (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION ) of INDVPART) TRANSFORMFN TRANSFORMDATA]) ) (DECLARE%: EVAL@COMPILE (RECORD LOCALSKIMAGEOBJ ((SKIMOBJLOCALPOS) LOCALHOTREGION SKIMOBJLOCALSCALE SKIMOBJLOCALREGION SKIMOBJLOCALOFFSETPOS)) (TYPERECORD SKIMAGEOBJ (SKIMAGEOBJ SKIMOBJ.GLOBALREGION SKIMOBJ.ORIGSCALE SKIMOBJ.OFFSETPOS)) (DATATYPE ANNO (ANNO\SUBSTANCE ANNO\ID ANNO\WINDOW ANNO\DATE ANNO\PARENTS ANNO\NEXTSUBID ANNO\TYPE ANNO\SUMMARIZED\IN ANNO\UPDATE\DATE ANNO\CREATE\BY ANNO\UPDATE\BY ANNO\FONT)) ) (/DECLAREDATATYPE 'ANNO '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((ANNO 0 POINTER) (ANNO 2 POINTER) (ANNO 4 POINTER) (ANNO 6 POINTER) (ANNO 8 POINTER) (ANNO 10 POINTER) (ANNO 12 POINTER) (ANNO 14 POINTER) (ANNO 16 POINTER) (ANNO 18 POINTER) (ANNO 20 POINTER) (ANNO 22 POINTER)) '24) (CREATE.SKIMAGEOBJ.TYPE) (PUTPROPS SKETCHOBJ COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1990 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2157 31523 (MAKE.IMAGE.OBJECT.OF.SKETCH 2167 . 3331) (SK.ELEMENT.FROM.IMAGEOBJ 3333 . 3632) (SKETCHIMAGEOBJ.FROM.VIEWER 3634 . 4046) (SKETCH.IMAGEOBJ 4048 . 4884) (SKETCH.DISPLAYFN 4886 . 8497) (SKETCH.BITMAP.IMAGE 8499 . 10170) (SKIO.IMAGEBOXFN 10172 . 12177) (SKIO.GETFN.2 12179 . 13648) (SKIO.UPDATE.FROM.OLD.FORM 13650 . 14334) (SKIO.GETFN 14336 . 14854) (SKIO.PUTFN 14856 . 15853) ( SKIO.COPYFN 15855 . 16557) (SKIO.BUTTONEVENTINFN 16559 . 21616) (TRANSLATE.REGION 21618 . 22147) ( UPDATE.IMAGE.IN.DOCUMENT 22149 . 24668) (SK.COPY.IMAGEOBJ 24670 . 26341) (COPY.IMAGE.OBJECT 26343 . 26880) (\CREATE.SKETCH.IMAGEFNS 26882 . 28019) (\SKIO.IN.TOO.SMALL.TEDITP 28021 . 28713) ( SKETCH.VIEWER.GRID 28715 . 30012) (SKETCH.VIEWER.SCALE 30014 . 31521)) (31886 39876 ( SKETCH.IMAGE.OBJECT.ELEMENT 31896 . 32309) (SKETCH.IMAGEOBJ.OF.ELEMENT 32311 . 32637) ( SKETCH.SCALE.OF.ELEMENT 32639 . 33067) (SKETCH.POSITION.OF.ELEMENT 33069 . 33716) ( CREATE.SKIMAGEOBJ.TYPE 33718 . 34643) (IMAGEBOXSIZE 34645 . 34996) (SK.UPDATE.IMAGEOBJECT.AFTER.CHANGE 34998 . 37125) (SKETCH.CREATE.IMAGE.OBJECT 37127 . 37849) (SKETCH.CREATE.IMAGE.OBJECT1 37851 . 39874) ) (39877 54282 (SK.IMAGEOBJ.DRAWFN 39887 . 41559) (SK.IMAGEOBJ.REGIONFN 41561 . 41986) ( SK.IMAGEOBJ.GLOBALREGIONFN 41988 . 42389) (SK.IMAGEOBJ.TRANSLATEFN 42391 . 44674) ( SK.IMAGEOBJ.EXPANDFN 44676 . 46862) (SK.IMAGEOBJ.INSIDEFN 46864 . 47398) (SK.IMAGEOBJ.MOVEFN 47400 . 49631) (SK.IMAGEOBJ.CHANGEFN 49633 . 52708) (SK.IMAGEOBJ.READCHANGEFN 52710 . 52939) ( SK.IMAGEOBJ.TRANSFORMFN 52941 . 54280))))) STOP \ No newline at end of file diff --git a/library/SKETCHOPS b/library/SKETCHOPS new file mode 100644 index 00000000..85225d56 --- /dev/null +++ b/library/SKETCHOPS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "21-Jan-93 17:03:05" {DSK}lde>lispcore>library>SKETCHOPS.;2 217175 changes to%: (VARS SKETCHOPSCOMS) (FNS SK.APPLY.AFFINE.TRANSFORM) previous date%: "20-Aug-92 14:07:42" {DSK}lde>lispcore>library>SKETCHOPS.;1) (* ; " Copyright (c) 1986, 1987, 1990, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SKETCHOPSCOMS) (RPAQQ SKETCHOPSCOMS [ (* ;  "functions that used to be on SKETCH") (COMS (* ;; "miscellaneous utility functions") (FNS SK.FONTNAMELIST SCALE.REGION.OUT SK.SCALE.POSITION.INTO.VIEWER SK.SCALE.POSITION.INTO.VIEWER.EXACT SK.MAKE.POSITION.INTEGER SCALE.POSITION.INTO.SKETCHW UNSCALE UNSCALE.REGION) (* ;; "misc IO functions") (FNS STATUSPRINT CLEARPROMPTWINDOW CLOSEPROMPTWINDOW MYGETPROMPTWINDOW PROMPT.GETINPUT) ) (COMS (* ;; "fns for dealing with display priorities") (FNS SK.SEND.TO.BOTTOM SK.BRING.TO.TOP SK.SWITCH.PRIORITIES SK.SEL.AND.CHANGE.PRIORITY SK.SEL.AND.SWITCH.PRIORITIES SK.SORT.ELTS.BY.PRIORITY SK.SORT.GELTS.BY.PRIORITY SORT.CHANGESPECS.BY.NEW.PRIORITY SORT.CHANGESPECS.BY.OLD.PRIORITY SK.SEND.ELEMENTS.TO.BOTTOM SK.BRING.ELEMENTS.TO.TOP SK.COPY.GLOBAL.ELEMENT.AND.PROPERTY.LIST) (FNS SK.ELEMENT.PRIORITY SK.SET.ELEMENT.PRIORITY SK.POP.NEXT.PRIORITY SK.PRIORITY.CELL SK.HIGH.PRIORITY SK.LOW.PRIORITY)) (COMS (* ;; "functions for dealing with display elements.") (FNS DRAW.LOCAL.SKETCH SET.PRIORITYIMPORTANT SK.FIGUREIMAGE) (COMS (* ;; "functions for hardcopying") (FNS SKETCHW.HARDCOPYFN SK.LIST.IMAGE SK.HARDCOPYIMAGEW) (FNS SK.DO.HARDCOPYIMAGEW.TOFILE SK.HARDCOPYIMAGEW.TOFILE SK.HARDCOPYIMAGEW.TOPRINTER SK.LIST.IMAGE.ON.FILE) (FNS \SK.LIST.PAGE.IMAGE SK.GetImageFile SK.PRINTER.FILE.CANDIDATE.NAME SK.SET.HARDCOPY.MODE SK.UNSET.HARDCOPY.MODE SK.UPDATE.AFTER.HARDCOPY DEFAULTPRINTINGIMAGETYPE SK.SWITCH.REGION.X.AND.Y) (CONSTANTS MICASPERPT IMICASPERPT PTSPERMICA))) (COMS (* ;; "fns to implement transformations on the elements") (FNS SK.SEL.AND.TRANSFORM SK.TRANSFORM.ELEMENTS SK.TRANSFORM.ITEM SK.TRANSFORM.ELEMENT SK.TRANSFORM.POINT SK.TRANSFORM.POINT.LIST SK.TRANSFORM.REGION SK.PUT.ELTS.ON.GRID SK.TRANSFORM.GLOBAL.ELEMENTS GLOBALELEMENTP SKETCH.LIST.OF.ELEMENTSP SK.TRANSFORM.SCALE.FACTOR SK.TRANSFORM.BRUSH SK.TRANSFORM.ARROWHEADS SCALE.BRUSH) (FNS TWO.PT.TRANSFORMATION.INPUTFN SK.TWO.PT.TRANSFORM.ELTS SK.SEL.AND.TWO.PT.TRANSFORM SK.APPLY.AFFINE.TRANSFORM SK.COMPUTE.TWO.PT.TRANSFORMATION SK.COMPUTE.SLOPE SK.THREE.PT.TRANSFORM.ELTS SK.COMPUTE.THREE.PT.TRANSFORMATION SK.SEL.AND.THREE.PT.TRANSFORM THREE.PT.TRANSFORMATION.INPUTFN) (FNS SK.COPY.AND.TWO.PT.TRANSFORM.ELTS SK.SEL.COPY.AND.TWO.PT.TRANSFORM SK.COPY.AND.THREE.PT.TRANSFORM.ELTS SK.SEL.COPY.AND.THREE.PT.TRANSFORM SK.COPY.AND.TRANSFORM.ELEMENTS SK.COPY.AND.TRANSFORM.ITEM) (DECLARE%: DONTCOPY (RECORDS AFFINETRANSFORMATION)) (UGLYVARS FIRSTPTMARK SECONDPTMARK THIRDPTMARK NEWFIRSTPTMARK NEWSECONDPTMARK) (GLOBALVARS FIRSTPTMARK SECONDPTMARK THIRDPTMARK NEWFIRSTPTMARK NEWSECONDPTMARK) (FILES MATMULT)) (COMS (* ; "functions for marking") (FNS SK.SHOWMARKS MARKPOINT SK.MARKHOTSPOTS SK.MARK.SELECTION) (UGLYVARS POINTMARK SPOTMARKER) (GLOBALVARS POINTMARK SPOTMARKER) (CURSORS POINTREADINGCURSOR) (* ; "hit detection functions.") (FNS SK.SELECT.ITEM IN.SKETCH.ELT? SK.MARK.HOTSPOT SK.MARK.POSITION SK.SELECT.ELT SK.DESELECT.ELT) (CONSTANTS (SK.POINT.WIDTH 4)) (* ;  "fns to support caching of hotspots.") (FNS SK.HOTSPOT.CACHE SK.HOTSPOT.CACHE.FOR.OPERATION SK.BUILD.CACHE SK.ELEMENT.PROTECTED? SK.HAS.SOME.HOTSPOTS SK.SET.HOTSPOT.CACHE SK.CREATE.HOTSPOT.CACHE SK.ELTS.FROM.HOTSPOT SK.ADD.HOTSPOTS.TO.CACHE SK.ADD.HOTSPOTS.TO.CACHE1 SK.ADD.HOTSPOT.TO.CACHE SK.REMOVE.HOTSPOTS.FROM.CACHE SK.REMOVE.HOTSPOTS.FROM.CACHE1 SK.REMOVE.HOTSPOT.FROM.CACHE SK.REMOVE.VALUE.FROM.CACHE.BUCKET SK.FIND.CACHE.BUCKET SK.ADD.VALUE.TO.CACHE.BUCKET)) (COMS (* ; "grid stuff") (FNS SK.SET.GRID SK.DISPLAY.GRID SK.DISPLAY.GRID.POINTS SK.REMOVE.GRID.POINTS SK.TAKE.DOWN.GRID SK.SHOW.GRID SK.GRIDFACTOR SK.TURN.GRID.ON SK.TURN.GRID.OFF SK.MAKE.GRID.LARGER SK.MAKE.GRID.SMALLER SK.CHANGE.GRID GRID.FACTOR1 LEASTPOWEROF2GT GREATESTPOWEROF2LT SK.DEFAULT.GRIDFACTOR SK.PUT.ON.GRID MAP.WINDOW.ONTO.GRID MAP.SCREEN.ONTO.GRID MAP.GLOBAL.PT.ONTO.GRID MAP.GLOBAL.REGION.ONTO.GRID MAP.WINDOW.POINT.ONTO.GLOBAL.GRID MAP.WINDOW.ONTO.GLOBAL.GRID SK.UPDATE.GRIDFACTOR SK.MAP.FROM.WINDOW.TO.GLOBAL.GRID SK.MAP.INPUT.PT.TO.GLOBAL SK.MAP.FROM.WINDOW.TO.NEAREST.GRID) (INITVARS (DEFAULTGRIDSIZE 8) (DEFAULTMINGRIDSIZE 4) (DEFAULTMAXGRIDSIZE 32))) (COMS (* ; "history and undo stuff") (FNS SK.ADD.HISTEVENT SK.SEL.AND.UNDO SK.UNDO.LAST SK.UNDO.NAME SKEVENTTYPEFNS SK.TYPE.OF.FIRST.ARG) (FNS SK.DELETE.UNDO SK.ADD.UNDO) (FNS SK.CHANGE.UNDO SK.ELT.IN.SKETCH? SK.CHANGE.REDO SK.MOVE.UNDO SK.MOVE.REDO) (FNS SK.UNDO.UNDO SK.UNDO.MENULABEL SK.LABEL.FROM.TYPE) (DECLARE%: DONTCOPY (RECORDS SKHISTEVENT SKEVENTTYPE)) (INITVARS (SKETCH.#.UNDO.ITEMS 30)) (GLOBALVARS SKETCH.#.UNDO.ITEMS) (IFPROP EVENTFNS ADD DELETE CHANGE UNDO MOVE COPY ZOOM ANNOTATE LINK)) (COMS (* ;  "functions for displaying the global coordinate space values.") (FNS SHOW.GLOBAL.COORDS LOCATOR.CLOSEFN SKETCHW.FROM.LOCATOR SKETCHW.UPDATE.LOCATORS LOCATOR.UPDATE UPDATE.GLOBAL.LOCATOR UPDATE.GLOBALCOORD.LOCATOR ADD.GLOBAL.DISPLAY ADD.GLOBAL.GRIDDED.DISPLAY CREATE.GLOBAL.DISPLAYER UPDATE.GLOBAL.GRIDDED.COORD.LOCATOR) (VARS (SKETCHW.LASTCURSORPTX 0) (SKETCHW.LASTCURSORY 0)) (GLOBALVARS SKETCHW.LASTCURSORPTX SKETCHW.LASTCURSORPTY)) (COMS (* ; "fns for reading colors") (FNS DISPLAYREADCOLORHLSLEVELS DISPLAYREADCOLORLEVEL DRAWREADCOLORBOX READ.CHANGE.COLOR READCOLOR1 READCOLORCOMMANDMENUSELECTEDFN READCOLOR2) (FNS CREATE.CNS.MENU) (VARS COLORMENUHEIGHT COLORMENUWIDTH) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILES (LOADCOMP) LLCOLOR))) (COMS (* ;; "functions that used to be taken from GRAPHZOOM. Renamed and defined here so GRAPHZOOM isn't loaded.") (FNS SK.ABSWXOFFSET SK.ABSWYOFFSET SK.UNSCALE.POSITION.FROM.VIEWER SK.SCALE.REGION)) (COMS (* ; "functions for zooming") (FNS VIEWER.SCALE SKETCH.ZOOM SAME.ASPECT.RATIO SKETCH.DO.ZOOM SKETCH.NEW.VIEW ZOOM.UPDATE.ELT SK.UPDATE.AFTER.SCALE.CHANGE SKETCH.AUTOZOOM SKETCH.GLOBAL.REGION.ZOOM) (INITVARS (AUTOZOOM.FACTOR 0.8) (AUTOZOOM.REPAINT.TIME 3000)) (CURSORS AUTOZOOMCURSOR ZOOMINCURSOR ZOOMOUTCURSOR) (GLOBALVARS AUTOZOOM.FACTOR AUTOZOOM.REPAINT.TIME ZOOMINCURSOR ZOOMOUTCURSOR)) (COMS (* ; "fns for changing the view") (FNS SKETCH.HOME SK.FRAME.IT SK.FRAME.WINDOW.TO.SKETCH SK.MOVE.TO.VIEW SK.NAME.CURRENT.VIEW SKETCH.ADD.VIEW SK.RESTORE.VIEW SK.FORGET.VIEW) (DECLARE%: DONTCOPY (RECORDS SKETCHVIEW))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILES (LOADCOMP) SKETCH SKETCHELEMENTS SKETCHOBJ SKETCHEDIT INTERPRESS)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA STATUSPRINT]) (* ; "functions that used to be on SKETCH") (* ;; "miscellaneous utility functions") (DEFINEQ (SK.FONTNAMELIST [LAMBDA (FONTDESC) (* rrb " 2-NOV-83 21:00") (LIST (FONTPROP FONTDESC 'FAMILY) (FONTPROP FONTDESC 'SIZE) (FONTPROP FONTDESC 'FACE]) (SCALE.REGION.OUT [LAMBDA (REGION SCALE) (* rrb "30-Dec-85 17:24") (* scales a region into a windows coordinate space making sure that all of the  region is covered e.g. rounds out.) (PROG [(ROUNDINGFACTOR (DIFFERENCE SCALE (QUOTIENT SCALE 20000.0] (RETURN (CREATEREGION (FIX (QUOTIENT (fetch (REGION LEFT) of REGION) SCALE)) (FIX (QUOTIENT (fetch (REGION BOTTOM) of REGION) SCALE)) (FIX (QUOTIENT (PLUS (fetch (REGION WIDTH) of REGION) ROUNDINGFACTOR) SCALE)) (FIX (QUOTIENT (PLUS (fetch (REGION HEIGHT) of REGION) ROUNDINGFACTOR) SCALE]) (SK.SCALE.POSITION.INTO.VIEWER [LAMBDA (POS SCALE) (* rrb "11-Sep-86 14:35") (* scales a position into window  coordinates from global coordinates.) (COND ((EQP SCALE 1) (* avoid QUOTIENT) (SK.MAKE.POSITION.INTEGER POS)) (T (create POSITION XCOORD _ (FIXR (QUOTIENT (fetch (POSITION XCOORD) of POS) SCALE)) YCOORD _ (FIXR (QUOTIENT (fetch (POSITION YCOORD) of POS) SCALE]) (SK.SCALE.POSITION.INTO.VIEWER.EXACT [LAMBDA (POS SCALE) (* rrb "30-Sep-86 15:28") (* * scales a position into global coordinates from window coordinates.  Doesn't convert to the closest integer like SK.SCALE.POSITION.INTO.VIEWER) (create POSITION XCOORD _ (QUOTIENT (fetch (POSITION XCOORD) of POS) SCALE) YCOORD _ (QUOTIENT (fetch (POSITION YCOORD) of POS) SCALE]) (SK.MAKE.POSITION.INTEGER [LAMBDA (POS) (* rrb "11-Sep-86 14:35") (* makes sure a position has integer  coordinates) (COND ((AND (FIXP (fetch (POSITION XCOORD) of POS)) (FIXP (fetch (POSITION YCOORD) of POS))) (* avoid creation if possible) POS) (T (create POSITION XCOORD _ (FIXR (fetch (POSITION XCOORD) of POS)) YCOORD _ (FIXR (fetch (POSITION YCOORD) of POS]) (SCALE.POSITION.INTO.SKETCHW [LAMBDA (POS SKETCHW) (* rrb "11-Jul-86 15:52") (* scales a position into a sketch window using its scale factor.) (SK.SCALE.POSITION.INTO.VIEWER POS (VIEWER.SCALE SKETCHW]) (UNSCALE [LAMBDA (COORD SCALE) (* unscales a coordinate) (TIMES COORD SCALE]) (UNSCALE.REGION [LAMBDA (REGION SCALE) (* rrb "15-AUG-83 17:31") (* scales a region from a window region to the larger coordinate space.) (CREATEREGION (TIMES SCALE (fetch (REGION LEFT) of REGION)) (TIMES SCALE (fetch (REGION BOTTOM) of REGION)) (TIMES SCALE (fetch (REGION WIDTH) of REGION)) (TIMES SCALE (fetch (REGION HEIGHT) of REGION]) ) (* ;; "misc IO functions") (DEFINEQ (STATUSPRINT [LAMBDA NEXPS (* rrb "26-Jun-84 09:42") (* prints a list of expressions in the status window associated with another  window. If the first arg is a window or a process, its prompt window is used.  Otherwise, the global prompt window is used.) (OR (EQ NEXPS 0) (PROG (WIN (BEG 1)) (COND ((WINDOWP (ARG NEXPS 1)) (SETQ BEG 2) (SETQ WIN (MYGETPROMPTWINDOW (ARG NEXPS 1) 2))) [(PROCESSP (ARG NEXPS 1)) (SETQ BEG 2) (COND ([AND (HASTTYWINDOWP (ARG NEXPS 1)) (SETQ WIN (OPENWP (PROCESS.TTY (ARG NEXPS 1] (SETQ WIN (GETPROMPTWINDOW WIN))) (T (SETQ WIN PROMPTWINDOW] ((EQ (ARG NEXPS 1) T) (SETQ BEG 2) (SETQ WIN (TTYDISPLAYSTREAM))) [(HASTTYWINDOWP (THIS.PROCESS)) (SETQ WIN (GETPROMPTWINDOW (TTYDISPLAYSTREAM] (T (SETQ WIN PROMPTWINDOW))) (for X from BEG to NEXPS do (PRIN1 (ARG NEXPS X) WIN]) (CLEARPROMPTWINDOW [LAMBDA (W) (* rrb "28-Nov-84 11:20") (* clears the prompt window of a window.  IF W is NIL, clears the global one.) (COND [(WINDOWP W) (PROG (PWIN) (AND (SETQ PWIN (GETPROMPTWINDOW W NIL NIL T)) (OPENWP PWIN) (CLEARW PWIN] (T (CLRPROMPT]) (CLOSEPROMPTWINDOW [LAMBDA (WINDOW) (* rrb "20-Nov-85 10:26") (* clears and closes the prompt window  for a window.) (PROG [(PROMPTW (OPENWP (GETPROMPTWINDOW WINDOW NIL NIL T] (COND (PROMPTW (CLEARW PROMPTW) (DETACHWINDOW PROMPTW) (CLOSEW PROMPTW]) (MYGETPROMPTWINDOW [LAMBDA (MAINW NLINES FONT DONTCREATE) (* rrb "28-Aug-85 11:10") (* a version of GETPROMPTWINDOW that  is locally closable.) (PROG ((PROMPTW (GETPROMPTWINDOW (ARG NEXPS 1) 2 (OR FONT (DEFAULTFONT 'DISPLAY)) DONTCREATE))) [COND (PROMPTW (* make it locally closeable) (WINDOWADDPROP PROMPTW 'CLOSEFN (FUNCTION DETACHWINDOW] (RETURN PROMPTW]) (PROMPT.GETINPUT [LAMBDA (WINDOW PROMPTSTRING DEFAULTSTRING DELIMITER.LIST) (* rrb "23-May-84 14:39") (* Ask for input (file names, &c)  perhaps with a default.) (PROG (PROMPTWIN) (COND (WINDOW (SETQ PROMPTWIN (GETPROMPTWINDOW WINDOW)) (FRESHLINE PROMPTWIN)) ((SETQ PROMPTWIN PROMPTWINDOW) (CLEARW PROMPTWIN))) (RETURN (PROMPTFORWORD PROMPTSTRING DEFAULTSTRING NIL PROMPTWIN NIL NIL (OR DELIMITER.LIST (CHARCODE (EOL LF TAB ESCAPE))) NIL]) ) (* ;; "fns for dealing with display priorities") (DEFINEQ (SK.SEND.TO.BOTTOM [LAMBDA (W) (* rrb "24-Sep-86 16:39") (* allows the user to select an element or group of elements and puts them on  the bottom of the priority stack.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.CHANGE.PRIORITY (KWOTE W)) W]) (SK.BRING.TO.TOP [LAMBDA (W) (* rrb "24-Sep-86 16:39") (* allows the user to select an element or group of elements and brings them to  the top of the priority stack.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.CHANGE.PRIORITY (KWOTE W) T) W]) (SK.SWITCH.PRIORITIES [LAMBDA (W) (* rrb "24-Sep-86 15:21") (* allows the user to select two elements and switches their positions in the  priority stack.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.SWITCH.PRIORITIES (KWOTE W)) W]) (SK.SEL.AND.CHANGE.PRIORITY [LAMBDA (W TOTOPFLG) (* rrb "24-Sep-86 16:39") (* lets the user select one or more elements and moves them to the top or the  bottom of the priority stack depending on WHERE) (PROG ((SELELTS (SK.SELECT.MULTIPLE.ITEMS W T))) (OR SELELTS (RETURN)) (SETQ SELELTS (SK.SORT.ELTS.BY.PRIORITY SELELTS)) (COND (TOTOPFLG (SK.BRING.ELEMENTS.TO.TOP SELELTS W)) (T (SK.SEND.ELEMENTS.TO.BOTTOM SELELTS W]) (SK.SEL.AND.SWITCH.PRIORITIES [LAMBDA (W) (* rrb "26-Sep-86 16:14") (* lets the user select a group of elements and reorderes them from the top to  bottom.) (PROG ((SELELTS (SK.SELECT.MULTIPLE.ITEMS W T)) SKETCH GELT NEWGELT PRIORITY) (OR (CDR SELELTS) (RETURN)) (OR (SETQ SKETCH (INSURE.SKETCH W)) (RETURN)) (SETQ SELELTS (SK.SORT.ELTS.BY.PRIORITY SELELTS)) (SK.DO.AND.RECORD.CHANGES (for ELT in SELELTS as TOELT in (REVERSE SELELTS) collect (SETQ GELT (fetch (SCREENELT GLOBALPART) of ELT)) (SETQ NEWGELT (SK.COPY.GLOBAL.ELEMENT.AND.PROPERTY.LIST GELT)) [SK.SET.ELEMENT.PRIORITY NEWGELT (SETQ PRIORITY (SK.ELEMENT.PRIORITY (fetch (SCREENELT GLOBALPART) of TOELT] (create SKHISTORYCHANGESPEC NEWELT _ NEWGELT OLDELT _ GELT PROPERTY _ 'PRIORITY NEWVALUE _ PRIORITY OLDVALUE _ (SK.ELEMENT.PRIORITY GELT))) W T T) (REDISPLAYW W]) (SK.SORT.ELTS.BY.PRIORITY [LAMBDA (LOCALELTS) (* rrb "24-Sep-86 15:57") (* sorts a list of local elements by their priority top most element first) (SORT LOCALELTS (FUNCTION (LAMBDA (A B) (GREATERP (SK.ELEMENT.PRIORITY (fetch (SCREENELT GLOBALPART) of A)) (SK.ELEMENT.PRIORITY (fetch (SCREENELT GLOBALPART) of B]) (SK.SORT.GELTS.BY.PRIORITY [LAMBDA (GLOBALELTS) (* rrb "25-Sep-86 15:19") (* sorts a list of local elements by their priority bottom most element first) (SORT GLOBALELTS (FUNCTION (LAMBDA (A B) (LESSP (SK.ELEMENT.PRIORITY A) (SK.ELEMENT.PRIORITY B]) (SORT.CHANGESPECS.BY.NEW.PRIORITY [LAMBDA (CHANGESPECLST) (* rrb "25-Sep-86 13:51") (* sorts a list of changespecs so that the first change spec element in the  list is the lowest priority, etc.) (SORT CHANGESPECLST (FUNCTION (LAMBDA (A B) (LESSP (SK.ELEMENT.PRIORITY (fetch (SKHISTORYCHANGESPEC NEWELT) of A)) (SK.ELEMENT.PRIORITY (fetch (SKHISTORYCHANGESPEC NEWELT) of B]) (SORT.CHANGESPECS.BY.OLD.PRIORITY [LAMBDA (CHANGESPECLST) (* rrb "25-Sep-86 13:54") (* sorts a list of changespecs so that the first change spec element in the  list is the lowest priority, etc.) (SORT CHANGESPECLST (FUNCTION (LAMBDA (A B) (LESSP (SK.ELEMENT.PRIORITY (fetch (SKHISTORYCHANGESPEC OLDELT) of A)) (SK.ELEMENT.PRIORITY (fetch (SKHISTORYCHANGESPEC OLDELT) of B]) (SK.SEND.ELEMENTS.TO.BOTTOM [LAMBDA (ELEMENTS VIEWER) (* rrb "24-Sep-86 18:06") (* * sets the priority of elements so that they all appear on the bottom.  ELEMENTS are sorted so the topmost element is first.) (PROG ((SKETCH (INSURE.SKETCH VIEWER)) LOWEST GELT NEWGELT) (OR SKETCH (RETURN)) (* find the lowest priority element so that all these do below it.) (SETQ LOWEST (SK.LOW.PRIORITY SKETCH)) (SK.DO.AND.RECORD.CHANGES (for ELT in ELEMENTS collect (SETQ LOWEST (SUB1 LOWEST)) (SETQ GELT (fetch (SCREENELT GLOBALPART) of ELT)) (SETQ NEWGELT (SK.COPY.GLOBAL.ELEMENT.AND.PROPERTY.LIST GELT)) (SK.SET.ELEMENT.PRIORITY NEWGELT LOWEST) (create SKHISTORYCHANGESPEC NEWELT _ NEWGELT OLDELT _ GELT PROPERTY _ 'PRIORITY NEWVALUE _ LOWEST OLDVALUE _ (SK.ELEMENT.PRIORITY GELT))) VIEWER T T) (SK.LOW.PRIORITY SKETCH LOWEST) (REDISPLAYW VIEWER]) (SK.BRING.ELEMENTS.TO.TOP [LAMBDA (ELEMENTS W) (* rrb "26-Sep-86 16:15") (* sets the priority of the elements ELEMENTS so that they are on top.) (PROG ((SKETCH (INSURE.SKETCH W)) HIGHEST GELT NEWGELT) (OR SKETCH (RETURN)) (SETQ HIGHEST (SK.HIGH.PRIORITY SKETCH)) (* the elements are ordered from highest to lowest, reverse them so that they  stay in the same order.) (SK.DO.AND.RECORD.CHANGES (for ELT in (REVERSE ELEMENTS) collect (SETQ HIGHEST (ADD1 HIGHEST)) (SETQ GELT (fetch (SCREENELT GLOBALPART) of ELT)) (SETQ NEWGELT (SK.COPY.GLOBAL.ELEMENT.AND.PROPERTY.LIST GELT)) (SK.SET.ELEMENT.PRIORITY NEWGELT HIGHEST) (create SKHISTORYCHANGESPEC NEWELT _ NEWGELT OLDELT _ GELT PROPERTY _ 'PRIORITY NEWVALUE _ HIGHEST OLDVALUE _ (SK.ELEMENT.PRIORITY GELT))) W T T) (SK.HIGH.PRIORITY SKETCH HIGHEST) (REDISPLAYW W]) (SK.COPY.GLOBAL.ELEMENT.AND.PROPERTY.LIST [LAMBDA (GELT) (* rrb "24-Sep-86 17:26") (* makes a copy of a global sketch element that has the property list copied as  well.) (PROG ((COMGLOBPART (fetch (GLOBALPART COMMONGLOBALPART) of GELT))) (RETURN (create GLOBALPART COMMONGLOBALPART _ (create COMMONGLOBALPART MINSCALE _ (fetch (COMMONGLOBALPART MINSCALE) of COMGLOBPART) MAXSCALE _ (fetch (COMMONGLOBALPART MAXSCALE) of COMGLOBPART) SKELEMENTPROPLIST _ (APPEND (fetch ( COMMONGLOBALPART SKELEMENTPROPLIST ) of COMGLOBPART ))) INDIVIDUALGLOBALPART _ (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT]) ) (DEFINEQ (SK.ELEMENT.PRIORITY [LAMBDA (GELEMENT) (* rrb "30-Aug-86 17:52") (* fetchs the priority of an element.) (OR (LISTGET (fetch (GLOBALPART SKELEMENTPROPLIST) of GELEMENT) 'PRI) 0]) (SK.SET.ELEMENT.PRIORITY [LAMBDA (GELEMENT PRIORITY) (* rrb "30-Aug-86 20:50") (* * sets the priority of an element.) (* keeps the priority first because it is looked at every display.) (PROG ((PLIST (fetch (GLOBALPART SKELEMENTPROPLIST) of GELEMENT))) [COND [PLIST (COND ((EQ (CAR PLIST) 'PRI) (RPLACA (CDR PLIST) PRIORITY)) (T (replace (GLOBALPART SKELEMENTPROPLIST) of GELEMENT with (CONS 'PRI (CONS PRIORITY PLIST] (T (replace (GLOBALPART SKELEMENTPROPLIST) of GELEMENT with (LIST 'PRI PRIORITY] (RETURN PRIORITY]) (SK.POP.NEXT.PRIORITY [LAMBDA (SKETCH) (* rrb "24-Sep-86 17:19") (* gets the next highest priority) (PROG ((PRIORITYCELL (SK.PRIORITY.CELL SKETCH))) (RETURN (CAR (RPLACA PRIORITYCELL (ADD1 (CAR PRIORITYCELL]) (SK.PRIORITY.CELL [LAMBDA (SKETCH) (* rrb "24-Sep-86 17:16") (OR (GETSKETCHPROP SKETCH 'PRIRANGE) (PUTSKETCHPROP SKETCH 'PRIRANGE (CONS 0 0]) (SK.HIGH.PRIORITY [LAMBDA (SKETCH VALUE) (* rrb "24-Sep-86 17:21") (* sets a new value of the highest  priority element.) (PROG ((CELL (SK.PRIORITY.CELL SKETCH))) (RETURN (PROG1 (CAR CELL) (COND ((NUMBERP VALUE) (RPLACA CELL VALUE]) (SK.LOW.PRIORITY [LAMBDA (SKETCH VALUE) (* rrb "24-Sep-86 17:22") (* reads and sets a new value of the lowest priority element.) (PROG ((CELL (SK.PRIORITY.CELL SKETCH))) (RETURN (PROG1 (CDR CELL) (COND ((NUMBERP VALUE) (RPLACD CELL VALUE]) ) (* ;; "functions for dealing with display elements.") (DEFINEQ (DRAW.LOCAL.SKETCH [LAMBDA (LOCALSPECS STREAM STREAMREGION SCALE) (* ; "Edited 24-Mar-92 14:00 by jds") (* ;; "draws the local specs on a stream") (* ;; "set priority of the stream in case mode is set to REPLACE or ERASE --- would be better to scan list looking for an element that actually has one of these.") (SET.PRIORITYIMPORTANT STREAM 1) [MAPSKETCHSPECS LOCALSPECS (FUNCTION SK.DRAWFIGURE) STREAM STREAMREGION (OR (NUMBERP SCALE) (AND (WINDOWP STREAM) (VIEWER.SCALE STREAM] (* ;  "turn the priority off so that the rest of the file procedes at speed.") (SET.PRIORITYIMPORTANT STREAM 0]) (SET.PRIORITYIMPORTANT [LAMBDA (STREAM TOVAL) (* rrb "26-Sep-86 15:11") (* sets the PriorityImportant variable  in an interpress master.) (COND ((IMAGESTREAMTYPEP STREAM 'INTERPRESS) (APPENDINTEGER.IP STREAM TOVAL) (ISET.IP STREAM PRIORITYIMPORTANT]) (SK.FIGUREIMAGE [LAMBDA (SCRITEMS LIMITREGION REGIONOFINTEREST) (* rrb "30-Sep-86 18:33") (* returns a bitmap which contains the image of the elements on SCRITEMS.  And a lower left corner.) (RESETFORM (CURSOR WAITINGCURSOR) (PROG (REGION DSPSTREAM BITMAP LEFT BOTTOM LIMITDIM) (COND ((NULL SCRITEMS) (RETURN))) [COND ((SCREENELEMENTP SCRITEMS) (* single item case.) (SETQ REGION (SK.ITEM.REGION SCRITEMS))) (T (SETQ REGION (SK.ITEM.REGION (CAR SCRITEMS))) [for SCITEM in (CDR SCRITEMS) do (SETQ REGION (SK.UNIONREGIONS REGION (SK.ITEM.REGION SCITEM] (* order the elements by priority) (SETQ SCRITEMS (REVERSE (SK.SORT.ELTS.BY.PRIORITY SCRITEMS] (* only some of the points are being moved, reduce the region to those.) (AND REGIONOFINTEREST (SETQ REGION (OR (INTERSECTREGIONS REGION REGIONOFINTEREST) REGION))) [COND (LIMITREGION (* limit the size of the bitmap. This is used by copy insert functions that do  not know how big the thing coming in is.) (COND ((GREATERP (fetch (REGION WIDTH) of REGION) (SETQ LIMITDIM (fetch (REGION WIDTH) of LIMITREGION))) (* reduce the width picking out the middle of the region) (replace (REGION LEFT) of REGION with (PLUS (fetch (REGION LEFT) of REGION) (QUOTIENT (DIFFERENCE LIMITDIM (fetch (REGION WIDTH) of REGION)) 2))) (replace (REGION WIDTH) of REGION with LIMITDIM))) (COND ((GREATERP (fetch (REGION HEIGHT) of REGION) (SETQ LIMITDIM (fetch (REGION HEIGHT) of LIMITREGION))) (* reduce the height picking out the middle of the region) (replace (REGION BOTTOM) of REGION with (PLUS (fetch (REGION BOTTOM) of REGION) (QUOTIENT (DIFFERENCE LIMITDIM (fetch (REGION HEIGHT) of REGION)) 2))) (replace (REGION HEIGHT) of REGION with LIMITDIM] (* ADD1 is used to convert the possibly floating region coordinates into fixed.) [SETQ DSPSTREAM (DSPCREATE (SETQ BITMAP (BITMAPCREATE (ADD1 (fetch (REGION WIDTH) of REGION)) (ADD1 (fetch (REGION HEIGHT) of REGION] (DSPXOFFSET [IMINUS (SETQ LEFT (FIXR (fetch (REGION LEFT) of REGION] DSPSTREAM) (DSPYOFFSET [IMINUS (SETQ BOTTOM (FIXR (fetch (REGION BOTTOM) of REGION] DSPSTREAM) (* this is because the default clipping region is smaller than the clipping  region of the figure in extreme cases.) (DSPCLIPPINGREGION REGION DSPSTREAM) (DSPOPERATION 'PAINT DSPSTREAM) (* to avoid carriage returns.) (DSPRIGHTMARGIN (PLUS 100 (fetch (REGION RIGHT) of REGION)) DSPSTREAM) (DRAW.LOCAL.SKETCH SCRITEMS DSPSTREAM REGION) (RETURN (create SKFIGUREIMAGE SKFIGURE.LOWERLEFT _ (create POSITION XCOORD _ LEFT YCOORD _ BOTTOM) SKFIGURE.BITMAP _ BITMAP]) ) (* ;; "functions for hardcopying") (DEFINEQ (SKETCHW.HARDCOPYFN [LAMBDA (SKETCHW OPENIMAGESTREAM) (* ; "Edited 20-Aug-92 13:33 by jds") (* ;  "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. (DONE: JDS 8/2-0/92)") (DSPLEFTMARGIN (MIN 0 (fetch (REGION LEFT) of PAGEREGION)) OPENIMAGESTREAM) (DSPBOTTOMMARGIN (MIN 0 (fetch (REGION BOTTOM) of PAGEREGION)) OPENIMAGESTREAM) (DSPTOPMARGIN (MAX MAX.FIXP (fetch (REGION TOP) of PAGEREGION)) OPENIMAGESTREAM) (DSPRIGHTMARGIN (MAX MAX.FIXP (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 (IMAGESTREAMTYPEP OPENIMAGESTREAM 'INTERPRESS) (GREATERP (fetch (REGION WIDTH) of SKETCHREGIONINPAGECOORDS) (fetch (REGION WIDTH) of PAGEREGION)) (GREATERP (fetch (REGION WIDTH) of SKETCHREGIONINPAGECOORDS) (fetch (REGION HEIGHT) of SKETCHREGIONINPAGECOORDS))) (* ; "Print in landscape mode") (* ;  "only know the hack for interpress streams.") (* ;  "Hack to coerce interpress stream into landscapemode") (* ;; "It's Landscape mode. PRINTERMODE may be looked up by POLYSHADE.IP") (NCONC (fetch (STREAM OTHERPROPS) of OPENIMAGESTREAM) '(PRINTERMODE LANDSCAPE)) (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) (* ; "End HACK") )) (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]) (SK.LIST.IMAGE [LAMBDA (SKETCHW FILE IMAGETYPE DONTLISTFLG) (* ; "Edited 20-Aug-92 13:42 by jds") (* ;; "makes an image file from the sketch in a window even if it takes more than one page.") (PROG ((SKETCH (INSURE.SKETCH (SKETCH.FROM.VIEWER SKETCHW))) (VIEWREGION (DSPCLIPPINGREGION NIL SKETCHW)) (SCALE (VIEWER.SCALE SKETCHW)) PAGEREGION OPENIMAGESTREAM PAGEOVERLAPMARGIN SKETCHREGION SKETCHLOCALELTS SKETCHREGIONINPAGECOORDS LEFTSTART BOTTOMSTART RIGHTEND BOTTOMEND PAGETOSKETCHFACTOR PAGEHEIGHTINSKETCHCOORDS PAGEWIDTHINSKETCHCOORDS) (OR SKETCH (RETURN)) (SPAWN.MOUSE) (STATUSPRINT SKETCHW "Hardcopying ... ") (SETQ OPENIMAGESTREAM (OPENIMAGESTREAM FILE IMAGETYPE)) (SETQ PAGEREGION (DSPCLIPPINGREGION NIL OPENIMAGESTREAM)) (* ; "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 MAX.FIXP (fetch (REGION TOP) of PAGEREGION)) OPENIMAGESTREAM) (DSPRIGHTMARGIN (MAX MAX.FIXP (fetch (REGION RIGHT) of PAGEREGION)) OPENIMAGESTREAM) (* ;; "calculate the local elements for all the sketch elements at this scale. This is done because the region testing routines all work on local elements. The local elements will be made again for each page; wasteful but should demonstrate the capability.") (SETQ SKETCHLOCALELTS (for SKELT in (fetch (SKETCH SKETCHELTS) of SKETCH) collect (SK.LOCAL.FROM.GLOBAL SKELT SKETCHW SCALE))) (SETQ SKETCHREGION (SK.GLOBAL.REGION.OF.LOCAL.ELEMENTS SKETCHLOCALELTS SCALE)) (* ;; "PAGETOSKETCHFACTOR is the factor to multiply the page coordinates by to get into sketch coordinates.") (SETQ PAGETOSKETCHFACTOR (FQUOTIENT SCALE (DSPSCALE NIL OPENIMAGESTREAM))) (SETQ SKETCHREGIONINPAGECOORDS (SCALE.REGION.OUT SKETCHREGION PAGETOSKETCHFACTOR)) (* ;  "should check here for wider than high and rotate it or use landscape imagestream.") [COND ((AND (ILESSP (fetch (REGION WIDTH) of SKETCHREGIONINPAGECOORDS) (fetch (REGION WIDTH) of PAGEREGION)) (ILESSP (fetch (REGION HEIGHT) of SKETCHREGIONINPAGECOORDS) (fetch (REGION HEIGHT) of PAGEREGION))) (* ;  "whole image fits on one page, center it") (SETQ LEFTSTART (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of PAGEREGION) (fetch (REGION WIDTH) of SKETCHREGIONINPAGECOORDS )) 2)) (SETQ BOTTOMSTART (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of PAGEREGION) (fetch (REGION HEIGHT) of SKETCHREGIONINPAGECOORDS )) 2)) (\SK.LIST.PAGE.IMAGE OPENIMAGESTREAM SKETCHREGION SKETCHLOCALELTS PAGETOSKETCHFACTOR (CREATEREGION LEFTSTART BOTTOMSTART (fetch (REGION WIDTH) of SKETCHREGIONINPAGECOORDS ) (fetch (REGION HEIGHT) of SKETCHREGIONINPAGECOORDS )) SCALE)) (T (* ;  "put sketch on multiple pages. Might also try scaling it to fit.") (* ;  "leave a half inch so that the pages can be taped together.") (SETQ PAGEOVERLAPMARGIN (TIMES 36 (DSPSCALE NIL OPENIMAGESTREAM))) (SETQ PAGEREGION (CREATEREGION (fetch (REGION LEFT) of PAGEREGION) (fetch (REGION BOTTOM) of PAGEREGION) (DIFFERENCE (fetch (REGION WIDTH) of PAGEREGION) PAGEOVERLAPMARGIN) (DIFFERENCE (fetch (REGION HEIGHT) of PAGEREGION) PAGEOVERLAPMARGIN))) (SETQ PAGEWIDTHINSKETCHCOORDS (TIMES (fetch (REGION WIDTH) of PAGEREGION) PAGETOSKETCHFACTOR)) (SETQ PAGEHEIGHTINSKETCHCOORDS (TIMES (fetch (REGION HEIGHT) of PAGEREGION) PAGETOSKETCHFACTOR)) (* ;; "adjust sketch region to center the image within the multiple pages. This is mostly to cover the case of a wide but not high image that extents across multiple pages.") [COND ([NOT (ZEROP (SETQ LEFTSTART (REMAINDER (fetch (REGION WIDTH) of SKETCHREGION ) PAGEWIDTHINSKETCHCOORDS] (* ;  "unless the sketch is right on a page boundary, leave half the room in front.") (SETQ LEFTSTART (QUOTIENT (DIFFERENCE PAGEWIDTHINSKETCHCOORDS LEFTSTART) 2] (SETQ LEFTSTART (DIFFERENCE (fetch (REGION LEFT) of SKETCHREGION) LEFTSTART)) [COND ([NOT (ZEROP (SETQ BOTTOMSTART (REMAINDER (fetch (REGION HEIGHT) of SKETCHREGION ) PAGEHEIGHTINSKETCHCOORDS] (* ;  "unless the sketch is right on a page boundary, leave half the room in front.") (SETQ BOTTOMSTART (QUOTIENT (DIFFERENCE PAGEHEIGHTINSKETCHCOORDS BOTTOMSTART) 2] (SETQ BOTTOMSTART (DIFFERENCE (PLUS (fetch (REGION TOP) of SKETCHREGION) BOTTOMSTART) PAGEHEIGHTINSKETCHCOORDS)) (SETQ BOTTOMEND (DIFFERENCE (fetch (REGION BOTTOM) of SKETCHREGION) PAGEHEIGHTINSKETCHCOORDS)) (SETQ RIGHTEND (fetch (REGION RIGHT) of SKETCHREGION)) (STATUSPRINT SKETCHW (TIMES (IQUOTIENT (DIFFERENCE (PLUS RIGHTEND (SUB1 PAGEWIDTHINSKETCHCOORDS )) LEFTSTART) PAGEWIDTHINSKETCHCOORDS) (IQUOTIENT (DIFFERENCE (PLUS BOTTOMSTART (SUB1 PAGEHEIGHTINSKETCHCOORDS )) BOTTOMEND) PAGEHEIGHTINSKETCHCOORDS)) " pgs...") (bind (PGN _ 0) for PGBOTTOM from BOTTOMSTART to BOTTOMEND by (MINUS PAGEHEIGHTINSKETCHCOORDS) as PGROW from 1 do (* ;  "unless this is the first line of pages, put out new page.") (OR (EQ PGROW 1) (DSPNEWPAGE OPENIMAGESTREAM)) (for PGLEFT from LEFTSTART to RIGHTEND by PAGEWIDTHINSKETCHCOORDS as PGCOL from 1 do (* ;  "unless this is the first page on a line of pages, put out new page.") (OR (EQ PGCOL 1) (DSPNEWPAGE OPENIMAGESTREAM)) (\SK.LIST.PAGE.IMAGE OPENIMAGESTREAM (CREATEREGION PGLEFT PGBOTTOM PAGEWIDTHINSKETCHCOORDS PAGEHEIGHTINSKETCHCOORDS) SKETCHLOCALELTS PAGETOSKETCHFACTOR PAGEREGION SCALE) (STATUSPRINT SKETCHW (SETQ PGN (ADD1 PGN)) ",") (* ;; "code to put out matrix numbers that I couldn't get to work. (COND ((IMAGESTREAMTYPEP OPENIMAGESTREAM (QUOTE PRESS)) (* Press does better at the left edge so put numbers on the right.) (COND ((LESSP (PLUS PGLEFT PAGEWIDTHINSKETCHCOORDS) (fetch (REGION RIGHT) of SKETCHREGION)) (* unless this is the last page, print a page number in the area that is overlapped.) (* this should change back to the default font of the stream but I don't know how to do that.) (MOVETO (fetch (REGION WIDTH) of PAGEREGION) (PLUS (fetch (REGION HEIGHT) of PAGEREGION) (FONTPROP OPENIMAGESTREAM (QUOTE DESCENT))) OPENIMAGESTREAM) (printout OPENIMAGESTREAM PGROW ', ' PGCOL)))) ((NEQ PGCOL 1) (* Interpress and assumed all others look better at the right edge so put the number on the left.) (* unless this is the first page, print a page number in the area that is overlapped.) (* this should change back to the default font of the stream but I don't know how to do that.) (MOVETO 10 (FONTPROP OPENIMAGESTREAM (QUOTE DESCENT)) OPENIMAGESTREAM) (printout OPENIMAGESTREAM PGROW ', ' PGCOL)))") ] (SETQ LEFTSTART (CLOSEF OPENIMAGESTREAM)) (STATUSPRINT SKETCHW "...done.") (RETURN LEFTSTART]) (SK.HARDCOPYIMAGEW [LAMBDA (SKW) (* ; "Edited 20-Aug-92 13:46 by jds") (* ;; "spawns a process to hardcopy a viewer. This is spawned so that the lock on the viewer is released.") (ADD.PROCESS (LIST 'HARDCOPYIMAGEW (KWOTE SKW)) 'NAME 'SketchHardcopy]) ) (DEFINEQ (SK.DO.HARDCOPYIMAGEW.TOFILE [LAMBDA (W) (* rrb " 5-May-86 13:38") (* sketch version of HARDCOPYIMAGEW.TOFILE that accepts a candidate file name.) (RESETFORM (TTY.PROCESS (THIS.PROCESS)) (LET [(FILE&TYPE (SK.GetImageFile (SK.PRINTER.FILE.CANDIDATE.NAME W] (COND (FILE&TYPE (HARDCOPY.SOMEHOW W (CAR FILE&TYPE) (CDR FILE&TYPE]) (SK.HARDCOPYIMAGEW.TOFILE [LAMBDA (SKW) (* rrb " 5-May-86 13:34") (* spawns a process to hardcopy a viewer.  This is spawned so that the lock on the viewer is released.) (ADD.PROCESS (LIST 'SK.DO.HARDCOPYIMAGEW.TOFILE (KWOTE SKW)) 'NAME 'SketchHardcopy]) (SK.HARDCOPYIMAGEW.TOPRINTER [LAMBDA (SKW) (* rrb "10-Feb-86 14:31") (* spawns a process to hardcopy a viewer.  This is spawned so that the lock on the viewer is released.) (ADD.PROCESS (LIST 'HARDCOPYIMAGEW.TOPRINTER (KWOTE SKW)) 'NAME 'SketchHardcopy]) (SK.LIST.IMAGE.ON.FILE [LAMBDA (SKETCHW) (* rrb " 5-May-86 13:39") (* makes a file suitable for the default printing host of the current sketch.  Pretty dumb about file names.) (RESETFORM (TTY.PROCESS (THIS.PROCESS)) (LET [(FILE&TYPE (SK.GetImageFile (SK.PRINTER.FILE.CANDIDATE.NAME SKETCHW] (COND (FILE&TYPE (SK.LIST.IMAGE SKETCHW (CAR FILE&TYPE) (CDR FILE&TYPE]) ) (DEFINEQ (\SK.LIST.PAGE.IMAGE [LAMBDA (OPENIMAGESTREAM REGIONINSKETCH LOCALSKELTS PAGETOSKETCHFACTOR REGIONONPAGE SKETCHTOWINDOWFACTOR) (* rrb "30-Dec-85 17:29") (* draws the image of a set of sketch elements on an OPENIMAGESTREAM.) (PROG ((SCALEDSKETCHREGION (SCALE.REGION.OUT REGIONINSKETCH SKETCHTOWINDOWFACTOR)) ELTSINREGION SKETCHX) (COND ((SETQ ELTSINREGION (for LOCALSKELT in LOCALSKELTS when (REGIONSINTERSECTP SCALEDSKETCHREGION (SK.ITEM.REGION LOCALSKELT)) collect (fetch (SCREENELT GLOBALPART) of LOCALSKELT))) (* translate the sketch so that the right stuff appears in the region on the  page.) [SETQ SKETCHX (TRANSLATE.SKETCH (create SKETCH SKETCHELTS _ ELTSINREGION) (DIFFERENCE (fetch (REGION LEFT) of REGIONINSKETCH) (TIMES (fetch (REGION LEFT) of REGIONONPAGE) PAGETOSKETCHFACTOR)) (DIFFERENCE (fetch (REGION BOTTOM) of REGIONINSKETCH) (TIMES (fetch (REGION BOTTOM) of REGIONONPAGE) PAGETOSKETCHFACTOR] (SETQ SKETCHX (MAKE.LOCAL.SKETCH SKETCHX (CREATEREGION 0 0 (fetch (REGION WIDTH) of REGIONINSKETCH) (fetch (REGION HEIGHT) of REGIONINSKETCH )) PAGETOSKETCHFACTOR OPENIMAGESTREAM T)) (DRAW.LOCAL.SKETCH SKETCHX OPENIMAGESTREAM REGIONONPAGE]) (SK.GetImageFile [LAMBDA (CANDIDATE) (* rrb " 5-May-86 10:41") (* version of GetImageFile that takes  a candidate name.) (PROG ((FILE (PopUpWindowAndGetAtom "File name (CR to abort): " CANDIDATE)) PRINTFILETYPE FILETYPEMENU EXTENSIONSUPPLIED EXTENSIONFORTYPE) (COND ((NULL FILE) (RETURN))) (SETQ FILETYPEMENU (MakeMenuOfImageTypes "File type?")) (COND ((SETQ PRINTFILETYPE (PRINTFILETYPE.FROM.EXTENSION FILE)) (RETURN (CONS FILE PRINTFILETYPE))) (T (SETQ PRINTFILETYPE (MENU FILETYPEMENU)) (COND ((NULL PRINTFILETYPE) (RETURN)) (T (RETURN (CONS FILE PRINTFILETYPE]) (SK.PRINTER.FILE.CANDIDATE.NAME [LAMBDA (VIEWER) (* rrb " 5-May-86 13:30") (* * returns the preferred printer file name for a viewer) (PROG ((FILENAME (SK.OUTPUT.FILE.NAME (SKETCH.TITLE VIEWER))) EXTENSION PRINTEXTENSION) (OR FILENAME (RETURN)) [COND ((EQ (SELECTQ (SETQ PRINTEXTENSION (DEFAULTPRINTINGIMAGETYPE)) (INTERPRESS (SETQ PRINTEXTENSION 'IP)) NIL) (FILENAMEFIELD FILENAME 'EXTENSION)) (* file name has a printer extension for some reason, propose either a null  extension or hdcpy extension.) (COND (PRINTEXTENSION (SETQ PRINTEREXTENSION NIL)) (T (SETQ PRINTEREXTENSION 'HDCPY] (RETURN (PACKFILENAME 'EXTENSION PRINTEXTENSION 'BODY FILENAME]) (SK.SET.HARDCOPY.MODE [LAMBDA (SKETCHW IMAGETYPE) (* rrb "28-Oct-85 16:43") (* * changes a sketch window to show things in hardcopy mode.) (PROG [NOWTYPE (IMAGETYPEX (OR IMAGETYPE (PRINTERTYPE] (RETURN (COND ((OR (NOT (IMAGESTREAMTYPEP SKETCHW 'HARDCOPY)) (AND (SETQ NOWTYPE (HARDCOPYSTREAMTYPE SKETCHW)) (NEQ IMAGETYPEX NOWTYPE))) (* make the font of the stream be something that will not cause  MAKEHARDCOPYSTREAM to barf on.) (* flip cursor because finding fonts  can take a while.) (SKED.CLEAR.SELECTION SKETCHW) (RESETFORM (CURSOR WAITINGCURSOR) (DSPFONT (DEFAULTFONT IMAGETYPE) SKETCHW) (MAKEHARDCOPYSTREAM SKETCHW IMAGETYPE) (SK.UPDATE.AFTER.HARDCOPY SKETCHW))) (T (* already in hardcopy mode.) (STATUSPRINT SKETCHW "The display is already showing " IMAGETYPE " output spacing."]) (SK.UNSET.HARDCOPY.MODE [LAMBDA (SKETCHW) (* rrb "28-Oct-85 16:43") (* * changes a sketch window to show things in normal display mode.) (COND ((IMAGESTREAMTYPEP (GETSTREAM SKETCHW 'OUTPUT) 'HARDCOPY) (SKED.CLEAR.SELECTION SKETCHW) (UNMAKEHARDCOPYSTREAM SKETCHW) (SK.UPDATE.AFTER.HARDCOPY SKETCHW]) (SK.UPDATE.AFTER.HARDCOPY [LAMBDA (SKETCHW) (* rrb "11-Jul-86 15:48") (* * goes through a sketch window updating those elements that have changed as  a result of a change in mode between normal and hardcopy and redraws the  screen.) (MAPSKETCHSPECS (LOCALSPECS.FROM.VIEWER SKETCHW) [FUNCTION (LAMBDA (SKELT SKW SCALE) (COND ((MEMB (fetch (SCREENELT GTYPE) of SKELT) '(TEXT TEXTBOX)) (ZOOM.UPDATE.ELT SKELT SKW] SKETCHW (VIEWER.SCALE SKETCHW)) (REDISPLAYW SKETCHW]) (DEFAULTPRINTINGIMAGETYPE [LAMBDA NIL (* rrb "20-Mar-85 12:45") (* returns the image type of the  default printer.) (* code copied from OPENIMAGESTREAM) (CAR (MKLIST (PRINTERPROP (PRINTERTYPE (OR (CAR (LISTP DEFAULTPRINTINGHOST)) DEFAULTPRINTINGHOST)) 'CANPRINT]) (SK.SWITCH.REGION.X.AND.Y [LAMBDA (REGION) (* rrb " 3-Sep-85 14:50") (* switchs the X and Y dimensions of a  region.) (CREATEREGION (fetch (REGION BOTTOM) of REGION) (fetch (REGION LEFT) of REGION) (fetch (REGION HEIGHT) of REGION) (fetch (REGION WIDTH) of REGION]) ) (DECLARE%: EVAL@COMPILE (RPAQQ MICASPERPT 35.27778) (RPAQQ IMICASPERPT 35) (RPAQQ PTSPERMICA 0.02834646) (CONSTANTS MICASPERPT IMICASPERPT PTSPERMICA) ) (* ;; "fns to implement transformations on the elements") (DEFINEQ (SK.SEL.AND.TRANSFORM [LAMBDA (W TRANSFORMFN TRANSFORMDATA) (* rrb "10-Dec-85 17:25") (* lets the user select some elements and moves all of their control points  onto the grid.) (SK.TRANSFORM.ELEMENTS (SK.SELECT.MULTIPLE.ITEMS W T NIL 'MOVE) TRANSFORMFN TRANSFORMDATA W]) (SK.TRANSFORM.ELEMENTS [LAMBDA (SCRELTS TRANSFORMFN TRANSFORMDATA SKW) (* rrb "26-Apr-85 09:08") (* changes SCRELTS to the elements that have had each of their control points  transformed by transformfn. TRANSFORMDATA is arbitrary data that is passed to  tranformfn.) (PROG (NEWGLOBALS) (* computes the scale factor inherent in the transformation so that it doesn't  have to be done on every element that might need it.  It major use is in scaling brush sizes.) (SETQ NEWGLOBALS (MAPCOLLECTSKETCHSPECS SCRELTS (FUNCTION SK.TRANSFORM.ITEM) TRANSFORMFN TRANSFORMDATA (SK.TRANSFORM.SCALE.FACTOR TRANSFORMFN TRANSFORMDATA) SKW)) (* make a history entry.) (SK.ADD.HISTEVENT 'MOVE (for NEWG in NEWGLOBALS as OLDG in SCRELTS when NEWG collect (LIST (fetch (SCREENELT GLOBALPART) of OLDG) NEWG)) SKW) (RETURN NEWGLOBALS]) (SK.TRANSFORM.ITEM [LAMBDA (SELELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR W) (* rrb "26-Apr-85 09:09") (* SELELT is a sketch element that was selected for a transformation operation.) (PROG (NEWGLOBAL OLDGLOBAL) (COND ((SETQ NEWGLOBAL (SK.TRANSFORM.ELEMENT (SETQ OLDGLOBAL (fetch (SCREENELT GLOBALPART) of SELELT)) TRANSFORMFN TRANSFORMDATA SCALEFACTOR)) (SK.UPDATE.ELEMENT OLDGLOBAL NEWGLOBAL W T) (RETURN NEWGLOBAL]) (SK.TRANSFORM.ELEMENT [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb "26-Apr-85 09:14") (* returns a copy of the global element that has had each of its control points  transformed by transformfn. TRANSFORMDATA is arbitrary data that is passed to  tranformfn.) (APPLY* (SK.TRANSFORMFN (fetch (GLOBALPART GTYPE) of GELT)) GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR]) (SK.TRANSFORM.POINT [LAMBDA (PT TRANSFORMFN TRANSFORMDATA) (* applies a transformation function to a position and returns the transformed  point.) (APPLY* TRANSFORMFN PT TRANSFORMDATA]) (SK.TRANSFORM.POINT.LIST [LAMBDA (PTLST TRANSFORMFN TRANSFORMDATA) (* transforms a list of points) (for PT in PTLST collect (SK.TRANSFORM.POINT PT TRANSFORMFN TRANSFORMDATA]) (SK.TRANSFORM.REGION [LAMBDA (REG TRANSFORMFN TRANSFORMDATA) (* rrb "31-May-85 10:42") (* applies a transformation function to a region and returns the transformed  region) (PROG (LOWERLEFT UPPERRIGHT) (* transform the font by changing the scale according to how much the width of  the box around the first line of text changes from the transformation.) (SETQ LOWERLEFT (SK.TRANSFORM.POINT (create POSITION XCOORD _ (fetch (REGION LEFT) of REG) YCOORD _ (fetch (REGION BOTTOM) of REG)) TRANSFORMFN TRANSFORMDATA)) (SETQ UPPERRIGHT (SK.TRANSFORM.POINT (create POSITION XCOORD _ (fetch (REGION PRIGHT) of REG) YCOORD _ (fetch (REGION PTOP) of REG)) TRANSFORMFN TRANSFORMDATA)) (* transformation may have changed the relative positions of the upper right  and lower left.) (RETURN (CREATEREGION (MIN (fetch (POSITION XCOORD) of LOWERLEFT) (fetch (POSITION XCOORD) of UPPERRIGHT)) (MIN (fetch (POSITION YCOORD) of LOWERLEFT) (fetch (POSITION YCOORD) of UPPERRIGHT)) (ABS (DIFFERENCE (fetch (POSITION XCOORD) of UPPERRIGHT) (fetch (POSITION XCOORD) of LOWERLEFT))) (ABS (DIFFERENCE (fetch (POSITION YCOORD) of UPPERRIGHT) (fetch (POSITION YCOORD) of LOWERLEFT]) (SK.PUT.ELTS.ON.GRID [LAMBDA (W) (* rrb "31-Jan-86 10:59") (* lets the user select some elements and moves all of their control points  onto the grid.) (SK.EVAL.AS.PROCESS (LIST (FUNCTION SK.SEL.AND.TRANSFORM) (KWOTE W) (KWOTE (FUNCTION SK.PUT.ON.GRID)) (KWOTE (SK.GRIDFACTOR W))) W]) (SK.TRANSFORM.GLOBAL.ELEMENTS [LAMBDA (SCRELTS TRANSFORMFN TRANSFORMDATA) (* rrb "29-Apr-85 12:57") (* returns a copy of the global elements that have had each of its control  points transformed by transformfn. TRANSFORMDATA is arbitrary data that is  passed to tranformfn.) (MAPGLOBALSKETCHSPECS SCRELTS (FUNCTION SK.TRANSFORM.ELEMENT) TRANSFORMFN TRANSFORMDATA (SK.TRANSFORM.SCALE.FACTOR TRANSFORMFN TRANSFORMDATA]) (GLOBALELEMENTP [LAMBDA (ELT?) (* rrb "30-Dec-85 15:26") (* * returns ELT? if it is a global sketch element.) (AND (LISTP ELT?) (SKETCH.ELEMENT.NAMEP (fetch (GLOBALPART GTYPE) of ELT?)) ELT?]) (SKETCH.LIST.OF.ELEMENTSP [LAMBDA (ELTS) (* return T if ELTS is a list of sketch elements.) (AND (LISTP ELTS) (for ELT in ELTS always (GLOBALELEMENTP ELT]) (SK.TRANSFORM.SCALE.FACTOR [LAMBDA (TRANSFORMFN TRANSFORMDATA) (* rrb "29-Apr-85 12:09") (* calculates scaling factor based on the transform of points.  Since the transform is arbitrary in x and y scaling, this can't really do the  right thing so it computes the area a unit square would have after  transformation and uses that.) (COND ((EQ TRANSFORMFN (FUNCTION SK.PUT.ON.GRID)) (* test for specially in case grid is larger than unit.  Don't change the scale.) 1.0) (T (PROG ((ORG (SK.TRANSFORM.POINT (CONSTANT (create POSITION XCOORD _ 0 YCOORD _ 0)) TRANSFORMFN TRANSFORMDATA)) (YUNIT (SK.TRANSFORM.POINT (CONSTANT (create POSITION XCOORD _ 0 YCOORD _ 1)) TRANSFORMFN TRANSFORMDATA)) (XUNIT (SK.TRANSFORM.POINT (CONSTANT (create POSITION XCOORD _ 1 YCOORD _ 0)) TRANSFORMFN TRANSFORMDATA))) (RETURN (SQRT (TIMES (DISTANCEBETWEEN YUNIT ORG) (DISTANCEBETWEEN XUNIT ORG]) (SK.TRANSFORM.BRUSH [LAMBDA (BRUSH SCALEFACTOR) (* rrb "26-Apr-85 09:34") (* returns a brush scaled from size  ORGSCALE to NEWSCALE.) (create BRUSH using BRUSH BRUSHSIZE _ (TIMES (fetch (BRUSH BRUSHSIZE) of BRUSH) SCALEFACTOR]) (SK.TRANSFORM.ARROWHEADS [LAMBDA (ARROWHEADS SCALEFACTOR) (* rrb "26-Sep-85 12:17") (* returns a arrowhead specification  scaled by SCALEFACTOR) (AND ARROWHEADS (LIST (AND (CAR ARROWHEADS) (create ARROWHEAD using (CAR ARROWHEADS) ARROWLENGTH _ (TIMES (fetch (ARROWHEAD ARROWLENGTH ) of (CAR ARROWHEADS)) SCALEFACTOR))) (AND (CADR ARROWHEADS) (create ARROWHEAD using (CADR ARROWHEADS) ARROWLENGTH _ (TIMES (fetch (ARROWHEAD ARROWLENGTH ) of (CADR ARROWHEADS)) SCALEFACTOR))) (CADDR ARROWHEADS]) (SCALE.BRUSH [LAMBDA (BRUSH ORGSCALE NEWSCALE) (* rrb " 8-Sep-86 20:02") (* returns a brush scaled from size ORGSCALE to NEWSCALE.  It will returns a size of 0 only if given a size of 0 This is so that brushes  that scale down always show up.) (COND [(EQP ORGSCALE NEWSCALE) (* make unscaled case fast -  avoid floating point.) (PROG ((BRUSHSIZE (fetch (BRUSH BRUSHSIZE) of BRUSH))) (RETURN (create BRUSH using BRUSH BRUSHSIZE _ (COND ((GREATERP 1.0 BRUSHSIZE) (* create a brush of at least 1) (COND ((ZEROP BRUSHSIZE) 0) (T 1))) ((NOT (FIXP BRUSHSIZE)) (FIXR BRUSHSIZE)) (T (RETURN BRUSH] (T (PROG ((BRUSHSIZE (FQUOTIENT (FTIMES (fetch (BRUSH BRUSHSIZE) of BRUSH) ORGSCALE) NEWSCALE))) (RETURN (create BRUSH using BRUSH BRUSHSIZE _ (COND ((ZEROP BRUSHSIZE) 0) (T (IMAX 1 (FIXR BRUSHSIZE]) ) (DEFINEQ (TWO.PT.TRANSFORMATION.INPUTFN [LAMBDA (WINDOW) (* rrb "11-Jul-86 15:54") (* reads four points from the user and returns the two point transformation  that maps the first two into the second two.) (PROG ((SCALE (VIEWER.SCALE WINDOW)) FIRSTPT SECONDPT THIRDPT FOURTHPT FIRSTLOCALPT SECONDLOCALPT THIRDLOCALPT FOURTHLOCALPT) (STATUSPRINT WINDOW " " "Indicate the first point to move.") (COND ((SETQ FIRSTPT (SK.GETGLOBALPOSITION WINDOW)) (SK.MARK.POSITION (SETQ FIRSTLOCALPT (SK.SCALE.POSITION.INTO.VIEWER FIRSTPT SCALE)) WINDOW FIRSTPTMARK)) (T (CLOSEPROMPTWINDOW WINDOW) (RETURN NIL))) (STATUSPRINT WINDOW " " "Indicate the second point to move.") (COND ((SETQ SECONDPT (SK.GETGLOBALPOSITION WINDOW)) (SK.MARK.POSITION (SETQ SECONDLOCALPT (SK.SCALE.POSITION.INTO.VIEWER SECONDPT SCALE)) WINDOW SECONDPTMARK)) (T (* erase first pt on way out) (SK.MARK.POSITION FIRSTLOCALPT WINDOW FIRSTPTMARK) (CLOSEPROMPTWINDOW WINDOW) (RETURN NIL))) (STATUSPRINT WINDOW " " "Indicate the new position of the first point.") (COND ((SETQ THIRDPT (SK.GETGLOBALPOSITION WINDOW)) (SK.MARK.POSITION (SETQ THIRDLOCALPT (SK.SCALE.POSITION.INTO.VIEWER THIRDPT SCALE)) WINDOW NEWFIRSTPTMARK)) (T (* erase first and second pts on way  out) (SK.MARK.POSITION FIRSTLOCALPT WINDOW FIRSTPTMARK) (SK.MARK.POSITION SECONDLOCALPT WINDOW SECONDPTMARK) (CLOSEPROMPTWINDOW WINDOW) (RETURN NIL))) (STATUSPRINT WINDOW " " "Indicate the new position of the second point.") (SETQ FOURTHPT (SK.GETGLOBALPOSITION WINDOW)) (CLOSEPROMPTWINDOW WINDOW) (* erase the point marks.) (SK.MARK.POSITION FIRSTLOCALPT WINDOW FIRSTPTMARK) (SK.MARK.POSITION SECONDLOCALPT WINDOW SECONDPTMARK) (SK.MARK.POSITION THIRDLOCALPT WINDOW NEWFIRSTPTMARK) (OR FOURTHPT (RETURN NIL)) (* keep the coefficients of the two  necessary equations.) (RETURN (SK.COMPUTE.TWO.PT.TRANSFORMATION FIRSTPT SECONDPT THIRDPT FOURTHPT]) (SK.TWO.PT.TRANSFORM.ELTS [LAMBDA (W) (* rrb "31-Jan-86 10:59") (* lets the user select some elements and specify a two point transformation  and applies the transformation to all of the points.) (SK.EVAL.AS.PROCESS (LIST (FUNCTION SK.SEL.AND.TWO.PT.TRANSFORM) (KWOTE W)) W]) (SK.SEL.AND.TWO.PT.TRANSFORM [LAMBDA (W) (* rrb "10-Dec-85 17:26") (* lets the user select some elements and specify a two point transformation  and applies the transformation to all of the points.) (PROG NIL (SK.TRANSFORM.ELEMENTS (OR (SK.SELECT.MULTIPLE.ITEMS W T NIL 'MOVE) (RETURN)) (FUNCTION SK.APPLY.AFFINE.TRANSFORM) (OR (TWO.PT.TRANSFORMATION.INPUTFN W) (RETURN)) W]) (SK.APPLY.AFFINE.TRANSFORM [LAMBDA (GPOSITION AFFINETRANS) (* rrb "28-Apr-85 16:05") (* * applies a tranformation to the point.  AFFINETRANS is an instance of AFFINETRANSFORMATION) (create POSITION XCOORD _ (PLUS (TIMES (fetch (AFFINETRANSFORMATION Ax) of AFFINETRANS) (fetch (POSITION XCOORD) of GPOSITION)) (TIMES (fetch (AFFINETRANSFORMATION By) of AFFINETRANS) (fetch (POSITION YCOORD) of GPOSITION)) (fetch (AFFINETRANSFORMATION C) of AFFINETRANS)) YCOORD _ (PLUS (TIMES (fetch (AFFINETRANSFORMATION Dx) of AFFINETRANS) (fetch (POSITION XCOORD) of GPOSITION)) (TIMES (fetch (AFFINETRANSFORMATION Ey) of AFFINETRANS) (fetch (POSITION YCOORD) of GPOSITION)) (fetch (AFFINETRANSFORMATION F) of AFFINETRANS]) (SK.COMPUTE.TWO.PT.TRANSFORMATION [LAMBDA (P1 P2 Q1 Q2) (* ; "Edited 30-Jan-87 14:24 by rrb") (* computes the AFFINETRANSFORMATION necessary to take P1 into Q1 and P2 into  Q2.) (PROG ((PX1 (fetch (POSITION XCOORD) of P1)) (PY1 (fetch (POSITION YCOORD) of P1)) (PX2 (fetch (POSITION XCOORD) of P2)) (PY2 (fetch (POSITION YCOORD) of P2)) (QX1 (fetch (POSITION XCOORD) of Q1)) (QY1 (fetch (POSITION YCOORD) of Q1)) (QX2 (fetch (POSITION XCOORD) of Q2)) (QY2 (fetch (POSITION YCOORD) of Q2)) (MATRIX2 (IDENTITY-3-BY-3)) (SCRATCHMATRIX (IDENTITY-3-BY-3)) MATRIX1 PDELTAX PDELTAY QDELTAX QDELTAY PLEN QLEN LENRATIO) (* compute the transformation that translates P1 to the origin, rotates it  until P has the same angle as Q, scales it until P has the same length as Q  then translates the new P1 to Q1.) (SETQ PDELTAX (DIFFERENCE PX2 PX1)) (SETQ PDELTAY (DIFFERENCE PY2 PY1)) (SETQ QDELTAX (DIFFERENCE QX2 QX1)) (SETQ QDELTAY (DIFFERENCE QY2 QY1)) (* compute the length of segments P  and Q.) [SETQ PLEN (SQRT (PLUS (TIMES PDELTAX PDELTAX) (TIMES PDELTAY PDELTAY] (COND ((ZEROP PLEN) (STATUSPRINT WINDOW " " "The two source points can not be the same.") (RETURN))) [SETQ QLEN (SQRT (PLUS (TIMES QDELTAX QDELTAX) (TIMES QDELTAY QDELTAY] (COND ((ZEROP QLEN) (STATUSPRINT WINDOW "The two destination points can not be the same.") (RETURN))) (* ratio is done to map P onto Q because the scaling is done after the  rotation. It could be done first if the mapping were done from Q onto P.) (SETQ LENRATIO (QUOTIENT QLEN PLEN)) (* translate P1 to origin.) (* use MATRIX1 and MATRIX2 to swap the running result back and forth since  matrix multiplication routines don't allow the result to be stored in one of  the arguments.) (SETQ MATRIX1 (TRANSLATE-3-BY-3 (MINUS PX1) (MINUS PY1))) (* Scale to make P the same length as  Q.) (MATMULT-333 MATRIX1 (SCALE-3-BY-3 LENRATIO LENRATIO SCRATCHMATRIX) MATRIX2) (* rotate it so that the slope of P is the same as Q.) (MATMULT-333 MATRIX2 (ROTATE-3-BY-3 (DEGREES-TO-RADIANS (DIFFERENCE (SK.COMPUTE.SLOPE PDELTAX PDELTAY) (SK.COMPUTE.SLOPE QDELTAX QDELTAY))) SCRATCHMATRIX) MATRIX1) (* translate the origin pt to Q1. This is complicated because Q1 needs to be  translated, rotated and scaled into new coordinates.) (MATMULT-333 MATRIX1 (TRANSLATE-3-BY-3 QX1 QY1 SCRATCHMATRIX) MATRIX2) (* return only the coefficients that  make a difference.) (RETURN (create AFFINETRANSFORMATION Ax _ (CL:AREF MATRIX2 0 0) By _ (CL:AREF MATRIX2 1 0) C _ (CL:AREF MATRIX2 2 0) Dx _ (CL:AREF MATRIX2 0 1) Ey _ (CL:AREF MATRIX2 1 1) F _ (CL:AREF MATRIX2 2 1]) (SK.COMPUTE.SLOPE [LAMBDA (DELTAX DELTAY) (* rrb "31-May-85 10:09") (* computes the angle of a line from the delta X and Y.) (COND ((ZEROP DELTAX) (COND ((GREATERP DELTAY 0) 90.0) (T -90.0))) (T (PLUS (COND ((GREATERP DELTAX 0) 0.0) (T (* if the line is sloping to the left, add 180 to it.  This is done because we need to make sure that P1 gets mapped into Q1.) 180.0)) (ARCTAN (FQUOTIENT DELTAY DELTAX]) (SK.THREE.PT.TRANSFORM.ELTS [LAMBDA (W) (* rrb "31-Jan-86 11:00") (* lets the user select some elements and specify a three point transformation  and applies the transformation to all of the points.) (SK.EVAL.AS.PROCESS (LIST (FUNCTION SK.SEL.AND.THREE.PT.TRANSFORM) (KWOTE W)) W]) (SK.COMPUTE.THREE.PT.TRANSFORMATION [LAMBDA (P1 P2 P3 Q1 Q2 Q3 ERRORFLG) (* rrb " 8-May-85 18:10") (* computes the AFFINETRANSFORMATION necessary to take P1 into Q1, P2 into Q2  and P3 into Q3.) (PROG ((PX1 (fetch (POSITION XCOORD) of P1)) (PY1 (fetch (POSITION YCOORD) of P1)) (PX2 (fetch (POSITION XCOORD) of P2)) (PY2 (fetch (POSITION YCOORD) of P2)) (PX3 (fetch (POSITION XCOORD) of P3)) (PY3 (fetch (POSITION YCOORD) of P3)) (QX1 (fetch (POSITION XCOORD) of Q1)) (QY1 (fetch (POSITION YCOORD) of Q1)) (QX2 (fetch (POSITION XCOORD) of Q2)) (QY2 (fetch (POSITION YCOORD) of Q2)) (QX3 (fetch (POSITION XCOORD) of Q3)) (QY3 (fetch (POSITION YCOORD) of Q3)) DELTAPY12 DELTAPX12 DELTAPY23 A&DBOTTOM AX BY C DX EY F) (* this is the computation dictated by solving the six equations of the form  QX1 = aPX1 + bPY1 + c for a, b, c, d, e, and f.) (* save some subexpressions that are  reused.) (SETQ DELTAPX12 (FDIFFERENCE PX1 PX2)) (SETQ DELTAPY23 (FDIFFERENCE PY2 PY3)) [COND ((ZEROP (SETQ DELTAPY12 (FDIFFERENCE PY1 PY2))) (* need to divide by this number and it is zero) (COND (ERRORFLG (* this is the second attempt, all points must be horizontal) (STATUSPRINT WINDOW " " "All three source points cannot be in the same line. If you meant this, you should use the TWO PT TRANSFORM.") (RETURN)) (T (* try switching two points) (RETURN (SK.COMPUTE.THREE.PT.TRANSFORMATION P2 P3 P1 Q2 Q3 Q1 T] [COND ([ZEROP (SETQ A&DBOTTOM (FDIFFERENCE (FDIFFERENCE PX2 PX3) (FTIMES (FQUOTIENT DELTAPX12 DELTAPY12) DELTAPY23] (* need to divide by this number and it is zero) (COND (ERRORFLG (* this is the second attempt, maybe all points are collinear, in any case,  can't continue.) (STATUSPRINT WINDOW " " "All three source points cannot be in the same line. If you meant this, you should use the TWO PT TRANSFORM.") (RETURN)) (T (* try switching two points) (RETURN (SK.COMPUTE.THREE.PT.TRANSFORMATION P2 P3 P1 Q2 Q3 Q1 T] (SETQ AX (FQUOTIENT (FDIFFERENCE (FDIFFERENCE QX2 QX3) (FQUOTIENT (FTIMES (FDIFFERENCE QX1 QX2) DELTAPY23) DELTAPY12)) A&DBOTTOM)) (SETQ DX (FQUOTIENT (FDIFFERENCE (FDIFFERENCE QY2 QY3) (FQUOTIENT (FTIMES (FDIFFERENCE QY1 QY2) DELTAPY23) DELTAPY12)) A&DBOTTOM)) (SETQ BY (FQUOTIENT (FDIFFERENCE (FDIFFERENCE QX1 QX2) (FTIMES AX DELTAPX12)) DELTAPY12)) (SETQ EY (FQUOTIENT (FDIFFERENCE (FDIFFERENCE QY1 QY2) (FTIMES DX DELTAPX12)) DELTAPY12)) [SETQ C (FDIFFERENCE QX1 (FPLUS (FTIMES AX PX1) (FTIMES BY PY1] [SETQ F (FDIFFERENCE QY1 (FPLUS (FTIMES DX PX1) (FTIMES EY PY1] (RETURN (create AFFINETRANSFORMATION Ax _ AX By _ BY C _ C Dx _ DX Ey _ EY F _ F]) (SK.SEL.AND.THREE.PT.TRANSFORM [LAMBDA (W) (* rrb "10-Dec-85 17:26") (* lets the user select some elements and specify a three point transformation  and applies the transformation to all of the points.) (PROG NIL (SK.TRANSFORM.ELEMENTS (OR (SK.SELECT.MULTIPLE.ITEMS W T NIL 'MOVE) (RETURN)) (FUNCTION SK.APPLY.AFFINE.TRANSFORM) (OR (THREE.PT.TRANSFORMATION.INPUTFN W) (RETURN)) W]) (THREE.PT.TRANSFORMATION.INPUTFN [LAMBDA (WINDOW) (* rrb "11-Jul-86 15:54") (* reads six points from the user and returns the affine transformation that  maps the first three into the second three) (PROG ((SCALE (VIEWER.SCALE WINDOW)) FIRSTPT SECONDPT THIRDPT FOURTHPT FIFTHPT SIXTHPT FIRSTLOCALPT SECONDLOCALPT THIRDLOCALPT FOURTHLOCALPT FIFTHLOCALPT) (STATUSPRINT WINDOW " " "Indicate the first point to move.") (COND ((SETQ FIRSTPT (SK.GETGLOBALPOSITION WINDOW)) (SK.MARK.POSITION (SETQ FIRSTLOCALPT (SK.SCALE.POSITION.INTO.VIEWER FIRSTPT SCALE)) WINDOW FIRSTPTMARK)) (T (CLOSEPROMPTWINDOW WINDOW) (RETURN NIL))) (STATUSPRINT WINDOW " " "Indicate the second point to move.") (COND ((SETQ SECONDPT (SK.GETGLOBALPOSITION WINDOW)) (SK.MARK.POSITION (SETQ SECONDLOCALPT (SK.SCALE.POSITION.INTO.VIEWER SECONDPT SCALE)) WINDOW SECONDPTMARK)) (T (* erase first pt on way out) (SK.MARK.POSITION FIRSTLOCALPT WINDOW FIRSTPTMARK) (CLOSEPROMPTWINDOW WINDOW) (RETURN NIL))) (STATUSPRINT WINDOW " " "Indicate the third point to move.") (COND ((SETQ THIRDPT (SK.GETGLOBALPOSITION WINDOW)) (SK.MARK.POSITION (SETQ THIRDLOCALPT (SK.SCALE.POSITION.INTO.VIEWER THIRDPT SCALE)) WINDOW THIRDPTMARK)) (T (* erase first and second pts on way  out) (SK.MARK.POSITION FIRSTLOCALPT WINDOW FIRSTPTMARK) (SK.MARK.POSITION SECONDLOCALPT WINDOW SECONDPTMARK) (CLOSEPROMPTWINDOW WINDOW) (RETURN NIL))) (STATUSPRINT WINDOW " " "Indicate the new position of the first point.") (COND ((SETQ FOURTHPT (SK.GETGLOBALPOSITION WINDOW)) (SK.MARK.POSITION (SETQ FOURTHLOCALPT (SK.SCALE.POSITION.INTO.VIEWER FOURTHPT SCALE)) WINDOW NEWFIRSTPTMARK)) (T (* erase first second and third pts on  way out) (SK.MARK.POSITION FIRSTLOCALPT WINDOW FIRSTPTMARK) (SK.MARK.POSITION SECONDLOCALPT WINDOW SECONDPTMARK) (SK.MARK.POSITION THIRDLOCALPT WINDOW THIRDPTMARK) (CLOSEPROMPTWINDOW WINDOW) (RETURN NIL))) (STATUSPRINT WINDOW " " "Indicate the new position of the second point.") (COND ((SETQ FIFTHPT (SK.GETGLOBALPOSITION WINDOW)) (SK.MARK.POSITION (SETQ FIFTHLOCALPT (SK.SCALE.POSITION.INTO.VIEWER FIFTHPT SCALE)) WINDOW NEWSECONDPTMARK)) (T (* erase first second and third pts on  way out) (SK.MARK.POSITION FIRSTLOCALPT WINDOW FIRSTPTMARK) (SK.MARK.POSITION SECONDLOCALPT WINDOW SECONDPTMARK) (SK.MARK.POSITION THIRDLOCALPT WINDOW THIRDPTMARK) (SK.MARK.POSITION FOURTHLOCALPT WINDOW NEWFIRSTPTMARK) (CLOSEPROMPTWINDOW WINDOW) (RETURN NIL))) (STATUSPRINT WINDOW " " "Indicate the new position of the third point.") (SETQ SIXTHPT (SK.GETGLOBALPOSITION WINDOW)) (CLOSEPROMPTWINDOW WINDOW) (* erase the point marks.) (SK.MARK.POSITION FIRSTLOCALPT WINDOW FIRSTPTMARK) (SK.MARK.POSITION SECONDLOCALPT WINDOW SECONDPTMARK) (SK.MARK.POSITION THIRDLOCALPT WINDOW THIRDPTMARK) (SK.MARK.POSITION FOURTHLOCALPT WINDOW NEWFIRSTPTMARK) (SK.MARK.POSITION FIFTHLOCALPT WINDOW NEWSECONDPTMARK) (OR SIXTHPT (RETURN NIL)) (* keep the coefficients of the two  necessary equations.) (RETURN (SK.COMPUTE.THREE.PT.TRANSFORMATION FIRSTPT SECONDPT THIRDPT FOURTHPT FIFTHPT SIXTHPT]) ) (DEFINEQ (SK.COPY.AND.TWO.PT.TRANSFORM.ELTS [LAMBDA (W) (* rrb "31-Jan-86 11:00") (* lets the user select some elements and specify a two point transformation  and applies the transformation to all of the points.) (SK.EVAL.AS.PROCESS (LIST (FUNCTION SK.SEL.COPY.AND.TWO.PT.TRANSFORM) (KWOTE W)) W]) (SK.SEL.COPY.AND.TWO.PT.TRANSFORM [LAMBDA (W) (* rrb "10-Dec-85 17:26") (* lets the user select some elements and specify a two point transformation  and applies the transformation to all copies of the points.) (PROG NIL (SK.COPY.AND.TRANSFORM.ELEMENTS (OR (SK.SELECT.MULTIPLE.ITEMS W T NIL 'COPY) (RETURN)) (FUNCTION SK.APPLY.AFFINE.TRANSFORM) (OR (TWO.PT.TRANSFORMATION.INPUTFN W) (RETURN)) W]) (SK.COPY.AND.THREE.PT.TRANSFORM.ELTS [LAMBDA (W) (* rrb "31-Jan-86 11:00") (* lets the user select some elements and specify a three point transformation  and applies the transformation to copies of the elements) (SK.EVAL.AS.PROCESS (LIST (FUNCTION SK.SEL.COPY.AND.THREE.PT.TRANSFORM) (KWOTE W)) W]) (SK.SEL.COPY.AND.THREE.PT.TRANSFORM [LAMBDA (W) (* rrb "10-Dec-85 17:26") (* lets the user select some elements and specify a three point transformation  and applies the transformation to copies of the elements) (PROG NIL (SK.COPY.AND.TRANSFORM.ELEMENTS (OR (SK.SELECT.MULTIPLE.ITEMS W T NIL 'COPY) (RETURN)) (FUNCTION SK.APPLY.AFFINE.TRANSFORM) (OR (THREE.PT.TRANSFORMATION.INPUTFN W) (RETURN)) W]) (SK.COPY.AND.TRANSFORM.ELEMENTS [LAMBDA (SCRELTS TRANSFORMFN TRANSFORMDATA SKW) (* rrb " 8-May-85 17:08") (* changes copies of SCRELTS to the elements that have had each of their  control points transformed by transformfn.  TRANSFORMDATA is arbitrary data that is passed to tranformfn.) (PROG (NEWGLOBALS) (* computes the scale factor inherent in the transformation so that it doesn't  have to be done on every element that might need it.  It major use is in scaling brush sizes.) (SETQ NEWGLOBALS (MAPCOLLECTSKETCHSPECS SCRELTS (FUNCTION SK.COPY.AND.TRANSFORM.ITEM) TRANSFORMFN TRANSFORMDATA (SK.TRANSFORM.SCALE.FACTOR TRANSFORMFN TRANSFORMDATA) SKW)) (* make a history entry.) (SK.ADD.HISTEVENT 'COPY NEWGLOBALS SKW) (RETURN NEWGLOBALS]) (SK.COPY.AND.TRANSFORM.ITEM [LAMBDA (SELELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR W) (* rrb "10-Mar-86 16:23") (* SELELT is a sketch element that was selected for a copy and transformation  operation.) (PROG (NEWGLOBAL) (COND ((SETQ NEWGLOBAL (SK.TRANSFORM.ELEMENT (fetch (SCREENELT GLOBALPART) of SELELT) TRANSFORMFN TRANSFORMDATA SCALEFACTOR)) (* clear the priority of the element.) (SK.SET.ELEMENT.PRIORITY NEWGLOBAL NIL) (SK.ADD.ELEMENT NEWGLOBAL W) (RETURN NEWGLOBAL]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD AFFINETRANSFORMATION (Ax By C Dx Ey F)) ) ) (READVARS-FROM-STRINGS '(FIRSTPTMARK SECONDPTMARK THIRDPTMARK NEWFIRSTPTMARK NEWSECONDPTMARK) "({(READBITMAP)(25 25 %"AOCNB@@@%" %"AA@HF@@@%" %"AA@HB@@@%" %"AN@HB@@@%" %"A@@HB@@@%" %"A@@HB@@@%" %"A@@HOH@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@GO@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%")} {(READBITMAP)(25 25 %"AOCNG@@@%" %"AA@HHH@@%" %"AA@HAH@@%" %"AN@HG@@@%" %"A@@HL@@@%" %"A@@HH@@@%" %"A@@HOH@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@GO@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%")} {(READBITMAP)(25 25 %"AOCNG@@@%" %"AA@HHH@@%" %"AA@HAH@@%" %"AN@HF@@@%" %"A@@HAH@@%" %"A@@HHH@@%" %"A@@HG@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@GO@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@@@@@@%")} {(READBITMAP)(25 25 %"AAGJB@@@%" %"AIDBJ@@@%" %"AEDBJ@@@%" %"AEGBJ@@@%" %"ACDBJ@@@%" %"ACDBJ@@@%" %"AAGID@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@GO@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"AOCNB@@@%" %"AA@HF@@@%" %"AA@HB@@@%" %"AN@HB@@@%" %"A@@HB@@@%" %"A@@HB@@@%" %"A@@HOH@@%")} {(READBITMAP)(25 25 %"AAGJB@@@%" %"AIDBJ@@@%" %"AEDBJ@@@%" %"AEGBJ@@@%" %"ACDBJ@@@%" %"ACDBJ@@@%" %"AAGID@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@GO@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@@H@@@@%" %"@@@@@@@@%" %"@@@@@@@@%" %"AOCNCH@@%" %"AA@HDD@@%" %"AA@H@D@@%" %"AN@HAH@@%" %"A@@HF@@@%" %"A@@HD@@@%" %"A@@HGL@@%")}) ") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FIRSTPTMARK SECONDPTMARK THIRDPTMARK NEWFIRSTPTMARK NEWSECONDPTMARK) ) (FILESLOAD MATMULT) (* ; "functions for marking") (DEFINEQ (SK.SHOWMARKS [LAMBDA (W HOTSPOTCACHE) (* rrb "29-Jan-85 18:04") (* marks all of the hot spots of sketch elements in a figure window.) (bind Y for BUCKET in HOTSPOTCACHE do (SETQ Y (CAR BUCKET)) (for XBUCKET in (CDR BUCKET) do (* there may be old buckets that don't contain any elements.) (AND (CDR XBUCKET) (SK.MARK.HOTSPOT (CAR XBUCKET) Y W SK.LOCATEMARK]) (MARKPOINT [LAMBDA (PT WINDOW MARK) (* rrb "12-May-85 18:50") (* marks a point in a window with a mark.  The mark should be a bitmap.) (OR MARK (SETQ MARK SK.SELECTEDMARK)) (PROG ((MARKWIDTH (BITMAPWIDTH MARK))) (RETURN (BITBLT MARK 0 0 WINDOW (IDIFFERENCE (fetch (POSITION XCOORD) of PT) (LRSH MARKWIDTH 1)) (IDIFFERENCE (fetch (POSITION YCOORD) of PT) (LRSH (fetch (BITMAP BITMAPHEIGHT) of MARK) 1)) MARKWIDTH MARKWIDTH 'INPUT 'INVERT]) (SK.MARKHOTSPOTS [LAMBDA (SKETCHELT W MARK) (* rrb "12-May-85 18:59") (* marks the hotspots of a sketch element that are not already selected) (PROG [(HOTSPOTCACHE (SK.HOTSPOT.CACHE W)) (SELECTEDELTS (WINDOWPROP W 'SKETCH.SELECTIONS] (for PTTAIL on (fetch (LOCALPART HOTSPOTS) of (fetch (SCREENELT LOCALPART) of SKETCHELT)) unless (OR (MEMBER (CAR PTTAIL) (CDR PTTAIL)) (for ELTSOFPT in (SK.ELTS.FROM.HOTSPOT (CAR PTTAIL) HOTSPOTCACHE) thereis (MEMB ELTSOFPT SELECTEDELTS))) do (* mark points that aren't also hotspots of an already selected element or  duplicate hot spots of this element.) (MARKPOINT (CAR PTTAIL) W MARK]) (SK.MARK.SELECTION [LAMBDA (ELT SKW MARKBM) (* rrb " 9-May-85 10:42") (* marks or unmarks a selection.) (COND ((POSITIONP ELT) (* handle positions {points}  specially.) (MARKPOINT ELT SKW MARKBM)) (T (SK.MARKHOTSPOTS ELT SKW MARKBM]) ) (READVARS-FROM-STRINGS '(POINTMARK SPOTMARKER) "({(READBITMAP)(7 7 %"HB@@%" %"DD@@%" %"BH@@%" %"A@@@%" %"BH@@%" %"DD@@%" %"HB@@%")} {(READBITMAP)(12 12 %"@B@@%" %"@G@@%" %"@G@@%" %"@G@@%" %"CHN@%" %"GHO@%" %"CHN@%" %"@G@@%" %"@G@@%" %"@G@@%" %"@B@@%" %"@@@@%")}) ") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS POINTMARK SPOTMARKER) ) (RPAQ POINTREADINGCURSOR (CURSORCREATE (QUOTE #*(16 16)@@@@@GL@ALG@C@AHF@@LD@@DL@@FH@@BHA@BH@@BL@@FD@@DF@@LC@AHALG@@GL@ ) (QUOTE NIL) 7 7)) (* ; "hit detection functions.") (DEFINEQ (SK.SELECT.ITEM [LAMBDA (WINDOW ITEMFLG SELITEMS OPERATION) (* rrb "10-Dec-85 17:01") (* selects allows the user to select one of the sketch elements from the sketch  WINDOW. If ITEMFLG is non-NIL, it returns the item selected, otherwise it  returns the position. If SELITEMS is given it is used as the items to be marked  and selected from. Keeps control and probably shouldn't) (PROG (HOTSPOTCACHE NOW PREVIOUS OLDPOS) (COND (SELITEMS (* create a cache for the items to  select from) (SETQ HOTSPOTCACHE (SK.ADD.HOTSPOTS.TO.CACHE SELITEMS NIL))) [(SK.HAS.SOME.HOTSPOTS (SETQ HOTSPOTCACHE (SK.HOTSPOT.CACHE.FOR.OPERATION WINDOW OPERATION] (T (* no items, don't do anything.) (RETURN))) (TOTOPW WINDOW) (SK.SHOWMARKS WINDOW HOTSPOTCACHE) (until (MOUSESTATE (NOT UP))) (COND ((NOT (LASTMOUSESTATE (OR LEFT MIDDLE))) (* for now not interested in anything besides left and middle.) (SK.SHOWMARKS WINDOW HOTSPOTCACHE) (RETURN))) (* note current item selection.) (SETQ NOW (IN.SKETCH.ELT? HOTSPOTCACHE (SETQ OLDPOS (CURSORPOSITION NIL WINDOW)) (NULL ITEMFLG))) FLIP (* turn off old selection.) (SK.DESELECT.ELT PREVIOUS WINDOW) (SK.SELECT.ELT (SETQ PREVIOUS NOW) WINDOW) LP (* wait for a button up or move out of region) (COND ((NOT (MOUSESTATE (OR LEFT MIDDLE))) (* button up, selected item if one) (SK.DESELECT.ELT PREVIOUS WINDOW) (SK.SHOWMARKS WINDOW HOTSPOTCACHE) (RETURN PREVIOUS)) ([EQUAL PREVIOUS (SETQ NOW (IN.SKETCH.ELT? HOTSPOTCACHE (CURSORPOSITION NIL WINDOW OLDPOS) (NULL ITEMFLG] (GO LP)) (T (GO FLIP]) (IN.SKETCH.ELT? [LAMBDA (CACHE POS PTFLG) (* rrb "21-Feb-85 13:47") (* returns the first element that POS  is on.) (PROG ((Y (fetch (POSITION YCOORD) of POS)) (X (fetch (POSITION XCOORD) of POS)) (BESTMEASURE 1000) PTLEFT PTRIGHT PTTOP PTBOTTOM BESTELT BESTX BESTY YDIF THISDIF) (SETQ PTLEFT (DIFFERENCE X SK.POINT.WIDTH)) (SETQ PTRIGHT (PLUS X SK.POINT.WIDTH)) (SETQ PTBOTTOM (DIFFERENCE Y SK.POINT.WIDTH)) (SETQ PTTOP (PLUS Y SK.POINT.WIDTH)) [for YBUCKET in CACHE when (ILEQ (CAR YBUCKET) PTTOP) do (COND ((ILESSP (CAR YBUCKET) PTBOTTOM) (* stop when Y gets too small.) (RETURN))) (SETQ YDIF (ABS (DIFFERENCE (CAR YBUCKET) Y))) (for XBUCKET in (CDR YBUCKET) when (ILEQ (CAR XBUCKET) PTRIGHT) do (COND ((ILESSP (CAR XBUCKET) PTLEFT) (* stop when X gets too small.) (RETURN))) (COND ((CDR XBUCKET) (* this bucket has entries) [SETQ THISDIF (PLUS YDIF (ABS (DIFFERENCE (CAR XBUCKET) X] (COND ((ILESSP THISDIF BESTMEASURE) (SETQ BESTMEASURE THISDIF) (COND (PTFLG (SETQ BESTX (CAR XBUCKET)) (SETQ BESTY (CAR YBUCKET))) (T (SETQ BESTELT (CADR XBUCKET] (RETURN (COND (PTFLG (AND BESTX (create POSITION XCOORD _ BESTX YCOORD _ BESTY))) (T BESTELT]) (SK.MARK.HOTSPOT [LAMBDA (X Y WINDOW MARK) (* rrb "29-Jan-85 15:45") (* marks a point in a window with a mark.  The mark should be a bitmap.) (PROG ((MARKWIDTH (BITMAPWIDTH MARK)) HALFWIDTH) (RETURN (BITBLT MARK 0 0 WINDOW (IDIFFERENCE X (SETQ HALFWIDTH (LRSH MARKWIDTH 1))) (IDIFFERENCE Y HALFWIDTH) MARKWIDTH MARKWIDTH 'INPUT 'INVERT]) (SK.MARK.POSITION [LAMBDA (PT WINDOW MARKBITMAP) (* rrb "20-Apr-85 18:47") (* marks a place on the sketch window  WINDOW.) (SK.MARK.HOTSPOT (fetch (POSITION XCOORD) of PT) (fetch (POSITION YCOORD) of PT) WINDOW MARKBITMAP]) (SK.SELECT.ELT [LAMBDA (ELT FIGW MARKBM) (* rrb " 3-Oct-84 11:18") (* selects an item from a figure  window.) (* for now just mark it.) (AND ELT (SK.MARK.SELECTION ELT FIGW MARKBM]) (SK.DESELECT.ELT [LAMBDA (ELT SKW MARKBM) (* rrb " 9-May-85 10:32") (* turns off the selection marking of an item from a figure window.) (AND ELT (SK.MARK.SELECTION ELT SKW MARKBM]) ) (DECLARE%: EVAL@COMPILE (RPAQQ SK.POINT.WIDTH 4) (CONSTANTS (SK.POINT.WIDTH 4)) ) (* ; "fns to support caching of hotspots.") (DEFINEQ (SK.HOTSPOT.CACHE [LAMBDA (SKW) (* rrb "29-Jan-85 14:23") (* retrieve the hotspot cache  associated with a sketch window.) (WINDOWPROP SKW 'HOTSPOT.CACHE]) (SK.HOTSPOT.CACHE.FOR.OPERATION [LAMBDA (VIEWER OPERATION) (* rrb "10-Dec-85 16:59") (* returns the hotspot cache for the elements in a viewer that are not  protected against OPERATION.) (PROG (SCRELTS) (RETURN (COND ((AND OPERATION (bind PROTECTION for SCRELT in (SETQ SCRELTS ( LOCALSPECS.FROM.VIEWER VIEWER)) thereis (* look for any element that disallows  the current operation) (SK.ELEMENT.PROTECTED? (fetch (SCREENELT GLOBALPART) of SCRELT) OPERATION))) (* compute special cache) (SK.BUILD.CACHE SCRELTS OPERATION)) (T (* use the cache of all elements.) (SK.HOTSPOT.CACHE VIEWER]) (SK.BUILD.CACHE [LAMBDA (SCRELTS SKETCHOP) (* rrb "11-Dec-85 11:10") (* Builds a cache of the elements in SCRELTS that aren't protected against  SKETCHOP.) (PROG (CACHE) (for ELT in SCRELTS when (NOT (SK.ELEMENT.PROTECTED? (fetch (SCREENELT GLOBALPART) of ELT) SKETCHOP)) do (SETQ CACHE (SK.ADD.HOTSPOTS.TO.CACHE1 ELT CACHE))) (RETURN CACHE]) (SK.ELEMENT.PROTECTED? [LAMBDA (GELT HOW) (* rrb " 5-Dec-85 11:16") (* determines if GELT is protected  against the operation HOW) (PROG [(PROTECTIONLST (GETSKETCHELEMENTPROP GELT 'PROTECTION] (RETURN (OR (EQMEMB HOW PROTECTIONLST) (AND (NEQ HOW 'COPYSELECT) (OR (EQMEMB T PROTECTIONLST) (EQMEMB 'FROZEN PROTECTIONLST]) (SK.HAS.SOME.HOTSPOTS [LAMBDA (HOTSPOTCACHE) (* rrb "17-Oct-85 11:18") (* return T if there is a selectable point in HOTSPOTCACHE.) (for BUCKET in HOTSPOTCACHE when (SOME (CDR BUCKET) (FUNCTION CDR)) do (RETURN T]) (SK.SET.HOTSPOT.CACHE [LAMBDA (SKW NEWCACHE) (* rrb "29-Jan-85 14:23") (* stores the hotspot cache associated  with a sketch window.) (WINDOWPROP SKW 'HOTSPOT.CACHE NEWCACHE]) (SK.CREATE.HOTSPOT.CACHE [LAMBDA (SKW) (* rrb " 4-Feb-85 14:18") (* creates the cache of hotspot locations for a sketch window.) (SK.SET.HOTSPOT.CACHE SKW (SK.ADD.HOTSPOTS.TO.CACHE (LOCALSPECS.FROM.VIEWER SKW) NIL]) (SK.ELTS.FROM.HOTSPOT [LAMBDA (POSITION CACHE) (* rrb "29-Jan-85 13:47") (* returns a list of local elements that have POSITION as one of their  hotspots.) (* a cache is an alist of alist with the top descriminator being the Y value  and the second one being the X value.) (PROG (TMP) (RETURN (AND (SETQ TMP (SK.FIND.CACHE.BUCKET (fetch (POSITION YCOORD) of POSITION) CACHE)) (SK.FIND.CACHE.BUCKET (fetch (POSITION XCOORD) of POSITION) TMP]) (SK.ADD.HOTSPOTS.TO.CACHE [LAMBDA (ELTS CACHE) (* rrb " 3-Feb-85 14:36") (* adds a collection of hotspots to a  cache.) (for ELT in ELTS do (SETQ CACHE (SK.ADD.HOTSPOTS.TO.CACHE1 ELT CACHE))) CACHE]) (SK.ADD.HOTSPOTS.TO.CACHE1 [LAMBDA (LOCALELT CACHE) (* rrb "29-Jan-85 14:55") (* adds an elements hotspots to the  cache.) (for HOTSPOT in (fetch (SCREENELT HOTSPOTS) of LOCALELT) do (SETQ CACHE (SK.ADD.HOTSPOT.TO.CACHE HOTSPOT LOCALELT CACHE)) ) CACHE]) (SK.ADD.HOTSPOT.TO.CACHE [LAMBDA (POSITION ELT CACHE) (* rrb "16-Sep-86 12:45") (* adds a hotspot to a cache.) (* a cache is an alist of alist with the top descriminator being the Y value  and the second one being the X value.) (PROG ((Y (fetch (POSITION YCOORD) of POSITION)) (X (fetch (POSITION XCOORD) of POSITION))) (RETURN (COND [(NULL CACHE) (LIST (LIST Y (LIST X ELT] ((GREATERP Y (CAAR CACHE)) (* this element goes first Splice it  onto the front.) (RPLACD CACHE (CONS (CAR CACHE) (CDR CACHE))) (RPLACA CACHE (LIST Y (LIST X ELT))) CACHE) ((EQ (CAAR CACHE) Y) (SK.ADD.VALUE.TO.CACHE.BUCKET X ELT (CDAR CACHE)) CACHE) (T [for TAIL on CACHE do [AND (CDR TAIL) (COND ((EQ (CAADR TAIL) Y) (SK.ADD.VALUE.TO.CACHE.BUCKET X ELT (CDADR TAIL)) (RETURN)) ((GREATERP Y (CAADR TAIL)) (RPLACD TAIL (CONS (LIST Y (LIST X ELT)) (CDR TAIL))) (RETURN] finally (NCONC1 CACHE (LIST Y (LIST X ELT] CACHE]) (SK.REMOVE.HOTSPOTS.FROM.CACHE [LAMBDA (ELTS CACHE) (* rrb "29-Jan-85 14:04") (* removes a collection of hotspots  from a cache.) (for ELT in ELTS do (SETQ CACHE (SK.REMOVE.HOTSPOTS.FROM.CACHE1 ELT CACHE]) (SK.REMOVE.HOTSPOTS.FROM.CACHE1 [LAMBDA (LOCALELT CACHE) (* rrb "29-Jan-85 13:45") (* removes an elements hotspots to the  cache.) (for HOTSPOT in (fetch (SCREENELT HOTSPOTS) of LOCALELT) do (SK.REMOVE.HOTSPOT.FROM.CACHE HOTSPOT LOCALELT CACHE]) (SK.REMOVE.HOTSPOT.FROM.CACHE [LAMBDA (POSITION ELT CACHE) (* rrb "16-Sep-86 12:45") (* removes a hotspot to a cache.) (* a cache is an alist of alist with the top descriminator being the Y value  and the second one being the X value.) (SK.REMOVE.VALUE.FROM.CACHE.BUCKET (fetch (POSITION XCOORD) of POSITION) ELT (FASSOC (fetch (POSITION YCOORD) of POSITION) CACHE]) (SK.REMOVE.VALUE.FROM.CACHE.BUCKET [LAMBDA (VAL ELT BUCKET) (* rrb "16-Sep-86 12:45") (* removes ELT from the list of elements stored on BUCKET under the key VAL.) (* leaves the x and y of the bucket because it seems easier than removing it  and it may be used again in the case of changing an element by deleting it then  adding it again.) (for TAIL on (FASSOC VAL (CDR BUCKET)) do (AND (CDR TAIL) (COND ((EQ (CADR TAIL) ELT) (RPLACD TAIL (CDDR TAIL]) (SK.FIND.CACHE.BUCKET [LAMBDA (VALUE CACHE) (* rrb "16-Sep-86 12:46") (* internal function for searching the caching Alists.  Returns the bucket if there is one; quits when a value is larger than the one  asked for.) (for TAIL on CACHE do (COND ((EQ (CAAR TAIL) VALUE) (RETURN (CDAR TAIL))) ((GREATERP VALUE (CAAR TAIL)) (RETURN NIL]) (SK.ADD.VALUE.TO.CACHE.BUCKET [LAMBDA (VAL ELT ALIST) (* rrb "16-Sep-86 12:46") (* adds ELT to the list of elements stored on ALIST under the key VAL.) (COND ((NULL ALIST) (* shouldn't ever happen.) NIL) ((GREATERP VAL (CAAR ALIST)) (* this element goes first Splice it  onto the front.) (RPLACD ALIST (CONS (CAR ALIST) (CDR ALIST))) (RPLACA ALIST (LIST VAL ELT))) ((EQ (CAAR ALIST) VAL) (* add it to the end of the first  list.) (NCONC1 (CAR ALIST) ELT)) (T (for TAIL on ALIST do [AND (CDR TAIL) (COND ((EQ (CAADR TAIL) VAL) (NCONC1 (CADR TAIL) ELT) (RETURN ALIST)) ((GREATERP VAL (CAADR TAIL)) (RPLACD TAIL (CONS (LIST VAL ELT) (CDR TAIL))) (RETURN ALIST] finally (NCONC1 ALIST (LIST VAL ELT]) ) (* ; "grid stuff") (DEFINEQ (SK.SET.GRID [LAMBDA (SKETCHW) (* rrb "25-Oct-84 12:40") (* switches from grided to non-grided  or vice versa.) (COND ((WINDOWPROP SKETCHW 'USEGRID) (SK.TURN.GRID.OFF SKETCHW)) (T (SK.TURN.GRID.ON SKETCHW]) (SK.DISPLAY.GRID [LAMBDA (SKETCHW) (* rrb "23-Sep-86 11:30") (* displays the current grid.) (COND ((WINDOWPROP SKETCHW 'USEGRID)) (T (* grid was not being used, turn it  on.) (SK.TURN.GRID.ON SKETCHW T))) (WINDOWPROP SKETCHW 'GRIDUP T) (SK.DISPLAY.GRID.POINTS SKETCHW]) (SK.DISPLAY.GRID.POINTS [LAMBDA (SKETCHW NEWFLG) (* rrb "16-Jan-85 10:09") (SK.SHOW.GRID (SK.GRIDFACTOR SKETCHW) SKETCHW NEWFLG]) (SK.REMOVE.GRID.POINTS [LAMBDA (SKETCHW) (* rrb "23-Sep-86 11:28") (* removes the grid by calling redisplay with the gridup property removed.) (COND ([NOT (GREATERP 3.0 (FQUOTIENT (SK.GRIDFACTOR SKETCHW) (VIEWER.SCALE SKETCHW] (* if grid factor is less than 3.0 the grid isn't displayed) (WINDOWPROP SKETCHW 'GRIDUP (PROG1 (WINDOWPROP SKETCHW 'GRIDUP NIL) (REDISPLAYW SKETCHW]) (SK.TAKE.DOWN.GRID [LAMBDA (SKETCHW) (* rrb "23-Sep-86 11:26") (* takes down the grid if it is up.) (COND ((WINDOWPROP SKETCHW 'GRIDUP NIL) (SK.REMOVE.GRID.POINTS SKETCHW]) (SK.SHOW.GRID [LAMBDA (GRID SKW NEWFLG) (* DECLARATIONS%: FLOATING) (* rrb "23-Sep-86 11:03") (* puts a grid of size GRID onto SKW.) (PROG ((SCALE (VIEWER.SCALE SKW)) (REGION (SKETCH.REGION.VIEWED SKW))) (COND ((GREATERP 3.0 (FQUOTIENT GRID SCALE)) (* would be every point or so) (STATUSPRINT SKW (CONCAT (COND (NEWFLG "New") (T "Current")) " grid has a position every " (FQUOTIENT GRID SCALE) " screen points.")) NIL) (T (* make a horizontal bitmap that has the X pattern then blt it at the proper Y  places.) [PROG ((WREG (DSPCLIPPINGREGION NIL SKW)) SCALEDWREG SCALEDWLEFT HORIZPATTERN WWIDTH WLEFT GRIDLEFT SKREGLEFT SKREGLIMIT ) (SETQ WWIDTH (fetch (REGION WIDTH) of WREG)) (SETQ WLEFT (fetch (REGION LEFT) of WREG)) (SETQ HORIZPATTERN (BITMAPCREATE WWIDTH 1)) (SETQ SCALEDWREG (UNSCALE.REGION WREG SCALE)) (SETQ SCALEDWLEFT (fetch (REGION LEFT) of SCALEDWREG)) (SETQ GRIDLEFT (NEAREST.ON.GRID SCALEDWLEFT GRID)) (* put limit calculation outside of  the loop.) (SETQ SKREGLIMIT (PLUS SCALEDWLEFT (fetch (REGION WIDTH) of SCALEDWREG))) (for X from GRIDLEFT to SKREGLIMIT by GRID do (BITMAPBIT HORIZPATTERN (FIXR (FQUOTIENT (DIFFERENCE X SCALEDWLEFT) SCALE)) 0 1)) (SETQ SKREGLIMIT (PLUS (fetch (REGION BOTTOM) of SCALEDWREG) (fetch (REGION HEIGHT) of SCALEDWREG))) (for Y from (NEAREST.ON.GRID (fetch (REGION BOTTOM) of SCALEDWREG) GRID) to SKREGLIMIT by GRID do (BITBLT HORIZPATTERN 0 0 SKW WLEFT (FIXR (FQUOTIENT Y SCALE)) WWIDTH 1 'INPUT 'PAINT] (COND ((GREATERP (FQUOTIENT GRID SCALE) (QUOTIENT (MIN (WINDOWPROP SKW 'HEIGHT) (WINDOWPROP SKW 'WIDTH)) 3)) (* there aren't enough visible points so tell the user how far apart they are.) (STATUSPRINT SKW (CONCAT (COND (NEWFLG "New") (T "Current")) " grid has a position every " (FIXR (FQUOTIENT GRID SCALE)) " screen points."]) (SK.GRIDFACTOR [LAMBDA (SKETCHW GRIDSIZE) (* rrb "25-Oct-84 12:34") (* sets the grid factor of a window to GRIDSIZE.  Returns the previous setting. The actual use of the grid is determined by  (QUOTE USEGRID) property.) (COND ((NUMBERP GRIDSIZE) (WINDOWPROP SKETCHW 'GRIDFACTOR GRIDSIZE)) (GRIDSIZE (\ILLEGAL.ARG GRIDSIZE) (WINDOWPROP SKETCHW 'GRIDFACTOR)) (T (WINDOWPROP SKETCHW 'GRIDFACTOR]) (SK.TURN.GRID.ON [LAMBDA (SKETCHW QUIETFLG) (* rrb "25-Oct-84 12:04") (* turns the grid on.) (COND ((WINDOWPROP SKETCHW 'USEGRID T) (OR QUIETFLG (STATUSPRINT SKETCHW "The grid was already in use."]) (SK.TURN.GRID.OFF [LAMBDA (SKETCHW) (* rrb "25-Oct-84 12:03") (* turns the grid off.) (COND ((WINDOWPROP SKETCHW 'USEGRID NIL) (SK.TAKE.DOWN.GRID SKETCHW)) (T (STATUSPRINT SKETCHW "The grid was not is use."]) (SK.MAKE.GRID.LARGER [LAMBDA (SKETCHW) (* rrb "23-Sep-86 10:51") (* makes the grid larger. If the grid is off, it turns it on.) (SK.CHANGE.GRID [PROG ((NOWGRID (SK.GRIDFACTOR SKETCHW))) (RETURN (COND ((EQP NOWGRID 0.5) (* if going from half to one, switch to integer scale factors) 1) (T (TIMES NOWGRID 2] SKETCHW]) (SK.MAKE.GRID.SMALLER [LAMBDA (SKETCHW) (* rrb "23-Sep-86 10:48") (* makes the grid smaller. If the grid is off, it turns it on.) (SK.CHANGE.GRID [PROG ((NOWGRID (SK.GRIDFACTOR SKETCHW))) (RETURN (COND ((EQ NOWGRID 1) (* if going from one to half, switch from integer scale factors to floating) 0.5) (T (QUOTIENT NOWGRID 2] SKETCHW]) (SK.CHANGE.GRID [LAMBDA (NEWGRID SKETCHW) (* rrb " 1-Feb-85 15:52") (* changes the grid of a window. Turns the grid on if it isn't already on.) (SK.TURN.GRID.ON SKETCHW T) (AND (WINDOWPROP SKETCHW 'GRIDUP) (SK.REMOVE.GRID.POINTS SKETCHW)) (SK.GRIDFACTOR SKETCHW NEWGRID) (AND (WINDOWPROP SKETCHW 'GRIDUP) (SK.DISPLAY.GRID.POINTS SKETCHW T]) (GRID.FACTOR1 [LAMBDA (REALHEIGHT HEIGHTONSCREEN NPTS) (* rrb "19-Jun-84 17:26") (* returns the greatest power of two such that REALHEIGHT maps onto  SCREENHEIGHT leaving at least NPTS per grid.) (LEASTPOWEROF2GT (FQUOTIENT (FTIMES NPTS REALHEIGHT) HEIGHTONSCREEN]) (LEASTPOWEROF2GT [LAMBDA (FLOATP) (* rrb "23-Sep-86 10:57") (* returns the number which is the least power of two that is greater than  FLOATP.) (PROG [(LOG2 (FQUOTIENT (LOG FLOATP) (CONSTANT (LOG 2] (RETURN (COND [(FGREATERP LOG2 0.0) (* keep the grid integer) (FIX (COND ((EQUAL LOG2 (FLOAT (FIX LOG2))) (* special case of exact hit.) (EXPT 2.0 (FIX LOG2))) (T (EXPT 2.0 (ADD1 (FIX LOG2] (T (EXPT 2.0 (FIX LOG2]) (GREATESTPOWEROF2LT [LAMBDA (FLOATP) (* rrb " 9-Jul-85 17:43") (* returns the number which is the greatest power of two that is less than  FLOATP.) (PROG [(LOG2 (FQUOTIENT (LOG FLOATP) (CONSTANT (LOG 2] (RETURN (COND ((FGREATERP LOG2 0.0) (EXPT 2.0 (FIX LOG2))) ((EQUAL LOG2 (FLOAT (FIX LOG2))) (* special case of exact hit.) (EXPT 2.0 (FIX LOG2))) (T (EXPT 2.0 (SUB1 (FIX LOG2]) (SK.DEFAULT.GRIDFACTOR [LAMBDA (SKETCHW) (* rrb "25-Nov-85 17:46") (* returns the default grid factor for a window.  Starts at about a quarter inch.) (GRID.FACTOR1 (fetch (REGION HEIGHT) of (SKETCH.REGION.VIEWED SKETCHW)) (WINDOWPROP SKETCHW 'HEIGHT) DEFAULTGRIDSIZE]) (SK.PUT.ON.GRID [LAMBDA (GPOSITION GRID) (* rrb " 7-Feb-85 11:32") (* returns the grid point that is  closest to GPOSITION.) (create POSITION XCOORD _ (NEAREST.ON.GRID (fetch (POSITION XCOORD) of GPOSITION) GRID) YCOORD _ (NEAREST.ON.GRID (fetch (POSITION YCOORD) of GPOSITION) GRID]) (MAP.WINDOW.ONTO.GRID [LAMBDA (X SCALE GRID) (* rrb "20-Jun-84 16:53") (* maps from a window point onto the window point that is closest to GRID.) (FIXR (QUOTIENT (NEAREST.ON.GRID (TIMES X SCALE) GRID) SCALE]) (MAP.SCREEN.ONTO.GRID [LAMBDA (X SCALE GRID WOFFSET) (* rrb "20-Jun-84 16:22") (* maps a screen coordinate into the screen coordinate that is closest to the  grid of a window with offset WOFFSET.) (COND ((OR (NOT GRID) (EQ GRID 0) (EQP GRID 0.0)) X) (T (IPLUS (MAP.WINDOW.ONTO.GRID (IDIFFERENCE X WOFFSET) SCALE GRID) WOFFSET]) (MAP.GLOBAL.PT.ONTO.GRID [LAMBDA (PT SKW) (* rrb " 7-Feb-85 11:33") (* If the grid is in use, maps from a point in global coordinates into the  closest grid point in global coordinates.) (COND ((WINDOWPROP SKW 'USEGRID) (SK.PUT.ON.GRID PT (SK.GRIDFACTOR SKW))) (T PT]) (MAP.GLOBAL.REGION.ONTO.GRID [LAMBDA (GREGION SKW) (* rrb "25-Jan-85 10:50") (* If the grid is in use, maps from a region in global coordinates into the  closest larger region in global coordinates.) (COND [(WINDOWPROP SKW 'USEGRID) (PROG ((GRID (SK.GRIDFACTOR SKW)) HALFGRID NEWLEFT NEWBOTTOM) (SETQ HALFGRID (QUOTIENT GRID 2.0)) (RETURN (CREATEREGION (SETQ NEWLEFT (NEAREST.ON.GRID (DIFFERENCE (fetch (REGION LEFT) of GREGION) HALFGRID) GRID)) (SETQ NEWBOTTOM (NEAREST.ON.GRID (DIFFERENCE (fetch (REGION BOTTOM) of GREGION) HALFGRID) GRID)) (DIFFERENCE (NEAREST.ON.GRID (PLUS (fetch (REGION RIGHT) of GREGION) HALFGRID) GRID) NEWLEFT) (DIFFERENCE (NEAREST.ON.GRID (PLUS (fetch (REGION TOP) of GREGION) HALFGRID) GRID) NEWBOTTOM] (T GREGION]) (MAP.WINDOW.POINT.ONTO.GLOBAL.GRID [LAMBDA (PT SCALE GRID) (* rrb " 1-Feb-85 14:08") (* maps from a point in window coordinates into the closest grid point in  global coordinates.) (create POSITION XCOORD _ (MAP.WINDOW.ONTO.GLOBAL.GRID (fetch (POSITION XCOORD) of PT) SCALE GRID) YCOORD _ (MAP.WINDOW.ONTO.GLOBAL.GRID (fetch (POSITION YCOORD) of PT) SCALE GRID]) (MAP.WINDOW.ONTO.GLOBAL.GRID [LAMBDA (X SCALE GRID) (* rrb " 1-Feb-85 14:08") (* maps from a window point onto the window point that is closest to GRID.) (NEAREST.ON.GRID (TIMES X SCALE) GRID]) (SK.UPDATE.GRIDFACTOR [LAMBDA (SKW OLDSCALE) (* rrb "25-Nov-85 17:46") (* determines the size of the grid for the newly scaled window.) (PROG ((OLDGRID (SK.GRIDFACTOR SKW)) X) (SK.GRIDFACTOR SKW (GRID.FACTOR1 (fetch (REGION HEIGHT) of (SKETCH.REGION.VIEWED SKW)) (WINDOWPROP SKW 'HEIGHT) (IMIN DEFAULTMAXGRIDSIZE (FQUOTIENT OLDGRID OLDSCALE]) (SK.MAP.FROM.WINDOW.TO.GLOBAL.GRID [LAMBDA (POSITION SKETCHW) (* rrb "11-Jul-86 15:56") (* maps from a position in a window to the corresponding global position taking  into account the grid if it is in use.) (COND ((WINDOWPROP SKETCHW 'USEGRID) (MAP.WINDOW.POINT.ONTO.GLOBAL.GRID POSITION (VIEWER.SCALE SKETCHW) (SK.GRIDFACTOR SKETCHW))) (T (SK.UNSCALE.POSITION.FROM.VIEWER POSITION (VIEWER.SCALE SKETCHW]) (SK.MAP.INPUT.PT.TO.GLOBAL [LAMBDA (POSSPEC SKETCHW) (* rrb "11-Jul-86 15:52") (* maps from a position ala GETSKWPOSITION in a window to the corresponding  global position (POSITION is a list of (GRIDON? position))) (AND POSSPEC (COND ((EQ (fetch (INPUTPT INPUT.ONGRID?) of POSSPEC) 'GLOBAL) (fetch (INPUTPT INPUT.GLOBALPOSITION) of POSSPEC)) ((fetch (INPUTPT INPUT.ONGRID?) of POSSPEC) (MAP.WINDOW.POINT.ONTO.GLOBAL.GRID (fetch (INPUTPT INPUT.POSITION) of POSSPEC) (VIEWER.SCALE SKETCHW) (SK.GRIDFACTOR SKETCHW))) (T (* map the point onto a grid location that would have the same screen position  as the given point.) (SK.MAP.FROM.WINDOW.TO.NEAREST.GRID (fetch (INPUTPT INPUT.POSITION) of POSSPEC) (VIEWER.SCALE SKETCHW) T]) (SK.MAP.FROM.WINDOW.TO.NEAREST.GRID [LAMBDA (POSITION SCALE NOMOVEFLG) (* rrb " 3-Oct-85 14:16") (* maps from a point in a window to the closest grid position in the global  space that has a distance between the points of less than 1.0) (PROG [(GRID (COND (NOMOVEFLG (* if NOMOVEFLG is on, use a grid small enough that the mapping into and out of  coordinate space will leave POSITION unchanged.  For most uses, this is too fine.) (GREATESTPOWEROF2LT SCALE)) (T (LEASTPOWEROF2GT (TIMES SCALE 2] (RETURN (create POSITION XCOORD _ (NEAREST.ON.GRID (TIMES (fetch (POSITION XCOORD) of POSITION) SCALE) GRID) YCOORD _ (NEAREST.ON.GRID (TIMES (fetch (POSITION YCOORD) of POSITION) SCALE) GRID]) ) (RPAQ? DEFAULTGRIDSIZE 8) (RPAQ? DEFAULTMINGRIDSIZE 4) (RPAQ? DEFAULTMAXGRIDSIZE 32) (* ; "history and undo stuff") (DEFINEQ (SK.ADD.HISTEVENT [LAMBDA (EVENTTYPE EVENTARGS SKETCHW) (* rrb "11-Jan-85 18:04") (* puts a history event on a sketch  window.) (* trim to a given length) (PROG [(HISTLST (WINDOWPROP SKETCHW 'SKETCHHISTORY] (WINDOWPROP SKETCHW 'SKETCHHISTORY (CONS (create SKHISTEVENT EVENTTYPE _ EVENTTYPE EVENTARGS _ EVENTARGS) (COND ((GREATERP SKETCH.#.UNDO.ITEMS (LENGTH HISTLST) ) (* there is room for one more) HISTLST) (T (REMOVE.LAST HISTLST]) (SK.SEL.AND.UNDO [LAMBDA (SKW) (* rrb " 5-Dec-85 17:18") (* gives the user a choice of past events to undo.) (SKED.CLEAR.SELECTION SKW) (PROG [EVENT UNDOFN (HISTLST (WINDOWPROP SKW 'SKETCHHISTORY] (COND ((NULL HISTLST) (STATUSPRINT SKW "Nothing to undo.") (RETURN))) (COND ([SETQ EVENT (\CURSOR.IN.MIDDLE.MENU (create MENU ITEMS _ (for EVENT in HISTLST collect (LIST (SK.UNDO.NAME EVENT) EVENT)) WHENSELECTEDFN _ (FUNCTION CADR) TITLE _ "Select event to undo" WHENHELDFN _ (FUNCTION (LAMBDA (ITEM MENU BUTTON) (PROMPTPRINT "Will undo this event." ] (COND ((fetch (SKHISTEVENT UNDONE?) of EVENT) (* can't undo already undone event. They are included in the menu to provide  session continuity.) (STATUSPRINT SKW "That event has already been undone.") (RETURN NIL)) ([NULL (SETQ UNDOFN (fetch (SKEVENTTYPE SKUNDOFN) of (SKEVENTTYPEFNS (fetch (SKHISTEVENT EVENTTYPE) of EVENT] (STATUSPRINT SKW "Can't undo that event.") (RETURN NIL))) (COND ((APPLY* UNDOFN (fetch (SKHISTEVENT EVENTARGS) of EVENT) SKW EVENT) (* only add to history list if  something happened.) (replace (SKHISTEVENT UNDONE?) of EVENT with T) (SK.ADD.HISTEVENT 'UNDO EVENT SKW)) ((NOT (EQ UNDOFN 'SK.UNDO.UNDO)) (STATUSPRINT SKW "Element subsequently modified, can't undo"]) (SK.UNDO.LAST [LAMBDA (SKW) (* rrb " 5-Dec-85 17:19") (* undoes the first not yet undone  history event.) (SKED.CLEAR.SELECTION SKW) (PROG [EVENT UNDOFN (HISTLST (WINDOWPROP SKW 'SKETCHHISTORY] (COND ((NULL HISTLST) (STATUSPRINT SKW "Nothing to undo.") (RETURN))) (COND [(SETQ EVENT (for HISTEVENT in HISTLST when [AND (NOT (EQ (fetch (SKHISTEVENT EVENTTYPE) of HISTEVENT) 'UNDO)) (NOT (fetch (SKHISTEVENT UNDONE?) of HISTEVENT)) (SETQ UNDOFN (fetch (SKEVENTTYPE SKUNDOFN) of (SKEVENTTYPEFNS (fetch (SKHISTEVENT EVENTTYPE) of HISTEVENT] do (RETURN HISTEVENT))) (COND ((APPLY* UNDOFN (fetch (SKHISTEVENT EVENTARGS) of EVENT) SKW EVENT) (* only add to history list if  something happened.) (STATUSPRINT SKW (SK.UNDO.NAME EVENT) " event undone.") (replace (SKHISTEVENT UNDONE?) of EVENT with T) (SK.ADD.HISTEVENT 'UNDO EVENT SKW)) ((NOT (EQ UNDOFN 'SK.UNDO.UNDO)) (STATUSPRINT SKW "Element subsequently modified, can't undo"] (T (STATUSPRINT SKW " " "All events have been undone. Use the '?UNDO' subcommand to undo an UNDO command."]) (SK.UNDO.NAME [LAMBDA (HISTEVENT) (* rrb "17-Apr-84 11:27") (* returns the menu label for  HISTEVENT.) (APPLY* (fetch (SKEVENTTYPE SKUNDONAMEFN) of (SKEVENTTYPEFNS (fetch (SKHISTEVENT EVENTTYPE) of HISTEVENT))) HISTEVENT]) (SKEVENTTYPEFNS [LAMBDA (EVENTTYPE) (* rrb "17-Apr-84 11:02") (* returns the list of type related functions associated with EVENTTYPE.) (GETPROP EVENTTYPE 'EVENTFNS]) (SK.TYPE.OF.FIRST.ARG [LAMBDA (HISTEVENT NOMARKUNDOFLG) (* rrb "11-Dec-85 15:20") (* returns a name suitable for a menu label for an history event by combining  the event name with the type of its arg.) (PROG ((ARGS (fetch (SKHISTEVENT EVENTARGS) of HISTEVENT)) (TYPE (fetch (SKHISTEVENT EVENTTYPE) of HISTEVENT))) (RETURN (CONCAT (COND ((AND (NULL NOMARKUNDOFLG) (fetch (SKHISTEVENT UNDONE?) of HISTEVENT)) "*") (T " ")) TYPE " " (COND ((CDR ARGS) '"a group") (T (SELECTQ TYPE ((GROUP UNGROUP FREEZE UNFREEZE) "") ((MOVE CHANGE) (SK.LABEL.FROM.TYPE (fetch (GLOBALPART GTYPE) of (CAAR ARGS)))) (SK.LABEL.FROM.TYPE (fetch (GLOBALPART GTYPE) of (CAR ARGS]) ) (DEFINEQ (SK.DELETE.UNDO [LAMBDA (EVENTARGS SKW) (* rrb "11-Sep-84 14:57") (* undoes a delete event) (PROG (CHANGED?) [for GELT in EVENTARGS do (COND ((SK.ADD.ELEMENT GELT SKW) (SETQ CHANGED? T] (RETURN CHANGED?]) (SK.ADD.UNDO [LAMBDA (EVENTARGS SKW) (* rrb "30-Dec-85 16:18") (* undoes an add event) (SK.DELETE.ELEMENT2 EVENTARGS SKW 'DON'T]) ) (DEFINEQ (SK.CHANGE.UNDO [LAMBDA (EVENTARGS SKW) (* rrb "24-Sep-86 17:09") (* undoes a change event) (* the args for a change event are the old {previous} global part of the  element and the new global part of the element, the property that was changed,  the new value and the old value.) (PROG [CHANGED? NOWELT PREVELT (WHENCHANGEDFN (GETSKETCHPROP (INSURE.SKETCH SKW) 'WHENCHANGEDFN] [for EVENT in EVENTARGS do (SETQ NOWELT (fetch (SKHISTORYCHANGESPEC NEWELT) of EVENT)) (SETQ PREVELT (fetch (SKHISTORYCHANGESPEC OLDELT) of EVENT)) (* apply the whenchangedfn if the element is still in the sketch.) (COND [(AND WHENCHANGEDFN (SK.ELT.IN.SKETCH? NOWELT SKW) (EQ (APPLY* WHENCHANGEDFN SKW NOWELT (fetch (SKHISTORYCHANGESPEC PROPERTY) of EVENT) (fetch (SKHISTORYCHANGESPEC OLDVALUE) of EVENT) (fetch (SKHISTORYCHANGESPEC NEWVALUE) of EVENT)) 'DON'T] ((SK.UPDATE.ELEMENT NOWELT PREVELT SKW NIL T) (SETQ CHANGED? T] (RETURN CHANGED?]) (SK.ELT.IN.SKETCH? [LAMBDA (ELEMENT SKETCH) (* determines if an element is in a  sketch.) (MEMBER ELEMENT (SKETCH.ELEMENTS.OF.SKETCH SKETCH]) (SK.CHANGE.REDO [LAMBDA (EVENTARGS SKW) (* rrb "24-Sep-86 17:10") (* redoes a change event) (PROG [CHANGED? NEWELT OLDELT (WHENCHANGEDFN (GETSKETCHPROP (INSURE.SKETCH SKW) 'WHENCHANGEDFN] [for EVENT in EVENTARGS do (SETQ NEWELT (fetch (SKHISTORYCHANGESPEC NEWELT) of EVENT)) (SETQ OLDELT (fetch (SKHISTORYCHANGESPEC OLDELT) of EVENT)) (* apply the whenchangedfn if the element is still in the sketch.) (COND [(AND WHENCHANGEDFN (SK.ELT.IN.SKETCH? OLDELT SKW) (EQ (APPLY* WHENCHANGEDFN SKW OLDELT (fetch (SKHISTORYCHANGESPEC PROPERTY) of EVENT) (fetch (SKHISTORYCHANGESPEC NEWVALUE) of EVENT) (fetch (SKHISTORYCHANGESPEC OLDVALUE) of EVENT)) 'DON'T] ((SK.UPDATE.ELEMENT OLDELT NEWELT SKW NIL T) (SETQ CHANGED? T] (OR CHANGED? (STATUSPRINT SKW "That sketch element has been changed by something else, can't redo."]) (SK.MOVE.UNDO [LAMBDA (EVENTARGS SKW) (* rrb "24-Sep-86 17:10") (* undoes a move event) (* the args for a move event are the old {previous} global part of the element  and the new global part of the element, and the amount of the move.) (PROG [CHANGED? NOWELT PREVELT (WHENMOVEDFN (GETSKETCHPROP (INSURE.SKETCH SKW) 'WHENMOVEDFN] [for EVENT in EVENTARGS do (SETQ NOWELT (CADR EVENT)) (SETQ PREVELT (CAR EVENT)) (* apply the WHENMOVEDFN if the element is still in the sketch.) (COND [(AND WHENMOVEDFN (SK.ELT.IN.SKETCH? NOWELT SKW) (EQ (APPLY* WHENMOVEDFN SKW (CONS T NOWELT) (CADDR EVENT)) 'DON'T] ((SK.UPDATE.ELEMENT NOWELT PREVELT SKW NIL T) (SETQ CHANGED? T] (RETURN CHANGED?]) (SK.MOVE.REDO [LAMBDA (EVENTARGS SKW) (* rrb "24-Sep-86 17:10") (* redoes a move event) (PROG [CHANGED? NEWELT OLDELT (WHENMOVEDFN (GETSKETCHPROP (INSURE.SKETCH SKW) 'WHENMOVEDFN] [for EVENT in EVENTARGS do (SETQ NEWELT (CADR EVENT)) (SETQ OLDELT (CAR EVENT)) (* apply the WHENMOVEDFN if the element is still in the sketch.) (COND [(AND WHENMOVEDFN (SK.ELT.IN.SKETCH? OLDELT SKW) (EQ (APPLY* WHENMOVEDFN SKW OLDELT (CADDR EVENT)) 'DON'T] ((SK.UPDATE.ELEMENT OLDELT NEWELT SKW NIL T) (SETQ CHANGED? T] (OR CHANGED? (STATUSPRINT SKW "That sketch element has been changed by something else, can't redo."]) ) (DEFINEQ (SK.UNDO.UNDO [LAMBDA (UNDONEEVENT SKW THISEVENT) (* rrb "18-Apr-84 15:32") (* undoes an UNDO event by calling the REDO fn of that event type.) (PROG (REDOFN) (COND ([SETQ REDOFN (fetch (SKEVENTTYPE SKREDOFN) of (SKEVENTTYPEFNS (fetch (SKHISTEVENT EVENTTYPE) of UNDONEEVENT] (APPLY* REDOFN (fetch (SKHISTEVENT EVENTARGS) of UNDONEEVENT) SKW) (replace (SKHISTEVENT UNDONE?) of UNDONEEVENT with NIL) (* remove the undo event from the  history list.) (WINDOWDELPROP SKW 'SKETCHHISTORY THISEVENT)) (T (STATUSPRINT SKW "Can't undo that event."))) (* always return NIL so the undoing of an undo event won't be added as an  event.) (RETURN NIL]) (SK.UNDO.MENULABEL [LAMBDA (UNDOEVENT) (* rrb "18-Sep-84 11:53") (* returns a name suitable for a menu label for an UNDO history event by  combining the event name with the type of its arg.) (CONCAT "undo" (SK.TYPE.OF.FIRST.ARG (fetch (SKHISTEVENT EVENTARGS) of UNDOEVENT) T]) (SK.LABEL.FROM.TYPE [LAMBDA (SKELEMENTTYPE) (* rrb " 4-Jun-85 13:40") (* takes a type name and returns the label for it.  These two are different because the names changed since the first sketchs were  made.) (SELECTQ SKELEMENTTYPE (WIRE 'LINE) (OPENCURVE 'CURVE) (CLOSEDWIRE 'POLYGON) SKELEMENTTYPE]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD SKHISTEVENT (EVENTTYPE EVENTARGS UNDONE?)) (RECORD SKEVENTTYPE (SKUNDOFN SKUNDONAMEFN SKREDOFN)) ) ) (RPAQ? SKETCH.#.UNDO.ITEMS 30) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SKETCH.#.UNDO.ITEMS) ) (PUTPROPS ADD EVENTFNS (SK.ADD.UNDO SK.TYPE.OF.FIRST.ARG SK.DELETE.UNDO)) (PUTPROPS DELETE EVENTFNS (SK.DELETE.UNDO SK.TYPE.OF.FIRST.ARG SK.ADD.UNDO)) (PUTPROPS CHANGE EVENTFNS (SK.CHANGE.UNDO SK.TYPE.OF.FIRST.ARG SK.CHANGE.REDO)) (PUTPROPS UNDO EVENTFNS (SK.UNDO.UNDO SK.UNDO.MENULABEL SHOULDNT)) (PUTPROPS MOVE EVENTFNS (SK.MOVE.UNDO SK.TYPE.OF.FIRST.ARG SK.MOVE.REDO)) (PUTPROPS COPY EVENTFNS (SK.ADD.UNDO SK.TYPE.OF.FIRST.ARG SK.DELETE.UNDO)) (* ; "functions for displaying the global coordinate space values.") (DEFINEQ (SHOW.GLOBAL.COORDS [LAMBDA (XCOORD YCOORD W) (* rrb " 5-Jun-85 18:30") (* converts to global coordinates and  displays it in W) (DSPRESET W) (COND ((AND (EQP XCOORD (FIX XCOORD)) (EQP YCOORD (FIX YCOORD))) (printout W |.F6.0| XCOORD " x" " " T |.F6.0| YCOORD " y" " ")) (T (printout W |.F8.2| XCOORD " x" " " T |.F8.2| YCOORD " y" " "]) (LOCATOR.CLOSEFN [LAMBDA (GCOORDW) (* rrb " 7-May-85 09:41") (* close function for a window that is keeping track of the global coordinate  system. It breaks the link to itself.) (DETACHWINDOW GCOORDW]) (SKETCHW.FROM.LOCATOR [LAMBDA (GCOORDW) (* rrb " 7-May-85 09:40") (* returns the active window if any that points to GCOORDW) (for W in (ACTIVEWINDOWS) when (MEMB GCOORDW (ATTACHEDWINDOWS W)) do (RETURN W]) (SKETCHW.UPDATE.LOCATORS [LAMBDA (W) (* rrb " 7-May-85 10:06") (* a cursor moved function for a sketch that shows the coordinates cursor in  global coordinates.) (AND (INSIDEP (DSPCLIPPINGREGION NIL W) (LASTMOUSEX W) (LASTMOUSEY W)) (for LOCATOR in (ATTACHEDWINDOWS W) when (MEMB (FUNCTION LOCATOR.CLOSEFN) (WINDOWPROP LOCATOR 'CLOSEFN)) do (LOCATOR.UPDATE LOCATOR W]) (LOCATOR.UPDATE [LAMBDA (LOCATORW SKW) (* rrb "22-May-85 11:09") (* updates the position of the locator  coordinates.) (* there are three kinds of locators%: real coordinate, gridded real  coordinates and latitude longitude, although lat lon has been deimplemented.) (SELECTQ (WINDOWPROP LOCATORW 'LOCATORTYPE) (GLOBALCOORD (UPDATE.GLOBALCOORD.LOCATOR LOCATORW SKW)) (GLOBALGRIDDEDCOORD (UPDATE.GLOBAL.GRIDDED.COORD.LOCATOR LOCATORW SKW)) (LATLON (UPDATE.LATLON.LOCATOR LOCATORW SKW)) (SHOULDNT]) (UPDATE.GLOBAL.LOCATOR [LAMBDA (SKETCHW) (* rrb "19-APR-83 14:19") (* checks to see if the latitude longitude display needs to be updated.) (COND ([OR (AND (NEQ SKETCHW.LASTCURSORPTX (SETQ SKETCHW.LASTCURSORPTX (LASTMOUSEX SKETCHW))) (SETQ SKETCHW.LASTCURSORPTY (LASTMOUSEY SKETCHW))) (NEQ SKETCHW.LASTCURSORPTY (SETQ SKETCHW.LASTCURSORPTY (LASTMOUSEY SKETCHW] (* call it if either point has  changed.) (SKETCHW.UPDATE.LOCATORS SKETCHW]) (UPDATE.GLOBALCOORD.LOCATOR [LAMBDA (GCOORDW W) (* rrb "11-Jul-86 15:52") (* a cursor moved function for a map that shows the coordinates cursor in  global coordinates.) (PROG (SCALE) (OR GCOORDW (RETURN)) (OR (SETQ SCALE (VIEWER.SCALE W)) (RETURN)) (SHOW.GLOBAL.COORDS (UNSCALE (LASTMOUSEX W) SCALE) (UNSCALE (LASTMOUSEY W) SCALE) GCOORDW]) (ADD.GLOBAL.DISPLAY [LAMBDA (SKW TYPE) (* rrb "28-Aug-85 11:10") (* creates a locator which gives the coordinates of the cursor in SKW in global  coordinates.) (PROG [(LOCATOR (CREATE.GLOBAL.DISPLAYER (FONTCREATE BOLDFONT) (COND ((EQ TYPE 'GRID) "cursor grid location") (T "cursor location in sketch"] (ATTACHWINDOW LOCATOR SKW 'BOTTOM 'RIGHT 'LOCALCLOSE) [WINDOWPROP LOCATOR 'LOCATORTYPE (COND ((EQ TYPE 'GRID) 'GLOBALGRIDDEDCOORD) (T 'GLOBALCOORD] (WINDOWPROP SKW 'CURSORMOVEDFN (FUNCTION SKETCHW.UPDATE.LOCATORS)) (RETURN LOCATOR]) (ADD.GLOBAL.GRIDDED.DISPLAY [LAMBDA (SKW) (* adds a locator that shows the  nearest grid location.) (ADD.GLOBAL.DISPLAY SKW 'GRID]) (CREATE.GLOBAL.DISPLAYER [LAMBDA (FONT TITLE) (* rrb " 7-May-85 09:59") (* creates a window for displaying  latitude longitude.) (PROG ((GCOORDW (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW (STRINGWIDTH "11111111.1111 " FONT)) (HEIGHTIFWINDOW (ITIMES 2 (FONTPROP FONT 'HEIGHT)) T)) (OR TITLE "Real Coordinates") NIL T))) (* extra space on stringwidth is to allow for the fact that printout translates  into PRIN1 rather than PRIN3.) (DSPFONT FONT GCOORDW) (DSPRESET GCOORDW) (* reset its coordinates to the upper  left) (WINDOWPROP GCOORDW 'CLOSEFN (FUNCTION LOCATOR.CLOSEFN)) (RETURN GCOORDW]) (UPDATE.GLOBAL.GRIDDED.COORD.LOCATOR [LAMBDA (GCOORDW W) (* rrb "11-Jul-86 15:52") (* a cursor moved function for a map that shows the coordinates cursor in  global coordinates.) (PROG (SCALE) (OR GCOORDW (RETURN)) (OR (SETQ SCALE (VIEWER.SCALE W)) (RETURN)) (COND [(WINDOWPROP W 'USEGRID) (PROG ((GRID (SK.GRIDFACTOR W)) XGRID YGRID) (SETQ YGRID (MAP.WINDOW.ONTO.GLOBAL.GRID (LASTMOUSEY W) SCALE GRID)) (COND ([OR [NOT (EQP (SETQ XGRID (MAP.WINDOW.ONTO.GLOBAL.GRID (LASTMOUSEX W) SCALE GRID)) (WINDOWPROP GCOORDW 'XCOORD] (NOT (EQP YGRID (WINDOWPROP GCOORDW 'YCOORD] (* only update if one of the values has changed.  This is done here but not in the ungridded case because it is handled by the  cursor moved fn.) (WINDOWPROP GCOORDW 'XCOORD XGRID) (WINDOWPROP GCOORDW 'YCOORD YGRID) (SHOW.GLOBAL.COORDS XGRID YGRID GCOORDW] (T (SHOW.GLOBAL.COORDS (UNSCALE (LASTMOUSEX W) SCALE) (UNSCALE (LASTMOUSEY W) SCALE) GCOORDW]) ) (RPAQQ SKETCHW.LASTCURSORPTX 0) (RPAQQ SKETCHW.LASTCURSORY 0) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SKETCHW.LASTCURSORPTX SKETCHW.LASTCURSORPTY) ) (* ; "fns for reading colors") (DEFINEQ (DISPLAYREADCOLORHLSLEVELS [LAMBDA (HLS WIN) (* rrb "17-Jul-85 15:10") (* displays a hue lightness saturation triple in the color reading window.) (PROG (LEVEL) (DISPLAYREADCOLORLEVEL (SETQ LEVEL (HLSLEVEL HLS 'HUE)) (LEVELFROMHLSVALUE 'HUE LEVEL) HUEREGION WIN) (DISPLAYREADCOLORLEVEL (SETQ LEVEL (HLSLEVEL HLS 'LIGHTNESS)) (LEVELFROMHLSVALUE 'LIGHTNESS LEVEL) LIGHTNESSREGION WIN) (DISPLAYREADCOLORLEVEL (SETQ LEVEL (HLSLEVEL HLS 'SATURATION)) (LEVELFROMHLSVALUE 'SATURATION LEVEL) SATURATIONREGION WIN]) (DISPLAYREADCOLORLEVEL [LAMBDA (PRINTLEVEL BARLEVEL REGION WINDOW) (* ; "Edited 12-Jun-90 15:14 by mitani") (* displays the value of a primary  color in a color bar region.) (COND ((FIXP PRINTLEVEL) (MOVETO (DIFFERENCE (fetch (REGION LEFT) of REGION) 4) VALBTM WINDOW) (PRIN1 PRINTLEVEL WINDOW) (* overstrike extra digits in case  the old value was larger.) (PRIN1 " " WINDOW)) (T (* floating point values) (MOVETO (DIFFERENCE (fetch (REGION LEFT) of REGION) 10) VALBTM WINDOW) (printout WINDOW |.F5.3| PRINTLEVEL))) (FILLINREGION REGION BARLEVEL GRAYSHADE WINDOW]) (DRAWREADCOLORBOX [LAMBDA (TITLELEFT TITLE WINDOW) (* rrb "17-Jul-85 14:20") (* draws the box and title for a display bar for an rgb or hls quantity.  Returns a dotted pair of the region the box occuppied and the left most  position printed in.) (PROG (XPOS REGION) (MOVETO TITLELEFT 4 WINDOW) (SETQ XPOS (DSPXPOSITION NIL WINDOW)) (PRIN1 TITLE WINDOW) (OUTLINEREGION (SETQ REGION (create REGION LEFT _ (CENTEREDLEFT 10 XPOS (SETQ XPOS (DSPXPOSITION NIL WINDOW))) BOTTOM _ (PLUS 4 (FONTPROP WIN 'HEIGHT)) WIDTH _ 10 HEIGHT _ 256)) 2 NIL WINDOW) (RETURN (CONS REGION XPOS]) (READ.CHANGE.COLOR [LAMBDA (MSG) (* reads a color from the user and  returns it) BLACKCOLOR]) (READCOLOR1 [LAMBDA (MSG ALLOWNONEFLG NOWCOLOR) (* rrb "19-Dec-85 12:02") (* lets the user select a color.) (PROG [(WIN (CREATEW (MAKEWITHINREGION (CREATEREGION LASTMOUSEX LASTMOUSEY COLORMENUWIDTH COLORMENUHEIGHT) WHOLEDISPLAY) (OR MSG "Enter a color: Left in rectangle sets level."))) VAL REDREGION GREENREGION BLUEREGION HUEREGION LIGHTNESSREGION SATURATIONREGION (INITCOLOR (AND NOWCOLOR (INSURE.RGB.COLOR NOWCOLOR T] [SETQ REDREGION (CAR (SETQ VAL (DRAWREADCOLORBOX 10 " RED " WIN] [SETQ GREENREGION (CAR (SETQ VAL (DRAWREADCOLORBOX (IPLUS (CDR VAL) 5) "GREEN" WIN] [SETQ BLUEREGION (CAR (SETQ VAL (DRAWREADCOLORBOX (IPLUS (CDR VAL) 5) " BLUE" WIN] [SETQ HUEREGION (CAR (SETQ VAL (DRAWREADCOLORBOX (IPLUS (CDR VAL) 20) " hue " WIN] [SETQ LIGHTNESSREGION (CAR (SETQ VAL (DRAWREADCOLORBOX (CDR VAL) " light " WIN] [SETQ SATURATIONREGION (CAR (SETQ VAL (DRAWREADCOLORBOX (CDR VAL) " sat " WIN] (ADDMENU (create MENU ITEMS _ [APPEND [COND (ALLOWNONEFLG '(("No color" 'NONE "specifies that no color should be used." ] '((OK 'OK "Returns the displayed color.") (Abort 'ABORT "Aborts this operation."] CENTERFLG _ T MENUBORDERSIZE _ 1 WHENSELECTEDFN _ (FUNCTION READCOLORCOMMANDMENUSELECTEDFN)) WIN (create POSITION XCOORD _ (PLUS (CDR VAL) 10) YCOORD _ 100)) [SETQ VAL (COND (INITCOLOR (READCOLOR2 WIN (fetch (RGB RED) of INITCOLOR) (fetch (RGB GREEN) of INITCOLOR) (fetch (RGB BLUE) of INITCOLOR))) (T (READCOLOR2 WIN 0 0 0] (CLOSEW WIN) (RETURN VAL]) (READCOLORCOMMANDMENUSELECTEDFN [LAMBDA (ITEM MENU BUTTON) (* rrb "18-Jul-85 11:01") (* when selected function for the menu that sits in the read color window.  Puts the value OK or ABORT on the window if selected.) (WINDOWPROP (WFROMMENU MENU) 'MENUCOMMAND (CADADR ITEM]) (READCOLOR2 [LAMBDA (WIN REDLEVEL GREENLEVEL BLUELEVEL) (* rrb "29-Oct-85 12:29") (* internal function to READCOLOR which polls mouse and updates fields.) (PROG ((VALBTM (IPLUS (fetch (REGION BOTTOM) of REDREGION) 264)) LEVEL LASTX LASTY HLS) (PROGN (DISPLAYREADCOLORLEVEL REDLEVEL REDLEVEL REDREGION WIN) (DISPLAYREADCOLORLEVEL GREENLEVEL GREENLEVEL GREENREGION WIN) (DISPLAYREADCOLORLEVEL BLUELEVEL BLUELEVEL BLUEREGION WIN)) (DISPLAYREADCOLORHLSLEVELS (SETQ HLS (RGBTOHLS REDLEVEL GREENLEVEL BLUELEVEL)) WIN) WAITLP (* check if menu command was pressed.) (SELECTQ (WINDOWPROP WIN 'MENUCOMMAND) (OK (RETURN (create RGB RED _ REDLEVEL GREEN _ GREENLEVEL BLUE _ BLUELEVEL))) (NONE (RETURN 'NONE)) (ABORT (RETURN NIL)) NIL) [COND ((MOUSESTATE LEFT) (COND [[SETQ COLOR (COND ((INSIDEP REDREGION (SETQ LASTX (LASTMOUSEX WIN)) (SETQ LASTY (LASTMOUSEY WIN))) 'RED) ((INSIDEP GREENREGION LASTX LASTY) 'GREEN) ((INSIDEP BLUEREGION LASTX LASTY) 'BLUE] (until (MOUSESTATE (NOT LEFT)) do (* as long as left is down, adjust the  color.) (COND ((NEQ [SETQ LEVEL (IMIN 255 (IMAX 0 (IDIFFERENCE (LASTMOUSEY WIN) (fetch (REGION BOTTOM) of REDREGION] (SELECTQ COLOR (RED REDLEVEL) (GREEN GREENLEVEL) BLUELEVEL)) (* see if color level has changed.) (SELECTQ COLOR (RED (DISPLAYREADCOLORLEVEL (SETQ REDLEVEL LEVEL) REDLEVEL REDREGION WIN)) (GREEN (DISPLAYREADCOLORLEVEL (SETQ GREENLEVEL LEVEL) GREENLEVEL GREENREGION WIN)) (DISPLAYREADCOLORLEVEL (SETQ BLUELEVEL LEVEL) BLUELEVEL BLUEREGION WIN)) (DISPLAYREADCOLORHLSLEVELS (SETQ HLS (RGBTOHLS REDLEVEL GREENLEVEL BLUELEVEL)) WIN] ([SETQ COLOR (COND ((INSIDEP HUEREGION (SETQ LASTX (LASTMOUSEX WIN)) (SETQ LASTY (LASTMOUSEY WIN))) 'HUE) ((INSIDEP LIGHTNESSREGION LASTX LASTY) 'LIGHTNESS) ((INSIDEP SATURATIONREGION LASTX LASTY) 'SATURATION] (until (MOUSESTATE (NOT LEFT)) do (* as long as red is down, adjust the  color.) (COND ((NOT (EQUAL [SETQ LEVEL (HLSVALUEFROMLEVEL COLOR (IMIN 255 (IMAX 0 (IDIFFERENCE (LASTMOUSEY WIN) (fetch (REGION BOTTOM) of REDREGION] (HLSLEVEL HLS COLOR))) (* see if color level has changed.) (HLSLEVEL HLS COLOR LEVEL) (SELECTQ COLOR (HUE (DISPLAYREADCOLORLEVEL LEVEL (LEVELFROMHLSVALUE 'HUE LEVEL) HUEREGION WIN)) (LIGHTNESS (DISPLAYREADCOLORLEVEL LEVEL (LEVELFROMHLSVALUE 'LIGHTNESS LEVEL) LIGHTNESSREGION WIN)) (DISPLAYREADCOLORLEVEL LEVEL (LEVELFROMHLSVALUE 'SATURATION LEVEL) SATURATIONREGION WIN)) (* set the color levels of the current color and update that display also.) (SETQ LEVEL (HLSTORGB HLS)) (PROGN (DISPLAYREADCOLORLEVEL (SETQ REDLEVEL (CAR LEVEL)) REDLEVEL REDREGION WIN) (DISPLAYREADCOLORLEVEL (SETQ GREENLEVEL (CADR LEVEL)) GREENLEVEL GREENREGION WIN) (DISPLAYREADCOLORLEVEL (SETQ BLUELEVEL (CADDR LEVEL)) BLUELEVEL BLUEREGION WIN] (BLOCK) (GO WAITLP]) ) (DEFINEQ (CREATE.CNS.MENU [LAMBDA NIL (* rrb "17-Jul-85 21:14") (* creates the CNS menu.) (* Not fully implemented. Use STYLESHEET.WHENSELECTEDFN to set items from level  bars.) (SETQ CNS.STYLE (CREATE.STYLE 'ITEM.TITLES '(Saturation Lightness Tint Hue) 'ITEM.TITLE.FONT '(TIMESROMAN 14 BOLD) 'ITEMS [LIST (create MENU ITEMS _ '(Grayish Moderate Strong Vivid)) (create MENU ITEMS _ '(Black ("Very Dark" 'VeryDark) Dark Medium Light ("Very Light" 'VeryLight) White)) (create MENU ITEMS _ '(Orange Orangish Red Reddish Yellow Yellowish Green Greenish Blue Bluish Purple Purplish Brown Brownish)) (create MENU ITEMS _ '(Red Orange Yellow Green Blue Purple Brown] 'SELECTION '("" "" "" "") 'NEED.NOT.FILL.IN T)) (STYLESHEET CNS.STYLE]) ) (RPAQQ COLORMENUHEIGHT 320) (RPAQQ COLORMENUWIDTH 360) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) LLCOLOR) ) (* ;; "functions that used to be taken from GRAPHZOOM. Renamed and defined here so GRAPHZOOM isn't loaded." ) (DEFINEQ (SK.ABSWXOFFSET [LAMBDA (NEWX W) (* rrb "29-MAR-83 11:27") (* sets the offset of a window.) (WXOFFSET (IDIFFERENCE (WXOFFSET NIL W) NEWX) W]) (SK.ABSWYOFFSET [LAMBDA (NEWY W) (* rrb "29-MAR-83 11:28") (* sets the offset of a window.) (WYOFFSET (IDIFFERENCE (WYOFFSET NIL W) NEWY) W]) (SK.UNSCALE.POSITION.FROM.VIEWER [LAMBDA (POSITION SCALE) (* rrb " 1-APR-83 16:05") (* unscales a point in a window out into the larger coordinate space.) (create POSITION XCOORD _ (TIMES (fetch (POSITION XCOORD) of POSITION) SCALE) YCOORD _ (TIMES (fetch (POSITION YCOORD) of POSITION) SCALE]) (SK.SCALE.REGION [LAMBDA (REGION SCALE) (* rrb "16-Sep-86 12:38") (* scales a region into a windows  coordinate space.) (COND [(EQP SCALE 1) (* make unscaled case fast but make sure it is integer.) (COND ((AND (FIXP (fetch (REGION LEFT) of REGION)) (FIXP (fetch (REGION BOTTOM) of REGION)) (FIXP (fetch (REGION WIDTH) of REGION)) (FIXP (fetch (REGION HEIGHT) of REGION))) REGION) (T (CREATEREGION (FIXR (fetch (REGION LEFT) of REGION)) (FIXR (fetch (REGION BOTTOM) of REGION)) (FIXR (fetch (REGION WIDTH) of REGION)) (FIXR (fetch (REGION HEIGHT) of REGION] (T (CREATEREGION (FIXR (QUOTIENT (fetch (REGION LEFT) of REGION) SCALE)) (FIXR (QUOTIENT (fetch (REGION BOTTOM) of REGION) SCALE)) (FIXR (QUOTIENT (fetch (REGION WIDTH) of REGION) SCALE)) (FIXR (QUOTIENT (fetch (REGION HEIGHT) of REGION) SCALE]) ) (* ; "functions for zooming") (DEFINEQ (VIEWER.SCALE [LAMBDA (WIN) (* rrb "11-Jul-86 15:49") (* returns the scale of a sketch  viewer) (WINDOWPROP WIN 'SCALE]) (SKETCH.ZOOM [LAMBDA (SKW) (* rrb " 8-May-85 18:11") (* changes the scale of the figure being looked at in a window.) (PROG (NEWREG) (PROMPTPRINT "Specify the part of this figure that will be seen after the zoom. It can be either larger or smaller than the present window size.") (SETQ NEWREG (GETWREGION SKW (FUNCTION SAME.ASPECT.RATIO) SKW 4 4)) (CLRPROMPT) (COND ((NULL (REGIONSINTERSECTP NEWREG (DSPCLIPPINGREGION NIL SKW))) (* if it doesn't overlap this window,  don't move.) (STATUSPRINT SKW "Specified region was entirely outside the window. Not changed.")) (T (SKETCH.DO.ZOOM SKW NEWREG]) (SAME.ASPECT.RATIO [LAMBDA (FIXPT MOVEPT WIN) (* rrb "29-MAR-83 11:13") (* new region function that keeps the same aspect ratio as a window.) (COND ((NULL MOVEPT) FIXPT) (T (PROG ((REG (DSPCLIPPINGREGION NIL WIN)) (YMOVE (fetch (POSITION YCOORD) of MOVEPT)) (XFIX (fetch (POSITION XCOORD) of FIXPT)) (XMOVE (fetch (POSITION XCOORD) of MOVEPT)) (YFIX (fetch (POSITION YCOORD) of FIXPT)) WID) (* use height as the deciding point.) [SETQ WID (ABS (QUOTIENT (ITIMES (fetch (REGION WIDTH) of REG) (IDIFFERENCE YMOVE YFIX)) (fetch (REGION HEIGHT) of REG] (RETURN (create POSITION XCOORD _ (COND ((IGREATERP XFIX XMOVE) (IDIFFERENCE XFIX WID)) (T (IPLUS XFIX WID))) YCOORD _ YMOVE]) (SKETCH.DO.ZOOM [LAMBDA (SKETCHW NEWREGION) (* rrb "11-Jul-86 15:57") (* moves the viewing region of a window to be over NEWREGION which is in window  coordinates.) (PROG (NEWSCALE (OLDSCALE (VIEWER.SCALE SKETCHW)) (OLDREG (DSPCLIPPINGREGION NIL SKETCHW))) (* scale on the basis of heights.) [SETQ NEWSCALE (FTIMES OLDSCALE (FQUOTIENT (fetch (REGION HEIGHT) of NEWREGION) (fetch (REGION HEIGHT) of OLDREG] (WINDOWPROP SKETCHW 'SCALE NEWSCALE) (SK.ABSWXOFFSET (FIXR (FQUOTIENT (FTIMES (fetch (REGION LEFT) of NEWREGION) OLDSCALE) NEWSCALE)) SKETCHW) (SK.ABSWYOFFSET (FIXR (FQUOTIENT (FTIMES (fetch (REGION BOTTOM) of NEWREGION) OLDSCALE) NEWSCALE)) SKETCHW) (SK.UPDATE.GRIDFACTOR SKETCHW OLDSCALE) (SK.UPDATE.AFTER.SCALE.CHANGE SKETCHW]) (SKETCH.NEW.VIEW [LAMBDA (SKW) (* rrb "11-Jul-86 15:51") (* opens a new view onto the sketch viewed by SKW.) (WINDOWPROP (SKETCHW.CREATE (SKETCH.FROM.VIEWER SKW) NIL NIL NIL (VIEWER.SCALE SKW) T (SK.GRIDFACTOR SKW)) 'DONTQUERYCHANGES T]) (ZOOM.UPDATE.ELT [LAMBDA (ELT SKW) (* rrb "29-Jan-85 14:40") (* destructively updates the local part of an element in response to a zoom or  hardcopy command.) (PROG ((CACHE (SK.HOTSPOT.CACHE SKW))) (SK.REMOVE.HOTSPOTS.FROM.CACHE1 ELT CACHE) (replace (SCREENELT LOCALPART) of ELT with (fetch (SCREENELT LOCALPART) of (SK.LOCAL.FROM.GLOBAL (fetch (SCREENELT GLOBALPART) of ELT) SKW))) (SK.ADD.HOTSPOTS.TO.CACHE1 ELT CACHE) (RETURN ELT]) (SK.UPDATE.AFTER.SCALE.CHANGE [LAMBDA (SKETCHW STOPIFMOUSEDOWN) (* rrb "19-Mar-86 15:05") (* called to update the display and local elements after a window has had a  scale change.) (* if STOPIFMOUSEDOWN is T, it displays some but stops if the button left or  middle button is still down and returns STOPPED) (PROG ([SKETCH (fetch (SKETCH SKETCHELTS) of (INSURE.SKETCH (SKETCH.FROM.VIEWER SKETCHW] NEWREGION INNEW? LOCALELT) (* take down the caret.) (SKED.CLEAR.SELECTION SKETCHW T) (SK.UPDATE.REGION.VIEWED SKETCHW) (WINDOWPROP SKETCHW 'PICKFONTCACHE NIL) (SETQ NEWREGION (SKETCH.REGION.VIEWED SKETCHW)) [for GELT in SKETCH do (SETQ INNEW? (SK.INSIDE.REGION GELT NEWREGION)) (COND [(SETQ LOCALELT (SK.LOCAL.ELT.FROM.GLOBALPART GELT SKETCHW)) (COND (INNEW? (* is still in but must have its local adjusted to the new scale.) (ZOOM.UPDATE.ELT LOCALELT SKETCHW)) (T (* if it is not supposed to be in the new region, remove it.) (SK.DELETE.ITEM LOCALELT SKETCHW] (INNEW? (* just came in) (SK.ADD.ITEM GELT SKETCHW] (DSPFILL NIL NIL 'REPLACE SKETCHW) (SKETCHW.REPAINTFN SKETCHW NIL STOPIFMOUSEDOWN T]) (SKETCH.AUTOZOOM [LAMBDA (SKW) (* rrb "10-Sep-86 16:51") (* allows the user to pick a point and zooms to or from that point according to  the cursor.) (RESETFORM (CURSOR AUTOZOOMCURSOR) (PROG [SKETCHREG NEWSKETCHREG PTX PTY SCALE LFT BTM WID HGHT DISPLAYSTOPPED (WINDOWREG (WINDOWPROP SKW 'REGION] (STATUSPRINT SKW "left button enlarges; middle reduces.") (* zoom by a constant factor that keeps the point that the cursor is on at the  same location.) [until (AND (MOUSESTATE (NOT UP)) (NOT (INSIDE? WINDOWREG LASTMOUSEX LASTMOUSEY)) (OR (NOT (EQ DISPLAYSTOPPED 'STOPPED)) (PROGN (* last display didn't finish) (SKETCH.GLOBAL.REGION.ZOOM SKW NEWSKETCHREG T) T))) do (COND ((LASTMOUSESTATE (OR LEFT MIDDLE)) [SETQ PTX (TIMES (LASTMOUSEX SKW) (SETQ SCALE (VIEWER.SCALE SKW] (SETQ PTY (TIMES (LASTMOUSEY SKW) SCALE)) (SETQ SKETCHREG (SKETCH.REGION.VIEWED SKW)) (SETQ LFT (fetch (REGION LEFT) of SKETCHREG)) (SETQ BTM (fetch (REGION BOTTOM) of SKETCHREG)) (SETQ WID (fetch (REGION WIDTH) of SKETCHREG)) (SETQ HGHT (fetch (REGION HEIGHT) of SKETCHREG)) (COND ([SETQ NEWSKETCHREG (COND ((LASTMOUSESTATE LEFT) (* zoom in) (CREATEREGION (FDIFFERENCE PTX (TIMES (DIFFERENCE PTX LFT ) AUTOZOOM.FACTOR)) (FDIFFERENCE PTY (TIMES AUTOZOOM.FACTOR (DIFFERENCE PTY BTM))) (TIMES WID AUTOZOOM.FACTOR) (TIMES HGHT AUTOZOOM.FACTOR))) ((LASTMOUSESTATE MIDDLE) (* zoom out) (CREATEREGION (FDIFFERENCE PTX (QUOTIENT (DIFFERENCE PTX LFT) AUTOZOOM.FACTOR)) (FDIFFERENCE PTY (QUOTIENT (DIFFERENCE PTY BTM) AUTOZOOM.FACTOR) ) (QUOTIENT WID AUTOZOOM.FACTOR) (QUOTIENT HGHT AUTOZOOM.FACTOR] (CURSOR (COND ((LASTMOUSESTATE LEFT) ZOOMINCURSOR) (T ZOOMOUTCURSOR))) (SETQ DISPLAYSTOPPED (SKETCH.GLOBAL.REGION.ZOOM SKW NEWSKETCHREG T)) (CURSOR AUTOZOOMCURSOR] (CLOSEPROMPTWINDOW SKW]) (SKETCH.GLOBAL.REGION.ZOOM [LAMBDA (SKETCHW NEWREGION STOPIFMOUSEDOWN) (* ; "Edited 9-Jan-87 08:45 by rrb") (* moves the viewing region of a window to be over NEWREGION which is in sketch  coordinates.) (PROG (WIDTHSCALE HEIGHTSCALE NEWSCALE NEWLEFT NEWSCALE NEWBOTTOM (OLDSCALE (VIEWER.SCALE SKETCHW )) (WINDOWREG (DSPCLIPPINGREGION NIL SKETCHW))) (* scale on the basis of which ever dimension make the region fit.) (SKED.CLEAR.SELECTION SKETCHW) (COND ([GREATERP (SETQ HEIGHTSCALE (FQUOTIENT (fetch (REGION HEIGHT) of NEWREGION) (fetch (REGION HEIGHT) of WINDOWREG))) (SETQ WIDTHSCALE (FQUOTIENT (fetch (REGION WIDTH) of NEWREGION) (fetch (REGION WIDTH) of WINDOWREG] (* height is largest scale) (SETQ NEWSCALE HEIGHTSCALE)) (T (SETQ NEWSCALE WIDTHSCALE))) (* center the extra width) (SETQ NEWLEFT (FIXR (FQUOTIENT (DIFFERENCE (fetch (REGION LEFT) of NEWREGION) (QUOTIENT (DIFFERENCE (TIMES (fetch (REGION WIDTH) of WINDOWREG) NEWSCALE) (fetch (REGION WIDTH) of NEWREGION)) 2)) NEWSCALE))) (* center the extra height) (SETQ NEWBOTTOM (FIXR (FQUOTIENT (DIFFERENCE (fetch (REGION BOTTOM) of NEWREGION) (QUOTIENT (DIFFERENCE (TIMES (fetch (REGION HEIGHT) of WINDOWREG) NEWSCALE) (fetch (REGION HEIGHT) of NEWREGION)) 2)) NEWSCALE))) (COND [(EQUAL OLDSCALE NEWSCALE) (* scale hasn't changed, just scroll) (RETURN (SKETCHW.SCROLLFN SKETCHW (DIFFERENCE NEWLEFT (fetch (REGION LEFT) of WINDOWREG )) (DIFFERENCE NEWBOTTOM (fetch (REGION BOTTOM) of WINDOWREG] (T (WINDOWPROP SKETCHW 'SCALE NEWSCALE) (SK.ABSWXOFFSET NEWLEFT SKETCHW) (SK.ABSWYOFFSET NEWBOTTOM SKETCHW) (SK.UPDATE.GRIDFACTOR SKETCHW OLDSCALE) (RETURN (SK.UPDATE.AFTER.SCALE.CHANGE SKETCHW STOPIFMOUSEDOWN]) ) (RPAQ? AUTOZOOM.FACTOR 0.8) (RPAQ? AUTOZOOM.REPAINT.TIME 3000) (RPAQ AUTOZOOMCURSOR (CURSORCREATE (QUOTE #*(16 16)O@@ON@@GO@@OKJEMANGH@NG@AOOH@BD@@BD@COOH@NG@ANGHKJEMOB@ON@@GO@@O ) (QUOTE NIL) 7 8)) (RPAQ ZOOMINCURSOR (CURSORCREATE (QUOTE #*(16 16)OLCON@@GN@@GI@@IHHAAHDBA@BD@@@@@@@@@@BD@HDBAHHAAI@@IN@@GN@@GOLCO ) (QUOTE NIL) 7 8)) (RPAQ ZOOMOUTCURSOR (CURSORCREATE (QUOTE #*(16 16)H@@ADBDBBBDDABDH@NG@@NG@GNGN@@@@@@@@GNGN@NG@@NG@ABDHBBDDDBDBH@@A ) (QUOTE NIL) 7 8)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS AUTOZOOM.FACTOR AUTOZOOM.REPAINT.TIME ZOOMINCURSOR ZOOMOUTCURSOR) ) (* ; "fns for changing the view") (DEFINEQ (SKETCH.HOME [LAMBDA (SKW) (* rrb " 7-May-85 12:43") (* changes the scale of the figure being looked at in a window.) (PROG NIL (WINDOWPROP SKW 'SCALE 1.0) (WXOFFSET (WXOFFSET NIL SKW) SKW) (WYOFFSET (WYOFFSET NIL SKW) SKW) (SK.UPDATE.AFTER.SCALE.CHANGE SKW]) (SK.FRAME.IT [LAMBDA (SKW) (* rrb "23-Oct-85 10:44") (* changes the region being viewed so that the entire sketch just fits.) (PROG ((SKETCH (INSURE.SKETCH SKW))) (COND ((NULL (fetch (SKETCH SKETCHELTS) of SKETCH)) (STATUSPRINT SKW "There is nothing in this sketch.")) (T (SKETCH.GLOBAL.REGION.ZOOM SKW (SKETCH.REGION.OF.SKETCH SKETCH]) (SK.FRAME.WINDOW.TO.SKETCH [LAMBDA (SKW) (* rrb "24-Sep-86 10:17") (* reshapes the window so that the sketch at the current scale just fits inside  the window.) (PROG ((SKETCH (INSURE.SKETCH SKW))) (COND ((NULL (fetch (SKETCH SKETCHELTS) of SKETCH)) (STATUSPRINT SKW "There is nothing in this sketch.")) (T (* make sure the region isn't larger  than the screen.) (PROG ((LOCALREGION (INCREASEREGION (SK.SCALE.REGION (SKETCH.REGION.OF.SKETCH SKETCH) (VIEWER.SCALE SKW)) 1)) ATWINS HOWATTED WININTERIOR WREGION BORDER) (* 1 point increase is because the region function for boxes is one too small  in the width and height, i.e. doesn't include the bit for the edge.) (COND ((OR (GREATERP (fetch (REGION WIDTH) of LOCALREGION) (BITMAPWIDTH (SCREENBITMAP SKW))) (GREATERP (fetch (REGION HEIGHT) of LOCALREGION) (DIFFERENCE (BITMAPHEIGHT (SCREENBITMAP SKW)) 12))) (* leave room at the top for part of the title so the user can use popup menu) (STATUSPRINT SKW "The window would have to be larger than the screen.")) (T (CLOSEPROMPTWINDOW SKW) (SETQ HOWATTED (for ATW in (SETQ ATWINS (ATTACHEDWINDOWS SKW)) collect (DETACHWINDOW ATW))) (SETQ WININTERIOR (DSPCLIPPINGREGION NIL SKW)) (SETQ WREGION (WINDOWPROP SKW 'REGION)) (* move the coordinate system to lower left corner and display the image there.) (SCROLLW SKW (DIFFERENCE (fetch (REGION LEFT) of WININTERIOR) (fetch (REGION LEFT) of LOCALREGION)) (DIFFERENCE (fetch (REGION BOTTOM) of WININTERIOR) (fetch (REGION BOTTOM) of LOCALREGION))) [SHAPEW SKW (CREATEREGION (fetch (REGION LEFT) of WREGION) (fetch (REGION BOTTOM) of WREGION) (PLUS (fetch (REGION WIDTH) of LOCALREGION) (DIFFERENCE (fetch (REGION WIDTH) of WREGION) (fetch (REGION WIDTH) of WININTERIOR))) (PLUS (fetch (REGION HEIGHT) of LOCALREGION) (DIFFERENCE (fetch (REGION HEIGHT) of WREGION) (fetch (REGION HEIGHT) of WININTERIOR] (for ATW in ATWINS as HOWAT in HOWATTED do (ATTACHWINDOW ATW SKW (CAR HOWAT) (CDR HOWAT]) (SK.MOVE.TO.VIEW [LAMBDA (SKW VIEW) (* rrb "28-Jun-85 18:16") (* restores a view by changing the position and scale of the figure being  looked at in a window.) (PROG ((NEWSCALE (fetch (SKETCHVIEW VIEWSCALE) of VIEW)) (OLDSCALE (WINDOWPROP SKW 'SCALE)) SKREGWIDTH SKREGHEIGHT) (WINDOWPROP SKW 'SCALE NEWSCALE) (WXOFFSET (WXOFFSET NIL SKW) SKW) (WXOFFSET (IMINUS (QUOTIENT (DIFFERENCE (fetch (SKETCHVIEW VIEWXPOSITION) of VIEW) (TIMES (QUOTIENT (WINDOWPROP SKW 'WIDTH) 2) NEWSCALE)) NEWSCALE)) SKW) (WYOFFSET (WYOFFSET NIL SKW) SKW) (WYOFFSET (IMINUS (QUOTIENT (DIFFERENCE (fetch (SKETCHVIEW VIEWYPOSITION) of VIEW) (TIMES (QUOTIENT (WINDOWPROP SKW 'HEIGHT) 2) NEWSCALE)) NEWSCALE)) SKW) (SK.UPDATE.GRIDFACTOR SKW OLDSCALE) (SK.UPDATE.AFTER.SCALE.CHANGE SKW]) (SK.NAME.CURRENT.VIEW [LAMBDA (SKW) (* rrb "11-Jul-86 15:52") (* reads a name from the user and adds the current view to the list of views) (PROG [(SKETCH (INSURE.SKETCH SKW)) (NAME (MKATOM (PROMPT.GETINPUT SKW "Name for this view: "] (COND (NAME [PUTSKETCHPROP SKETCH 'VIEWS (APPEND (GETSKETCHPROP SKETCH 'VIEWS) (CONS (create SKETCHVIEW VIEWNAME _ NAME VIEWSCALE _ (VIEWER.SCALE SKW) VIEWPOSITION _ (REGION.CENTER ( SKETCH.REGION.VIEWED SKW] (STATUSPRINT SKW " ... done."]) (SKETCH.ADD.VIEW [LAMBDA (SKETCH NAME SCALE CENTERPOSITION) (* rrb "25-Nov-85 18:27") (* Adds a view to SKETCH.) (PROG ((SKETCH (INSURE.SKETCH SKETCH))) (COND (NAME (PUTSKETCHPROP SKETCH 'VIEWS (APPEND (GETSKETCHPROP SKETCH 'VIEWS) (CONS (create SKETCHVIEW VIEWNAME _ NAME VIEWSCALE _ (OR (NUMBERP SCALE) (\ILLEGAL.ARG SCALE)) VIEWPOSITION _ (OR (POSITIONP CENTERPOSITION) (\ILLEGAL.ARG CENTERPOSITION]) (SK.RESTORE.VIEW [LAMBDA (SKW) (* rrb " 6-Nov-85 09:56") (* puts up a menu of the previously saved places in the sketch and moves to the  one selected.) (PROG [(VIEW (\CURSOR.IN.MIDDLE.MENU (create MENU ITEMS _ (CONS '(Home 'HOME "returns to the origin at the original scale" ) (for SAVEDVIEW in (GETSKETCHPROP (INSURE.SKETCH SKW) 'VIEWS) collect (LIST (fetch (SKETCHVIEW VIEWNAME) of SAVEDVIEW) (KWOTE SAVEDVIEW) "returns the view to this location." ))) TITLE _ "Which view?" CENTERFLG _ T] (* treat home specially so the user will always have one way back.) (COND ((EQ VIEW 'HOME) (SKETCH.HOME SKW)) (VIEW (SK.MOVE.TO.VIEW SKW VIEW]) (SK.FORGET.VIEW [LAMBDA (SKW) (* rrb " 6-Nov-85 09:57") (* puts up a menu of the previously saved places in the sketch and lets the  user select one to forget.) (PROG ((SKETCH (INSURE.SKETCH SKW)) VIEWS ONETOFORGET) (SETQ VIEWS (GETSKETCHPROP SKETCH 'VIEWS)) (COND ((NULL VIEWS) (STATUSPRINT SKW "There are no saved views. They are created with the 'Save view' command.") (RETURN))) (SETQ ONETOFORGET (MENU (create MENU ITEMS _ (for SAVEDVIEW in VIEWS collect (LIST (fetch (SKETCHVIEW VIEWNAME) of SAVEDVIEW) (KWOTE SAVEDVIEW) "removes this view.")) TITLE _ "Which view?" CENTERFLG _ T))) (COND (ONETOFORGET (PUTSKETCHPROP SKETCH 'VIEWS (REMOVE ONETOFORGET VIEWS)) (STATUSPRINT SKW "View " (fetch (SKETCHVIEW VIEWNAME) of ONETOFORGET) " forgotten."]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD SKETCHVIEW (VIEWNAME VIEWSCALE VIEWPOSITION) (RECORD VIEWPOSITION (VIEWXPOSITION . VIEWYPOSITION))) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) SKETCH SKETCHELEMENTS SKETCHOBJ SKETCHEDIT INTERPRESS) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA STATUSPRINT) ) (PUTPROPS SKETCHOPS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1992 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (9954 14097 (SK.FONTNAMELIST 9964 . 10190) (SCALE.REGION.OUT 10192 . 11189) ( SK.SCALE.POSITION.INTO.VIEWER 11191 . 11951) (SK.SCALE.POSITION.INTO.VIEWER.EXACT 11953 . 12511) ( SK.MAKE.POSITION.INTEGER 12513 . 13185) (SCALE.POSITION.INTO.SKETCHW 13187 . 13478) (UNSCALE 13480 . 13608) (UNSCALE.REGION 13610 . 14095)) (14133 17889 (STATUSPRINT 14143 . 15522) (CLEARPROMPTWINDOW 15524 . 15960) (CLOSEPROMPTWINDOW 15962 . 16463) (MYGETPROMPTWINDOW 16465 . 17168) (PROMPT.GETINPUT 17170 . 17887)) (17947 28691 (SK.SEND.TO.BOTTOM 17957 . 18312) (SK.BRING.TO.TOP 18314 . 18698) ( SK.SWITCH.PRIORITIES 18700 . 19042) (SK.SEL.AND.CHANGE.PRIORITY 19044 . 19628) ( SK.SEL.AND.SWITCH.PRIORITIES 19630 . 21413) (SK.SORT.ELTS.BY.PRIORITY 21415 . 22035) ( SK.SORT.GELTS.BY.PRIORITY 22037 . 22449) (SORT.CHANGESPECS.BY.NEW.PRIORITY 22451 . 23155) ( SORT.CHANGESPECS.BY.OLD.PRIORITY 23157 . 23861) (SK.SEND.ELEMENTS.TO.BOTTOM 23863 . 25476) ( SK.BRING.ELEMENTS.TO.TOP 25478 . 27073) (SK.COPY.GLOBAL.ELEMENT.AND.PROPERTY.LIST 27075 . 28689)) ( 28692 31383 (SK.ELEMENT.PRIORITY 28702 . 29034) (SK.SET.ELEMENT.PRIORITY 29036 . 29890) ( SK.POP.NEXT.PRIORITY 29892 . 30239) (SK.PRIORITY.CELL 30241 . 30450) (SK.HIGH.PRIORITY 30452 . 30964) (SK.LOW.PRIORITY 30966 . 31381)) (31446 37530 (DRAW.LOCAL.SKETCH 31456 . 32296) (SET.PRIORITYIMPORTANT 32298 . 32755) (SK.FIGUREIMAGE 32757 . 37528)) (37574 57662 (SKETCHW.HARDCOPYFN 37584 . 45361) ( SK.LIST.IMAGE 45363 . 57316) (SK.HARDCOPYIMAGEW 57318 . 57660)) (57663 59501 ( SK.DO.HARDCOPYIMAGEW.TOFILE 57673 . 58180) (SK.HARDCOPYIMAGEW.TOFILE 58182 . 58560) ( SK.HARDCOPYIMAGEW.TOPRINTER 58562 . 58940) (SK.LIST.IMAGE.ON.FILE 58942 . 59499)) (59502 67449 ( \SK.LIST.PAGE.IMAGE 59512 . 61855) (SK.GetImageFile 61857 . 62791) (SK.PRINTER.FILE.CANDIDATE.NAME 62793 . 63739) (SK.SET.HARDCOPY.MODE 63741 . 65153) (SK.UNSET.HARDCOPY.MODE 65155 . 65588) ( SK.UPDATE.AFTER.HARDCOPY 65590 . 66329) (DEFAULTPRINTINGIMAGETYPE 66331 . 66925) ( SK.SWITCH.REGION.X.AND.Y 66927 . 67447)) (67687 80028 (SK.SEL.AND.TRANSFORM 67697 . 68063) ( SK.TRANSFORM.ELEMENTS 68065 . 69350) (SK.TRANSFORM.ITEM 69352 . 69986) (SK.TRANSFORM.ELEMENT 69988 . 70463) (SK.TRANSFORM.POINT 70465 . 70700) (SK.TRANSFORM.POINT.LIST 70702 . 70923) (SK.TRANSFORM.REGION 70925 . 72877) (SK.PUT.ELTS.ON.GRID 72879 . 73373) (SK.TRANSFORM.GLOBAL.ELEMENTS 73375 . 73894) ( GLOBALELEMENTP 73896 . 74202) (SKETCH.LIST.OF.ELEMENTSP 74204 . 74420) (SK.TRANSFORM.SCALE.FACTOR 74422 . 76027) (SK.TRANSFORM.BRUSH 76029 . 76500) (SK.TRANSFORM.ARROWHEADS 76502 . 78097) (SCALE.BRUSH 78099 . 80026)) (80029 99919 (TWO.PT.TRANSFORMATION.INPUTFN 80039 . 82828) (SK.TWO.PT.TRANSFORM.ELTS 82830 . 83251) (SK.SEL.AND.TWO.PT.TRANSFORM 83253 . 83860) (SK.APPLY.AFFINE.TRANSFORM 83862 . 84979) ( SK.COMPUTE.TWO.PT.TRANSFORMATION 84981 . 89135) (SK.COMPUTE.SLOPE 89137 . 89813) ( SK.THREE.PT.TRANSFORM.ELTS 89815 . 90242) (SK.COMPUTE.THREE.PT.TRANSFORMATION 90244 . 94657) ( SK.SEL.AND.THREE.PT.TRANSFORM 94659 . 95272) (THREE.PT.TRANSFORMATION.INPUTFN 95274 . 99917)) (99920 103888 (SK.COPY.AND.TWO.PT.TRANSFORM.ELTS 99930 . 100365) (SK.SEL.COPY.AND.TWO.PT.TRANSFORM 100367 . 101004) (SK.COPY.AND.THREE.PT.TRANSFORM.ELTS 101006 . 101451) (SK.SEL.COPY.AND.THREE.PT.TRANSFORM 101453 . 102093) (SK.COPY.AND.TRANSFORM.ELEMENTS 102095 . 103168) (SK.COPY.AND.TRANSFORM.ITEM 103170 . 103886)) (106016 108985 (SK.SHOWMARKS 106026 . 106769) (MARKPOINT 106771 . 107507) (SK.MARKHOTSPOTS 107509 . 108495) (SK.MARK.SELECTION 108497 . 108983)) (109514 116069 (SK.SELECT.ITEM 109524 . 112034) (IN.SKETCH.ELT? 112036 . 114426) (SK.MARK.HOTSPOT 114428 . 114926) (SK.MARK.POSITION 114928 . 115369) (SK.SELECT.ELT 115371 . 115802) (SK.DESELECT.ELT 115804 . 116067)) (116212 128369 (SK.HOTSPOT.CACHE 116222 . 116570) (SK.HOTSPOT.CACHE.FOR.OPERATION 116572 . 117943) (SK.BUILD.CACHE 117945 . 118616) ( SK.ELEMENT.PROTECTED? 118618 . 119215) (SK.HAS.SOME.HOTSPOTS 119217 . 119570) (SK.SET.HOTSPOT.CACHE 119572 . 119931) (SK.CREATE.HOTSPOT.CACHE 119933 . 120282) (SK.ELTS.FROM.HOTSPOT 120284 . 120983) ( SK.ADD.HOTSPOTS.TO.CACHE 120985 . 121390) (SK.ADD.HOTSPOTS.TO.CACHE1 121392 . 121942) ( SK.ADD.HOTSPOT.TO.CACHE 121944 . 123836) (SK.REMOVE.HOTSPOTS.FROM.CACHE 123838 . 124245) ( SK.REMOVE.HOTSPOTS.FROM.CACHE1 124247 . 124770) (SK.REMOVE.HOTSPOT.FROM.CACHE 124772 . 125351) ( SK.REMOVE.VALUE.FROM.CACHE.BUCKET 125353 . 126167) (SK.FIND.CACHE.BUCKET 126169 . 126775) ( SK.ADD.VALUE.TO.CACHE.BUCKET 126777 . 128367)) (128397 146992 (SK.SET.GRID 128407 . 128832) ( SK.DISPLAY.GRID 128834 . 129387) (SK.DISPLAY.GRID.POINTS 129389 . 129589) (SK.REMOVE.GRID.POINTS 129591 . 130179) (SK.TAKE.DOWN.GRID 130181 . 130496) (SK.SHOW.GRID 130498 . 133991) (SK.GRIDFACTOR 133993 . 134531) (SK.TURN.GRID.ON 134533 . 134865) (SK.TURN.GRID.OFF 134867 . 135229) ( SK.MAKE.GRID.LARGER 135231 . 135814) (SK.MAKE.GRID.SMALLER 135816 . 136417) (SK.CHANGE.GRID 136419 . 136882) (GRID.FACTOR1 136884 . 137257) (LEASTPOWEROF2GT 137259 . 138049) (GREATESTPOWEROF2LT 138051 . 138682) (SK.DEFAULT.GRIDFACTOR 138684 . 139084) (SK.PUT.ON.GRID 139086 . 139648) (MAP.WINDOW.ONTO.GRID 139650 . 139983) (MAP.SCREEN.ONTO.GRID 139985 . 140489) (MAP.GLOBAL.PT.ONTO.GRID 140491 . 140889) ( MAP.GLOBAL.REGION.ONTO.GRID 140891 . 142624) (MAP.WINDOW.POINT.ONTO.GLOBAL.GRID 142626 . 143185) ( MAP.WINDOW.ONTO.GLOBAL.GRID 143187 . 143471) (SK.UPDATE.GRIDFACTOR 143473 . 144008) ( SK.MAP.FROM.WINDOW.TO.GLOBAL.GRID 144010 . 144564) (SK.MAP.INPUT.PT.TO.GLOBAL 144566 . 145811) ( SK.MAP.FROM.WINDOW.TO.NEAREST.GRID 145813 . 146990)) (147132 155393 (SK.ADD.HISTEVENT 147142 . 148281) (SK.SEL.AND.UNDO 148283 . 151108) (SK.UNDO.LAST 151110 . 153191) (SK.UNDO.NAME 153193 . 153701) ( SKEVENTTYPEFNS 153703 . 153952) (SK.TYPE.OF.FIRST.ARG 153954 . 155391)) (155394 156088 (SK.DELETE.UNDO 155404 . 155837) (SK.ADD.UNDO 155839 . 156086)) (156089 162492 (SK.CHANGE.UNDO 156099 . 157994) ( SK.ELT.IN.SKETCH? 157996 . 158250) (SK.CHANGE.REDO 158252 . 160019) (SK.MOVE.UNDO 160021 . 161325) ( SK.MOVE.REDO 161327 . 162490)) (162493 164550 (SK.UNDO.UNDO 162503 . 163694) (SK.UNDO.MENULABEL 163696 . 164107) (SK.LABEL.FROM.TYPE 164109 . 164548)) (165376 173153 (SHOW.GLOBAL.COORDS 165386 . 165947) ( LOCATOR.CLOSEFN 165949 . 166250) (SKETCHW.FROM.LOCATOR 166252 . 166559) (SKETCHW.UPDATE.LOCATORS 166561 . 167163) (LOCATOR.UPDATE 167165 . 167939) (UPDATE.GLOBAL.LOCATOR 167941 . 168641) ( UPDATE.GLOBALCOORD.LOCATOR 168643 . 169236) (ADD.GLOBAL.DISPLAY 169238 . 170171) ( ADD.GLOBAL.GRIDDED.DISPLAY 170173 . 170432) (CREATE.GLOBAL.DISPLAYER 170434 . 171527) ( UPDATE.GLOBAL.GRIDDED.COORD.LOCATOR 171529 . 173151)) (173360 185633 (DISPLAYREADCOLORHLSLEVELS 173370 . 174105) (DISPLAYREADCOLORLEVEL 174107 . 175136) (DRAWREADCOLORBOX 175138 . 176144) ( READ.CHANGE.COLOR 176146 . 176363) (READCOLOR1 176365 . 179283) (READCOLORCOMMANDMENUSELECTEDFN 179285 . 179668) (READCOLOR2 179670 . 185631)) (185634 186930 (CREATE.CNS.MENU 185644 . 186928)) (187207 189745 (SK.ABSWXOFFSET 187217 . 187515) (SK.ABSWYOFFSET 187517 . 187815) ( SK.UNSCALE.POSITION.FROM.VIEWER 187817 . 188285) (SK.SCALE.REGION 188287 . 189743)) (189784 204423 ( VIEWER.SCALE 189794 . 190107) (SKETCH.ZOOM 190109 . 191043) (SAME.ASPECT.RATIO 191045 . 192308) ( SKETCH.DO.ZOOM 192310 . 193531) (SKETCH.NEW.VIEW 193533 . 193947) (ZOOM.UPDATE.ELT 193949 . 194858) ( SK.UPDATE.AFTER.SCALE.CHANGE 194860 . 196640) (SKETCH.AUTOZOOM 196642 . 201090) ( SKETCH.GLOBAL.REGION.ZOOM 201092 . 204421)) (205060 216600 (SKETCH.HOME 205070 . 205496) (SK.FRAME.IT 205498 . 205989) (SK.FRAME.WINDOW.TO.SKETCH 205991 . 209705) (SK.MOVE.TO.VIEW 209707 . 211137) ( SK.NAME.CURRENT.VIEW 211139 . 212264) (SKETCH.ADD.VIEW 212266 . 213363) (SK.RESTORE.VIEW 213365 . 215152) (SK.FORGET.VIEW 215154 . 216598))))) STOP \ No newline at end of file diff --git a/library/SKETCHSTREAM b/library/SKETCHSTREAM new file mode 100644 index 00000000..c9ffa3b8 --- /dev/null +++ b/library/SKETCHSTREAM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "12-Jun-90 15:21:13" {DSK}local>lde>lispcore>library>SKETCHSTREAM.;2 34014 changes to%: (VARS SKETCHSTREAMCOMS) previous date%: "17-Aug-88 12:36:19" {DSK}local>lde>lispcore>library>SKETCHSTREAM.;1) (* ; " Copyright (c) 1984, 1985, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SKETCHSTREAMCOMS) (RPAQQ SKETCHSTREAMCOMS [ (* ;; "contains the functions needed to support sketch streams. Sketch streams allow a user program to print, draw, etc. to a stream and builds a sketch of the result.") (FNS OPENSKETCHSTREAM \SKETCHSTREAM.POSITION.CHANGED \SKETCHSTREAMINIT \SK.SET.FONT \SKSTRM.WINDOW.FROM.STREAM ZOOM.SKETCH.STREAM) (* ;  "fns to support stream operations on sketches") (FNS \DSPFONT.SKETCH \DSPLEFTMARGIN.SKETCH \DSPRIGHTMARGIN.SKETCH \DSPLINEFEED.SKETCH \DSPXPOSITION.SKETCH \DSPYPOSITION.SKETCH \DRAWCURVE.SKETCH \DRAWCIRCLE.SKETCH \FILLCIRCLE.SKETCH \FILLPOLYGON.SKETCH \DRAWELLIPSE.SKETCH \DRAWARC.SKETCH \DRAWLINE.SKETCH \BOUT.SKETCH \DSPCOLOR.SKETCH \DSPBACKCOLOR.SKETCH \DSPOPERATION.SKETCH \STRINGWIDTH.SKETCH \BLTSHADE.1BITSKETCH \NEWPAGE.SKETCH \CHARWIDTH.SKETCH \BITBLT.1BITSKETCH \DSPCLIPPINGREGION.SKETCH \DSPRESET.SKETCH \DSPSCALE.SKETCH \DRAWPOLYGON.SKETCH) (ALISTS (IMAGESTREAMTYPES SKETCH)) (GLOBALVARS SketchFDEV) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\SKETCHSTREAMINIT]) (* ;; "contains the functions needed to support sketch streams. Sketch streams allow a user program to print, draw, etc. to a stream and builds a sketch of the result." ) (DEFINEQ (OPENSKETCHSTREAM [LAMBDA (TITLE OPTIONS) (* rrb "20-Dec-84 12:12") (* opens a stream onto a window that will keep a sketch of what is displayed  there.) (* changes default alignment to left baseline and default font to the default  font of display device.) (PROG ((SKW (SKETCHW.CREATE NIL (LISTGET OPTIONS 'SKETCHREGION) (LISTGET OPTIONS 'REGION) TITLE))) (* changes default alignment to left baseline and default font to the default  font of display device.) (SK.SET.TEXT.HORIZ.ALIGN SKW 'LEFT) [SK.SET.FONT SKW (FONTNAMELIST (DEFAULTFONT 'DISPLAY] (RETURN (create STREAM DEVICE _ SketchFDEV ACCESS _ 'OUTPUT USERCLOSEABLE _ NIL OUTCHARFN _ (FUNCTION \BOUT.SKETCH) IMAGEOPS _ \SKETCHIMAGEOPS IMAGEDATA _ NIL F1 _ SKW]) (\SKETCHSTREAM.POSITION.CHANGED [LAMBDA (SKW) (* called whenever the position of a  sketch stream changes.) (RESET.LINE.BEING.INPUT SKW) (SKED.CLEAR.SELECTION SKW]) (\SKETCHSTREAMINIT [LAMBDA NIL (* rrb " 4-Oct-85 17:35") (* Initializes global variables for  the Sketch device) (* Sketch Streams are referred to only by themselves so they do not need  directory operations. Most of the fields in the DisplayDevice are empty to  avoid something bad happening.) (DECLARE (GLOBALVARS SketchFDEV \SKETCHIMAGEOPS)) (SETQ \SKETCHIMAGEOPS (create IMAGEOPS IMAGETYPE _ 'SKETCH IMFONT _ (FUNCTION \DSPFONT.SKETCH) IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.SKETCH) IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.SKETCH) IMLINEFEED _ (FUNCTION \DSPLINEFEED.SKETCH) IMXPOSITION _ (FUNCTION \DSPXPOSITION.SKETCH) IMYPOSITION _ (FUNCTION \DSPYPOSITION.SKETCH) IMCLOSEFN _ (FUNCTION NILL) IMDRAWCURVE _ (FUNCTION \DRAWCURVE.SKETCH) IMFILLCIRCLE _ (FUNCTION \FILLCIRCLE.SKETCH) IMFILLPOLYGON _ (FUNCTION \FILLPOLYGON.SKETCH) IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.SKETCH) IMDRAWLINE _ (FUNCTION \DRAWLINE.SKETCH) IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.SKETCH) IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.SKETCH) IMBITBLT _ (FUNCTION \BITBLT.1BITSKETCH) IMBLTSHADE _ (FUNCTION \BLTSHADE.1BITSKETCH) IMNEWPAGE _ (FUNCTION \NEWPAGE.SKETCH) IMSCALE _ (FUNCTION \DSPSCALE.SKETCH) IMSPACEFACTOR _ (FUNCTION \DSPSPACEFACTOR.DISPLAY) IMFONTCREATE _ 'DISPLAY IMCOLOR _ (FUNCTION \DSPCOLOR.SKETCH) IMBACKCOLOR _ (FUNCTION \DSPBACKCOLOR.SKETCH) IMOPERATION _ (FUNCTION \DSPOPERATION.SKETCH) IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.SKETCH) IMCHARWIDTH _ (FUNCTION \CHARWIDTH.SKETCH) IMCLIPPINGREGION _ (FUNCTION \DSPCLIPPINGREGION.SKETCH) IMRESET _ (FUNCTION \DSPRESET.SKETCH) IMDRAWARC _ (FUNCTION \DRAWARC.SKETCH))) (SETQ SketchFDEV (create FDEV DEVICENAME _ 'SKETCH RESETABLE _ NIL RANDOMACCESSP _ NIL PAGEMAPPED _ NIL CLOSEFILE _ (FUNCTION NILL) DELETEFILE _ (FUNCTION NILL) GETFILEINFO _ (FUNCTION NILL) OPENFILE _ [FUNCTION (LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV) NAME] READPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) SETFILEINFO _ (FUNCTION NILL) GENERATEFILES _ (FUNCTION \GENERATENOFILES) TRUNCATEFILE _ (FUNCTION NILL) WRITEPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) GETFILENAME _ [FUNCTION (LAMBDA (NAME RECOG FDEV) NAME] REOPENFILE _ [FUNCTION (LAMBDA (NAME) NAME] EVENTFN _ (FUNCTION NILL) DIRECTORYNAMEP _ (FUNCTION NILL) HOSTNAMEP _ (FUNCTION NILL) BIN _ (FUNCTION \ILLEGAL.DEVICEOP) BOUT _ (FUNCTION \BOUT.SKETCH) PEEKBIN _ (FUNCTION \ILLEGAL.DEVICEOP) BACKFILEPTR _ (FUNCTION \ILLEGAL.DEVICEOP) BLOCKIN _ (FUNCTION \ILLEGAL.DEVICEOP) BLOCKOUT _ (FUNCTION \ILLEGAL.DEVICEOP))) (\DEFINEDEVICE NIL SketchFDEV]) (\SK.SET.FONT [LAMBDA (FONTDESC SKW) (* rrb "12-Dec-84 08:48") (* sets the default font from a font  descriptor.) (replace (SKETCHCONTEXT SKETCHFONT) of (WINDOWPROP SKW 'SKETCHCONTEXT) with (FONTNAMELIST FONTDESC]) (\SKSTRM.WINDOW.FROM.STREAM [LAMBDA (SKSTRM) (* rrb "12-Dec-84 08:53") (* returns the window that is associated with a sketch stream.) (fetch (STREAM F1) of SKSTRM]) (ZOOM.SKETCH.STREAM [LAMBDA (REGION SKSTREAM) (* ; "Edited 9-Jan-87 16:13 by rrb") (* changes the part of the sketch seen in a sketch window.) (PROG1 (SKETCH.REGION.VIEWED (\SKSTRM.WINDOW.FROM.STREAM SKSTREAM)) (AND REGION (COND ((REGIONP REGION) (* move the sketch region to be the new clipping region.) (SKETCH.GLOBAL.REGION.ZOOM (\SKSTRM.WINDOW.FROM.STREAM SKSTREAM) REGION)) (T (\ILLEGAL.ARG REGION]) ) (* ; "fns to support stream operations on sketches") (DEFINEQ (\DSPFONT.SKETCH [LAMBDA (SKETCHSTREAM FONT) (* rrb " 2-Aug-85 10:12") (* sets the font that a display stream uses to print characters.  SKETCHSTREAM is guaranteed to be a stream of type sketch) (PROG ((SKETCHWINDOW (\SKSTRM.WINDOW.FROM.STREAM SKETCHSTREAM)) RESULT) (SETQ RESULT (DSPFONT FONT SKETCHWINDOW)) (* if the font was changed, update the  current font.) (COND (FONT (\SKETCHSTREAM.POSITION.CHANGED SKETCHWINDOW) (\SK.SET.FONT (DSPFONT NIL SKETCHWINDOW) SKETCHWINDOW))) (RETURN RESULT]) (\DSPLEFTMARGIN.SKETCH [LAMBDA (SKSTRM LEFTMARGIN) (* rrb "21-Dec-84 08:55") (* version which passed the operation  through without doing anything.) (DSPLEFTMARGIN LEFTMARGIN (\SKSTRM.WINDOW.FROM.STREAM SKSTRM]) (\DSPRIGHTMARGIN.SKETCH [LAMBDA (SKSTRM RIGHTMARGIN) (* rrb "21-Dec-84 08:55") (* version which passed the operation  through without doing anything.) (DSPRIGHTMARGIN RIGHTMARGIN (\SKSTRM.WINDOW.FROM.STREAM SKSTRM]) (\DSPLINEFEED.SKETCH [LAMBDA (SKSTRM LINEFEED) (* rrb "21-Dec-84 08:55") (* version which passed the operation  through without doing anything.) (DSPLINEFEED LINEFEED (\SKSTRM.WINDOW.FROM.STREAM SKSTRM]) (\DSPXPOSITION.SKETCH [LAMBDA (SKSTRM XPOSITION) (* rrb " 2-Aug-85 09:26") (* version which passed the operation  through without doing anything.) (PROG ((SKW (\SKSTRM.WINDOW.FROM.STREAM SKSTRM)) RESULT) (SETQ RESULT (DSPXPOSITION XPOSITION SKW)) (AND XPOSITION (\SKETCHSTREAM.POSITION.CHANGED SKW)) (RETURN RESULT]) (\DSPYPOSITION.SKETCH [LAMBDA (SKSTRM YPOSITION) (* rrb " 2-Aug-85 09:25") (* version which passed the operation  through without doing anything.) (PROG ((SKW (\SKSTRM.WINDOW.FROM.STREAM SKSTRM)) RESULT) (SETQ RESULT (DSPYPOSITION YPOSITION SKW)) (AND YPOSITION (\SKETCHSTREAM.POSITION.CHANGED SKW)) (RETURN RESULT]) (\DRAWCURVE.SKETCH [LAMBDA (SKSTRM KNOTS CLOSED BRUSH DASHING) (* rrb "30-Oct-85 14:25") (* draws a spline curve with a given  brush.) (PROG ((SKW (\SKSTRM.WINDOW.FROM.STREAM SKSTRM))) (\SKETCHSTREAM.POSITION.CHANGED SKW) (RETURN (SK.ADD.ELEMENT (SK.CURVE.CREATE KNOTS CLOSED BRUSH DASHING (SK.INPUT.SCALE SKW)) SKW]) (\DRAWCIRCLE.SKETCH [LAMBDA (SKSTRM CENTERX CENTERY RADIUS BRUSH DASHING) (* rrb "30-Oct-85 14:25") (* draws a circle on a sketch stream) (PROG ((SKW (\SKSTRM.WINDOW.FROM.STREAM SKSTRM)) SKCONTEXT) (* put the radius point on a horzontal  line.) (\SKETCHSTREAM.POSITION.CHANGED SKW) (SETQ SKCONTEXT (WINDOWPROP SKW 'SKETCHCONTEXT)) (RETURN (SK.ADD.ELEMENT (SK.CIRCLE.CREATE (create POSITION XCOORD _ CENTERX YCOORD _ CENTERY) (create POSITION XCOORD _ (PLUS CENTERX RADIUS) YCOORD _ CENTERY) BRUSH DASHING (SK.INPUT.SCALE SKW) (fetch (SKETCHCONTEXT SKETCHFILLING) of SKCONTEXT)) SKW]) (\FILLCIRCLE.SKETCH [LAMBDA (SKSTRM CENTERX CENTERY RADIUS TEXTURE) (* rrb "27-Sep-85 09:25") (* implements fill circle on a sketch  stream.) (PROG ((SKW (\SKSTRM.WINDOW.FROM.STREAM SKSTRM))) (* put the radius point on a horzontal  line.) (\SKETCHSTREAM.POSITION.CHANGED SKW) (RETURN (SK.ADD.ELEMENT (SK.CIRCLE.CREATE (create POSITION XCOORD _ CENTERX YCOORD _ CENTERY) (create POSITION XCOORD _ (PLUS CENTERX RADIUS) YCOORD _ CENTERY) (create BRUSH BRUSHSIZE _ 0) (fetch (SKETCHCONTEXT SKETCHDASHING) of (WINDOWPROP SKW 'SKETCHCONTEXT)) (SK.INPUT.SCALE SKW) (SK.INSURE.FILLING TEXTURE)) SKW]) (\FILLPOLYGON.SKETCH [LAMBDA (SKSTRM KNOTS TEXTURE) (* rrb "26-Sep-85 18:04") (* implements fill polygon on a sketch  stream.) (PROG ((SKW (\SKSTRM.WINDOW.FROM.STREAM SKSTRM))) (\SKETCHSTREAM.POSITION.CHANGED SKW) (* add a closed wire element with a  filling.) (RETURN (SK.ADD.ELEMENT (SK.WIRE.CREATE KNOTS (create BRUSH BRUSHSIZE _ 0) (fetch (SKETCHCONTEXT SKETCHDASHING) of (WINDOWPROP SKW 'SKETCHCONTEXT)) T (SK.INPUT.SCALE SKW) NIL (SK.INSURE.FILLING TEXTURE SKW)) SKW]) (\DRAWELLIPSE.SKETCH [LAMBDA (SKSTRM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) (* rrb "30-Oct-85 14:25") (* draws an ellipse on a sketch stream) (PROG ((SKW (\SKSTRM.WINDOW.FROM.STREAM SKSTRM))) (* put the radius point on a horzontal  line.) (\SKETCHSTREAM.POSITION.CHANGED SKW) (* have the major radius be the point on the circle, the minor one be  perpendicular to it.) (RETURN (SK.ADD.ELEMENT (ELLIPSE.CREATE (create POSITION XCOORD _ CENTERX YCOORD _ CENTERY) [create POSITION XCOORD _ [PLUS CENTERX (TIMES SEMIMINORRADIUS (COS (PLUS ORIENTATION 90] YCOORD _ (PLUS CENTERY (TIMES SEMIMINORRADIUS (SIN (PLUS ORIENTATION 90] [create POSITION XCOORD _ (PLUS CENTERX (TIMES SEMIMAJORRADIUS (COS ORIENTATION))) YCOORD _ (PLUS CENTERY (TIMES SEMIMAJORRADIUS (SIN ORIENTATION] BRUSH DASHING (SK.INPUT.SCALE SKW)) SKW]) (\DRAWARC.SKETCH [LAMBDA (SKSTRM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) (* rrb "30-Oct-85 14:26") (* draws an ellipse on a sketch stream) (PROG ((SKW (\SKSTRM.WINDOW.FROM.STREAM SKSTRM))) (* put the radius point on a horzontal  line.) (\SKETCHSTREAM.POSITION.CHANGED SKW) (* have the major radius be the point on the circle, the minor one be  perpendicular to it.) (RETURN (SK.ADD.ELEMENT (ARC.CREATE (create POSITION XCOORD _ CENTERX YCOORD _ CENTERY) [create POSITION XCOORD _ (PLUS CENTERX (TIMES RADIUS (COS STARTANGLE) )) YCOORD _ (PLUS CENTERY (TIMES RADIUS (SIN STARTANGLE] [create POSITION XCOORD _ [PLUS CENTERX (TIMES RADIUS (COS (PLUS STARTANGLE NDEGREES] YCOORD _ (PLUS CENTERY (TIMES RADIUS (SIN (PLUS STARTANGLE NDEGREES] BRUSH DASHING (SK.INPUT.SCALE SKW) NIL (LESSP NDEGREES 0)) SKW]) (\DRAWLINE.SKETCH [LAMBDA (SKETCHSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) (* rrb " 4-Sep-85 16:34") (* draws a line on a sketch stream) (PROG ((SKW (\SKSTRM.WINDOW.FROM.STREAM SKETCHSTREAM))) (\SKETCHSTREAM.POSITION.CHANGED SKW) (RETURN (SK.ADD.ELEMENT (WIRE.INPUTFN SKW (LIST (create POSITION XCOORD _ X1 YCOORD _ Y1) (create POSITION XCOORD _ X2 YCOORD _ Y2)) NIL (OR WIDTH 1) (SK.INPUT.SCALE SKW) DASHING) SKW]) (\BOUT.SKETCH [LAMBDA (SKETCHSTREAM CHARCODE) (* rrb " 4-Sep-85 16:34") (* bout function for the device that  makes a sketch) (* It would be faster to keep the characters until a CR or reset line is done  but it it unclear what happens if the last operation is printing.) (PROG ((SKW (\SKSTRM.WINDOW.FROM.STREAM SKETCHSTREAM))) (COND ((NULL (WINDOWPROP SKW 'SELECTION)) (SKED.SET.SELECTION (create POSITION XCOORD _ (DSPXPOSITION NIL SKW) YCOORD _ (DSPYPOSITION NIL SKW)) SKW))) (SKED.INSERT (LIST CHARCODE) SKW (SK.INPUT.SCALE SKW)) (RETURN CHARCODE]) (\DSPCOLOR.SKETCH [LAMBDA (SKSTRM COLOR) (* rrb "20-Dec-84 10:53") (* sketch stream function for changing  the color.) (DSPCOLOR COLOR (\SKSTRM.WINDOW.FROM.STREAM SKSTRM]) (\DSPBACKCOLOR.SKETCH [LAMBDA (SKSTRM COLOR) (* rrb "20-Dec-84 10:52") (* sketch stream function for changing  the background color.) (DSPBACKCOLOR COLOR (\SKSTRM.WINDOW.FROM.STREAM SKSTRM]) (\DSPOPERATION.SKETCH [LAMBDA (SKSTRM OPERATION) (* rrb "20-Dec-84 10:53") (* sketch stream function for changing  the operation.) (DSPOPERATION OPERATION (\SKSTRM.WINDOW.FROM.STREAM SKSTRM]) (\STRINGWIDTH.SKETCH [LAMBDA (SKSTRM STR RDTBL) (* rrb "21-Dec-84 08:56") (* computes the string width for a  sketch stream.) (* calls the display stream function  directly and probably shouldn't.) (\STRINGWIDTH.DISPLAY (WINDOWPROP (\SKSTRM.WINDOW.FROM.STREAM SKSTRM) 'DSP) STR RDTBL]) (\BLTSHADE.1BITSKETCH [LAMBDA (TEXTURE SKETCHSTREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* rrb " 4-Sep-85 16:35") (* implements blt shade for a sketch  stream.) (PROG ((SKW (\SKSTRM.WINDOW.FROM.STREAM SKETCHSTREAM))) (RETURN (SK.ADD.ELEMENT (SK.BOX.CREATE (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT) (create BRUSH BRUSHSIZE _ 0) NIL (SK.INPUT.SCALE SKW) TEXTURE) SKW]) (\NEWPAGE.SKETCH [LAMBDA (SKSTRM) (* rrb " 1-Aug-85 11:59") (* NEWPAGE function for sketch  streams.) (* should probably save the current sketch before resetting it and if DSPRESET  ever resets defaults this shouldn't.) (\DSPRESET.SKETCH SKSTRM]) (\CHARWIDTH.SKETCH [LAMBDA (SKSTRM CHARCODE) (* rrb "21-Dec-84 08:54") (* computes the character width for a  sketch stream.) (* calls the display stream function  directly and probably shouldn't.) (\CHARWIDTH.DISPLAY (WINDOWPROP (\SKSTRM.WINDOW.FROM.STREAM SKSTRM) 'DSP) CHARCODE]) (\BITBLT.1BITSKETCH [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTSTRM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (* ; "Edited 9-Jan-87 16:03 by rrb") (* handles bitblt to a sketch stream. Does it by creating a bitmap imageobject.) (COND ((BITMAPP SOURCEBITMAP) (* only handles simple cases.) (PROG ((SKW (\SKSTRM.WINDOW.FROM.STREAM DESTSTRM)) (BMWIDTH (OR WIDTH (BITMAPWIDTH SOURCEBITMAP))) (BMHEIGHT (OR HEIGHT (BITMAPHEIGHT SOURCEBITMAP))) BM) (SETQ BM (BITMAPCREATE BMWIDTH BMHEIGHT)) (BITBLT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM BM 0 0 WIDTH HEIGHT NIL 'REPLACE NIL) (SK.ADD.ELEMENT (SK.ELEMENT.FROM.IMAGEOBJ (BITMAPTEDITOBJ BM 1 0) SKW (create POSITION XCOORD _ DESTINATIONLEFT YCOORD _ DESTINATIONBOTTOM)) SKW))) (T (BITBLT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM (WINDOWPROP (\SKSTRM.WINDOW.FROM.STREAM DESTSTRM) 'DSP) DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION]) (\DSPCLIPPINGREGION.SKETCH [LAMBDA (SKSTRM REGION) (* ; "Edited 17-Aug-88 12:18 by jds") (* ;; "sets the clipping region in a sketch stream.") (* ;; "(DSPCLIPPINGREGION REGION (\SKSTRM.WINDOW.FROM.STREAM SKSTRM))") (* ;;; "JDS: Changed this to be a NO-OP, but to return the existing clipping region for the underlying windo. Changing the clipping region for the window KILLS the screen.") (DSPCLIPPINGREGION NIL (\SKSTRM.WINDOW.FROM.STREAM SKSTRM]) (\DSPRESET.SKETCH [LAMBDA (SKSTRM) (* rrb " 9-Jul-85 12:42") (* reset the properties of a sketch  stream.) (PROG ((W (\SKSTRM.WINDOW.FROM.STREAM SKSTRM)) SKETCH OLDSKETCH) (SKED.CLEAR.SELECTION W) [WINDOWPROP W 'SKETCH (SETQ SKETCH (COND ((SETQ OLDSKETCH (WINDOWPROP W 'SKETCH)) (* copy properties and defaults from  old sketch.) (create SKETCH using OLDSKETCH SKETCHELTS _ NIL)) (T (SKETCH.CREATE NIL] (* for now, don't reset the defaults  other than position.) (DSPRESET W) (\DSPXPOSITION.SKETCH SKSTRM (DSPXPOSITION NIL W)) (\DSPYPOSITION.SKETCH SKSTRM (DSPYPOSITION NIL W)) (WINDOWPROP W 'SCALE INITIAL.SCALE) (SK.UPDATE.REGION.VIEWED W) (MAP.SKETCHSPEC.INTO.VIEWER SKETCH W) (SK.CREATE.HOTSPOT.CACHE W) (WINDOWPROP W 'GRIDFACTOR (SK.DEFAULT.GRIDFACTOR W)) (WINDOWPROP W 'USEGRID NIL) (WINDOWPROP W 'SKETCHCHANGED NIL]) (\DSPSCALE.SKETCH [LAMBDA (SKSTRM SCALE) (* ; "Edited 9-Jan-87 16:00 by rrb") (* returns the scale of a sketch  stream.) (PROG ((SKWINDOW (\SKSTRM.WINDOW.FROM.STREAM SKSTRM)) OLDSCALE) (RETURN (PROG1 (SETQ OLDSCALE (VIEWER.SCALE SKWINDOW)) (AND SCALE (COND [(NUMBERP SCALE) (* zoom the current sketch view around  the center.) (* don't redraw if scale is the same.) (OR (EQP OLDSCALE SCALE) (PROG [NEWWIDTH NEWHEIGHT (CENTERPT (REGION.CENTER ( SKETCH.REGION.VIEWED SKWINDOW] [SETQ NEWWIDTH (TIMES SCALE (WINDOWPROP SKWINDOW 'WIDTH] [SETQ NEWHEIGHT (TIMES SCALE (WINDOWPROP SKWINDOW 'HEIGHT] (SKETCH.GLOBAL.REGION.ZOOM SKWINDOW (CREATEREGION (DIFFERENCE (fetch (POSITION XCOORD) of CENTERPT) (QUOTIENT NEWWIDTH 2)) (DIFFERENCE (fetch (POSITION YCOORD) of CENTERPT) (QUOTIENT NEWHEIGHT 2)) NEWWIDTH NEWHEIGHT] (T (\ILLEGAL.ARG SCALE]) (\DRAWPOLYGON.SKETCH [LAMBDA (SKETCHSTREAM POINTS CLOSED BRUSH DASHING) (* rrb "26-Sep-85 18:07") (* draws a polygon on a sketch stream) (PROG ((SKW (\SKSTRM.WINDOW.FROM.STREAM SKETCHSTREAM))) (\SKETCHSTREAM.POSITION.CHANGED SKW) (RETURN (SK.ADD.ELEMENT (SK.WIRE.CREATE POINTS BRUSH DASHING T (SK.INPUT.SCALE SKW) NIL NIL) SKW]) ) (ADDTOVAR IMAGESTREAMTYPES (SKETCH (OPENSTREAM OPENSKETCHSTREAM) (FONTCREATE \CREATEDISPLAYFONT))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SketchFDEV) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\SKETCHSTREAMINIT) ) (PUTPROPS SKETCHSTREAM COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1917 9341 (OPENSKETCHSTREAM 1927 . 3074) (\SKETCHSTREAM.POSITION.CHANGED 3076 . 3368) ( \SKETCHSTREAMINIT 3370 . 7936) (\SK.SET.FONT 7938 . 8436) (\SKSTRM.WINDOW.FROM.STREAM 8438 . 8697) ( ZOOM.SKETCH.STREAM 8699 . 9339)) (9403 33638 (\DSPFONT.SKETCH 9413 . 10185) (\DSPLEFTMARGIN.SKETCH 10187 . 10581) (\DSPRIGHTMARGIN.SKETCH 10583 . 10980) (\DSPLINEFEED.SKETCH 10982 . 11370) ( \DSPXPOSITION.SKETCH 11372 . 11917) (\DSPYPOSITION.SKETCH 11919 . 12464) (\DRAWCURVE.SKETCH 12466 . 12999) (\DRAWCIRCLE.SKETCH 13001 . 14207) (\FILLCIRCLE.SKETCH 14209 . 15621) (\FILLPOLYGON.SKETCH 15623 . 16733) (\DRAWELLIPSE.SKETCH 16735 . 18829) (\DRAWARC.SKETCH 18831 . 20892) (\DRAWLINE.SKETCH 20894 . 22004) (\BOUT.SKETCH 22006 . 22975) (\DSPCOLOR.SKETCH 22977 . 23336) (\DSPBACKCOLOR.SKETCH 23338 . 23716) (\DSPOPERATION.SKETCH 23718 . 24093) (\STRINGWIDTH.SKETCH 24095 . 24738) ( \BLTSHADE.1BITSKETCH 24740 . 25669) (\NEWPAGE.SKETCH 25671 . 26151) (\CHARWIDTH.SKETCH 26153 . 26792) (\BITBLT.1BITSKETCH 26794 . 28415) (\DSPCLIPPINGREGION.SKETCH 28417 . 28944) (\DSPRESET.SKETCH 28946 . 30515) (\DSPSCALE.SKETCH 30517 . 33121) (\DRAWPOLYGON.SKETCH 33123 . 33636))))) STOP \ No newline at end of file diff --git a/library/SPY b/library/SPY new file mode 100644 index 00000000..177e339b --- /dev/null +++ b/library/SPY @@ -0,0 +1,943 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "29-Apr-94 14:13:52" {DSK}export>lispcore>library>SPY.;4 64372 + + changes to%: (FILES GRAPHER) + (FNS SPY.GRAPH.EDITOR SPY.UPDATE.TITLE SPY.MERGEINFO SPY.MAKEGRAPHNODES SPY.MAX + SPY.MERGE SPY.MERGE1 SPY.MERGETREE SPY.NEXT.TREE SPY.SUM SPY.MAKE.TREE + SPY.DELETE SPY.DUMP.BUFFER SPY.ORIGINAL SPY.MERGE.CALLEES) + + previous date%: "28-Apr-94 15:56:32" {DSK}export>lispcore>library>SPY.;3) + + +(* ; " +Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT SPYCOMS) + +(RPAQQ SPYCOMS + ((VARS SPY.BORDERS SPY.BUFFER.SIZE SPY.FRAGMENTS SPY.NOMERGEFNS SPY.MERGEINFO (SPY.HASH) + (SPY.GRAPH.MENU) + SPY.SHOW.PERCENTAGES SPY.SMALLGHOSTS SPY.ICON) + (INITVARS (SPY.NEXT 0) + (SPY.BUFFER) + (SPY.SHOWCOUNTS T) + (SPY.SHOW.THRESHOLD 1) + (SPY.MAXLINES 10) + (SPY.FREQUENCY 10) + (SPY.FONT '(GACHA 8)) + (SPY.TREE)) + (COMS * SPYOBJCOMS) + (FNS SPY.FIND.TREE SPY.TOGGLE SPY.TREE SPY.LEGEND SPY.GRAPH.EDITOR SPY.END SPY.MAKEGRAPHNODES + SPY.MAX SPY.MERGE SPY.MERGE1 SPY.MERGETREE SPY.NEXT.TREE SPY.SUM SPY.TITLE SPY.MAKE.TREE + SPY.UPDATE.TITLE SPY.DELETE SPY.DRAWBOX SPY.BUFFER.ENTRY SPY.BUTTON SPY.END.ENTRY + SPY.START SPY.INIT \SPY.INTERRUPT SPY.DUMP.BUFFER SPY.START.ENTRY SPY.ADD.ENTRY + SPY.ORIGINAL SPY.OVERFLOW SPY.MERGE.CALLEES SPY.PRINT) + (COMS (INITVARS (SPY.BUTTON)) + (VARS SPY.OPEN SPY.CLOSED)) + (VARIABLES SPY.POINTERS) + (GLOBALVARS SPY.OVERFLOWED \PERIODIC.INTERRUPT SPY.TREE SPY.BUFFER.SIZE SPY.NEXT + SPY.BUFFER.THRESHOLD SPY.BUFFER SPY.FREQUENCY SPY.SHOW.THRESHOLD SPY.MAXLINES SPY.FONT + ) + (MACROS WITH-SPY WITH.SPY) + (DECLARE%: DONTCOPY (RECORDS SPYRECORD SPYDATA)) + (INITRECORDS SPYRECORD) + (DECLARE%: DOCOPY DOEVAL@COMPILE (FILES GRAPHER READNUMBER IMAGEOBJ)))) + +(RPAQQ SPY.BORDERS ((NORMAL "Normal" 2 -1) + (GHOST "Shown elsewhere" 2 8840) + (RECURSIVEGHOST "End of recursive chain" 2 0 -1) + (MERGED "Includes other branches" 4 42405) + (SELFRECURSIVE "Includes self-recursive calls" 2 61375) + (RECURSIVE "Head of recursive chain" 4 28086) + (ENDOFLINE "exceeded depth limit" 6 64510))) + +(RPAQQ SPY.BUFFER.SIZE 5120) + +(RPAQQ SPY.FRAGMENTS T) + +(RPAQQ SPY.NOMERGEFNS (SI::*UNWIND-PROTECT* CL:EVAL \EVAL-PROGN \INTERPRET-ARGUMENTS \INTERPRETER + \INTERPRETER1 ERRORSET \EVAL \EVALFORM APPLY \PROGV EVAL)) + +(RPAQQ SPY.MERGEINFO ((EXEC :EXEC) + (EXEC-READ-LINE :EXEC) + (EXEC-READ :EXEC) + (XCL-USER::LEX-DO-EVENT :EXEC) + (DO-EVENT :EXEC) + (EVAL-INPUT :EXEC) + (SI::*UNWIND-PROTECT* :ANY) + (\MAKE.PROCESS0 T) + (\PROC.REPEATEDLYEVALQT T) + (\EVALFORM T :EVAL) + (PROGN PROGN :EVAL T) + (TTYIN1 TTYIN) + (TTBIN TTYIN) + (TTWAITFORINPUT TTYIN) + (\PROGV :ANY))) + +(RPAQQ SPY.HASH NIL) + +(RPAQQ SPY.GRAPH.MENU NIL) + +(RPAQQ SPY.SHOW.PERCENTAGES T) + +(RPAQQ SPY.SMALLGHOSTS T) + +(RPAQQ SPY.ICON #*(56 28)OOOOOOOOOOOOOO@@OOOOOOOOOOOOOO@@L@@@@@@@@@@@@C@@L@@@@@@@@@@@@C@@L@@@@@@@@@@@@C@@L@@@@@@@@COONC@@L@@@@@@@@B@@BC@@L@@@@@@@@B@@BC@@L@GOOOO@@N@@BC@@L@D@@@A@CB@@BC@@L@ENODE@LB@@BC@@L@E@IBIC@COONC@@L@ENOAAL@@@@@C@@L@DBHAAF@COONC@@L@ENHAAAHB@@BC@@L@D@@@A@FB@@BC@@L@GOOOO@AJ@@BC@@L@@@@@@@@F@@BC@@L@@@@@@@@B@@BC@@L@@@@@@@@B@@BC@@L@@@@@@@@B@@BC@@L@@@@@@@@B@@BC@@L@@@@@@@@B@@BC@@L@@@@@@@@COONC@@L@@@@@@@@@@@@C@@L@@@@@@@@@@@@C@@OOOOOOOOOOOOOO@@OOOOOOOOOOOOOO@@ +) + +(RPAQ? SPY.NEXT 0) + +(RPAQ? SPY.BUFFER ) + +(RPAQ? SPY.SHOWCOUNTS T) + +(RPAQ? SPY.SHOW.THRESHOLD 1) + +(RPAQ? SPY.MAXLINES 10) + +(RPAQ? SPY.FREQUENCY 10) + +(RPAQ? SPY.FONT '(GACHA 8)) + +(RPAQ? SPY.TREE ) + +(RPAQQ SPYOBJCOMS ((FNS SPYOBJ SPYOBJ.BUTTON SPYOBJ.SAVE SPYOBJ.COPY SPYOBJ.GET SPYOBJ.IMAGEBOX + SPYOBJ.DISPLAY SPYOBJ.LABEL SPYOBJ.HEIGHT SPYOBJ.COPYIN SPY.COPYBUTTON + SPY.MERGEINFO) + [VARS (SPYOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY) + (FUNCTION SPYOBJ.IMAGEBOX) + (FUNCTION SPYOBJ.SAVE) + (FUNCTION SPYOBJ.GET) + (FUNCTION SPYOBJ.COPY) + (FUNCTION SPYOBJ.BUTTON) + (FUNCTION SPYOBJ.COPYIN) + NIL NIL NIL NIL NIL NIL 'SPYNODE] + (DECLARE%: DONTCOPY DOEVAL@COMPILE (RECORDS FX SPYOBJDATA)) + (INITRECORDS SPYOBJDATA))) +(DEFINEQ + +(SPYOBJ (LAMBDA (NAME PERCENT STATUS) (* ; "Edited 9-Sep-87 17:56 by Masinter") (IMAGEOBJCREATE (create SPYOBJDATA LABEL _ NAME PERCENT _ PERCENT CACHEDLABEL _ (LET ((*PRINT-PRETTY* NIL) (*PRINT-LEVEL* 1) (*PRINT-LENGTH* 1)) (CL:FORMAT NIL "~D ~S" PERCENT LABEL))) SPYOBJ.IMAGEFNS)) ) + +(SPYOBJ.BUTTON (LAMBDA (OBJ WINDOWSTREAM SEL RELX RELY WINDOW TEXT BUTTON) (* lmm " 9-Jun-85 00:40") NIL)) + +(SPYOBJ.SAVE (LAMBDA (OBJ STREAM) (* edited%: "11-Jun-85 05:03") (PRIN2 (fetch OBJECTDATUM OBJ) STREAM FILERDTBL))) + +(SPYOBJ.COPY (LAMBDA (OBJ) (* lmm " 9-Jun-85 00:43") OBJ)) + +(SPYOBJ.GET (LAMBDA (STREAM TEXTSTREAM) (* lmm " 9-Jun-85 00:44") (IMAGEOBJCREATE (READ STREAM FILERDTBL) SPYOBJ.IMAGEFNS)) ) + +(SPYOBJ.IMAGEBOX [LAMBDA (OBJ FONTSOURCE) (* ; "Edited 16-Aug-88 11:07 by sye") (OR FONTSOURCE (SETQ FONTSOURCE SPY.FONT)) (LET ((DATA (fetch OBJECTDATUM OBJ))) (LET ((HEIGHT (SPYOBJ.HEIGHT OBJ FONTSOURCE))) (create IMAGEBOX XSIZE _ (STRINGWIDTH (SPYOBJ.LABEL OBJ) FONTSOURCE) YSIZE _ HEIGHT YDESC _ 0 XKERN _ 0]) + +(SPYOBJ.DISPLAY (LAMBDA (OBJ STREAM) (* lmm " 9-Jun-85 01:13") (DSPFONT SPY.FONT STREAM) (LET ((DATA (fetch OBJECTDATUM OBJ))) (LET ((HEIGHT (SPYOBJ.HEIGHT OBJ STREAM))) (RELMOVETO 0 (QUOTIENT (DIFFERENCE HEIGHT (QUOTIENT (FONTHEIGHT STREAM) 2)) 2) STREAM) (PRIN3 (SPYOBJ.LABEL OBJ) STREAM)))) ) + +(SPYOBJ.LABEL (LAMBDA (OBJ) (* lmm " 9-Jun-85 01:24") (LET ((DATUM (fetch OBJECTDATUM OBJ))) (with SPYOBJDATA DATUM CACHEDLABEL))) ) + +(SPYOBJ.HEIGHT (LAMBDA (OBJ STREAM) (* lmm " 9-Jun-85 00:51") (LET ((DATUM (fetch OBJECTDATUM OBJ)) (FH (FONTHEIGHT STREAM))) (with SPYOBJDATA DATUM (MAX FH (QUOTIENT (TIMES PERCENT SPY.MAXLINES FH) 100))))) ) + +(SPYOBJ.COPYIN (LAMBDA (A B C) (HELP))) + +(SPY.COPYBUTTON (LAMBDA (WINDOW) (* lmm " 9-Jun-85 01:55") (SPY.GRAPH.EDITOR WINDOW T))) + +(SPY.MERGEINFO + [LAMBDA (NAME SPYDATA PARENT-NAME) (* ; "Edited 28-Apr-94 14:00 by sybalsky") + (OR [AND (fetch (SPYDATA MERGEINFO) of SPYDATA) + (for X in (fetch (SPYDATA MERGEINFO) of SPYDATA) + when (AND (EQ (CAR X) + NAME) + (FMEMB PARENT-NAME (CDR X))) do (RETURN (CDR X] + (CDR (FASSOC NAME SPY.MERGEINFO)) + (if (STRPOS "\interpret-" NAME) + then '(:INTERPRETER CL:EVAL]) +) + +(RPAQ SPYOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY) + (FUNCTION SPYOBJ.IMAGEBOX) + (FUNCTION SPYOBJ.SAVE) + (FUNCTION SPYOBJ.GET) + (FUNCTION SPYOBJ.COPY) + (FUNCTION SPYOBJ.BUTTON) + (FUNCTION SPYOBJ.COPYIN) + NIL NIL NIL NIL NIL NIL 'SPYNODE)) +(DECLARE%: DONTCOPY DOEVAL@COMPILE +(DECLARE%: EVAL@COMPILE + +(ACCESSFNS FX ((FXBLOCK (ADDSTACKBASE DATUM))) (* ; "frame extension index") + (BLOCKRECORD FXBLOCK ((FLAGS BITS 3) (* ; "= \STK.FX") + (FAST FLAG) + (NIL FLAG) + (INCALL FLAG) (* ; + "set when fncall microcode has to punt") + (VALIDNAMETABLE FLAG)(* ; + "if on, NAMETABLE field is filled in. If off, is same as FNHEADER") + (NOPUSH FLAG) (* ; + "when returning to this frame, don't push a value. Set by interrupt code") + (USECNT BITS 8) + (%#ALINK WORD) (* ; "low bit is SLOWP") + (FNHEADER FULLXPOINTER) + (NEXTBLOCK WORD) + (PC WORD) + (NAMETABLE# FULLXPOINTER) + (%#BLINK WORD) + (%#CLINK WORD))) + (BLOCKRECORD FXBLOCK ((FLAGBYTE BYTE) + (NIL BYTE) + (NIL BITS 15) (* ; "most of the bits of #ALINK") + (SLOWP FLAG) (* ; + "if on, then BLINK and CLINK fields are valid. If off, they are implicit") + (NIL FULLXPOINTER 2) + (NAMETABHI WORD) + (NAMETABLO WORD))) + (TYPE? (IEQ (fetch (FX FLAGS) of DATUM) + \STK.FX)) + [ACCESSFNS FX ((NAMETABLE (COND + ((fetch (FX VALIDNAMETABLE) of DATUM) + (fetch (FX NAMETABLE#) of DATUM)) + (T (fetch (FX FNHEADER) of DATUM))) + (PROGN (replace (FX FAST) of DATUM with NIL) + (replace (FX NAMETABLE#) of DATUM with + NEWVALUE) + (replace (FX VALIDNAMETABLE) of DATUM + with T))) + (FRAMENAME (fetch (FNHEADER FRAMENAME) + of (fetch (FX NAMETABLE) of DATUM))) + (INVALIDP (EQ DATUM 0)) (* ; + "true when A/CLink points at nobody, i.e. FX is bottom of stack") + [FASTP (NOT (fetch (FX SLOWP) of DATUM)) + (PROGN (CHECK (NULL NEWVALUE)) + (COND + ((fetch (FX FASTP) of DATUM) + (replace (FX %#BLINK) of DATUM + with (fetch (FX DUMMYBF) of DATUM)) + (replace (FX %#CLINK) of DATUM + with (fetch (FX %#ALINK) of DATUM)) + (replace (FX SLOWP) of DATUM with + T] + [BLINK (COND + ((fetch (FX FASTP) of DATUM) + (fetch (FX DUMMYBF) of DATUM)) + (T (fetch (FX %#BLINK) of DATUM))) + (PROGN (replace (FX %#BLINK) of DATUM with + NEWVALUE) + (COND + ((fetch (FX FASTP) of DATUM) + (replace (FX %#CLINK) of DATUM + with (fetch (FX %#ALINK) of DATUM)) + (replace (FX SLOWP) of DATUM with + T] + [CLINK (IDIFFERENCE (COND + ((fetch (FX FASTP) of DATUM) + (fetch (FX %#ALINK) of DATUM)) + (T (fetch (FX %#CLINK) of DATUM))) + \#ALINK.OFFSET) + (PROGN (replace (FX %#CLINK) of DATUM + with (IPLUS NEWVALUE \#ALINK.OFFSET)) + (COND + ((fetch (FX FASTP) of DATUM) + (replace (FX %#BLINK) of DATUM + with (fetch (FX DUMMYBF) of DATUM)) + (replace (FX SLOWP) of DATUM with + T] + [ALINK (IDIFFERENCE (FLOOR (fetch (FX %#ALINK) of DATUM) + WORDSPERCELL) + \#ALINK.OFFSET) + (PROGN [COND + ((fetch (FX FASTP) of DATUM) + (replace (FX %#BLINK) of DATUM + with (fetch (FX DUMMYBF) of DATUM)) + (replace (FX %#CLINK) of DATUM + with (fetch (FX %#ALINK) of DATUM] + (replace (FX %#ALINK) of DATUM + with (IPLUS NEWVALUE \#ALINK.OFFSET + (SUB1 WORDSPERCELL] + [ACLINK (SHOULDNT) + (PROGN [COND + ((fetch (FX FASTP) of DATUM) + (replace (FX %#BLINK) of DATUM + with (fetch (FX DUMMYBF) of DATUM] + (replace (FX %#CLINK) of DATUM + with (IPLUS NEWVALUE \#ALINK.OFFSET)) + (replace (FX %#ALINK) of DATUM + with (IPLUS NEWVALUE \#ALINK.OFFSET + (SUB1 WORDSPERCELL] + (* ; + "replaces A & C Links at once more efficiently than separately") + (DUMMYBF (IDIFFERENCE DATUM WORDSPERCELL)) + + (* ;; "This is either an actual BF or %"residual%" BF that provides enough BF to find its IVAR slot. This means that when a FX is copied, the cell preceding the FX is copied too.") + + (IVAR (fetch (BF IVAR) of (fetch (FX DUMMYBF) + of DATUM))) + [CHECKED (AND (type? FX DATUM) + (OR (IEQ (fetch (FX DUMMYBF) of DATUM) + (fetch (FX BLINK) of DATUM)) + (AND (fetch (BF RESIDUAL) + of (fetch (FX DUMMYBF) + of DATUM)) + (IEQ (fetch (BF IVAR) + of (fetch (FX DUMMYBF) + of DATUM)) + (fetch (BF IVAR) + of (fetch (FX BLINK) + of DATUM] + (FIRSTPVAR (IPLUS DATUM (fetch (FX FXSIZE) of T))) + (* ; "stack offset of PVAR0") + (FXSIZE (PROGN 10)) (* ; + "fixed overhead from flags thru clink") + (PADDING (PROGN 4)) (* ; + "doublecell of garbage for microcode use") + (FIRSTTEMP (IPLUS (fetch (FX FIRSTPVAR) of DATUM) + (fetch (FX NPVARWORDS) of DATUM) + (fetch (FX PADDING) of DATUM))) + (* ; + "note that NPVARWORDS is obtained from the FNHEADER") + (SIZE (IDIFFERENCE (fetch (FX NEXTBLOCK) of DATUM) + DATUM]) + +(RECORD SPYOBJDATA (CACHEDLABEL PERCENT LABEL)) +) +) +(DEFINEQ + +(SPY.FIND.TREE [LAMBDA (FN) (* ; "Edited 25-Sep-87 16:23 by jop") (OR (find X in SPY.TREE suchthat (EQ (fetch (SPYRECORD NAME) of X) FN)) (CAR (push SPY.TREE (create SPYRECORD NAME _ FN COUNT _ 0]) + +(SPY.TOGGLE (LAMBDA NIL (* lmm "24-Oct-84 22:49") (if (EQ \PERIODIC.INTERRUPT (QUOTE \SPY.INTERRUPT)) then (SPY.END) (RESETFORM (CURSOR WAITINGCURSOR) (SPY.TREE 10)) else (SPY.START))) ) + +(SPY.TREE [LAMBDA (THRESHOLD INDIVIDUALP MERGETYPE DEPTHLIMIT) (* ; "Edited 9-Dec-87 13:10 by sye") (COND ((NULL SPY.TREE) "no spy samples have been gathered") (T (PROG ((SPYDATA (create SPYDATA PACKAGE _ *PACKAGE* READTABLE _ *READTABLE* PRINT-CASE _ *PRINT-CASE* CUMULATIVE _ (NOT INDIVIDUALP) THRESHOLD _ (OR THRESHOLD SPY.SHOW.THRESHOLD) MERGETYPE _ (OR (if (EQ MERGETYPE 'DEFAULT) then T else MERGETYPE) (COND (INDIVIDUALP 'ALL) (T T))) DEPTH _ DEPTHLIMIT))) (SPY.MAKE.TREE (SPY.MERGE SPY.TREE SPYDATA) SPYDATA]) + +(SPY.LEGEND (LAMBDA NIL (* lmm "28-Sep-84 21:27") (SHOWGRAPH (LAYOUTGRAPH (for X in SPY.BORDERS collect (create GRAPHNODE NODEID _ X NODELABEL _ (CADR X) TONODES _ NIL NODEFONT _ SPY.FONT NODEBORDER _ (CDDR X) NODELABELSHADE _ (CADDR (CDDR X)))) (REVERSE SPY.BORDERS) NIL SPY.FONT NIL 10) "SPY border interpretation" (QUOTE NILL) (QUOTE NILL))) ) + +(SPY.GRAPH.EDITOR + [LAMBDA (W COPY) (* ; "Edited 29-Apr-94 14:03 by sybalsky") + (PROG* ((TREES (WINDOWPROP W 'TREES)) + NEW-TREES + (TOPCOUNT (WINDOWPROP W 'TOPCOUNT)) + (WINDOW W) + NODE LASTNODE ACTION (SPYDATA (WINDOWPROP W 'SPYDATA)) + PENDING + [MULTIPLE (AND (= (LOGAND LASTKEYBOARD 32) + 32) + (MOUSESTATE (OR LEFT MIDDLE] + (*READTABLE* (fetch (SPYDATA READTABLE) of SPYDATA)) + (*PACKAGE* (fetch (SPYDATA PACKAGE) of SPYDATA)) + (*PRINT-CASE* (fetch (SPYDATA PRINT-CASE) of SPYDATA))) + (TOTOPW W) + (do (SETQ NODE (OR (NODELST/AS/MENU (fetch (GRAPH GRAPHNODES) + of (WINDOWPROP W 'GRAPH)) + (CONS (LASTMOUSEX W) + (LASTMOUSEY W))) + COPY)) + (if (NEQ NODE LASTNODE) + then [COND + (LASTNODE (if (EQ LASTNODE T) + then (INVERTW W) + else (FLIPNODE LASTNODE W] + [COND + (NODE (if (EQ NODE T) + then (INVERTW W) + else (FLIPNODE NODE W] + (SETQ LASTNODE NODE)) repeatwhile (MOUSESTATE (OR MIDDLE LEFT))) + [COND + (COPY (RETURN (COND + ((EQ NODE T) + (INVERTW W) + (GRAPHERCOPYBUTTONEVENTFN W)) + (T (FLIPNODE NODE W) + (COPYINSERT (fetch (SPYRECORD NAME) of (fetch + (GRAPHNODE NODEID) + of NODE] + (if NODE + then + (LET [(NAME (fetch (SPYRECORD NAME) of (fetch (GRAPHNODE NODEID) + of NODE] + (SELECTQ [SETQ ACTION (MENU (CONSTANT (create MENU + ITEMS _ + '(NewSubTree SubTree Delete Merge + Edit InspectCode] + (NIL (FLIPNODE NODE W) (* ; "no tree action ") + ) + (Edit (FLIPNODE NODE W) + (ED NAME '(FUNCTIONS FNS :DONTWAIT :DISPLAY))) + (InspectCode (FLIPNODE NODE W) + (INSPECTCODE NAME)) + (Delete (* ; + "remove this node. Leave still marked") + (push (fetch (SPYDATA DELETED) of SPYDATA) + NAME) + (SETQ PENDING "delete")) + (Merge [if (fetch (GRAPHNODE FROMNODES) of NODE) + then (push (fetch (SPYDATA MERGEINFO) of SPYDATA) + (LIST NAME (fetch (SPYRECORD NAME) + of (CAR (fetch (GRAPHNODE + FROMNODES) + of NODE] + (SETQ PENDING "merge")) + (NewSubTree (FLIPNODE NODE W) + (SPY.MAKE.TREE (SPY.MERGE + (SPY.ORIGINAL (LIST (fetch + (GRAPHNODE NODEID) + of NODE))) + SPYDATA) + (create SPYDATA + using SPYDATA PENDING _ NIL DELETED _ NIL))) + ((SubTree) + (SETQ NEW-TREES (SPY.MERGE (SPY.ORIGINAL + (LIST (fetch (GRAPHNODE NODEID) + of NODE))) + SPYDATA))) + (printout PROMPTWINDOW T "SORRY, FEATURE NOT IMPLEMENTED YET"))) + elseif (INSIDE? (WINDOWPROP W 'REGION) + LASTMOUSEX LASTMOUSEY) + then (SELECTQ [MENU (create + MENU + ITEMS _ + `(Legend Inspect SetThreshold ,(COND + ((fetch (SPYDATA + CUMULATIVE + ) + of SPYDATA) + 'Individual) + (T 'Cumulative)) + ,@(SELECTQ (fetch (SPYDATA MERGETYPE) + of SPYDATA) + (ALL '(MergeDefault MergeNone)) + (T '(MergeNone MergeAll)) + ((NIL NONE) + '(MergeDefault MergeAll)) + (SHOULDNT] + (NIL) + (Legend (SPY.LEGEND)) + (Inspect (INSPECT/PLIST SPYDATA)) + (SetThreshold (* ; "no need to remerge") + (replace (SPYDATA THRESHOLD) of SPYDATA + with (RNUMBER "Threshold (percent)" NIL DEFAULTFONT + DEFAULTFONT)) + (SETQ PENDING "threshold")) + (MergeAll (replace (SPYDATA MERGETYPE) of SPYDATA + with 'ALL) + (SETQ PENDING "merge-type")) + (MergeNone (replace (SPYDATA MERGETYPE) of SPYDATA + with 'NONE) + (SETQ PENDING "merge-type")) + (MergeDefault (replace (SPYDATA MERGETYPE) of SPYDATA + with T) + (SETQ PENDING "merge-type")) + ((Cumulative Individual) + [replace (SPYDATA MERGETYPE) of SPYDATA + with (COND + ((change (fetch (SPYDATA CUMULATIVE) + of SPYDATA) + (NOT DATUM)) + T) + (T 'ALL] + (SETQ PENDING "merge-type")) + (SHOULDNT))) + DOIT + (if (AND (NOT NEW-TREES) + MULTIPLE) + then (* ; + "multiple action while shift down") + (if PENDING + then [if [NOT (STRPOS PENDING (WINDOWPROP W 'TITLE] + then (WINDOWPROP W 'TITLE (CONCAT PENDING "/" + (WINDOWPROP W 'TITLE] + (replace (SPYDATA PENDING) of SPYDATA with T)) + elseif (OR NEW-TREES PENDING (fetch (SPYDATA PENDING) of SPYDATA)) + then (SPY.MAKE.TREE (OR NEW-TREES (SPY.MERGE (SPY.ORIGINAL TREES) + SPYDATA)) + (create SPYDATA using SPYDATA PENDING _ NIL DELETED _ NIL) + WINDOW]) + +(SPY.END (LAMBDA NIL (* ; "Edited 9-Sep-87 17:51 by Masinter") (if (EQ \PERIODIC.INTERRUPT (QUOTE \SPY.INTERRUPT)) then (SETQ \PERIODIC.INTERRUPT) (SPY.DUMP.BUFFER) (if (OPENWP SPY.BUTTON) then (BITBLT SPY.CLOSED NIL NIL SPY.BUTTON)))) ) + +(SPY.MAKEGRAPHNODES + [LAMBDA (TREE THRESHOLD SPYDATA) (* ; "Edited 28-Apr-94 14:00 by sybalsky") + +(* ;;; "RETURNS NODE ID FOR TREE") + + (PROG ((LABEL (fetch (SPYRECORD NAME) of TREE)) + [COUNT (COND + ((fetch (SPYDATA CUMULATIVE) + SPYDATA) + (fetch (SPYRECORD SUM) of TREE)) + (T (fetch (SPYRECORD COUNT) of TREE] + (STATUS (fetch (SPYRECORD STATUS) of TREE)) + HEIGHT BORDER WIDTH NODEBITMAP TOOSMALL) + [SETQ BORDER (CDDR (OR (ASSOC STATUS SPY.BORDERS) + (SHOULDNT] + (push SPY.NODES (create + GRAPHNODE + NODEID _ TREE + NODELABEL _ (SPYOBJ LABEL (QUOTIENT (TIMES COUNT 100) + TOPCOUNT) + STATUS) + TONODES _ (for X in (fetch (SPYRECORD CALLEES) + of TREE) + when (OR (ZEROP THRESHOLD) + (IGEQ (SPY.MAX + (LIST X) + (NOT (fetch (SPYDATA CUMULATIVE) + SPYDATA))) + THRESHOLD)) bind VAL + do (push VAL (SPY.MAKEGRAPHNODES X THRESHOLD + SPYDATA)) + finally (RETURN VAL)) + NODEBORDER _ BORDER + NODEFONT _ SPY.FONT))) + TREE]) + +(SPY.MAX + [LAMBDA (TREES COUNTP MAX) (* ; "Edited 28-Apr-94 13:59 by sybalsky") + [for X in TREES do (SETQ MAX (SPY.MAX (fetch (SPYRECORD CALLEES) of + X) + COUNTP + (IMAX (OR MAX (IMAX)) + (if COUNTP + then (fetch (SPYRECORD COUNT) + of X) + else (fetch (SPYRECORD SUM) + of X] + MAX]) + +(SPY.MERGE + [LAMBDA (TREES SPYDATA) (* ; "Edited 28-Apr-94 14:00 by sybalsky") + [COND + (SPY.HASH (CLRHASH SPY.HASH)) + (T (SETQ SPY.HASH (HASHARRAY 100] + (if (fetch (SPYDATA DELETED) of SPYDATA) + then (SETQ TREES (SPY.DELETE (fetch (SPYDATA DELETED) of SPYDATA) + TREES))) + (for X in TREES do (SPY.SUM X)) + (for NEWNODE in TREES bind VAL Z + do [for OLDNODE in VAL when (EQ (fetch (SPYRECORD NAME) of OLDNODE) + (fetch (SPYRECORD NAME) of NEWNODE)) + do (RETURN (SPY.MERGETREE NEWNODE OLDNODE SPYDATA NIL (fetch + (SPYDATA DEPTH) + SPYDATA))) + finally (AND (SETQ Z (SPY.MERGE1 NEWNODE SPYDATA NIL NIL (fetch + (SPYDATA DEPTH) + SPYDATA))) + (SETQ VAL (NCONC1 VAL Z] finally (CLRHASH SPY.HASH) + (RETURN VAL]) + +(SPY.MERGE1 + [LAMBDA (NEWORIGINAL SPYDATA PARENTS CALLER DEPTH) (* ; "Edited 28-Apr-94 14:00 by sybalsky") + (* ; + "return the 'merged' tree for TREE, a copy of the original") + (PROG* ((NAME (fetch (SPYRECORD NAME) of NEWORIGINAL)) + [PARENT-NAME (AND PARENTS (fetch (SPYRECORD NAME) of (CAR PARENTS] + (NEW-NAME NAME) + MERGE-LIST MERGEP OLDCOPY NEWCOPY) + [SELECTQ (fetch (SPYDATA MERGETYPE) of SPYDATA) + ((NIL NONE)) + (PROGN (if (AND PARENTS (CL:SYMBOLP NAME) + (CL:SYMBOLP PARENT-NAME) + (GENSYM? NAME) + (if (CL:KEYWORDP PARENT-NAME) + then (STRPOS (LET* [(ORIG (fetch (SPYRECORD TREEFROM) + of (CAR PARENTS] + (fetch (SPYRECORD NAME) + of (if (LISTP ORIG) + then (CAR ORIG) + else ORIG))) + NAME 1 NIL T) + elseif (EQ (CL:SYMBOL-PACKAGE NAME) + (CL:SYMBOL-PACKAGE PARENT-NAME)) + then (STRPOS PARENT-NAME NAME 1 NIL T))) + then (SETQ NEW-NAME PARENT-NAME)) + (SETQ MERGE-LIST (if (LITATOM NEW-NAME) + then (SPY.MERGEINFO NEW-NAME SPYDATA PARENT-NAME)) + ) + (if MERGE-LIST + then (if (EQ (CAR MERGE-LIST) + ':ANY) + then (if PARENTS + then (SETQ NEW-NAME PARENT-NAME)) + elseif (EQ (CAR MERGE-LIST) + ':NONE) + then (SETQ MERGEP NIL) + (GO NO-MERGE) + elseif (OR (NULL PARENTS) + (NOT (FMEMB PARENT-NAME MERGE-LIST))) + then (SETQ NEW-NAME (CAR MERGE-LIST)) + else (SETQ NEW-NAME PARENT-NAME))) + (SELECTQ (fetch (SPYDATA MERGETYPE) of SPYDATA) + ((NIL NONE) + NIL) + ((RECURSIVE-ONLY) + NIL) + (T [SETQ MERGEP (OR (NOT (CL:SYMBOLP NEW-NAME)) + (AND (NOT MERGE-LIST) + (NOT (FMEMB NEW-NAME SPY.NOMERGEFNS)) + (NOT (FMEMB NEW-NAME OPENFNS)) + (NOT (STRPOS "\interpret" NEW-NAME]) + (ALL (SETQ MERGEP T)) + (SHOULDNT] + [COND + ([OR (AND MERGEP (SETQ OLDCOPY (GETHASH NEW-NAME SPY.HASH))) + (SELECTQ (fetch (SPYDATA MERGETYPE) of SPYDATA) + ((NIL NONE) + NIL) + (AND PARENTS (EQ NEW-NAME (fetch (SPYRECORD NAME) of (SETQ OLDCOPY + (CAR PARENTS] + (* ; + "mergeable, and we found one to merge into") + (* ; "show this node only as a ghost") + (SPY.MERGETREE NEWORIGINAL OLDCOPY SPYDATA PARENTS DEPTH) + (COND + ((OR (fetch (SPYDATA NOGHOSTS) of SPYDATA) + (EQ OLDCOPY (CAR PARENTS))) + (RETURN NIL)) + ([AND CALLER (SETQ NEWCOPY (find X in (fetch (SPYRECORD CALLEES) + of CALLER) + suchthat (EQ (fetch (SPYRECORD NAME) + of X) + NEW-NAME] + (SELECTQ (fetch (SPYRECORD STATUS) of NEWCOPY) + (GHOST (AND (FMEMB OLDCOPY PARENTS) + (replace (SPYRECORD STATUS) of NEWCOPY with + 'RECURSIVEGHOST))) + ((RECURSIVEGHOST ENDOFLINE)) + (HELP "spy: never seen this case before")) + (RETURN NIL)) + (T (SETQ NEWCOPY (create SPYRECORD using NEWORIGINAL CALLEES _ NIL STATUS _ + 'GHOST TREEFROM _ NEWORIGINAL)) + (AND CALLER (push (fetch (SPYRECORD CALLEES) of CALLER) + NEWCOPY)) + (RETURN NEWCOPY] + NO-MERGE + (SETQ NEWCOPY (create SPYRECORD + using NEWORIGINAL CALLEES _ NIL TREEFROM _ NEWORIGINAL NAME _ + NEW-NAME)) (* ; "create the copy") + (AND MERGEP (PUTHASH NEW-NAME NEWCOPY SPY.HASH)) (* ; "remember it if it is mergable") + (AND CALLER (push (fetch (SPYRECORD CALLEES) of CALLER) + NEWCOPY)) + (SPY.MERGE.CALLEES NEWORIGINAL NEWCOPY SPYDATA PARENTS DEPTH) + (* ; "") + (RETURN NEWCOPY]) + +(SPY.MERGETREE + [LAMBDA (NEWORIGINAL OLDCOPY SPYDATA PARENTS DEPTH) (* ; "Edited 28-Apr-94 13:59 by sybalsky") + (* ; + "insert call tree from NEWORIGINAL into node starting with OLDCOPY") + (* ; + "this function is only called once we've decided to merge something after all") + (PROG ((RECURSIVE (FMEMB OLDCOPY PARENTS))) + [COND + ((NOT RECURSIVE) + (add (fetch (SPYRECORD SUM) of OLDCOPY) + (fetch (SPYRECORD SUM) of NEWORIGINAL] + (add (fetch (SPYRECORD COUNT) of OLDCOPY) + (fetch (SPYRECORD COUNT) of NEWORIGINAL)) + [if RECURSIVE + then (SELECTQ (fetch (SPYRECORD STATUS) of OLDCOPY) + ((NORMAL SELFRECURSIVE) + (replace (SPYRECORD TREEFROM) of OLDCOPY + with (LIST (fetch (SPYRECORD TREEFROM) of OLDCOPY))) + (* ; "must be a list") + (replace (SPYRECORD STATUS) of OLDCOPY with 'RECURSIVE)) + ((RECURSIVE GHOST)) + (MERGED (replace (SPYRECORD STATUS) of OLDCOPY with + 'RECURSIVE)) + (SHOULDNT)) + else (* ; "add to TREEFROM") + (replace (SPYRECORD TREEFROM) of OLDCOPY + with (CONS NEWORIGINAL (SELECTQ (fetch (SPYRECORD STATUS) of OLDCOPY + ) + ((NORMAL SELFRECURSIVE) + (replace (SPYRECORD STATUS) of + OLDCOPY + with 'MERGED) + (LIST (fetch (SPYRECORD TREEFROM) + of OLDCOPY))) + ((MERGED RECURSIVE ENDOFLINE GHOST) + (fetch (SPYRECORD TREEFROM) of + OLDCOPY)) + (SHOULDNT] + (SPY.MERGE.CALLEES NEWORIGINAL OLDCOPY SPYDATA PARENTS DEPTH) + (RETURN T]) + +(SPY.NEXT.TREE + [LAMBDA (TREE FN) (* ; "Edited 28-Apr-94 13:59 by sybalsky") + (for X in (fetch (SPYRECORD CALLEES) of TREE) + do (COND + ((EQ (fetch (SPYRECORD NAME) of X) + FN) + (RETURN X))) finally (push (fetch (SPYRECORD CALLEES) of TREE) + (SETQ X (create SPYRECORD + NAME _ FN + COUNT _ 0))) + (RETURN X]) + +(SPY.SUM + [LAMBDA (TREE) (* ; "Edited 28-Apr-94 13:59 by sybalsky") + (replace (SPYRECORD SUM) of TREE + with (PLUS (fetch (SPYRECORD COUNT) of TREE) + (PROG1 (for X in (fetch (SPYRECORD CALLEES) of TREE) + sum (SPY.SUM X)) + [SORT (fetch (SPYRECORD CALLEES) of TREE) + (FUNCTION (LAMBDA (X Y) + (IGREATERP (fetch (SPYRECORD SUM) of X) + (fetch (SPYRECORD SUM) of Y])]) + +(SPY.TITLE [LAMBDA (X TOPCOUNT SPYDATA) (* ; "Edited 25-Sep-87 16:30 by jop") (CONCAT "SPY " (fetch (SPYRECORD NAME) of X) ", " TOPCOUNT " samples"]) + +(SPY.MAKE.TREE + [LAMBDA (TREES SPYDATA WINDOW) (* ; "Edited 28-Apr-94 13:59 by sybalsky") + (PROG (GRAPH IDS W H THRSH TOPCOUNT (*PACKAGE* (fetch (SPYDATA PACKAGE) of SPYDATA)) + (*READTABLE* (fetch (SPYDATA READTABLE) of SPYDATA)) + (*PRINT-CASE* (fetch (SPYDATA PRINT-CASE) of SPYDATA))) + (OR (FONTP SPY.FONT) + (SETQ SPY.FONT (FONTCREATE SPY.FONT))) + (SETQ TOPCOUNT (for X in TREES sum (fetch (SPYRECORD SUM) of X))) + (SETQ THRSH (QUOTIENT (TIMES TOPCOUNT (fetch (SPYDATA THRESHOLD) of SPYDATA)) + 100)) + (SETQ SPY.NODES) + (SETQ SPY.TOPNODES (for X in TREES collect (SPY.MAKEGRAPHNODES X THRSH + SPYDATA))) + (SETQ TITLE (SPY.TITLE (CAR SPY.TOPNODES) + TOPCOUNT SPYDATA)) + (SETQ SPY.WINDOW (SHOWGRAPH (LAYOUTGRAPH (REVERSE SPY.NODES) + SPY.TOPNODES NIL SPY.FONT) + (COND + ((WINDOWP WINDOW) + (WINDOWPROP WINDOW 'TITLE TITLE) + WINDOW) + (T TITLE)) + NIL NIL NIL NIL (FUNCTION SPY.COPYBUTTON))) + (WINDOWPROP SPY.WINDOW 'ICON SPY.ICON) + (WINDOWPROP SPY.WINDOW 'BUTTONEVENTFN (FUNCTION SPY.GRAPH.EDITOR)) + (WINDOWPROP SPY.WINDOW 'RIGHTBUTTONFN (FUNCTION SPY.UPDATE.TITLE)) + (WINDOWPROP SPY.WINDOW 'SPYDATA SPYDATA) + (WINDOWPROP SPY.WINDOW 'TREES TREES) + (WINDOWPROP SPY.WINDOW 'SPYTITLE TITLE) + (WINDOWPROP SPY.WINDOW 'TOPCOUNT TOPCOUNT]) + +(SPY.UPDATE.TITLE + [LAMBDA (W) (* ; "Edited 29-Apr-94 14:03 by sybalsky") + (LET [(NODE (NODELST/AS/MENU (fetch (GRAPH GRAPHNODES) of (WINDOWPROP W 'GRAPH)) + (CONS (LASTMOUSEX W) + (LASTMOUSEY W] + (TOTOPW W) + (COND + ((NOT (INSIDE? (DSPCLIPPINGREGION NIL W) + (LASTMOUSEX W) + (LASTMOUSEY W))) + + (* ;; " display the default window menu") + + (DOWINDOWCOM W)) + (T [if NODE + then + + (* ;; +" change the window title to show the function name, and the individual and cumulative percentages ") + + (WINDOWPROP W 'TITLE (CONCAT (fetch (SPYRECORD NAME) + of (fetch (GRAPHNODE NODEID) + of NODE)) + " " + (QUOTIENT (TIMES (fetch (SPYRECORD COUNT) + of (fetch + (GRAPHNODE NODEID) + of NODE)) + 100) + (WINDOWPROP W 'TOPCOUNT)) + "%% " + (QUOTIENT (TIMES (fetch (SPYRECORD SUM) + of (fetch + (GRAPHNODE NODEID) + of NODE)) + 100) + (WINDOWPROP W 'TOPCOUNT)) + "%%")) + else + + (* ;; + "change the window title to show the top function name and total number of samples") + + (WINDOWPROP W 'TITLE (WINDOWPROP W 'SPYTITLE] + (UNTILMOUSESTATE UP]) + +(SPY.DELETE + [LAMBDA (NAMES TREES) (* ; "Edited 28-Apr-94 13:59 by sybalsky") + (for X in TREES when (NOT (EQMEMB (fetch (SPYRECORD NAME) of X) + NAMES)) + collect (create SPYRECORD using X CALLEES _ (SPY.DELETE NAMES + (fetch (SPYRECORD CALLEES) + of X]) + +(SPY.DRAWBOX (LAMBDA (WIDTH HEIGHT BORDERWIDTH BITMAP TEXTURE) (* ; "Edited 9-Sep-87 17:54 by Masinter") (BITBLT NIL NIL NIL BITMAP 0 0 BORDERWIDTH HEIGHT (QUOTE TEXTURE) (QUOTE PAINT) TEXTURE) (BITBLT NIL NIL NIL BITMAP 0 0 WIDTH BORDERWIDTH (QUOTE TEXTURE) (QUOTE PAINT) TEXTURE) (BITBLT NIL NIL NIL BITMAP 0 (DIFFERENCE HEIGHT BORDERWIDTH) WIDTH BORDERWIDTH (QUOTE TEXTURE) (QUOTE PAINT) TEXTURE) (BITBLT NIL NIL NIL BITMAP (DIFFERENCE WIDTH BORDERWIDTH) 0 BORDERWIDTH HEIGHT (QUOTE TEXTURE) (QUOTE PAINT) TEXTURE)) ) + +(SPY.BUFFER.ENTRY (LAMBDA (N) (* ; "Edited 9-Sep-87 18:27 by Masinter") (COND (SPY.POINTERS (AND (ILEQ (SETQ N (LLSH N 1)) SPY.BUFFER.SIZE) (\GETBASEPTR SPY.BUFFER N))) ((ILEQ N SPY.BUFFER.SIZE) (\VAG2 0 (\GETBASE SPY.BUFFER N))))) ) + +(SPY.BUTTON (LAMBDA (POS) (* gbn " 2-Jun-85 13:12") (PROG ((REG (if POS then (CREATEREGION (fetch XCOORD of POS) (fetch YCOORD of POS) (WIDTHIFWINDOW (BITMAPWIDTH SPY.CLOSED)) (HEIGHTIFWINDOW (BITMAPHEIGHT SPY.CLOSED))) else (GETBOXREGION (WIDTHIFWINDOW (BITMAPWIDTH SPY.CLOSED)) (HEIGHTIFWINDOW (BITMAPHEIGHT SPY.CLOSED)) NIL NIL NIL "Specify region for window %"Spy Control%"")))) (BITBLT SPY.CLOSED NIL NIL (SETQ SPY.BUTTON (CREATEW REG NIL NIL T))) (WINDOWPROP SPY.BUTTON (QUOTE BUTTONEVENTFN) (FUNCTION (LAMBDA (W) (AND (LASTMOUSESTATE UP) (SPY.TOGGLE))))))) ) + +(SPY.END.ENTRY (LAMBDA NIL (* ejs%: "27-APR-84 11:37") (SPY.ADD.ENTRY NIL))) + +(SPY.START (LAMBDA (FILE) (* lmm "24-Oct-84 22:49") (if (OPENWP SPY.BUTTON) then (BITBLT SPY.OPEN NIL NIL SPY.BUTTON)) (* ejs%: "27-APR-84 11:37") (SPY.INIT FILE) (SETQ \PERIODIC.INTERRUPT.FREQUENCY (QUOTIENT 60 SPY.FREQUENCY)) (SETQ \PERIODIC.INTERRUPT (QUOTE \SPY.INTERRUPT))) ) + +(SPY.INIT (LAMBDA NIL (* ; "Edited 9-Sep-87 23:47 by Masinter") (OR SPY.BUFFER (SETQ SPY.BUFFER (\ALLOCBLOCK (CL:* SPY.BUFFER.SIZE 2)))) (SETQ SPY.BUFFER.THRESHOLD (QUOTIENT SPY.BUFFER.SIZE 2)) (SETQ SPY.NEXT 0) (SETQ SPY.TREE)) ) + +(\SPY.INTERRUPT (LAMBDA NIL (* ; "Edited 9-Sep-87 18:32 by Masinter") (SETQ \PERIODIC.INTERRUPT) (* ; "turn off sampling while gathering sample") (PROG ((FRAME (fetch (FX CLINK) (\MYALINK)))) (COND ((IGEQ (if SPY.POINTERS then (LLSH SPY.NEXT 1) else SPY.NEXT) SPY.BUFFER.THRESHOLD) (COND (\INTERRUPTABLE (SPY.DUMP.BUFFER)) (T (* ; "this sample might overflow; just don't do it") (RETURN))))) (SPY.START.ENTRY) SAMPLELOOP (SPY.ADD.ENTRY (fetch (FX FRAMENAME) FRAME)) (COND ((NOT (fetch (FX INVALIDP) (SETQ FRAME (fetch (FX CLINK) FRAME)))) (GO SAMPLELOOP)) (T (SPY.END.ENTRY)))) (SETQ \PERIODIC.INTERRUPT (QUOTE \SPY.INTERRUPT))) ) + +(SPY.DUMP.BUFFER + [LAMBDA NIL (* ; "Edited 28-Apr-94 14:00 by sybalsky") + (bind (I _ 0) + NEXTI while (ILESSP I SPY.NEXT) + do (bind [J _ (SETQ NEXTI (for K from I by 1 while (SPY.BUFFER.ENTRY + K) + finally (RETURN K] + TREE + (NAME _ "NO SUCH NAME") first [SETQ TREE (SPY.FIND.TREE + (SPY.BUFFER.ENTRY (add + J -1] + while (IGREATERP J I) do [COND + ([NEQ NAME (SETQ NAME (SPY.BUFFER.ENTRY + (add J -1] + (SETQ TREE (SPY.NEXT.TREE TREE NAME))) + (T (replace (SPYRECORD STATUS) of TREE + with 'SELFRECURSIVE] + finally (add (fetch (SPYRECORD COUNT) of TREE) + 1)) + (SETQ I (ADD1 NEXTI))) + (SETQ SPY.NEXT 0]) + +(SPY.START.ENTRY (LAMBDA NIL (* ejs%: "27-APR-84 11:37") (* do nothing at the start of the entry, do this at the end) NIL) ) + +(SPY.ADD.ENTRY (LAMBDA (NAME) (* ; "Edited 9-Sep-87 18:29 by Masinter") (COND (SPY.POINTERS (\PUTBASEPTR SPY.BUFFER (LLSH SPY.NEXT 1) NAME) (COND ((IGEQ (LLSH (add SPY.NEXT 1) 1) SPY.BUFFER.SIZE) (SPY.OVERFLOW)))) (T (OR (LITATOM NAME) (SETQ NAME (QUOTE *FORM*))) (\PUTBASE SPY.BUFFER SPY.NEXT (\LOLOC NAME)) (COND ((IGEQ (add SPY.NEXT 1) SPY.BUFFER.SIZE) (SPY.OVERFLOW)))))) ) + +(SPY.ORIGINAL + [LAMBDA (TREES) (* ; "Edited 28-Apr-94 14:00 by sybalsky") + (for X in TREES join (SELECTQ (fetch (SPYRECORD STATUS) of X) + ((RECURSIVE MERGED ENDOFLINE) + (APPEND (OR (LISTP (fetch (SPYRECORD TREEFROM) + of X)) + (SHOULDNT)))) + ((NORMAL GHOST RECURSIVEGHOST SELFRECURSIVE) + (LIST (OR (fetch (SPYRECORD TREEFROM) of X) + X))) + (SHOULDNT]) + +(SPY.OVERFLOW (LAMBDA NIL (* ejs%: "27-APR-84 11:37") (add SPY.NEXT -1) (SETQ SPY.OVERFLOWED T))) + +(SPY.MERGE.CALLEES + [LAMBDA (NEWORIGINAL OLDCOPY SPYDATA PARENTS DEPTH) (* ; "Edited 28-Apr-94 14:00 by sybalsky") + (* ; + "insert copies of the CALLEEs of NEWORIGINAL into OLDTREE's CALLEEs") + (for ORIGCALLEE in (fetch (SPYRECORD CALLEES) of NEWORIGINAL) + do (for COPYCALLEE in (fetch (SPYRECORD CALLEES) of OLDCOPY) + when (EQ (fetch (SPYRECORD NAME) of COPYCALLEE) + (fetch (SPYRECORD NAME) of ORIGCALLEE)) + do (* ; + "found a 'callee' that can merge this one with") + [RETURN (if (EQ (fetch (SPYRECORD STATUS) of COPYCALLEE) + 'ENDOFLINE) + then (push (fetch (SPYRECORD TREEFROM) of + COPYCALLEE + ) + ORIGCALLEE) + else (SPY.MERGETREE + ORIGCALLEE + (SELECTQ (fetch (SPYRECORD STATUS) of COPYCALLEE) + ((NORMAL RECURSIVE SELFRECURSIVE MERGED) + COPYCALLEE) + ((GHOST RECURSIVEGHOST) + (OR (GETHASH (fetch (SPYRECORD NAME) + of ORIGCALLEE) + SPY.HASH) + COPYCALLEE)) + (SHOULDNT)) + SPYDATA + (CONS OLDCOPY PARENTS) + (AND DEPTH (SUB1 DEPTH] + finally (* ; "no old node of same name found") + (if (AND DEPTH (ILEQ DEPTH 0)) + then (push (fetch (SPYRECORD CALLEES) of OLDCOPY) + (create SPYRECORD using ORIGCALLEE CALLEES _ NIL + STATUS _ 'ENDOFLINE TREEFROM _ + (LIST NEWORIGINAL))) + else (SPY.MERGE1 ORIGCALLEE SPYDATA (CONS OLDCOPY PARENTS) + OLDCOPY + (AND DEPTH (SUB1 DEPTH]) + +(SPY.PRINT [LAMBDA (X FILE RDTBL) (* ; "Edited 25-Sep-87 16:32 by jop") (LIST (CONCAT "spy:" (if (LISTP (fetch (SPYRECORD NAME) of X)) then "*form*" else (fetch (SPYRECORD NAME) of X]) +) + +(RPAQ? SPY.BUTTON ) + +(RPAQQ SPY.OPEN #*(56 59)@@@@@@@@@@@@@@@@GLOLLC@@@@@@@@@@LFLFLC@@@@@@@@@@LFLFFF@@@@@@@@@@O@LFFF@@GLOL@@@@GLLFCL@@LFLF@@@@ANOLAH@@LFLF@@@@LFL@AH@@LFLF@@@@LFL@AH@@LFLF@@@@LFL@AH@@LFLF@@@@GLL@AH@@GLLF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@IEGOOJ@@@@J@@HJ@@BOONHH@@BA@@@@HKOOOFNJHA@D@@HHBGOKNOEB@@@B@@@EDOMMBIGNJH@I@@@HBONJMEEKE@HA@@ECONMJB@KOOJCE@@@KOOJJHEAONHDJ@@KONJD@@@@AONIE@@GOMJH@@@BMOJEB@@FOB@@D@B@@AOEM@@GODDHA@@@AENMG@@KLH@@D@@@@BONM@@GM@HB@@@@BEFKG@@JJDBH@@@@@@INM@@ODA@DDD@@@BEOG@@@KJOMKB@@@AEEK@@JJEBNLIB@@DEOG@@DKNOKONHDDABFI@@BBKFOOMD@AAEFM@@IEIABEEOD@@@JJ@@EFLJKKGEB@EFEB@@J@@BOOHNHD@AEE@@EEEDONKEJ@EEBJ@@H@IOOOOOIEB@HD@@MDDOOOOMDHIEBJ@@BAOKOOOGONNJ@A@@HBKGOOOOOJKHBE@@DHLKMGMGOONJ@I@@@EMBOOJOOOKHBD@@BKDEOOJAOONJ@B@@BKIBOOHEOOOH@D@@HNDAONJBOJDDAA@@BO@DMGDEGOEB@A@@A@DBFJ@BL@@@@D@@@E@ICMAEOJDH@A@@B@@D@ADI@@@@BD@@HDA@JDBEFHH@@A@@@@@H@IDID@@B@D@@AA@A@@@B@A@@AA@@@@@D@@B@J@@A@A@@@@@H@@@D@@@@@J@@@A@@@D@AB@@@BA@@@@@@@@E@@@@@@D@@HH@@@B@@@@@@@B@@ +) + +(RPAQQ SPY.CLOSED #*(56 59)@@@@@@@@@@@@@@@@GLOLLC@@@@CHND@@LFLFLC@@@@FAHA@@LFLFFF@@@@FAH@@@O@LFFF@@GLOKNA@@GLLFCL@@LFFAH@@@ANOLAH@@LFFAHA@@LFL@AH@@LFFAH@@@LFL@AH@@LFFAHJ@@LFL@AH@@LFFAH@@@GLL@AH@@GLFAHB@@@@@@@@@@@@@@@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@@IEGOOJ@@@@J@@HJ@@BOONHH@@BA@@@@HKOOOFNJHA@D@@HHBGOKNOEB@@@B@@@EDOMMBIGNJH@I@@@HBONJMEEKE@HA@@ECONMJB@KOOBCE@@@KOOJJHEAOOHDJ@@KONJD@@@@AONIE@@GOMJH@@@BMOJEB@@FOB@@D@B@@AOEM@@GODDHA@@@AENMG@@KLH@@D@@@@BONM@@GM@HB@@@@BEFKG@@JJDBH@@@@@@INM@@ODA@DDD@@@BEOG@@@KJOMKB@@@AEEK@@JJEBNLIB@@DEOG@@DKNOKONHDDABFI@@BBKFOOOD@AAEFM@@IEIABEGND@@@JJ@@EFLLDGGGB@EFEB@@J@@@@@IOHD@AEE@@EEAAEA@FI@EEBJ@@H@HDL@EAME@@HD@@MDEB@NHDJHDABJ@@BAB@@ABICF@J@A@@HB@KDDI@BLI@BE@@DID@A@@JHKDJ@I@@@D@DDDE@EBKEBD@@BAD@@@@A@OED@B@@BHAAAAA@CGNH@D@@H@D@@@@@MOE@AA@@BK@DDDDDGOJJ@A@@B@DA@B@CODFBBD@@EE@HBIAENK@@@A@@BLHBDDDON@@@BD@@KGDHJJIGJHB@@A@@BOBBECGOLB@B@D@@AAMLMKGOH@@@AA@@@GGONNON@H@A@A@@@IKKKKOLJ@@@@J@@@DFOKOO@D@@@BA@@@AEGMMD@A@@@@D@@HHBJMBLA@@@@@B@@ +) + +(DEFGLOBALVAR SPY.POINTERS T) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS SPY.OVERFLOWED \PERIODIC.INTERRUPT SPY.TREE SPY.BUFFER.SIZE SPY.NEXT SPY.BUFFER.THRESHOLD + SPY.BUFFER SPY.FREQUENCY SPY.SHOW.THRESHOLD SPY.MAXLINES SPY.FONT) +) +(DECLARE%: EVAL@COMPILE + +[PUTPROPS WITH-SPY MACRO ((FORM) + (PROGN (SPY.START) + (PROG1 FORM (SPY.END] + +[PUTPROPS WITH.SPY MACRO ((FORM) + (PROGN (SPY.START) + (PROG1 FORM (SPY.END] +) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(DATATYPE SPYRECORD (NAME COUNT SUM CALLEES STATUS TREEFROM) + STATUS _ 'NORMAL (INIT (DEFPRINT 'SPYRECORD 'SPY.PRINT))) + +(PROPRECORD SPYDATA (DELETED CUMULATIVE MERGETYPE THRESHOLD SPYMENU DEPTH NOGHOSTS PACKAGE + READTABLE PRINT-CASE MERGEINFO PENDING) + CUMULATIVE _ T) +) + +(/DECLAREDATATYPE 'SPYRECORD '(POINTER POINTER POINTER POINTER POINTER POINTER) + '((SPYRECORD 0 POINTER) + (SPYRECORD 2 POINTER) + (SPYRECORD 4 POINTER) + (SPYRECORD 6 POINTER) + (SPYRECORD 8 POINTER) + (SPYRECORD 10 POINTER)) + '12) + +(DEFPRINT 'SPYRECORD 'SPY.PRINT) +) + +(/DECLAREDATATYPE 'SPYRECORD '(POINTER POINTER POINTER POINTER POINTER POINTER) + '((SPYRECORD 0 POINTER) + (SPYRECORD 2 POINTER) + (SPYRECORD 4 POINTER) + (SPYRECORD 6 POINTER) + (SPYRECORD 8 POINTER) + (SPYRECORD 10 POINTER)) + '12) + +(DEFPRINT 'SPYRECORD 'SPY.PRINT) +(DECLARE%: DOCOPY DOEVAL@COMPILE + +(FILESLOAD GRAPHER READNUMBER IMAGEOBJ) +) +(PUTPROPS SPY COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1987 1988 1990 1991 1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (5474 8081 (SPYOBJ 5484 . 5773) (SPYOBJ.BUTTON 5775 . 5885) (SPYOBJ.SAVE 5887 . 6006) ( +SPYOBJ.COPY 6008 . 6070) (SPYOBJ.GET 6072 . 6201) (SPYOBJ.IMAGEBOX 6203 . 6727) (SPYOBJ.DISPLAY 6729 + . 7028) (SPYOBJ.LABEL 7030 . 7166) (SPYOBJ.HEIGHT 7168 . 7381) (SPYOBJ.COPYIN 7383 . 7426) ( +SPY.COPYBUTTON 7428 . 7520) (SPY.MERGEINFO 7522 . 8079)) (19431 60601 (SPY.FIND.TREE 19441 . 19850) ( +SPY.TOGGLE 19852 . 20042) (SPY.TREE 20044 . 21156) (SPY.LEGEND 21158 . 21508) (SPY.GRAPH.EDITOR 21510 + . 31075) (SPY.END 31077 . 31319) (SPY.MAKEGRAPHNODES 31321 . 33421) (SPY.MAX 33423 . 34306) ( +SPY.MERGE 34308 . 35739) (SPY.MERGE1 35741 . 42224) (SPY.MERGETREE 42226 . 45156) (SPY.NEXT.TREE 45158 + . 45832) (SPY.SUM 45834 . 46523) (SPY.TITLE 46525 . 46742) (SPY.MAKE.TREE 46744 . 48632) ( +SPY.UPDATE.TITLE 48634 . 51210) (SPY.DELETE 51212 . 51747) (SPY.DRAWBOX 51749 . 52274) ( +SPY.BUFFER.ENTRY 52276 . 52514) (SPY.BUTTON 52516 . 53085) (SPY.END.ENTRY 53087 . 53167) (SPY.START +53169 . 53453) (SPY.INIT 53455 . 53690) (\SPY.INTERRUPT 53692 . 54328) (SPY.DUMP.BUFFER 54330 . 55790) + (SPY.START.ENTRY 55792 . 55920) (SPY.ADD.ENTRY 55922 . 56304) (SPY.ORIGINAL 56306 . 57133) ( +SPY.OVERFLOW 57135 . 57236) (SPY.MERGE.CALLEES 57238 . 60274) (SPY.PRINT 60276 . 60599))))) +STOP diff --git a/library/SYSEDIT b/library/SYSEDIT new file mode 100644 index 00000000..95e0575c --- /dev/null +++ b/library/SYSEDIT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "12-Jun-90 15:31:15" {DSK}local>lde>lispcore>library>SYSEDIT.;2 1411 changes to%: (VARS SYSEDITCOMS) previous date%: " 9-Mar-87 10:53:12" {DSK}local>lde>lispcore>library>SYSEDIT.;1) (* ; " Copyright (c) 1984, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SYSEDITCOMS) (RPAQQ SYSEDITCOMS [(VARS (CLISPIFYPRETTYFLG) (MSRECORDTRANFLG T) (MSMACROPROPS COMPILERMACROPROPS) (RECOMPILEDEFAULT 'CHANGES) (CLEANUPOPTIONS '(RC F)) (GLOBALVARFLG T) (CLISPIFTRANFLG T) (CROSSCOMPILING 'ASK)) (P (RESETVARS ((CROSSCOMPILING T) (DIRECTORIES DIRECTORIES)) (FILESLOAD (SOURCE) EXPORTS.ALL]) (RPAQQ CLISPIFYPRETTYFLG NIL) (RPAQQ MSRECORDTRANFLG T) (RPAQ MSMACROPROPS COMPILERMACROPROPS) (RPAQQ RECOMPILEDEFAULT CHANGES) (RPAQQ CLEANUPOPTIONS (RC F)) (RPAQQ GLOBALVARFLG T) (RPAQQ CLISPIFTRANFLG T) (RPAQQ CROSSCOMPILING ASK) (RESETVARS ((CROSSCOMPILING T) (DIRECTORIES DIRECTORIES)) (FILESLOAD (SOURCE) EXPORTS.ALL)) (PUTPROPS SYSEDIT COPYRIGHT ("Venue & Xerox Corporation" 1984 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/library/TABLEBROWSER b/library/TABLEBROWSER new file mode 100644 index 00000000..090b2b1b --- /dev/null +++ b/library/TABLEBROWSER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 1-Dec-2018 17:25:13"  {DSK}kaplan>Local>medley3.5>lispcore>library>TABLEBROWSER.;3 57302 changes to%: (FNS TB.REDISPLAY.ITEMS) previous date%: "26-Jun-99 00:30:27" {DSK}kaplan>Local>medley3.5>lispcore>library>TABLEBROWSER.;2) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1993, 1994, 1995, 1999, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TABLEBROWSERCOMS) (RPAQQ TABLEBROWSERCOMS ((COMS (* ; "Entries") (FNS TB.MAKE.BROWSER TB.REPLACE.ITEMS) (FNS TB.DELETE.ITEM TB.UNDELETE.ITEM TB.INSERT.ITEM TB.REMOVE.ITEM TB.NORMALIZE.ITEM TB.REDISPLAY.ITEMS TB.SELECT.ITEM TB.UNSELECT.ITEM TB.UNSELECT.ALL.ITEMS) (FNS TB.NUMBER.OF.ITEMS TB.NTH.ITEM TB.COLLECT.ITEMS TB.MAP.ITEMS TB.MAP.DELETED.ITEMS TB.MAP.SELECTED.ITEMS TB.FIND.ITEM TB.ITEM.SELECTED? TB.ITEM.DELETED?) (FNS TB.CLEAR.LINE TB.USERDATA TB.WINDOW)) (COMS (* ; "Display") (FNS TB.REPAINTFN TB.RESHAPEFN TB.SCROLLFN TB.DISPLAY.LINES TB.PRINT.LINE TB.FIRST.VISIBLE.ITEM# TB.LAST.VISIBLE.ITEM# TB.ITEM.VISIBLE? TB.ITEM.FROM.YCOORD TB.BOTTOM.OF.ITEM TB.SHOW.DELETION TB.SHOW.SELECTION TB.UPDATE.DISPLAY TB.ITEM.UPDATABLE?)) (COMS (* ; "Selection") (FNS TB.BUTTONEVENTFN TB.DO.UNLESS.BUSY TB.DO.ITEM.SELECTION TB.CONTIGUOUS.SELP TB.DECONSIDERRANGE TB.CONSIDERRANGE TB.DESELECTRANGE TB.RECONSIDERRANGE TB.SELECTRANGE TB.UNDOSELECTION TB.FIND.SELECTED.ITEM TB.REV.FIND.SELECTED.ITEM) (FNS TB.COPYBUTTONEVENTFN TB.SHOW.COPY.SELECTION)) (COMS (* ; "Misc state change") (FNS TB.BROWSER.BUSY TB.CLOSE/SHRINK TB.CLOSEFN TB.FINISH.CLOSE TB.FLUSH.WINDOW TB.SET.FONT TB.SHRINKFN TB.EXPANDFN TB.FIND.PREVIOUS.TAIL TB.RENUMBER.TAIL)) (COMS (* ; "Misc") (FNS TB.PROCESS) (INITVARS (TB.DELETEDLINEHEIGHT 1)) (VARS TB.SELECTION.BITMAP) (CURSORS TB.CROSSCURSOR) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TBDECLS) (CONSTANTS * TOCSTATES) (MACROS .COPYKEYDOWNP.) (GLOBALVARS TB.CROSSCURSOR TB.SELECTION.BITMAP TB.DELETEDLINEHEIGHT) (LOCALVARS . T))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA TB.USERDATA))) (INITRECORDS TABLEBROWSER TABLEITEM) (SYSRECORDS TABLEBROWSER TABLEITEM))) (* ; "Entries") (DEFINEQ (TB.MAKE.BROWSER (LAMBDA (ITEMS WINDOWSPEC PROPS) (* ; "Edited 28-Jan-88 04:37 by bvm") (* ;;; "Build a browser window, which consists of three attached windows: the main BROWSERWINDOW, the BROWSERMENUWINDOW containing the menu, and a BROWSERPROMPTWINDOW for displaying random info") (PROG ((LINESPERITEM 1) FONT PRINTFN COPYFN CLOSEFN AFTERCLOSEFN TITLE COLUMNS USERDATA WINDOW USERPROPS BROWSER ITEMHEIGHT BASELINE HEADINGWINDOW LINETHICKNESS) (DECLARE (SPECVARS FONT PRINTFN COPYFN CLOSEFN AFTERCLOSEFN TITLE COLUMNS USERDATA LINESPERITEM ITEMHEIGHT BASELINE HEADINGWINDOW LINETHICKNESS)) (* ; "For SET below") (for TAIL on PROPS by (CDDR TAIL) do (SELECTQ (CAR TAIL) ((FONT PRINTFN COPYFN CLOSEFN AFTERCLOSEFN TITLE COLUMNS USERDATA LINESPERITEM ITEMHEIGHT BASELINE HEADINGWINDOW LINETHICKNESS) (SET (CAR TAIL) (CADR TAIL))) (push USERPROPS (LIST (CAR TAIL) (CADR TAIL))))) (SETQ WINDOW (DECODE.WINDOW.ARG WINDOWSPEC NIL NIL TITLE)) (WINDOWPROP WINDOW (QUOTE TABLEBROWSER) (SETQ BROWSER (create TABLEBROWSER TBWINDOW _ WINDOW TBFONT _ FONT TBLOCK _ (CREATE.MONITORLOCK (OR (WINDOWPROP WINDOW (QUOTE TITLE)) "Table Browser")) TB#LINESPERITEM _ (OR LINESPERITEM 1) TBBASELINE _ (OR BASELINE 0) TBCOLUMNS _ COLUMNS TBPRINTFN _ PRINTFN TBCOPYFN _ COPYFN TBCLOSEFN _ CLOSEFN TBAFTERCLOSEFN _ AFTERCLOSEFN TBUSERDATA _ USERDATA TBHEADINGWINDOW _ HEADINGWINDOW TBLINETHICKNESS _ (OR LINETHICKNESS TB.DELETEDLINEHEIGHT)))) (if ITEMHEIGHT then (* ; "User explicitly controlling height variables.") (replace (TABLEBROWSER TBITEMHEIGHT) of BROWSER with ITEMHEIGHT) (replace (TABLEBROWSER TBHEIGHTEXPLICIT) of BROWSER with T)) (DSPLEFTMARGIN TB.LEFT.MARGIN WINDOW) (TB.REPLACE.ITEMS BROWSER ITEMS) (WINDOWPROP WINDOW (QUOTE SCROLLFN) (FUNCTION TB.SCROLLFN)) (WINDOWPROP WINDOW (QUOTE REPAINTFN) (FUNCTION TB.REPAINTFN)) (WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN) (FUNCTION TB.BUTTONEVENTFN)) (WINDOWPROP WINDOW (QUOTE RIGHTBUTTONFN) (FUNCTION TB.BUTTONEVENTFN)) (WINDOWPROP WINDOW (QUOTE COPYBUTTONEVENTFN) (FUNCTION TB.COPYBUTTONEVENTFN)) (for PROP in (QUOTE (CLOSEFN SHRINKFN RESHAPEFN)) do (* ;; "This used to be (progn (windowaddprop window 'closefn (function tb.closefn)) (windowaddprop window 'shrinkfn (function tb.shrinkfn)) (windowaddprop window 'reshapefn (function tb.reshapefn))). However, we want to be careful to put our stuff on before any attached window stuff, so that we can reject a CLOSE, for example, before CLOSEATTACHEDWINDOWS has already closed them. Could always put on front, but it's probably better to put our functions after any the user might have explicitly put there already.") (LET ((OLDP (WINDOWPROP WINDOW PROP)) (FN (PACK* "TB." PROP))) (if (NULL OLDP) then (SETQ OLDP (LIST FN)) else (for TAIL on (OR (LISTP OLDP) (SETQ OLDP (LIST OLDP))) do (if (EQ (CAR TAIL) FN) then (* ; "Window already has our fn!") (RETURN) elseif (STRPOS "ATTACHED" (CAR TAIL)) then (* ; "Insert before this attached window hacker") (RETURN (ATTACH FN TAIL))) finally (* ; "Put at end") (NCONC1 OLDP FN))) (WINDOWPROP WINDOW PROP OLDP))) (replace (TABLEBROWSER TBREADY) of BROWSER with T) (RETURN BROWSER))) ) (TB.REPLACE.ITEMS (LAMBDA (BROWSER NEWITEMS) (* ; "Edited 27-Jan-88 16:27 by bvm") (* ;; "Completely replace the current items with the specified items") (LET ((N 0) FIRSTSEL) (SETQ BROWSER (\DTEST BROWSER (QUOTE TABLEBROWSER))) (for ITEM in NEWITEMS do (* ; "Number the items") (freplace TI# of (\DTEST ITEM (QUOTE TABLEITEM)) with (add N 1))) (freplace (TABLEBROWSER TBTAILHINT) of BROWSER with NIL) (freplace (TABLEBROWSER TBITEMS) of BROWSER with NEWITEMS) (freplace (TABLEBROWSER TB#ITEMS) of BROWSER with N) (freplace (TABLEBROWSER TB#DELETED) of BROWSER with (for ITEM in NEWITEMS count (ffetch TIDELETED of ITEM))) (COND ((SETQ FIRSTSEL (TB.FIND.SELECTED.ITEM BROWSER 1 N)) (freplace (TABLEBROWSER TBFIRSTSELECTEDITEM) of BROWSER with FIRSTSEL) (freplace (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER with (TB.REV.FIND.SELECTED.ITEM BROWSER FIRSTSEL N))) (T (freplace (TABLEBROWSER TBFIRSTSELECTEDITEM) of BROWSER with (ADD1 N)) (freplace (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER with 0))) (TB.SET.FONT BROWSER) (LET ((REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of BROWSER)))) (TB.DISPLAY.LINES BROWSER (TB.FIRST.VISIBLE.ITEM# BROWSER REGION) (TB.LAST.VISIBLE.ITEM# BROWSER REGION))))) ) ) (DEFINEQ (TB.DELETE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:08 by bvm") (COND ((NOT (ffetch (TABLEITEM TIDELETED) of (\DTEST ITEM (QUOTE TABLEITEM)))) (freplace (TABLEITEM TIDELETED) of ITEM with T) (add (ffetch (TABLEBROWSER TB#DELETED) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) 1) (if (TB.ITEM.UPDATABLE? BROWSER ITEM T) then (TB.SHOW.DELETION BROWSER ITEM (ffetch (TABLEBROWSER TBWINDOW) of BROWSER) (QUOTE REPLACE)))))) ) (TB.UNDELETE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:08 by bvm") (COND ((ffetch (TABLEITEM TIDELETED) of (\DTEST ITEM (QUOTE TABLEITEM))) (freplace (TABLEITEM TIDELETED) of ITEM with NIL) (add (ffetch (TABLEBROWSER TB#DELETED) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) -1) (COND ((TB.ITEM.UPDATABLE? BROWSER ITEM T) (LET ((WINDOW (ffetch (TABLEBROWSER TBWINDOW) of BROWSER))) (TB.SHOW.DELETION BROWSER ITEM WINDOW (QUOTE ERASE)) (* ; "reprint the line sans deletion mark") (TB.PRINT.LINE BROWSER ITEM WINDOW (ffetch (TABLEBROWSER TBPRINTFN) of BROWSER)))))))) ) (TB.INSERT.ITEM (LAMBDA (BROWSER NEWITEM BEFOREITEM) (* ; "Edited 27-Jan-88 16:08 by bvm") (* ;;; "Inserts NEWITEM in TABLEBROWSER before item BEFOREITEM or at the end if BEFOREITEM is NIL") (LET ((LASTITEM# (ffetch (TABLEBROWSER TB#ITEMS) of (SETQ BROWSER (\DTEST BROWSER (QUOTE TABLEBROWSER))))) BEFORE# TAIL N) (SETQ NEWITEM (\DTEST NEWITEM (QUOTE TABLEITEM))) (if BEFOREITEM then (SETQ BEFORE# (OR (FIXP BEFOREITEM) (ffetch TI# of (\DTEST BEFOREITEM (QUOTE TABLEITEM))))) (COND ((OR (> BEFORE# LASTITEM#) (< BEFORE# 1)) (* ; "Check for bad values") (\ILLEGAL.ARG BEFOREITEM))) else (SETQ BEFORE# (ADD1 LASTITEM#))) (PROGN (* ;; "Need to change the following if TBITEMS representation changes") (if (EQ BEFORE# 1) then (* ; "Goes at the beginning (or at the end of a null list)") (freplace (TABLEBROWSER TBITEMS) of BROWSER with (SETQ TAIL (CONS NEWITEM (ffetch (TABLEBROWSER TBITEMS) of BROWSER)))) else (* ; "Somewhere else--find the tail") (SETQ TAIL (if (NULL BEFOREITEM) then (* ; "Insert at end") (FLAST (OR (ffetch (TABLEBROWSER TBTAILHINT) of BROWSER) (ffetch (TABLEBROWSER TBITEMS) of BROWSER))) else (TB.FIND.PREVIOUS.TAIL BROWSER BEFORE#))) (RPLACD TAIL (SETQ TAIL (CONS NEWITEM (CDR TAIL))))) (* ;; "Now (CAR TAIL) is the new item") (TB.RENUMBER.TAIL BROWSER TAIL BEFORE#)) (freplace (TABLEBROWSER TB#ITEMS) of BROWSER with (ADD1 LASTITEM#)) (COND ((ffetch TIDELETED of NEWITEM) (add (ffetch (TABLEBROWSER TB#DELETED) of BROWSER) 1))) (* ;; "Update first & last selected item if they fall after the insertion, or if the new item is selected") (COND ((>= (SETQ N (ffetch TBFIRSTSELECTEDITEM of BROWSER)) BEFORE#) (freplace TBFIRSTSELECTEDITEM of BROWSER with (COND ((ffetch TISELECTED of NEWITEM) BEFORE#) (T (ADD1 N)))))) (COND ((>= (SETQ N (ffetch TBLASTSELECTEDITEM of BROWSER)) BEFORE#) (freplace TBLASTSELECTEDITEM of BROWSER with (ADD1 N))) ((ffetch TISELECTED of NEWITEM) (freplace TBLASTSELECTEDITEM of BROWSER with BEFORE#))) (TB.UPDATE.DISPLAY BROWSER BEFORE# (QUOTE INSERT)))) ) (TB.REMOVE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:09 by bvm") (* ;;; "Removes ITEM from TABLEBROWSER") (LET ((LASTITEM# (fetch (TABLEBROWSER TB#ITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) (ITEM# (ffetch TI# of (\DTEST ITEM (QUOTE TABLEITEM)))) N TAIL) (PROGN (* ;; "Need to change the following if TBITEMS representation changes") (COND ((EQ ITEM# 1) (freplace (TABLEBROWSER TBITEMS) of BROWSER with (SETQ TAIL (CDR (ffetch (TABLEBROWSER TBITEMS) of BROWSER))))) (T (RPLACD (SETQ TAIL (TB.FIND.PREVIOUS.TAIL BROWSER ITEM#)) (SETQ TAIL (CDDR TAIL))))) (TB.RENUMBER.TAIL BROWSER TAIL ITEM#)) (freplace (TABLEBROWSER TB#ITEMS) of BROWSER with (SUB1 LASTITEM#)) (COND ((ffetch TIDELETED of ITEM) (add (ffetch (TABLEBROWSER TB#DELETED) of BROWSER) -1))) (* ;; "Update first & last selected item if they fall after the deletion or if the old item is selected") (COND ((>= (SETQ N (ffetch TBFIRSTSELECTEDITEM of BROWSER)) ITEM#) (freplace TBFIRSTSELECTEDITEM of BROWSER with (COND ((EQ N ITEM#) (* ; "removed item was the first selected, so look for next one after it") (OR (TB.FIND.SELECTED.ITEM BROWSER ITEM#) LASTITEM#)) (T (* ; "Item numbers are decremented") (SUB1 N)))))) (COND ((>= (SETQ N (ffetch TBLASTSELECTEDITEM of BROWSER)) ITEM#) (freplace TBLASTSELECTEDITEM of BROWSER with (COND ((EQ N ITEM#) (* ; "removed item was the last selected, so look for next one before it") (OR (TB.REV.FIND.SELECTED.ITEM BROWSER NIL (SUB1 ITEM#)) 0)) (T (SUB1 N)))))) (TB.UPDATE.DISPLAY BROWSER ITEM# (QUOTE REMOVE)))) ) (TB.NORMALIZE.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 22-Jan-88 16:22 by bvm") (* ;; "Scroll, if necessary, so that ITEM is visible in browser.") (LET* ((WINDOW (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) (BOT (TB.BOTTOM.OF.ITEM BROWSER ITEM)) (CLIP (DSPCLIPPINGREGION NIL WINDOW))) (COND ((OR (> (fetch (REGION BOTTOM) of CLIP) BOT) (< (fetch (REGION PTOP) of CLIP) (+ BOT (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))) (* ; "Scroll so that item's midline is at midline of window") (SCROLLBYREPAINTFN WINDOW 0 (- (+ (fetch (REGION BOTTOM) of CLIP) (IQUOTIENT (fetch (REGION HEIGHT) of CLIP) 2)) (+ BOT (IQUOTIENT (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) 2)))))))) ) (TB.REDISPLAY.ITEMS [LAMBDA (BROWSER FIRSTITEM LASTITEM) (* ; "Edited 1-Dec-2018 17:25 by rmk:") (* ; "Edited 2-Feb-88 11:53 by bvm:") (* ;; "Force redisplay of all items from FIRSTITEM to LASTITEM, e.g., because their content or format changed. We'll only redisplay the visible ones, of course. Also, if browser isn't open, we'll save the change until browser is expanded") (LET [(REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER 'TABLEBROWSER] (if (AND (NULL FIRSTITEM) (NULL LASTITEM)) then (* ; "We're being told to redisplay the whole browser, so recompute the extent while we're at it (it might have gotten smaller).") (replace (TABLEBROWSER TBMAXXPOS) of BROWSER with 0)) (SETQ FIRSTITEM (IMAX [COND ((NULL FIRSTITEM) 1) ((FIXP FIRSTITEM)) (T (ffetch TI# of (\DTEST FIRSTITEM 'TABLEITEM] (TB.FIRST.VISIBLE.ITEM# BROWSER REGION))) (SETQ LASTITEM (IMIN [COND ((NULL LASTITEM) (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER)) ((FIXP LASTITEM)) (T (ffetch TI# of (\DTEST LASTITEM 'TABLEITEM] (TB.LAST.VISIBLE.ITEM# BROWSER REGION))) (if (AND (>= LASTITEM FIRSTITEM) (TB.ITEM.UPDATABLE? BROWSER FIRSTITEM)) then (* ;; "RMK: For whatever reason, on an FB recompute, this gets called after the items have first been displayed but not in proper alignment. This redisplays them to get the alignment, but the window is garbled if the old stuff isn't cleared first. So, added the CLEARW") (CLEARW (ffetch (TABLEBROWSER TBWINDOW) of BROWSER)) (TB.DISPLAY.LINES BROWSER FIRSTITEM LASTITEM]) (TB.SELECT.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:08 by bvm") (LET ((N (ffetch (TABLEITEM TI#) of (\DTEST ITEM (QUOTE TABLEITEM))))) (TB.SELECTRANGE (\DTEST BROWSER (QUOTE TABLEBROWSER)) N N T) (if (TB.ITEM.UPDATABLE? BROWSER N T) then (TB.SHOW.SELECTION BROWSER N (QUOTE REPLACE))))) ) (TB.UNSELECT.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 29-Jan-88 12:09 by bvm") (if (ffetch (TABLEITEM TISELECTED) of (\DTEST ITEM (QUOTE TABLEITEM))) then (LET ((N (ffetch (TABLEITEM TI#) of ITEM))) (TB.DESELECTRANGE (\DTEST BROWSER (QUOTE TABLEBROWSER)) N N) (if (TB.ITEM.UPDATABLE? BROWSER N T) then (TB.SHOW.SELECTION BROWSER N (QUOTE ERASE)))))) ) (TB.UNSELECT.ALL.ITEMS (LAMBDA (BROWSER) (* ; "Edited 29-Jan-88 12:14 by bvm") (* ;; "User entry for unselecting all items in the browser. ") (LET ((START (ffetch (TABLEBROWSER TBFIRSTSELECTEDITEM) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) (END (ffetch (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER))) (if (<= START END) then (for I from START to END bind (UPDATABLE _ (TB.ITEM.UPDATABLE? BROWSER START)) ITEM when (ffetch (TABLEITEM TISELECTED) of (SETQ ITEM (TB.NTH.ITEM BROWSER I))) do (freplace TISELECTED of ITEM with NIL) (if UPDATABLE then (TB.SHOW.SELECTION BROWSER I (QUOTE ERASE)))) (freplace TBFIRSTSELECTEDITEM of BROWSER with (ADD1 (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER))) (freplace TBLASTSELECTEDITEM of BROWSER with 0)))) ) ) (DEFINEQ (TB.NUMBER.OF.ITEMS (LAMBDA (BROWSER TYPE) (* ; "Edited 27-Jan-88 16:16 by bvm") (SETQ BROWSER (\DTEST BROWSER (QUOTE TABLEBROWSER))) (SELECTQ TYPE (NIL (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER)) (DELETED (ffetch (TABLEBROWSER TB#DELETED) of BROWSER)) (SELECTED (for I from (ffetch (TABLEBROWSER TBFIRSTSELECTEDITEM) of BROWSER) to (ffetch (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER) count (ffetch (TABLEITEM TISELECTED) of (TB.NTH.ITEM BROWSER I)))) (\ILLEGAL.ARG TYPE))) ) (TB.NTH.ITEM (LAMBDA (BROWSER N) (* ; "Edited 27-Jan-88 16:18 by bvm") (* ;; "Return the Nth item of BROWSER, or NIL if N is out of range.") (* ;; "Browser items are currently stored as a simple list. To make most accesses reasonable, we save a hint to a recent tail of the list to speed up the search.") (\DTEST BROWSER (QUOTE TABLEBROWSER)) (LET (TAIL TAILN) (if (AND (> N 0) (OR (AND (SETQ TAIL (ffetch (TABLEBROWSER TBTAILHINT) of BROWSER)) (>= N (SETQ TAILN (ffetch (TABLEITEM TI#) of (CAR TAIL))))) (PROG1 (SETQ TAIL (ffetch (TABLEBROWSER TBITEMS) of BROWSER)) (* ; "Item is not in hint tail, have to search whole list") (SETQ TAILN 1)))) then (while (< TAILN N) do (if (NULL (SETQ TAIL (CDR TAIL))) then (* ; "Greater than last item. I could have done a comparison against #items, but it is rare to ask for this (and we never do internally).") (RETURN NIL)) (add TAILN 1) finally (freplace (TABLEBROWSER TBTAILHINT) of BROWSER with TAIL) (* ; "Store away the new hint. This makes ascending iterations constant time, rather than n^2.") (RETURN (CAR TAIL)))))) ) (TB.COLLECT.ITEMS (LAMBDA (BROWSER PREDFN) (* ; "Edited 27-Jan-88 16:18 by bvm") (SELECTQ PREDFN (DELETED (SETQ PREDFN (FUNCTION TB.ITEM.DELETED?))) (SELECTED (SETQ PREDFN (FUNCTION TB.ITEM.SELECTED?))) NIL) (for ITEM in (ffetch (TABLEBROWSER TBITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) collect ITEM when (OR (NULL PREDFN) (CL:FUNCALL PREDFN BROWSER ITEM)))) ) (TB.MAP.ITEMS (LAMBDA (BROWSER MAPFN NULLFN) (* ; "Edited 27-Jan-88 16:18 by bvm") (* ;;; "Apply MAPFN to each item in TABLEBROWSER -- args (TABLEBROWSER ITEM)") (LET ((ITEMS (ffetch (TABLEBROWSER TBITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER))))) (COND (ITEMS (for ITEM in ITEMS do (CL:FUNCALL MAPFN BROWSER ITEM))) (NULLFN (CL:FUNCALL NULLFN BROWSER))))) ) (TB.MAP.DELETED.ITEMS (LAMBDA (BROWSER MAPFN NULLFN) (* ; "Edited 27-Jan-88 16:18 by bvm") (* ;;; "Apply MAPFN to each deleted item in TABLEBROWSER -- args (TABLEBROWSER ITEM)") (COND ((NEQ (ffetch TB#DELETED of (\DTEST BROWSER (QUOTE TABLEBROWSER))) 0) (for ITEM in (ffetch (TABLEBROWSER TBITEMS) of BROWSER) when (ffetch TIDELETED of ITEM) do (CL:FUNCALL MAPFN BROWSER ITEM))) (NULLFN (* ; "Nothing deleted") (CL:FUNCALL NULLFN BROWSER)))) ) (TB.MAP.SELECTED.ITEMS (LAMBDA (BROWSER MAPFN NULLFN) (* ; "Edited 27-Jan-88 16:19 by bvm") (* ;;; "Apply MAPFN to each selected item in TABLEBROWSER -- args (TABLEBROWSER ITEM)") (LET ((ITEM# (SUB1 (ffetch (TABLEBROWSER TBFIRSTSELECTEDITEM) of (\DTEST BROWSER (QUOTE TABLEBROWSER))))) (LASTITEM# (ffetch (TABLEBROWSER TBLASTSELECTEDITEM) of BROWSER)) ITEM) (COND ((< ITEM# LASTITEM#) (until (> (add ITEM# 1) LASTITEM#) when (ffetch (TABLEITEM TISELECTED) of (SETQ ITEM (TB.NTH.ITEM BROWSER ITEM#))) do (CL:FUNCALL MAPFN BROWSER ITEM))) (NULLFN (* ; "Nothing selected") (CL:FUNCALL NULLFN BROWSER))))) ) (TB.FIND.ITEM (LAMBDA (BROWSER PREDFN FIRST# LAST# BACKWARDSFLG) (* ; "Edited 27-Jan-88 16:20 by bvm") (* ;;; "Returns the first item in the designated range satisfying (PREDFN browser item); range defaults to whole browser") (\DTEST BROWSER (QUOTE TABLEBROWSER)) (LET ((LO (COND (FIRST# (IMAX FIRST# 1)) (T 1))) (HI (COND (LAST# (IMIN LAST# (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER))) (T (ffetch (TABLEBROWSER TB#ITEMS) of BROWSER)))) I END INCREMENT ITEM) (COND ((<= LO HI) (COND (BACKWARDSFLG (SETQ I (ADD1 HI)) (SETQ END LO) (SETQ INCREMENT -1)) (T (SETQ I (SUB1 LO)) (SETQ END HI) (SETQ INCREMENT 1))) (SELECTQ PREDFN (DELETED (SETQ PREDFN (FUNCTION TB.ITEM.DELETED?))) (SELECTED (SETQ PREDFN (FUNCTION TB.ITEM.SELECTED?))) NIL) (when (CL:FUNCALL PREDFN BROWSER (SETQ ITEM (TB.NTH.ITEM BROWSER (add I INCREMENT)))) do (RETURN ITEM) repeatuntil (EQ I END)))))) ) (TB.ITEM.SELECTED? (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:20 by bvm") (ffetch TISELECTED of (\DTEST ITEM (QUOTE TABLEITEM)))) ) (TB.ITEM.DELETED? (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:20 by bvm") (ffetch TIDELETED of (\DTEST ITEM (QUOTE TABLEITEM)))) ) ) (DEFINEQ (TB.CLEAR.LINE (LAMBDA (BROWSER ITEM LEFT WIDTH) (* ; "Edited 22-Jan-88 16:06 by bvm") (* ;;; "Clears the contents of ITEM's line starting at xpos LEFT for width WIDTH. Defaults to whole line") (BLTSHADE WHITESHADE (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (OR LEFT 0) (TB.BOTTOM.OF.ITEM BROWSER ITEM) WIDTH (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) (QUOTE REPLACE))) ) (TB.USERDATA (CL:LAMBDA (BROWSER &OPTIONAL (NEWDATA NIL NEWP)) (* ; "Edited 27-Jan-88 16:25 by bvm") (PROG1 (ffetch (TABLEBROWSER TBUSERDATA) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (COND (NEWP (freplace (TABLEBROWSER TBUSERDATA) of BROWSER with NEWDATA))))) ) (TB.WINDOW (LAMBDA (BROWSER) (* ; "Edited 27-Jan-88 16:25 by bvm") (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER)))) ) ) (* ; "Display") (DEFINEQ (TB.REPAINTFN (LAMBDA (WINDOW REGION) (* bvm%: "10-Sep-85 13:00") (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER)))) (AND (NEQ (fetch (TABLEBROWSER TB#ITEMS) of BROWSER) 0) (RESETLST (COND ((OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T) (TB.DISPLAY.LINES BROWSER (TB.FIRST.VISIBLE.ITEM# BROWSER REGION) (TB.LAST.VISIBLE.ITEM# BROWSER REGION))) (T (TB.BROWSER.BUSY BROWSER))))))) ) (TB.RESHAPEFN (LAMBDA (WINDOW OLDIMAGEBM OLDREGION) (* ; "Edited 22-Jan-88 10:21 by bvm") (RESETLST (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) (REGION (DSPCLIPPINGREGION NIL WINDOW)) ITEM#) (COND ((NOT (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T)) (* ; "Browser is busy, have to wait until it is ready. But don't tie up mouse!") (ALLOW.BUTTON.EVENTS) (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) NIL T)) ((NOT (fetch (TABLEBROWSER TBREADY) of BROWSER)) (* ; "Browser not functional") (RETURN (RESHAPEBYREPAINTFN WINDOW OLDIMAGEBM OLDREGION)))) (SETQ ITEM# (TB.FIRST.VISIBLE.ITEM# BROWSER REGION)) (TB.SET.FONT BROWSER) (WYOFFSET (TIMES (SUB1 ITEM#) (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)) WINDOW) (TB.DISPLAY.LINES BROWSER ITEM# (TB.LAST.VISIBLE.ITEM# BROWSER REGION))))) ) (TB.SCROLLFN (LAMBDA (WINDOW DX DY CONTINUOUSFLG) (* ; "Edited 22-Jan-88 17:32 by bvm") (* ;; "only scroll if can get the monitor lock") (RESETLST (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) HW) (COND ((OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T) (SCROLLBYREPAINTFN WINDOW DX DY CONTINUOUSFLG) (if (AND (EQ DY 0) (SETQ HW (fetch (TABLEBROWSER TBHEADINGWINDOW) of BROWSER))) then (* ; "Horizontally scroll the header window together with it.") (SCROLLW HW DX DY CONTINUOUSFLG))) (T (TB.BROWSER.BUSY BROWSER)))))) ) (TB.DISPLAY.LINES (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 25-Jan-88 18:34 by bvm") (for ITEM# from (IMAX FIRST# 1) to (IMIN LAST# (fetch (TABLEBROWSER TB#ITEMS) of BROWSER)) bind (WINDOW _ (fetch (TABLEBROWSER TBWINDOW) of BROWSER)) (MAXXPOS _ (fetch (TABLEBROWSER TBMAXXPOS) of BROWSER)) (PRINTFN _ (fetch (TABLEBROWSER TBPRINTFN) of BROWSER)) EXTENTCHANGED ITEM HERE EXTENT HWINDOW do (SETQ ITEM (TB.NTH.ITEM BROWSER ITEM#)) (TB.PRINT.LINE BROWSER ITEM WINDOW PRINTFN) (* ; "keep track of maximum width printed to, so window's EXTENT is always right") (COND ((< MAXXPOS (SETQ HERE (DSPXPOSITION NIL WINDOW))) (SETQ MAXXPOS HERE) (SETQ EXTENTCHANGED T))) finally (COND (EXTENTCHANGED (replace (TABLEBROWSER TBMAXXPOS) of BROWSER with MAXXPOS) (replace (REGION WIDTH) of (SETQ EXTENT (fetch (TABLEBROWSER TBEXTENT) of BROWSER)) with MAXXPOS) (WINDOWPROP WINDOW (QUOTE EXTENT) EXTENT) (if (SETQ HWINDOW (fetch (TABLEBROWSER TBHEADINGWINDOW) of BROWSER)) then (* ; "Update heading window extent, too. Width has to account for the difference, if any, in borders.") (replace (REGION WIDTH) of (SETQ EXTENT (WINDOWPROP HWINDOW (QUOTE EXTENT))) with (+ MAXXPOS (TIMES 2 (- (WINDOWPROP WINDOW (QUOTE BORDER)) (WINDOWPROP HWINDOW (QUOTE BORDER))))))))))) ) (TB.PRINT.LINE (LAMBDA (BROWSER ITEM WINDOW PRINTFN) (* ; "Edited 22-Jan-88 17:16 by bvm") (MOVETO TB.LEFT.MARGIN (+ (TB.BOTTOM.OF.ITEM BROWSER ITEM) (fetch (TABLEBROWSER TBBASELINE) of BROWSER)) WINDOW) (* ; "Move to item's baseline") (POSITION WINDOW 0) (CL:FUNCALL PRINTFN BROWSER ITEM WINDOW) (TB.SHOW.SELECTION BROWSER ITEM (COND ((fetch (TABLEITEM TISELECTED) of ITEM) (QUOTE REPLACE)) (T (QUOTE ERASE)))) (COND ((fetch (TABLEITEM TIDELETED) of ITEM) (TB.SHOW.DELETION BROWSER ITEM WINDOW (QUOTE REPLACE))))) ) (TB.FIRST.VISIBLE.ITEM# (LAMBDA (BROWSER REGION) (* ; "Edited 22-Jan-88 16:59 by bvm") (* ;; "Computes number of the first item in TABLEBROWSER that is visible in REGION") (IMAX 1 (ADD1 (IQUOTIENT (- (ffetch (TABLEBROWSER TBORIGIN) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (fetch (REGION PTOP) of (OR REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of BROWSER))))) (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER))))) ) (TB.LAST.VISIBLE.ITEM# (LAMBDA (BROWSER REGION) (* ; "Edited 22-Jan-88 17:00 by bvm") (* ;; "Computes number of the last item in TABLEBROWSER that is visible in REGION") (IMIN (ffetch (TABLEBROWSER TB#ITEMS) of (\DTEST BROWSER (QUOTE TABLEBROWSER))) (CL:CEILING (- (ffetch (TABLEBROWSER TBORIGIN) of BROWSER) (fetch (REGION BOTTOM) of (OR REGION (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of BROWSER))))) (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))) ) (TB.ITEM.VISIBLE? (LAMBDA (BROWSER ITEM) (* ; "Edited 22-Jan-88 16:12 by bvm") (* ;;; "True if any part of ITEM is visible in window of BROWSER") (LET ((CLIP (DSPCLIPPINGREGION NIL (ffetch (TABLEBROWSER TBWINDOW) of (\DTEST BROWSER (QUOTE TABLEBROWSER))))) (BOT (TB.BOTTOM.OF.ITEM BROWSER ITEM))) (* ;; "Check bottom of line is below top, and top of line is above the bottom") (AND (< BOT (fetch (REGION PTOP) of CLIP)) (< (fetch (REGION BOTTOM) of CLIP) (+ BOT (ffetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))))) ) (TB.ITEM.FROM.YCOORD (LAMBDA (BROWSER YPOS) (* ; "Edited 22-Jan-88 16:41 by bvm") (LET ((N (CL:CEILING (- (fetch (TABLEBROWSER TBORIGIN) of BROWSER) YPOS) (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)))) (TB.NTH.ITEM BROWSER (COND ((<= N 0) 1) (T (IMIN N (fetch (TABLEBROWSER TB#ITEMS) of BROWSER))))))) ) (TB.BOTTOM.OF.ITEM (LAMBDA (BROWSER ITEM) (* ; "Edited 27-Jan-88 16:11 by bvm") (* ;; "Returns the y position of the bottom of specified item (number or tableitem). Add the font descent to get the baseline of the first line.") (- (fetch (TABLEBROWSER TBORIGIN) of BROWSER) (TIMES (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) (OR (FIXP ITEM) (ffetch (TABLEITEM TI#) of (\DTEST ITEM (QUOTE TABLEITEM))))))) ) (TB.SHOW.DELETION (LAMBDA (BROWSER ITEM WINDOW OPERATION) (* ; "Edited 27-Jan-88 17:00 by bvm") (* ;;; "Draws or erases, for OPERATION = REPLACE or ERASE, the line indicating that ITEM is deleted") (LET ((THICKNESS (fetch (TABLEBROWSER TBLINETHICKNESS) of BROWSER)) (BASELINE (fetch (TABLEBROWSER TBBASELINE) of BROWSER))) (BLTSHADE BLACKSHADE WINDOW TB.LEFT.MARGIN (PROGN (* ;; "Center the deletion line between the baseline and the top of the item") (+ (SUB1 BASELINE) (IQUOTIENT (- (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) BASELINE THICKNESS) 2) (TB.BOTTOM.OF.ITEM BROWSER ITEM))) NIL THICKNESS OPERATION))) ) (TB.SHOW.SELECTION (LAMBDA (BROWSER ITEM OPERATION) (* ; "Edited 27-Jan-88 15:42 by bvm") (* ;;; "Displays or erases, per OPERATION = REPLACE or ERASE, the mark indicating that ITEM is selected") (LET ((BASELINE (fetch (TABLEBROWSER TBBASELINE) of BROWSER)) (BM TB.SELECTION.BITMAP)) (BITBLT BM 0 0 (fetch (TABLEBROWSER TBWINDOW) of BROWSER) 0 (PROGN (* ;; "Center the selection bitmap between the baseline and the top of the item, rounding down slightly on the grounds that the top pixel of the line tends to be blank, so the center of gravity is lower than it might be.") (+ (SUB1 BASELINE) (IQUOTIENT (- (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER) BASELINE (fetch BITMAPHEIGHT of BM)) 2) (TB.BOTTOM.OF.ITEM BROWSER ITEM))) NIL NIL (QUOTE INPUT) OPERATION))) ) (TB.UPDATE.DISPLAY (LAMBDA (BROWSER FROMITEM# TYPE) (* ; "Edited 11-Feb-88 11:34 by bvm") (* ;;; "Updates the display window appropriately after a TYPE operation (REMOVE or INSERT) on TABLEBROWSER that affects items starting at FROMITEM#") (PROG ((WINDOW (fetch (TABLEBROWSER TBWINDOW) of BROWSER)) (EXTENT (fetch (TABLEBROWSER TBEXTENT) of BROWSER)) (LASTITEM# (fetch (TABLEBROWSER TB#ITEMS) of BROWSER)) (ITEMHEIGHT (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER)) (ITEMBOTTOM (TB.BOTTOM.OF.ITEM BROWSER FROMITEM#)) DELTA HEIGHT LAST# CLIP WBOTTOM EXTENTBOTTOM) (* ; "YPOS is the bottom of the line corresponding to FROMITEM#") (add (fetch (REGION HEIGHT) of EXTENT) (SETQ DELTA (SELECTQ TYPE (REMOVE (- ITEMHEIGHT)) (INSERT ITEMHEIGHT) (SHOULDNT)))) (SETQ CLIP (DSPCLIPPINGREGION NIL WINDOW)) (COND ((>= ITEMBOTTOM (fetch (REGION PTOP) of CLIP)) (* ; "Changed item above top of window, so no visible change -- just cheat the origin appropriately") (add (fetch (TABLEBROWSER TBORIGIN) of BROWSER) DELTA)) (T (* ; "Changed item visible or below bottom of window, so bottom of extent changes") (replace (REGION BOTTOM) of EXTENT with (SETQ EXTENTBOTTOM (- (fetch (REGION BOTTOM) of EXTENT) DELTA))) (COND ((<= (+ ITEMBOTTOM ITEMHEIGHT) (SETQ WBOTTOM (fetch (REGION BOTTOM) of CLIP))) (* ; "Below bottom of window, so we're done")) ((TB.ITEM.UPDATABLE? BROWSER FROMITEM#) (* ; "If window is visible, update it now") (SELECTQ TYPE (INSERT (* ; "Push everything from line FROMITEM# down one line, then redisplay item FROMITEM#") (BITBLT WINDOW 0 (+ WBOTTOM ITEMHEIGHT) WINDOW 0 WBOTTOM NIL (- ITEMBOTTOM WBOTTOM) (QUOTE INPUT) (QUOTE REPLACE)) (TB.DISPLAY.LINES BROWSER FROMITEM# FROMITEM#)) (REMOVE (* ; "Pull everything below line FROMITEM# up one line, then redisplay last visible item(s)") (BITBLT WINDOW 0 WBOTTOM WINDOW 0 (+ WBOTTOM ITEMHEIGHT) NIL (- ITEMBOTTOM WBOTTOM) (QUOTE INPUT) (QUOTE REPLACE)) (TB.DISPLAY.LINES BROWSER (SETQ LAST# (+ FROMITEM# (IQUOTIENT (- ITEMBOTTOM WBOTTOM) ITEMHEIGHT))) (ADD1 LAST#)) (* ; "May have to display two lines if the bottom line of window was a half line") (COND ((> EXTENTBOTTOM WBOTTOM) (* ; "Clear everything below the extent") (BLTSHADE WHITESHADE WINDOW 0 WBOTTOM NIL (- EXTENTBOTTOM WBOTTOM) (QUOTE REPLACE))))) (SHOULDNT)))))))) ) (TB.ITEM.UPDATABLE? (LAMBDA (BROWSER ITEM ONLYIFVISIBLE) (* ; "Edited 29-Jan-88 12:08 by bvm") (* ;;; "True if window of BROWSER is open. If false, we update the TBUPDATEFROMHERE field, denoting that we should repaint window when it is opened. If ONLYIFVISIBLE is true, we do nothing and return NIL if the item is not currently visible.") (OR (FIXP ITEM) (SETQ ITEM (fetch TI# of ITEM))) (COND ((AND ONLYIFVISIBLE (NOT (TB.ITEM.VISIBLE? BROWSER ITEM))) (* ; "Item not visible, so no need to change display") NIL) ((OPENWP (fetch (TABLEBROWSER TBWINDOW) of BROWSER))) (T (LET ((OLDN (fetch (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER))) (COND ((OR (NULL OLDN) (< ITEM OLDN)) (* ; "Mark browser for display update after being unshrunk") (replace (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER with ITEM)))) NIL))) ) ) (* ; "Selection") (DEFINEQ (TB.BUTTONEVENTFN (LAMBDA (WINDOW) (* bvm%: " 6-Sep-85 15:23") (TOTOPW WINDOW) (LET (FN) (COND ((INSIDEP (DSPCLIPPINGREGION NIL WINDOW) (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (TB.DO.UNLESS.BUSY WINDOW (FUNCTION TB.DO.ITEM.SELECTION))) ((LASTMOUSESTATE (ONLY RIGHT)) (DOWINDOWCOM WINDOW)) ((AND (LASTMOUSESTATE (ONLY MIDDLE)) (SETQ FN (fetch (TABLEBROWSER TBTITLEEVENTFN) of (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))))) (TB.DO.UNLESS.BUSY WINDOW FN))))) ) (TB.DO.UNLESS.BUSY (LAMBDA (WINDOW FN) (* ; "Edited 20-Jan-88 23:30 by bvm") (RESETLST (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER)))) (COND ((AND (fetch (TABLEBROWSER TBREADY) of BROWSER) (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T)) (CL:FUNCALL FN WINDOW BROWSER)))))) ) (TB.DO.ITEM.SELECTION (LAMBDA (WINDOW) (* ; "Edited 20-Jan-88 22:17 by bvm") (DECLARE (GLOBALVARS LASTMOUSEBUTTONS) (SPECVARS SELECTIONSTATE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) SELECTIONREGION FIRST# LAST# FIRSTVISIBLE# LASTVISIBLE# SELECTIONSTATE NEWSELECTION OLDSELECTION SEL# OLDSEL# CTRLDOWN OLDLASTMOUSEBUTTONS ITEM LASTX LASTY) (COND ((EQ (fetch (TABLEBROWSER TB#ITEMS) of BROWSER) 0) (* ; "Nothing to select") (RETURN))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) (SETQ LAST# (fetch TBLASTSELECTEDITEM of BROWSER)) (SETQ FIRST# (fetch TBFIRSTSELECTEDITEM of BROWSER)) (SETQ FIRSTVISIBLE# (TB.FIRST.VISIBLE.ITEM# BROWSER SELECTIONREGION)) (SETQ LASTVISIBLE# (TB.LAST.VISIBLE.ITEM# BROWSER SELECTIONREGION)) (* ;; "keep looping until all mouse buttons are up") (do (GETMOUSESTATE) (COND ((NOT (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW)))) (* ;; "I would like to just return here and let the next window take over, but current mouse arrangement means I'll never get control back unless user lets up on mouse") (COND ((NEQ SELECTIONSTATE TS.IDLE) (TB.UNDOSELECTION) (* ; "Forget what we were doing") (SETQ OLDSELECTION))) (COND ((LASTMOUSESTATE UP) (RETURN)) (T (BLOCK)))) ((LASTMOUSESTATE UP) (* ; "Make selection permanent") (AND OLDSELECTION (SETQ OLDSEL# (fetch TI# of OLDSELECTION))) (SELECTC SELECTIONSTATE (TS.REPLACING (for I from FIRST# to LAST# do (replace TISELECTED of (TB.NTH.ITEM BROWSER I) with NIL)) (replace TISELECTED of OLDSELECTION with T) (replace TBFIRSTSELECTEDITEM of BROWSER with (replace TBLASTSELECTEDITEM of BROWSER with OLDSEL#))) (TS.ADDING (TB.SELECTRANGE BROWSER OLDSEL# OLDSEL# T)) (TS.REMOVING (TB.DESELECTRANGE BROWSER OLDSEL# OLDSEL#)) (TS.EXTENDING.HI (TB.SELECTRANGE BROWSER (ADD1 LAST#) OLDSEL# CTRLDOWN)) (TS.EXTENDING.LO (TB.SELECTRANGE BROWSER OLDSEL# (SUB1 FIRST#) CTRLDOWN)) (TS.SHRINKING.HI (TB.DESELECTRANGE BROWSER (ADD1 OLDSEL#) LAST#)) (TS.SHRINKING.LO (TB.DESELECTRANGE BROWSER FIRST# (SUB1 OLDSEL#))) NIL) (RETURN)) ((AND NIL (* ; "In a special column")) (COND ((NEQ SELECTIONSTATE TS.IDLE) (TB.UNDOSELECTION) (SETQ OLDSELECTION)))) ((OR (NEQ (SETQ NEWSELECTION (TB.ITEM.FROM.YCOORD BROWSER LASTY)) OLDSELECTION) (NEQ LASTMOUSEBUTTONS OLDLASTMOUSEBUTTONS)) (* ; "Something changed") (COND ((AND (fetch TIUNSELECTABLE of NEWSELECTION) (NOT (LASTMOUSESTATE RIGHT))) (* ; "Can't select that item, so revert to idle") (COND ((NEQ SELECTIONSTATE TS.IDLE) (TB.UNDOSELECTION)))) ((AND (LASTMOUSESTATE (OR LEFT MIDDLE)) (SHIFTDOWNP (QUOTE CTRL))) (* ; "Deselect this item") (SELECTC SELECTIONSTATE (TS.REMOVING (* ; "we were deselecting, so reselect that guy") (TB.SHOW.SELECTION BROWSER OLDSELECTION (QUOTE REPLACE))) (TS.IDLE (* ; "nothing going on")) (TB.UNDOSELECTION)) (SETQ SELECTIONSTATE (COND ((fetch TISELECTED of NEWSELECTION) (TB.SHOW.SELECTION BROWSER NEWSELECTION (QUOTE ERASE)) TS.REMOVING) (T TS.IDLE)))) ((LASTMOUSESTATE LEFT) (* ; "Set (change) the selection to this single item") (COND ((EQ SELECTIONSTATE TS.REPLACING) (TB.SHOW.SELECTION BROWSER OLDSELECTION (QUOTE ERASE))) (T (TB.DECONSIDERRANGE FIRSTVISIBLE# LASTVISIBLE#) (SETQ SELECTIONSTATE TS.REPLACING))) (TB.SHOW.SELECTION BROWSER NEWSELECTION (QUOTE REPLACE))) ((LASTMOUSESTATE MIDDLE) (* ; "Add this item to the selection") (SELECTC SELECTIONSTATE (TS.ADDING (TB.SHOW.SELECTION BROWSER OLDSELECTION (QUOTE ERASE))) (TS.IDLE) (TB.UNDOSELECTION)) (SETQ SELECTIONSTATE (COND ((NOT (fetch TISELECTED of NEWSELECTION)) (TB.SHOW.SELECTION BROWSER NEWSELECTION (QUOTE REPLACE)) TS.ADDING) (T TS.IDLE)))) ((LASTMOUSESTATE RIGHT) (* ; "Extend: either up or down, or shrink a selection. This is messy") (SETQ SEL# (fetch TI# of NEWSELECTION)) (SETQ OLDSEL# (AND OLDSELECTION (fetch TI# of OLDSELECTION))) (SELECTC SELECTIONSTATE (TS.EXTENDING.HI (COND ((> SEL# OLDSEL#) (* ; "Extend further") (TB.CONSIDERRANGE (ADD1 OLDSEL#) SEL# CTRLDOWN)) (T (* ; "Shrinking back") (TB.RECONSIDERRANGE (ADD1 (COND ((> SEL# LAST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) LAST#))) OLDSEL#)))) (TS.EXTENDING.LO (COND ((< SEL# OLDSEL#) (* ; "Extend further") (TB.CONSIDERRANGE SEL# (SUB1 OLDSEL#) CTRLDOWN)) (T (* ; "Shrinking back") (TB.RECONSIDERRANGE OLDSEL# (SUB1 (COND ((< SEL# FIRST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) FIRST#))))))) (TS.SHRINKING.HI (COND ((>= SEL# OLDSEL#) (* ; "Shrinking less") (TB.RECONSIDERRANGE (ADD1 OLDSEL#) (COND ((< SEL# LAST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) LAST#)))) ((>= SEL# FIRST#) (* ; "Shrinking further") (TB.DECONSIDERRANGE (ADD1 SEL#) OLDSEL#)) (T (* ; "Too far to shrink") (TB.RECONSIDERRANGE FIRST# LAST#) (SETQ SELECTIONSTATE TS.IDLE)))) (TS.SHRINKING.LO (COND ((<= SEL# OLDSEL#) (* ; "Shrinking less") (TB.RECONSIDERRANGE (COND ((> SEL# FIRST#) SEL#) (T (SETQ SELECTIONSTATE TS.IDLE) FIRST#)) (SUB1 OLDSEL#))) ((<= SEL# LAST#) (* ; "Shrinking further") (TB.DECONSIDERRANGE OLDSEL# (SUB1 SEL#))) (T (* ; "Too far to shrink") (TB.RECONSIDERRANGE FIRST# LAST#) (SETQ SELECTIONSTATE TS.IDLE)))) (COND ((<= FIRST# LAST#) (* ; "Something is already selected, so we can think about extending.") (COND ((NEQ SELECTIONSTATE TS.IDLE) (* ; "Cancel any selection we were thinking about") (TB.UNDOSELECTION))) (SETQ CTRLDOWN (SHIFTDOWNP (QUOTE CTRL))) (SETQ SELECTIONSTATE (COND ((> SEL# LAST#) (TB.CONSIDERRANGE (ADD1 LAST#) SEL# CTRLDOWN) TS.EXTENDING.HI) ((< SEL# FIRST#) (TB.CONSIDERRANGE SEL# (SUB1 FIRST#) CTRLDOWN) TS.EXTENDING.LO) ((> SEL# (LRSH (+ LAST# FIRST#) 1)) (* ; "we are closer to the high end, but inside. Shrink from the top, but only if we are pointing at a contigous selection") (if (TB.CONTIGUOUS.SELP BROWSER SEL# (SUB1 LAST#)) then (TB.DECONSIDERRANGE (ADD1 SEL#) LAST#) TS.SHRINKING.HI else TS.IDLE)) (T (* ; "We are closer to the low end, so shrink from bottom") (if (TB.CONTIGUOUS.SELP BROWSER (ADD1 FIRST#) SEL#) then (TB.DECONSIDERRANGE FIRST# (SUB1 SEL#)) TS.SHRINKING.LO else TS.IDLE))))))))) (SETQ OLDLASTMOUSEBUTTONS LASTMOUSEBUTTONS) (SETQ OLDSELECTION NEWSELECTION)))))) ) (TB.CONTIGUOUS.SELP (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:16 by bvm") (* ;; "true if all the elements of ITEMS from FIRST# to LAST# are selected (or deleted or unselectable)") (for I from FIRST# to LAST# bind ITEM always (OR (fetch TISELECTED of (SETQ ITEM (TB.NTH.ITEM BROWSER I))) (fetch TIDELETED of ITEM) (fetch TIUNSELECTABLE of ITEM)))) ) (TB.DECONSIDERRANGE (LAMBDA (FIRST# LAST#) (* ; "Edited 20-Jan-88 22:08 by bvm") (* ;;; "Change display so that items from FIRST# to LAST# are marked as unselected.") (DECLARE (USEDFREE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (for I from (IMAX FIRST# FIRSTVISIBLE#) to (IMIN LAST# LASTVISIBLE#) do (TB.SHOW.SELECTION BROWSER (TB.NTH.ITEM BROWSER I) (QUOTE ERASE)))) ) (TB.CONSIDERRANGE (LAMBDA (FIRST# LAST# EVENIFDELETED) (* ; "Edited 20-Jan-88 22:08 by bvm") (* ;;; "Change display so that items from FIRST# to LAST# are marked as selected. Deleted items are not selected unless EVENIFDELETED is true") (DECLARE (USEDFREE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (for I from (IMAX FIRST# FIRSTVISIBLE#) to (IMIN LAST# LASTVISIBLE#) bind ITEM do (SETQ ITEM (TB.NTH.ITEM BROWSER I)) (COND ((AND (NOT (fetch TIUNSELECTABLE of ITEM)) (OR EVENIFDELETED (NOT (fetch TIDELETED of ITEM)))) (TB.SHOW.SELECTION BROWSER ITEM (QUOTE REPLACE)))))) ) (TB.DESELECTRANGE (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:09 by bvm") (* ;;; "Mark internally items FIRST# thru LAST# as unselected. Keeps TBFIRSTSELECTEDITEM and TBLASTSELECTEDITEM up to date. Assumes display has already been appropriately modified--use TB.UNSELECT.ALL.ITEMS to do both") (LET ((FIRSTSEL (fetch TBFIRSTSELECTEDITEM of BROWSER)) (LASTSEL (fetch TBLASTSELECTEDITEM of BROWSER))) (if (< FIRST# FIRSTSEL) then (SETQ FIRST# FIRSTSEL)) (if (> LAST# LASTSEL) then (SETQ LAST# LASTSEL)) (if (<= FIRST# LAST#) then (for I from FIRST# to LAST# do (replace TISELECTED of (TB.NTH.ITEM BROWSER I) with NIL)) (COND ((EQ FIRST# FIRSTSEL) (replace TBFIRSTSELECTEDITEM of BROWSER with (COND ((TB.FIND.SELECTED.ITEM BROWSER (ADD1 LAST#) LASTSEL)) (T (replace TBLASTSELECTEDITEM of BROWSER with 0) (* ; "Null selection indicated by first GT last.") (ADD1 (fetch (TABLEBROWSER TB#ITEMS) of BROWSER)))))) ((EQ LAST# LASTSEL) (replace TBLASTSELECTEDITEM of BROWSER with (OR (TB.REV.FIND.SELECTED.ITEM BROWSER FIRSTSEL (SUB1 FIRST#)) 1))))))) ) (TB.RECONSIDERRANGE (LAMBDA (FIRST# LAST#) (* ; "Edited 20-Jan-88 22:09 by bvm") (* ;;; "Change display so that messages from FIRST# to LAST# are marked as selected or unselected according to the truth of the matter.") (DECLARE (USEDFREE BROWSER FIRSTVISIBLE# LASTVISIBLE#)) (for I from (IMAX FIRST# FIRSTVISIBLE#) to (IMIN LAST# LASTVISIBLE#) bind ITEM do (TB.SHOW.SELECTION BROWSER (SETQ ITEM (TB.NTH.ITEM BROWSER I)) (COND ((fetch TISELECTED of ITEM) (QUOTE REPLACE)) (T (QUOTE ERASE)))))) ) (TB.SELECTRANGE (LAMBDA (BROWSER FIRST# LAST# EVENIFDELETED) (* ; "Edited 20-Jan-88 22:10 by bvm") (* ;;; "Mark internally items FIRST# thru LAST# as selected. Do not select deleted messages unless EVENIFDELETED is true. Keeps TBFIRSTSELECTEDITEM and TBLASTSELECTEDITEM up to date. Assumes display has already been appropriately modified") (PROG ((FIRSTSEL (fetch TBFIRSTSELECTEDITEM of BROWSER)) (LASTSEL (fetch TBLASTSELECTEDITEM of BROWSER)) ITEM) (for I from FIRST# to LAST# do (SETQ ITEM (TB.NTH.ITEM BROWSER I)) (COND ((AND (NOT (fetch TIUNSELECTABLE of ITEM)) (OR EVENIFDELETED (NOT (fetch TIDELETED of ITEM)))) (replace TISELECTED of ITEM with T)))) (COND ((OR (> FIRSTSEL LASTSEL) (< FIRST# (fetch TBFIRSTSELECTEDITEM of BROWSER))) (replace TBFIRSTSELECTEDITEM of BROWSER with FIRST#))) (COND ((OR (> FIRSTSEL LASTSEL) (> LAST# (fetch TBLASTSELECTEDITEM of BROWSER))) (replace TBLASTSELECTEDITEM of BROWSER with LAST#))))) ) (TB.UNDOSELECTION (LAMBDA NIL (* bvm%: " 6-Sep-85 15:04") (* ;;; "Restore browser to state before any selections were attempted") (DECLARE (USEDFREE FIRSTVISIBLE# LASTVISIBLE# SELECTIONSTATE)) (TB.RECONSIDERRANGE FIRSTVISIBLE# LASTVISIBLE#) (SETQ SELECTIONSTATE TS.IDLE)) ) (TB.FIND.SELECTED.ITEM (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:11 by bvm") (find I from (OR FIRST# 1) to (OR LAST# (fetch TB#ITEMS of BROWSER)) suchthat (fetch TISELECTED of (TB.NTH.ITEM BROWSER I)))) ) (TB.REV.FIND.SELECTED.ITEM (LAMBDA (BROWSER FIRST# LAST#) (* ; "Edited 20-Jan-88 22:11 by bvm") (find I from (OR LAST# (fetch TB#ITEMS of BROWSER)) to (OR FIRST# 1) by -1 suchthat (fetch TISELECTED of (TB.NTH.ITEM BROWSER I)))) ) ) (DEFINEQ (TB.COPYBUTTONEVENTFN (LAMBDA (WINDOW) (* ; "Edited 22-Jan-88 12:08 by bvm") (* ;;; "copy select an item from the window.") (PROG ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) SELECTIONREGION COPYFN CURRENTITEM NEWITEM LASTX LASTY) (COND ((OR (NULL (SETQ COPYFN (fetch (TABLEBROWSER TBCOPYFN) of BROWSER))) (NULL (fetch (TABLEBROWSER TBITEMS) of BROWSER))) (RETURN (TOTOPW WINDOW)))) (SETQ SELECTIONREGION (DSPCLIPPINGREGION NIL WINDOW)) LP (TOTOPW WINDOW) (COND ((AND (SETQ NEWITEM (AND (INSIDEP SELECTIONREGION (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW))) (TB.ITEM.FROM.YCOORD BROWSER LASTY))) (fetch TIUNCOPYSELECTABLE of NEWITEM)) (SETQ NEWITEM NIL))) (COND ((NEQ CURRENTITEM NEWITEM) (COND (CURRENTITEM (* ; "turn off old selection.") (TB.SHOW.COPY.SELECTION BROWSER CURRENTITEM))) (COND ((SETQ CURRENTITEM NEWITEM) (TB.SHOW.COPY.SELECTION BROWSER CURRENTITEM))))) (* ; "wait for a button up or move out of region") LP2 (BLOCK) (COND ((NOT (.COPYKEYDOWNP.)) (* ; "Finished, copy selected item") (COND (CURRENTITEM (TB.SHOW.COPY.SELECTION BROWSER CURRENTITEM) (CL:FUNCALL COPYFN BROWSER CURRENTITEM))) (RETURN)) ((MOUSESTATE UP) (* ; "button up, no action") (GO LP2)) (T (GO LP))))) ) (TB.SHOW.COPY.SELECTION (LAMBDA (BROWSER ITEM) (* ; "Edited 22-Jan-88 16:38 by bvm") (* ;;; "underline this item in browser") (BLTSHADE GRAYSHADE (fetch (TABLEBROWSER TBWINDOW) of BROWSER) TB.LEFT.MARGIN (TB.BOTTOM.OF.ITEM BROWSER ITEM) NIL 2 (QUOTE INVERT))) ) ) (* ; "Misc state change") (DEFINEQ (TB.BROWSER.BUSY (LAMBDA (BROWSER) (* bvm%: " 8-Sep-85 16:42") (RESETFORM (CURSOR TB.CROSSCURSOR) (BLOCK 1000)))) (TB.CLOSE/SHRINK (LAMBDA (WINDOW FLG) (* ; "Edited 20-Jan-88 23:36 by bvm") (RESETLST (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER))) HOW?) (COND ((OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of BROWSER) T T) (COND ((AND (SETQ HOW? (fetch (TABLEBROWSER TBCLOSEFN) of BROWSER)) (SETQ HOW? (CL:FUNCALL HOW? BROWSER WINDOW FLG))) (COND ((NEQ HOW? (QUOTE DON'T)) (TB.PROCESS (BQUOTE ((\, HOW?) (QUOTE (\, BROWSER)) (QUOTE (\, WINDOW)) (QUOTE (\, FLG)))) (QUOTE TB.UPDATE)))) (QUOTE DON'T)) (T (TB.FINISH.CLOSE BROWSER WINDOW FLG T) NIL))) (T (printout PROMPTWINDOW T "Browser is busy, can't close") (QUOTE DON'T)))))) ) (TB.CLOSEFN (LAMBDA (WINDOW) (* bvm%: " 6-Sep-85 12:25") (TB.CLOSE/SHRINK WINDOW (QUOTE CLOSE)))) (TB.FINISH.CLOSE (LAMBDA (BROWSER WINDOW CLOSEFLG DONTCLOSE) (* bvm%: " 9-Sep-85 00:42") (* ;;; "Takes care of closing/shrinking WINDOW after an update or expunge. DONTCLOSE is true if neither occurred, in which case we are being called directly from the CLOSEFN and should not close/shrink the window ourselves") (WITH.MONITOR (fetch (TABLEBROWSER TBLOCK) of BROWSER) (SELECTQ CLOSEFLG (CLOSE (SETQ WINDOW (TB.FLUSH.WINDOW BROWSER WINDOW)) (OR DONTCLOSE (CLOSEW WINDOW))) (SHRINK (WINDOWADDPROP WINDOW (QUOTE EXPANDFN) (FUNCTION TB.EXPANDFN)) (WINDOWDELPROP WINDOW (QUOTE SHRINKFN) (FUNCTION TB.SHRINKFN)) (OR DONTCLOSE (SHRINKW WINDOW))) NIL))) ) (TB.FLUSH.WINDOW (LAMBDA (BROWSER WINDOW) (* ; "Edited 20-Jan-88 22:42 by bvm") (WINDOWDELPROP WINDOW (QUOTE CLOSEFN) (FUNCTION TB.CLOSEFN)) (ERSETQ (LET ((FN (fetch (TABLEBROWSER TBAFTERCLOSEFN) of BROWSER))) (AND FN (CL:FUNCALL FN BROWSER WINDOW)))) (replace (TABLEBROWSER TBITEMS) of BROWSER with (replace (TABLEBROWSER TBWINDOW) of BROWSER with (replace (TABLEBROWSER TBTAILHINT) of BROWSER with NIL))) (WINDOWPROP WINDOW (QUOTE TABLEBROWSER) NIL) (OR (OPENWP WINDOW) (OPENWP (WINDOWPROP WINDOW (QUOTE ICONWINDOW))))) ) (TB.SET.FONT (LAMBDA (BROWSER FONT) (* ; "Edited 10-Feb-88 11:07 by bvm:") (* ;;; "Sets/changes font of TABLEBROWSER to be FONT. Clears window. Caller is responsible for repainting window") (LET ((FONTGIVEN FONT) (WINDOW (fetch (TABLEBROWSER TBWINDOW) of BROWSER)) WIDTH HEIGHT ASCENT TOTALHEIGHT ORIGIN FN EXTENT HW) (CLEARW WINDOW) (SETQ FONT (FONTCREATE (OR FONT (fetch (TABLEBROWSER TBFONT) of BROWSER) (DSPFONT NIL WINDOW)))) (DSPFONT FONT WINDOW) (DSPRIGHTMARGIN MAX.SMALLP WINDOW) (LINELENGTH T WINDOW) (replace (TABLEBROWSER TBFONT) of BROWSER with FONT) (replace (TABLEBROWSER TBFONTHEIGHT) of BROWSER with (SETQ HEIGHT (FONTPROP FONT (QUOTE HEIGHT)))) (if (NOT (fetch (TABLEBROWSER TBHEIGHTEXPLICIT) of BROWSER)) then (* ; "Compute item heights. Don't do this if user gave an explicit height.") (replace (TABLEBROWSER TBITEMHEIGHT) of BROWSER with (SETQ HEIGHT (TIMES HEIGHT (fetch (TABLEBROWSER TB#LINESPERITEM) of BROWSER)))) (replace (TABLEBROWSER TBFONTASCENT) of BROWSER with (SETQ ASCENT (FONTPROP FONT (QUOTE ASCENT)))) (replace (TABLEBROWSER TBBASELINE) of BROWSER with (- HEIGHT ASCENT)) else (SETQ HEIGHT (fetch (TABLEBROWSER TBITEMHEIGHT) of BROWSER))) (replace (TABLEBROWSER TBORIGIN) of BROWSER with (SETQ ORIGIN (fetch (REGION PTOP) of (DSPCLIPPINGREGION NIL WINDOW)))) (SETQ TOTALHEIGHT (TIMES (fetch (TABLEBROWSER TB#ITEMS) of BROWSER) HEIGHT)) (WINDOWPROP WINDOW (QUOTE EXTENT) (replace (TABLEBROWSER TBEXTENT) of BROWSER with (create REGION LEFT _ 0 BOTTOM _ (- ORIGIN TOTALHEIGHT) WIDTH _ 0 HEIGHT _ TOTALHEIGHT))) (* ; "Let extent width be zero until we print something") (replace (TABLEBROWSER TBMAXXPOS) of BROWSER with 0) (if (SETQ HW (fetch (TABLEBROWSER TBHEADINGWINDOW) of BROWSER)) then (* ; "Fix extent of header window, too. Be sure to account for different size of borders, if any") (LET ((HWIDTH (TIMES 2 (- (WINDOWPROP WINDOW (QUOTE BORDER)) (WINDOWPROP HW (QUOTE BORDER)))))) (if (SETQ EXTENT (WINDOWPROP HW (QUOTE EXTENT))) then (replace (REGION WIDTH) of EXTENT with HWIDTH) else (WINDOWPROP HW (QUOTE EXTENT) (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ HWIDTH HEIGHT _ -1))))) (COND ((AND FONTGIVEN (SETQ FN (fetch (TABLEBROWSER TBFONTCHANGEFN) of BROWSER))) (* ; "Notify application program of font change") (CL:FUNCALL FN BROWSER WINDOW))))) ) (TB.SHRINKFN (LAMBDA (WINDOW) (* bvm%: " 6-Sep-85 12:14") (TB.CLOSE/SHRINK WINDOW (QUOTE SHRINK)))) (TB.EXPANDFN (LAMBDA (WINDOW) (* ; "Edited 27-Jan-88 16:53 by bvm") (* ;;; "If browser changed while it was shrunk, update display accordingly") (LET ((BROWSER (WINDOWPROP WINDOW (QUOTE TABLEBROWSER)))) (WITH.MONITOR (fetch (TABLEBROWSER TBLOCK) of BROWSER) (LET ((FIRSTCHANGEDITEM# (fetch (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER)) REGION FN) (* ; "Restore SHRINKFN prop if necessary") (WINDOWADDPROP WINDOW (QUOTE SHRINKFN) (FUNCTION TB.SHRINKFN) T) (COND (FIRSTCHANGEDITEM# (* ; "Browser has changed since shrinking") (TB.DISPLAY.LINES BROWSER (IMAX FIRSTCHANGEDITEM# (TB.FIRST.VISIBLE.ITEM# BROWSER (SETQ REGION (DSPCLIPPINGREGION NIL WINDOW)))) (TB.LAST.VISIBLE.ITEM# BROWSER REGION)) (replace (TABLEBROWSER TBUPDATEFROMHERE) of BROWSER with NIL))))))) ) (TB.FIND.PREVIOUS.TAIL (LAMBDA (BROWSER ITEM#) (* ; "Edited 20-Jan-88 23:23 by bvm") (* ;; "Return the tail of BROWSER's items whose CADR is ITEM#. Assumes ITEM# at least 2 and not greater than number of items") (LET (TAIL TAILN) (if (OR (NULL (SETQ TAIL (fetch (TABLEBROWSER TBTAILHINT) of BROWSER))) (< ITEM# (SETQ TAILN (ADD1 (fetch (TABLEITEM TI#) of (CAR TAIL)))))) then (* ; "Can't use the hint") (SETQ TAIL (fetch (TABLEBROWSER TBITEMS) of BROWSER)) (SETQ TAILN 2)) (* ;; "TAILN is the number of (CADR TAIL). Want to get TAIL pointing to one before the requested number") (while (< TAILN ITEM#) do (SETQ TAIL (CDR TAIL)) (add TAILN 1)) (if (OR (NULL TAIL) (NEQ TAILN ITEM#)) then (HELP "Failed to find item tail" ITEM#)) TAIL)) ) (TB.RENUMBER.TAIL (LAMBDA (BROWSER TAIL FIRST#) (* ; "Edited 20-Jan-88 23:22 by bvm") (* ;; "Renumbers all of BROWSER's items from TAIL onward, giving (CAR TAIL) the number FIRST#. Also updates tail hint.") (for ITEM in TAIL as I from FIRST# do (replace TI# of ITEM with I)) (replace (TABLEBROWSER TBTAILHINT) of BROWSER with TAIL)) ) ) (* ; "Misc") (DEFINEQ (TB.PROCESS (LAMBDA (FORM NAME ALLOWLOGOUT RESTARTABLE) (* bvm%: "25-Mar-84 17:16") (* ;;; "Creates a process running FORM which by default is not restartable and will not permit LOGOUT while it is running") (ADD.PROCESS FORM (QUOTE NAME) NAME (QUOTE RESTARTABLE) (OR RESTARTABLE (QUOTE NO)) (QUOTE BEFOREEXIT) (COND (ALLOWLOGOUT NIL) (T (QUOTE DON'T))))) ) ) (RPAQ? TB.DELETEDLINEHEIGHT 1) (RPAQQ TB.SELECTION.BITMAP #*(8 9)L@@@N@@@O@@@OH@@OL@@OH@@O@@@N@@@L@@@) (RPAQ TB.CROSSCURSOR (CURSORCREATE (QUOTE #*(16 16)L@@CN@@GG@@NCHALALCH@NG@@GN@@CL@@CL@@GN@@NG@ALCHCHALG@@NN@@GL@@C ) (QUOTE NIL) 8 8)) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) TBDECLS) (RPAQQ TOCSTATES ((TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7))) (DECLARE%: EVAL@COMPILE (RPAQQ TS.IDLE 0) (RPAQQ TS.REPLACING 1) (RPAQQ TS.ADDING 2) (RPAQQ TS.REMOVING 3) (RPAQQ TS.EXTENDING.HI 4) (RPAQQ TS.EXTENDING.LO 5) (RPAQQ TS.SHRINKING.HI 6) (RPAQQ TS.SHRINKING.LO 7) (CONSTANTS (TS.IDLE 0) (TS.REPLACING 1) (TS.ADDING 2) (TS.REMOVING 3) (TS.EXTENDING.HI 4) (TS.EXTENDING.LO 5) (TS.SHRINKING.HI 6) (TS.SHRINKING.LO 7)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS .COPYKEYDOWNP. MACRO [NIL (OR (KEYDOWNP 'LSHIFT) (KEYDOWNP 'RSHIFT) (KEYDOWNP 'COPY]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TB.CROSSCURSOR TB.SELECTION.BITMAP TB.DELETEDLINEHEIGHT) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA TB.USERDATA) ) (/DECLAREDATATYPE 'TABLEBROWSER '(FLAG FLAG POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((TABLEBROWSER 0 (FLAGBITS . 0)) (TABLEBROWSER 0 (FLAGBITS . 16)) (TABLEBROWSER 0 POINTER) (TABLEBROWSER 2 (BITS . 15)) (TABLEBROWSER 3 (BITS . 15)) (TABLEBROWSER 4 (BITS . 15)) (TABLEBROWSER 5 (BITS . 15)) (TABLEBROWSER 6 (BITS . 15)) (TABLEBROWSER 7 (BITS . 15)) (TABLEBROWSER 8 (BITS . 15)) (TABLEBROWSER 9 (BITS . 15)) (TABLEBROWSER 10 (BITS . 15)) (TABLEBROWSER 11 (BITS . 15)) (TABLEBROWSER 12 POINTER) (TABLEBROWSER 14 POINTER) (TABLEBROWSER 16 POINTER) (TABLEBROWSER 18 POINTER) (TABLEBROWSER 20 POINTER) (TABLEBROWSER 22 POINTER) (TABLEBROWSER 24 POINTER) (TABLEBROWSER 26 POINTER) (TABLEBROWSER 28 POINTER) (TABLEBROWSER 30 POINTER) (TABLEBROWSER 32 POINTER) (TABLEBROWSER 34 POINTER) (TABLEBROWSER 36 POINTER) (TABLEBROWSER 38 POINTER) (TABLEBROWSER 40 POINTER) (TABLEBROWSER 42 POINTER) (TABLEBROWSER 44 POINTER) (TABLEBROWSER 46 POINTER)) '48) (/DECLAREDATATYPE 'TABLEITEM '(FLAG FLAG FLAG FLAG FLAG POINTER WORD) '((TABLEITEM 0 (FLAGBITS . 0)) (TABLEITEM 0 (FLAGBITS . 16)) (TABLEITEM 0 (FLAGBITS . 32)) (TABLEITEM 0 (FLAGBITS . 48)) (TABLEITEM 0 (FLAGBITS . 64)) (TABLEITEM 2 POINTER) (TABLEITEM 1 (BITS . 15))) '4) (ADDTOVAR SYSTEMRECLST (DATATYPE TABLEBROWSER ((TBREADY FLAG) (TBHEIGHTEXPLICIT FLAG) (TBITEMS POINTER) (TB#ITEMS WORD) (TB#DELETED WORD) (TB#LINESPERITEM WORD) (TBFIRSTSELECTEDITEM WORD) (TBLASTSELECTEDITEM WORD) (TBITEMHEIGHT WORD) (TBMAXXPOS WORD) (TBFONTHEIGHT WORD) (TBFONTASCENT WORD) (TBBASELINE WORD) (TBWINDOW POINTER) (TBLOCK POINTER) (TBUSERDATA POINTER) (TBFONT POINTER) (TBEXTENT POINTER) (TBUPDATEFROMHERE POINTER) (TBCOLUMNS POINTER) (TBPRINTFN POINTER) (TBCOPYFN POINTER) (TBFONTCHANGEFN POINTER) (TBCLOSEFN POINTER) (TBAFTERCLOSEFN POINTER) (TBTITLEEVENTFN POINTER) (TBLINETHICKNESS POINTER) (TBORIGIN POINTER) (TBTAILHINT POINTER) (TBHEADINGWINDOW POINTER) (NIL POINTER))) (DATATYPE TABLEITEM ((TISELECTED FLAG) (TIDELETED FLAG) (TIUNDELETABLE FLAG) (TIUNSELECTABLE FLAG) (TIUNCOPYSELECTABLE FLAG) (TIDATA POINTER) (TI# WORD))) ) (PUTPROPS TABLEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1993 1994 1995 1999 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3215 7566 (TB.MAKE.BROWSER 3225 . 6341) (TB.REPLACE.ITEMS 6343 . 7564)) (7567 16586 ( TB.DELETE.ITEM 7577 . 8011) (TB.UNDELETE.ITEM 8013 . 8592) (TB.INSERT.ITEM 8594 . 10601) ( TB.REMOVE.ITEM 10603 . 12135) (TB.NORMALIZE.ITEM 12137 . 12850) (TB.REDISPLAY.ITEMS 12852 . 15171) ( TB.SELECT.ITEM 15173 . 15478) (TB.UNSELECT.ITEM 15480 . 15835) (TB.UNSELECT.ALL.ITEMS 15837 . 16584)) (16587 21113 (TB.NUMBER.OF.ITEMS 16597 . 17079) (TB.NTH.ITEM 17081 . 18155) (TB.COLLECT.ITEMS 18157 . 18528) (TB.MAP.ITEMS 18530 . 18894) (TB.MAP.DELETED.ITEMS 18896 . 19343) (TB.MAP.SELECTED.ITEMS 19345 . 19952) (TB.FIND.ITEM 19954 . 20827) (TB.ITEM.SELECTED? 20829 . 20970) (TB.ITEM.DELETED? 20972 . 21111)) (21114 21955 (TB.CLEAR.LINE 21124 . 21536) (TB.USERDATA 21538 . 21804) (TB.WINDOW 21806 . 21953)) (21980 32238 (TB.REPAINTFN 21990 . 22401) (TB.RESHAPEFN 22403 . 23241) (TB.SCROLLFN 23243 . 23794) (TB.DISPLAY.LINES 23796 . 25053) (TB.PRINT.LINE 25055 . 25575) (TB.FIRST.VISIBLE.ITEM# 25577 . 26014) (TB.LAST.VISIBLE.ITEM# 26016 . 26489) (TB.ITEM.VISIBLE? 26491 . 27011) (TB.ITEM.FROM.YCOORD 27013 . 27323) (TB.BOTTOM.OF.ITEM 27325 . 27738) (TB.SHOW.DELETION 27740 . 28362) (TB.SHOW.SELECTION 28364 . 29133) (TB.UPDATE.DISPLAY 29135 . 31420) (TB.ITEM.UPDATABLE? 31422 . 32236)) (32265 43678 ( TB.BUTTONEVENTFN 32275 . 32734) (TB.DO.UNLESS.BUSY 32736 . 33043) (TB.DO.ITEM.SELECTION 33045 . 39119) (TB.CONTIGUOUS.SELP 39121 . 39488) (TB.DECONSIDERRANGE 39490 . 39858) (TB.CONSIDERRANGE 39860 . 40431 ) (TB.DESELECTRANGE 40433 . 41495) (TB.RECONSIDERRANGE 41497 . 41995) (TB.SELECTRANGE 41997 . 42937) ( TB.UNDOSELECTION 42939 . 43216) (TB.FIND.SELECTED.ITEM 43218 . 43441) (TB.REV.FIND.SELECTED.ITEM 43443 . 43676)) (43679 45178 (TB.COPYBUTTONEVENTFN 43689 . 44909) (TB.SHOW.COPY.SELECTION 44911 . 45176)) ( 45213 51520 (TB.BROWSER.BUSY 45223 . 45340) (TB.CLOSE/SHRINK 45342 . 45974) (TB.CLOSEFN 45976 . 46077) (TB.FINISH.CLOSE 46079 . 46732) (TB.FLUSH.WINDOW 46734 . 47261) (TB.SET.FONT 47263 . 49561) ( TB.SHRINKFN 49563 . 49666) (TB.EXPANDFN 49668 . 50433) (TB.FIND.PREVIOUS.TAIL 50435 . 51177) ( TB.RENUMBER.TAIL 51179 . 51518)) (51542 51915 (TB.PROCESS 51552 . 51913))))) STOP \ No newline at end of file diff --git a/library/TABLEBROWSERDECLS b/library/TABLEBROWSERDECLS new file mode 100644 index 00000000..3921771a --- /dev/null +++ b/library/TABLEBROWSERDECLS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "26-Jun-99 00:30:01" {DSK}medley3.5>library>TABLEBROWSERDECLS.;2 7377 changes to%: (RECORDS TABLEBROWSER TABLEITEM) previous date%: "20-Jan-93 14:52:38" {DSK}medley3.5>library>TABLEBROWSERDECLS.;1) (* ; " Copyright (c) 1985, 1988, 1990, 1993, 1999 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TABLEBROWSERDECLSCOMS) (RPAQQ TABLEBROWSERDECLSCOMS ((RECORDS TABLEBROWSER TABLEITEM) (CONSTANTS TB.LEFT.MARGIN))) (DECLARE%: EVAL@COMPILE (DATATYPE TABLEBROWSER ((TBREADY FLAG) (TBHEIGHTEXPLICIT FLAG) (* ;  "True if creator set explicit item height or baseline") (TBITEMS POINTER) (* ; "List of items in this browser") (TB#ITEMS WORD) (* ; "Number of items") (TB#DELETED WORD) (* ; "Number of items marked deleted") (TB#LINESPERITEM WORD) (* ;  "Number of lines occupied by each item, normally 1 (dunno if any other values work)") (TBFIRSTSELECTEDITEM WORD) (* ;  "Number of first selected item. If none selected, is > TB#ITEMS") (TBLASTSELECTEDITEM WORD) (* ;  "Number of last selected item. If none selected, is 0") (TBITEMHEIGHT WORD) (* ;  "Height of an item, i.e., fontheight*linesperitem") (TBMAXXPOS WORD) (* ;  "The largest x-position a user printfn has printed to") (TBFONTHEIGHT WORD) (* ; "Height, ascent, descent of font") (TBFONTASCENT WORD) (TBBASELINE WORD) (TBWINDOW POINTER) (* ;  "Pointer to the display window. Need to snap this link when browser is closed") (TBLOCK POINTER) (* ;  "Monitor lock guarding some browser operations") (TBUSERDATA POINTER) (* ; "Arbitrary user storage") (TBFONT POINTER) (* ; "Pointer to font used by display") (TBEXTENT POINTER) (* ;  "Window's extent, updated as items are added, deleted, or printfn prints farther to right") (TBUPDATEFROMHERE POINTER) (* ;  "If changes have occurred while shrunk, this gives the # of first item that needs redisplay") (TBCOLUMNS POINTER) (* ;  "Number of columns--not yet implemented") (TBPRINTFN POINTER) (* ;  "(Browser Item Window) -- displays Item at current line position in window") (TBCOPYFN POINTER) (* ;  "(Browser Item) -- copy selects Item") (TBFONTCHANGEFN POINTER) (* ;  "(Browser Window) -- called when tb.set.font changes the font") (TBCLOSEFN POINTER) (* ;  "(Browser Window Close/Shrink) -- called when you try to close or shrink window") (TBAFTERCLOSEFN POINTER) (* ;  "(Browser Window) -- called to cleanup AFTER a closew") (TBTITLEEVENTFN POINTER) (* ;  "(Window Browser) -- handles button event in browser's title") (TBLINETHICKNESS POINTER) (* ;  "Thickness of line for deletions (normally 1)") (TBORIGIN POINTER) (* ;  "Y position of the top of the first item") (TBTAILHINT POINTER) (* ;  "A tail of TBITEMS, used to speed up TB.NTH.ITEM") (TBHEADINGWINDOW POINTER) (* ;  "An optional %"header window%" that should be horizontally scrolled in synchrony with this one") (NIL POINTER))) (DATATYPE TABLEITEM ((TISELECTED FLAG) (TIDELETED FLAG) (TIUNDELETABLE FLAG) (TIUNSELECTABLE FLAG) (TIUNCOPYSELECTABLE FLAG) (TIDATA POINTER) (TI# WORD))) ) (/DECLAREDATATYPE 'TABLEBROWSER '(FLAG FLAG POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((TABLEBROWSER 0 (FLAGBITS . 0)) (TABLEBROWSER 0 (FLAGBITS . 16)) (TABLEBROWSER 0 POINTER) (TABLEBROWSER 2 (BITS . 15)) (TABLEBROWSER 3 (BITS . 15)) (TABLEBROWSER 4 (BITS . 15)) (TABLEBROWSER 5 (BITS . 15)) (TABLEBROWSER 6 (BITS . 15)) (TABLEBROWSER 7 (BITS . 15)) (TABLEBROWSER 8 (BITS . 15)) (TABLEBROWSER 9 (BITS . 15)) (TABLEBROWSER 10 (BITS . 15)) (TABLEBROWSER 11 (BITS . 15)) (TABLEBROWSER 12 POINTER) (TABLEBROWSER 14 POINTER) (TABLEBROWSER 16 POINTER) (TABLEBROWSER 18 POINTER) (TABLEBROWSER 20 POINTER) (TABLEBROWSER 22 POINTER) (TABLEBROWSER 24 POINTER) (TABLEBROWSER 26 POINTER) (TABLEBROWSER 28 POINTER) (TABLEBROWSER 30 POINTER) (TABLEBROWSER 32 POINTER) (TABLEBROWSER 34 POINTER) (TABLEBROWSER 36 POINTER) (TABLEBROWSER 38 POINTER) (TABLEBROWSER 40 POINTER) (TABLEBROWSER 42 POINTER) (TABLEBROWSER 44 POINTER) (TABLEBROWSER 46 POINTER)) '48) (/DECLAREDATATYPE 'TABLEITEM '(FLAG FLAG FLAG FLAG FLAG POINTER WORD) '((TABLEITEM 0 (FLAGBITS . 0)) (TABLEITEM 0 (FLAGBITS . 16)) (TABLEITEM 0 (FLAGBITS . 32)) (TABLEITEM 0 (FLAGBITS . 48)) (TABLEITEM 0 (FLAGBITS . 64)) (TABLEITEM 2 POINTER) (TABLEITEM 1 (BITS . 15))) '4) (DECLARE%: EVAL@COMPILE (RPAQQ TB.LEFT.MARGIN 8) (CONSTANTS TB.LEFT.MARGIN) ) (PUTPROPS TABLEBROWSERDECLS COPYRIGHT ("Venue & Xerox Corporation" 1985 1988 1990 1993 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/library/TBDECLS b/library/TBDECLS new file mode 100644 index 00000000..d9b78084 --- /dev/null +++ b/library/TBDECLS @@ -0,0 +1,150 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "27-Sep-94 15:03:22" {DSK}library>TBDECLS.;3 7831 + + changes to%: (RECORDS TABLEBROWSER TABLEITEM) + + previous date%: "20-Jan-93 14:52:38" {DSK}library>TBDECLS.;2) + + +(* ; " +Copyright (c) 1985, 1988, 1990, 1993, 1994 by Venue. All rights reserved. +") + +(PRETTYCOMPRINT TBDECLSCOMS) + +(RPAQQ TBDECLSCOMS ((RECORDS TABLEBROWSER TABLEITEM) + (CONSTANTS TB.LEFT.MARGIN))) +(DECLARE%: EVAL@COMPILE + +(DATATYPE TABLEBROWSER ((TBREADY FLAG) + (TBHEIGHTEXPLICIT FLAG) (* ; + "True if creator set explicit item height or baseline") + (NIL 6 FLAG) + (TBITEMS POINTER) (* ; "List of items in this browser") + (TB#ITEMS WORD) (* ; "Number of items") + (TB#DELETED WORD) (* ; "Number of items marked deleted") + (TB#LINESPERITEM WORD) (* ; + "Number of lines occupied by each item, normally 1 (dunno if any other values work)") + (TBFIRSTSELECTEDITEM WORD) (* ; + "Number of first selected item. If none selected, is > TB#ITEMS") + (TBLASTSELECTEDITEM WORD) (* ; + "Number of last selected item. If none selected, is 0") + (TBITEMHEIGHT WORD) (* ; + "Height of an item, i.e., fontheight*linesperitem") + (TBMAXXPOS WORD) (* ; + "The largest x-position a user printfn has printed to") + (TBFONTHEIGHT WORD) (* ; "Height, ascent, descent of font") + (TBFONTASCENT WORD) + (TBBASELINE WORD) + (TBWINDOW POINTER) (* ; + "Pointer to the display window. Need to snap this link when browser is closed") + (TBLOCK POINTER) (* ; + "Monitor lock guarding some browser operations") + (TBUSERDATA POINTER) (* ; "Arbitrary user storage") + (TBFONT POINTER) (* ; "Pointer to font used by display") + (TBEXTENT POINTER) (* ; + "Window's extent, updated as items are added, deleted, or printfn prints farther to right") + (TBUPDATEFROMHERE POINTER) (* ; + "If changes have occurred while shrunk, this gives the # of first item that needs redisplay") + (TBCOLUMNS POINTER) (* ; + "Number of columns--not yet implemented") + (TBPRINTFN POINTER) (* ; + "(Browser Item Window) -- displays Item at current line position in window") + (TBCOPYFN POINTER) (* ; + "(Browser Item) -- copy selects Item") + (TBFONTCHANGEFN POINTER) (* ; + "(Browser Window) -- called when tb.set.font changes the font") + (TBCLOSEFN POINTER) (* ; + "(Browser Window Close/Shrink) -- called when you try to close or shrink window") + (TBAFTERCLOSEFN POINTER) (* ; + "(Browser Window) -- called to cleanup AFTER a closew") + (TBTITLEEVENTFN POINTER) (* ; + "(Window Browser) -- handles button event in browser's title") + (TBLINETHICKNESS POINTER) (* ; + "Thickness of line for deletions (normally 1)") + (TBORIGIN POINTER) (* ; + "Y position of the top of the first item") + (TBTAILHINT POINTER) (* ; + "A tail of TBITEMS, used to speed up TB.NTH.ITEM") + (TBHEADINGWINDOW POINTER) (* ; + "An optional %"header window%" that should be horizontally scrolled in synchrony with this one") + (NIL POINTER))) + +(DATATYPE TABLEITEM ((TISELECTED FLAG) + (TIDELETED FLAG) + (TIUNDELETABLE FLAG) + (TIUNSELECTABLE FLAG) + (TIUNCOPYSELECTABLE FLAG) + (NIL 3 FLAG) + (TIDATA POINTER) + (TI# WORD) + (NIL WORD))) +) + +(/DECLAREDATATYPE 'TABLEBROWSER + '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD + WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) + '((TABLEBROWSER 0 (FLAGBITS . 0)) + (TABLEBROWSER 0 (FLAGBITS . 16)) + (TABLEBROWSER 0 (FLAGBITS . 32)) + (TABLEBROWSER 0 (FLAGBITS . 48)) + (TABLEBROWSER 0 (FLAGBITS . 64)) + (TABLEBROWSER 0 (FLAGBITS . 80)) + (TABLEBROWSER 0 (FLAGBITS . 96)) + (TABLEBROWSER 0 (FLAGBITS . 112)) + (TABLEBROWSER 0 POINTER) + (TABLEBROWSER 2 (BITS . 15)) + (TABLEBROWSER 3 (BITS . 15)) + (TABLEBROWSER 4 (BITS . 15)) + (TABLEBROWSER 5 (BITS . 15)) + (TABLEBROWSER 6 (BITS . 15)) + (TABLEBROWSER 7 (BITS . 15)) + (TABLEBROWSER 8 (BITS . 15)) + (TABLEBROWSER 9 (BITS . 15)) + (TABLEBROWSER 10 (BITS . 15)) + (TABLEBROWSER 11 (BITS . 15)) + (TABLEBROWSER 12 POINTER) + (TABLEBROWSER 14 POINTER) + (TABLEBROWSER 16 POINTER) + (TABLEBROWSER 18 POINTER) + (TABLEBROWSER 20 POINTER) + (TABLEBROWSER 22 POINTER) + (TABLEBROWSER 24 POINTER) + (TABLEBROWSER 26 POINTER) + (TABLEBROWSER 28 POINTER) + (TABLEBROWSER 30 POINTER) + (TABLEBROWSER 32 POINTER) + (TABLEBROWSER 34 POINTER) + (TABLEBROWSER 36 POINTER) + (TABLEBROWSER 38 POINTER) + (TABLEBROWSER 40 POINTER) + (TABLEBROWSER 42 POINTER) + (TABLEBROWSER 44 POINTER) + (TABLEBROWSER 46 POINTER)) + '48) + +(/DECLAREDATATYPE 'TABLEITEM '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD) + '((TABLEITEM 0 (FLAGBITS . 0)) + (TABLEITEM 0 (FLAGBITS . 16)) + (TABLEITEM 0 (FLAGBITS . 32)) + (TABLEITEM 0 (FLAGBITS . 48)) + (TABLEITEM 0 (FLAGBITS . 64)) + (TABLEITEM 0 (FLAGBITS . 80)) + (TABLEITEM 0 (FLAGBITS . 96)) + (TABLEITEM 0 (FLAGBITS . 112)) + (TABLEITEM 0 POINTER) + (TABLEITEM 2 (BITS . 15)) + (TABLEITEM 3 (BITS . 15))) + '4) +(DECLARE%: EVAL@COMPILE + +(RPAQQ TB.LEFT.MARGIN 8) + + +(CONSTANTS TB.LEFT.MARGIN) +) +(PUTPROPS TBDECLS COPYRIGHT ("Venue" 1985 1988 1990 1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL))) +STOP diff --git a/library/TEDIT b/library/TEDIT new file mode 100644 index 00000000..d85ae0f1 --- /dev/null +++ b/library/TEDIT @@ -0,0 +1,1655 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Apr-2018 12:22:03" {DSK}kaplan>Local>medley3.5>lispcore>library>TEDIT.;2 140045 changes to%: (VARS TEDITCOMS) previous date%: "21-Jun-99 20:00:16" {DSK}kaplan>Local>medley3.5>lispcore>library>TEDIT.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995, 1999, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDITCOMS) (RPAQQ TEDITCOMS [(FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (FILES PCTREE TEXTOFD TEDITCOMMAND TEDITSCREEN TEDITABBREV TEDITLOOKS) (VARS (TEDIT.TERMSA.FONTS NIL) (TEDIT.TENTATIVE NIL) (TEDIT.DEFAULT.PROPS NIL) (TEDIT.STARTUP.MONITORLOCK (CREATE.MONITORLOCK 'TEDIT.STARTUP)) (TEDIT.RESTART.MENU (\CREATE.TEDIT.RESTART.MENU)) (* ;  "Original was (CREATE MENU ITEMS _ '(NewEditProcess)).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") ) (GLOBALVARS TEDIT.TENTATIVE TEDIT.DEFAULT.PROPS) (FNS \TEDIT2 COERCETEXTOBJ TEDIT TEDIT.CHARWIDTH TEDIT.COPY TEDIT.DELETE TEDIT.DO.BLUEPENDINGDELETE TEDIT.INSERT TEDIT.KILL TEDIT.MAPLINES TEDIT.MAPPIECES TEDIT.MOVE TEDIT.QUIT TEDIT.STRINGWIDTH TEDIT.\INSERT TEXTOBJ TEXTSTREAM \TEDIT.INCLUDE \TEDIT.INSERT.PIECES \TEDIT.MOVE.PIECEMAPFN \TEDIT.OBJECT.SHOWSEL \TEDIT.RESTARTFN \TEDIT.CHARDELETE \TEDIT.COPY.PIECEMAPFN \TEDIT.DELETE \TEDIT.DIFFUSE.PARALOOKS \TEDIT.FOREIGN.COPY? \TEDIT.QUIT \TEDIT.WORDDELETE \TEDIT1) (P (MOVD? 'NILL 'OBJECTOUTOFTEDIT)) (* ;  "HOOK for looked-string copy, etc. Used in \TEDIT.FOREIGN.COPY?.") (COMS (FNS \CREATE.TEDIT.RESTART.MENU)) (* ;  "Added by yabu.fx, for SUNLOADUP without DWIM.") (COMS (* ; "Debugging functions") (FNS PLCHAIN PRINTLINE SEEFILE)) (COMS (* ; "Object-oriented editing") (FNS TEDIT.INSERT.OBJECT TEDIT.EDIT.OBJECT TEDIT.FIND.OBJECT TEDIT.FIND.OBJECT.SUBTREE TEDIT.PUT.OBJECT TEDIT.GET.OBJECT TEDIT.OBJECT.CHANGED)) (FILES TEDITFIND TEDITHISTORY TEDITFILE TEDITWINDOW TEDITSELECTION IMAGEOBJ TFBRAVO TEDITHCPY TEDITPAGE TEDITMENU TEDITFNKEYS) (COMS (* ; "TEDIT Support information") (E (SETQ TEDITSYSTEMDATE (DATE))) (VARS TEDITSYSTEMDATE (TEDITSUPPORT "TEditSupport.PA")) (FNS MAKETEDITFORM) (P (ADDTOVAR LAFITESPECIALFORMS ("TEdit Report" 'MAKETEDITFORM "Report a problem with TEdit")) (SETQ LAFITEFORMSMENU NIL))) (COMS (* ;  "LISTFILES Interface, so the system can decide if a file is a TEdit file.") (ADDVARS (PRINTFILETYPES (TEDIT (TEST \TEDIT.FORMATTEDP1) (EXTENSION (TEDIT]) (FILESLOAD TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SCRATCHLEN 64) (CONSTANTS (\SCRATCHLEN 64)) ) (FILESLOAD (LOADCOMP) TEDITDCL) ) (FILESLOAD PCTREE TEXTOFD TEDITCOMMAND TEDITSCREEN TEDITABBREV TEDITLOOKS) (RPAQQ TEDIT.TERMSA.FONTS NIL) (RPAQQ TEDIT.TENTATIVE NIL) (RPAQQ TEDIT.DEFAULT.PROPS NIL) (RPAQ TEDIT.STARTUP.MONITORLOCK (CREATE.MONITORLOCK 'TEDIT.STARTUP)) (RPAQ TEDIT.RESTART.MENU (\CREATE.TEDIT.RESTART.MENU)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.TENTATIVE TEDIT.DEFAULT.PROPS) ) (DEFINEQ (\TEDIT2 + [LAMBDA (TEXT WINDOW UNSPAWNED) (* ; "Edited 12-Jun-90 17:51 by mitani") + + (* ;; "Does the actual editing work, once TEDIT has OPENTEXTSTREAMed the thing to be edited.") + + (\TEDIT.COMMAND.LOOP (fetch (TEXTSTREAM TEXTOBJ) of TEXT)) + (* ; "Run the editing engine") + (CLOSEW WINDOW) (* ; "Close the edit window") + (\TEXTCLOSEF TEXT) (* ; "Close the underlying files") + (replace (STREAM ACCESSBITS) of TEXT with BothBits) + (* ; + "But leave the stream itself accessible") + (AND (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) + 'AFTERQUITFN) + (APPLY* (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) + '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 (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM + TEXTOBJ) + of TEXT)) + T) + (PROG1 (fetch (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM + TEXTOBJ) + of TEXT)) + (replace (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM + TEXTOBJ) + of TEXT) with + NIL))) + ((STRINGP (fetch (TEXTOBJ TXTFILE) of (fetch (TEXTSTREAM TEXTOBJ + ) of TEXT))) + (COERCETEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT) + 'STRINGP)) + (T TEXT]) (COERCETEXTOBJ [LAMBDA (STREAM TYPE OUTPUTSTREAM) (* ; "Edited 11-Jun-99 15:10 by rmk:") (* ; "Edited 11-Jun-99 15:10 by rmk:") (* ; "Edited 11-Jun-99 13:58 by rmk:") (* ; "Edited 11-Jun-99 13:58 by rmk:") (* ; "Edited 18-Apr-93 23:42 by jds") (* ;; "Coerce the contents of the TEXOTBJ to be of the given type. This is for making a string from a textobj, e.g.") (PROG ((TEXTOBJ (COND ((type? STREAM STREAM) (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) (T STREAM))) OFILE FMTFILE) (OR (type? TEXTOBJ TEXTOBJ) (\ILLEGAL.ARG TEXTOBJ)) (* ;  "If we haven't got a TEXTOBJ, something is wrong.") (RETURN (SELECTQ TYPE ((STRINGP STRING) (AND (ILEQ (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) 65535) (PROG ((STR (ALLOCSTRING (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) PC (CH# 1) (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (DELTA 0) PFILE) (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB) 0)) [WHILE PC do (COND ((ATOM PC)(* ;  "It's the lastpiece atom -- do nothing.") (SETQ PC NIL)) ((fetch CLINVISIBLE of (fetch (PIECE PLOOKS) of PC)) (* ;; "If the characters are invisible, do nothing. HOWEVER, we have to shrink the final string to account for the characters we ignored.") (add DELTA (fetch (PIECE PLEN) of PC))) ((fetch (PIECE PSTR) of PC) [OR (ZEROP (fetch (PIECE PLEN) of PC)) (RPLSTRING STR CH# (SUBSTRING (fetch (PIECE PSTR) of PC) 1 (fetch (PIECE PLEN) of PC] (add CH# (fetch (PIECE PLEN) of PC))) ((SETQ PFILE (fetch (PIECE PFILE) of PC)) [COND ((NOT (OPENP PFILE)) (SETQ PFILE (\TEDIT.REOPEN.STREAM STREAM PFILE] (SETFILEPTR PFILE (fetch (PIECE PFPOS) of PC)) (for C from CH# as I from 1 to (fetch (PIECE PLEN) of PC) do (RPLCHARCODE STR C (BIN PFILE))) (add CH# (fetch (PIECE PLEN) of PC))) ((fetch (PIECE POBJ) of PC) (* ; "DO NOTHING FOR OBJECTS") (add CH# (fetch (PIECE PLEN) of PC)) (add DELTA (fetch (PIECE PLEN) of PC))) (T (ERROR "CANNOT GET TEXT FROM A 'PIECE.'" PC))) (AND PC (SETQ PC (FETCH (PIECE NEXTPIECE) OF PC] [COND ((ZEROP DELTA) (* ;  "No change in the length; do nothing.") ) (T (* ;  "The string got shortened to account for invisible chars. Chop it off") (SETQ STR (SUBSTRING STR 1 (IDIFFERENCE (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) DELTA] (RETURN STR)))) (STREAM (COND ((type? STREAM (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) [OPENFILE (fetch (STREAM FULLNAME) of (fetch (TEXTOBJ TXTFILE ) of TEXTOBJ)) 'INPUT NIL '((TYPE TEXT] (replace (STREAM ACCESSBITS) of (fetch (TEXTOBJ TXTFILE) of TEXTOBJ) with ReadBit))) (\SETUPGETCH 1 TEXTOBJ) (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) (FILE [SETQ OFILE (OR (AND OUTPUTSTREAM (OPENP OUTPUTSTREAM 'OUTPUT)) (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW] (TEDIT.PUT.PCTB TEXTOBJ OFILE) (OR OUTPUTSTREAM (CLOSEF OFILE)) OFILE) (SPLIT (* ;; "I.e., Return 2 files, one with plain text, one with formatting info, such that concatenating them will do the right thing.") (SETQ OFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW)) (SETQ FMTFILE (CAR (TEDIT.PUT.PCTB TEXTOBJ (\GETSTREAM OFILE 'BOTH) NIL T))) (CLOSEF OFILE) (CONS OFILE FMTFILE)) NIL]) (TEDIT [LAMBDA (TEXT WINDOW DONTSPAWN PROPS) (* ; "Edited 11-Jun-99 14:14 by rmk:") (* ; "Edited 11-Jun-99 14:13 by rmk:") (* ; "Edited 11-Jun-99 14:08 by rmk:") (* ; "Edited 3-Jun-88 14:27 by jds") (* ;; "User entry to the text editor. Takes an optional window to be used for editing") (* ;; "DONTSPAWN => Don't try to create a new process for this edit.") (PROG (PROC TEDITCREATEDWINDOW) (* ;  "Include the default properties in the list.") [COND ((AND TEXT (ATOM TEXT)) (* ;  "Make sure the file exists before trying to open the window.") (SETQ TEXT (OPENFILE TEXT 'INPUT 'OLD '((TYPE TEXT] (RESETLST [RESETSAVE NIL `(AND ,WINDOW (WINDOWPROP ,WINDOW 'TEXTOBJ NIL] (WITH.MONITOR TEDIT.STARTUP.MONITORLOCK (COND ((NOT WINDOW) (SETQ TEDITCREATEDWINDOW T) (SETQ WINDOW (COND [(OR (NOT TEDIT.DEFAULT.WINDOW) (\TEDIT.ACTIVE.WINDOWP TEDIT.DEFAULT.WINDOW)) (TEDIT.CREATEW (COND ((AND TEXT (ATOM TEXT)) (CONCAT "Please specify an editing window for " TEXT)) (T "Please specify a region for the editing window." )) TEXT (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS] (T (\TEDIT.CREATEW.FROM.REGION (WINDOWPROP TEDIT.DEFAULT.WINDOW 'REGION) TEXT (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS))) (* ; "Replace the old title") TEDIT.DEFAULT.WINDOW))) (* ;;  "Mark the newly-created window reserved until the OPENTEXTSTREAM has done its work.") (* ;;  "mark that we created the window so that we know we can update the title, etc.") (WINDOWPROP WINDOW 'TEXTOBJ T))))) [SETQ TEXT (OPENTEXTSTREAM TEXT WINDOW NIL NIL (APPEND PROPS '(BEING-EDITED T] (* ;  "Connect the editor to the window") (replace (TEXTOBJ TXTEDITING) of (TEXTOBJ TEXT) with T) (* ; "For the moment, mark the document as actively in edit. (so caret flashes when the window is first brought up.)") [COND (TEDITCREATEDWINDOW (TEXTPROP TEXT 'TEDITCREATEDWINDOW 'T] (COND (DONTSPAWN (* ;  "Either no processes running, or specifically not to spawn one.") (RETURN (\TEDIT2 TEXT WINDOW T))) (T (* ; "Spawn a process to do the edit.") [SETQ PROC (ADD.PROCESS (LIST '\TEDIT2 (KWOTE TEXT) WINDOW NIL) 'NAME 'TEdit 'RESTARTABLE 'HARDRESET 'RESTARTFORM (LIST '\TEDIT.RESTARTFN (KWOTE TEXT) WINDOW (KWOTE PROPS] (PROCESSPROP PROC 'WINDOW WINDOW) (COND ((NOT (LISTGET (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS)) 'LEAVETTY)) (* ;  "Unless he asked us to leave the tty where it is, TEdit should get it.") (TTY.PROCESS PROC))) (RETURN PROC]) (TEDIT.CHARWIDTH + [LAMBDA (CH FONT TERMSA) (* jds "22-OCT-83 19:32") + + (* Returns the width of CH in FONT printed according to any special printing + instructions in CHARTABLE TERMSA) + + (COND + (TERMSA (* There IS a TERMTABLE to account for) + (SELECTC (fetch CCECHO of (\SYNCODE TERMSA CH)) + (INDICATE.CCE (IPLUS (COND + ((IGREATERP CH 127)(* META character) + (SETQ CH (LOGAND CH 127)) + (CHARWIDTH (CHARCODE %#) + FONT)) + (T 0)) + (COND + ((ILESSP CH 32) (* CONTROL character) + (SETQ CH (LOGOR CH 64)) + (CHARWIDTH (CHARCODE ^) + FONT)) + (T 0)) + (CHARWIDTH CH FONT))) + (SIMULATE.CCE (SELCHARQ CH + ((EOL CR LF) + (IMAX 6 (CHARWIDTH CH FONT))) + (ESCAPE (CHARWIDTH (CHARCODE $) + FONT)) + (BELL 0) + (TAB 36) + (CHARWIDTH CH FONT))) + (REAL.CCE (CHARWIDTH CH FONT)) + (IGNORE.CCE 0) + (SHOULDNT))) + (T (* The usual case is to treat every character as a graphic.) + (SELCHARQ CH + (CR (IMAX 6 (CHARWIDTH CH FONT))) + (TAB 36) + (CHARWIDTH CH FONT]) (TEDIT.COPY + [LAMBDA (FROM TO) (* ; "Edited 4-Jun-92 11:11 by jds") + (SETQ TEDIT.COPY.PENDING NIL) (* ; + "First, Turn off the global flag that got us here.") + (COND + ((NOT (AND FROM (fetch (SELECTION SET) of FROM))) + (* ; + "There MUST be a source selected first.") + (TEDIT.PROMPTPRINT (fetch (SELECTION \TEXTOBJ) of TO) + "Copy source selection hasn't been set yet." T)) + ((ZEROP (fetch (SELECTION DCH) of FROM)) (* ; + "The source is empty. Just turn off the selection hilite and ignore the request.") + (\SHOWSEL FROM NIL NIL)) + ((fetch (TEXTOBJ TXTREADONLY) of (fetch (SELECTION \TEXTOBJ) of TO)) + (* ; "The target is read-only. Don't do anything except turn off the selection highlighting and ignore the request.") + (\SHOWSEL FROM NIL NIL)) + (T (\SHOWSEL FROM NIL NIL) (* ; + "Before all else, make sure the copy source selection is turned off") + (replace (SELECTION SET) of FROM with NIL) + (COND + ((AND TO (fetch (SELECTION SET) of TO)) (* ; + "Can only do copy if there's a target selection") + (PROG ((TOOBJ (fetch (SELECTION \TEXTOBJ) of TO)) + (FROMOBJ (fetch (SELECTION \TEXTOBJ) of FROM)) + (CROSSCOPY (NEQ (fetch (SELECTION \TEXTOBJ) of FROM) + (fetch (SELECTION \TEXTOBJ) of TO))) + TOLEN LEN INSPC INSPC# PC NPC PCCH NPCCH OPLEN EVENT REPLACING INSERTCH# PCLST + OBJ COPYFN UNDOCHAIN) + (SETQ PCLST (TEDIT.SELECTED.PIECES FROMOBJ FROM CROSSCOPY (FUNCTION + \TEDIT.COPY.PIECEMAPFN + ) + FROMOBJ TOOBJ)) (* ; + "Get the list of pieces to be copied") + (SETQ REPLACING (TEDIT.DO.BLUEPENDINGDELETE TO TOOBJ)) + (* ; "Do any blue-pending-delete") + (SETQ TOLEN (fetch (TEXTOBJ TEXTLEN) of TOOBJ)) + (\SHOWSEL TO NIL NIL) (* ; + "NOW turn off the target selection.") + [COND + ((EQ (fetch (SELECTION POINT) of TO) + 'LEFT) + (SETQ INSERTCH# (fetch (SELECTION CH#) of TO))) + (T (SETQ INSERTCH# (IMIN (fetch (SELECTION CHLIM) of TO) + (ADD1 TOLEN] (* ; + "Figure out where to do the insertion.") + (COND + ((AND (fetch (TEXTOBJ FORMATTEDP) of FROMOBJ) + (NOT (fetch (TEXTOBJ FORMATTEDP) of TOOBJ))) + (* ; + "The source is formatted and the target isn't. Give the guy a choice.") + (* ; + "For now, convert the target file to formatted.") + (\TEDIT.CONVERT.TO.FORMATTED TOOBJ))) + (SETQ UNDOCHAIN (\TEDIT.INSERT.PIECES TOOBJ INSERTCH# PCLST + (SETQ LEN (IDIFFERENCE (fetch (SELECTION CHLIM) + of FROM) + (fetch (SELECTION CH#) of FROM))) + NIL NIL CROSSCOPY NIL T)) + (bind OBJ AFTERCOPYFN for PC in PCLST + when [AND (SETQ OBJ (fetch (PIECE POBJ) of PC)) + (SETQ AFTERCOPYFN (IMAGEOBJPROP OBJ 'AFTERCOPYFN] + do (APPLY* AFTERCOPYFN OBJ)) + (SETQ EVENT (fetch (TEXTOBJ TXTHISTORY) of TOOBJ)) + (\TEDIT.HISTORYADD TOOBJ + (create TEDITHISTORYEVENT + THACTION _ (COND + (REPLACING 'Replace) + (T 'Copy)) + THLEN _ LEN + THCH# _ INSERTCH# + THFIRSTPIECE _ UNDOCHAIN + THOLDINFO _ (AND REPLACING EVENT))) + (* ; + "Make a history-list entry for the COPY.") + (replace (TEXTOBJ \DIRTY) of TOOBJ with T) + (* ; "Mark the document changed") + (replace (TEXTOBJ TEXTLEN) of TOOBJ with (IPLUS LEN TOLEN)) + (* ; "Set the new length") + (\FIXILINES TOOBJ TO INSERTCH# LEN TOLEN)(* ; "Fix LINES and SELs") + [COND + ((EQ (fetch (TEXTOBJ FORMATTEDP) of TOOBJ) + (fetch (TEXTOBJ FORMATTEDP) of FROMOBJ)) + (* ; + "Either both of the files are formatted or neither is. This case is OK") + ) + ((fetch (TEXTOBJ FORMATTEDP) of TOOBJ) + (* ; + "The source wasn't formatted, but the target is. Go convert the copied text.") + (\TEDIT.CONVERT.TO.FORMATTED TOOBJ INSERTCH# (IPLUS INSERTCH# LEN] + (TEDIT.UPDATE.SCREEN TOOBJ) (* ; "Refresh the display") + (replace (SELECTION CH#) of TO with INSERTCH#) + (* ; "Correct the target selection") + (replace (SELECTION CHLIM) of TO with (IPLUS INSERTCH# LEN)) + (replace (SELECTION DCH) of TO with LEN) + (replace (SELECTION DX) of TO with 0) + (replace (SELECTION POINT) of TO with 'RIGHT) + (* ; + "(replace CARETLOOKS of TOOBJ with (\TEDIT.GET.INSERT.CHARLOOKS TOOBJ TO))") + (* ; + "Make any later type-in look like what we just copied.") + (replace (TEXTOBJ \INSERTPCVALID) of TOOBJ with NIL) + (* ; + "And make sure that the pieces copied never have their strings smashed by back spacing.") + (replace (TEXTOBJ \INSERTPCVALID) of FROMOBJ with NIL) + (\FIXSEL TO TOOBJ) + (\SHOWSEL TO NIL T))) + (T (* ; + "There is no target selection -- complain") + (TEDIT.PROMPTPRINT (fetch (SELECTION \TEXTOBJ) of FROM) + "Please select a destination for the copy first." T]) (TEDIT.DELETE + [LAMBDA (STREAM SEL LEN LEAVECARETLOOKS) (* ; "Edited 12-Jun-90 17:49 by mitani") + + (* ;; "DELETE THE CHARACTERS SPECIFIED FROM THE MAIN TEXT.") + + (* ;; "If LEAVECARETLOOKS is non-NIL, the selection will NOT be set up to do the right thing with type-in. This can save time in inner loops.") + + (PROG ((TEXTOBJ (TEXTOBJ STREAM))) + [COND + ((FIXP SEL) + (TEDIT.SETSEL STREAM SEL LEN NIL NIL LEAVECARETLOOKS) + (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ] + (OR SEL (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))) + (\TEDIT.DELETE SEL TEXTOBJ]) (TEDIT.DO.BLUEPENDINGDELETE + [LAMBDA (SEL TEXTOBJ) (* ; "Edited 29-May-91 18:21 by jds") + (* Check for blue-pending-delete, + and do it if it's there.) + (* Return T if the deletion was + made. For people who need to know) + (COND + ((fetch (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ) + (* If he's in a Blue-pending-delete + state, delete the selection.) + (PROG1 (fetch (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ) + (COND + ((NOT (ZEROP (fetch (SELECTION DCH) of SEL))) + (* There really IS something to + delete.) + (\SHOWSEL SEL NIL NIL) (* Turn off the selection) + (\DELETECH (fetch (SELECTION CH#) of SEL) + (fetch (SELECTION CHLIM) of SEL) + (fetch (SELECTION DCH) of SEL) + TEXTOBJ) (* Delete the characters.) + (\FIXDLINES (fetch (TEXTOBJ LINES) of TEXTOBJ) + SEL + (fetch (SELECTION CH#) of SEL) + (fetch (SELECTION CHLIM) of SEL) + TEXTOBJ) (* Fix up any line descriptors to + reflect the deletion.) + (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* Make it a normal selection again.) + (replace (SELECTION CHLIM) of SEL with (fetch (SELECTION CH#) + of SEL)) + + (* Fix up the selection, so that it is 0 wide, where the old text used to be.) + + (replace (SELECTION DCH) of SEL with 0) + (replace (SELECTION POINT) of SEL with 'LEFT) + (\FIXSEL SEL TEXTOBJ) (* Make its line descriptors &c + reflect the new reality) + (\SHOWSEL SEL NIL T) (* And turn it back on.) + ) + (T (* Don't do it, since it's + zero-width. However, DO turn off the + blue-pendingness of it.) + (TEDIT.RESET.EXTEND.PENDING.DELETE SEL))))]) (TEDIT.INSERT + [LAMBDA (STREAM TEXT CH#ORSEL LOOKS DONTSCROLL) (* ; "Edited 29-May-91 18:21 by jds") + (* ; + "Insert TEXT (character, litatom or string) at the appropriate spot in the text.") + (SETQ STREAM (TEXTSTREAM STREAM)) + [COND + ((FIXP CH#ORSEL) (* ; + "He gave us a ch# to insert before") + (TEDIT.SETSEL STREAM CH#ORSEL 1 'LEFT] + [COND + ((LITATOM TEXT) + (SETQ TEXT (MKSTRING TEXT] + [OR (type? SELECTION CH#ORSEL) + (SETQ CH#ORSEL (fetch (TEXTOBJ SEL) of (fetch (TEXTSTREAM TEXTOBJ) + of STREAM] + (COND + ((AND (STRINGP TEXT) + (ZEROP (NCHARS TEXT))) (* ; + "Can't insert an empty string sensibly. It confuses the screen update code.") + NIL) + [(AND CH#ORSEL (fetch (SELECTION SET) of CH#ORSEL)) + (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) + CH# LINE XPOINT OTEXTLEN DS LINES CHARS BLANKSEEN CRSEEN) + (TEDIT.DO.BLUEPENDINGDELETE CH#ORSEL TEXTOBJ) + (* ; + "If the selected text was for pending delete, delete it before doing the insert.") + (COND + (LOOKS (* ; + "If looks for this insertion were specified, set them up.") + (TEDIT.CARETLOOKS STREAM LOOKS))) + (SETQ OTEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (* ; + "The PRE-INSERT text length, for starting the screen update process") + (COND + ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + + (* ;; "If this text is in a window, move it so the insertion point is on-screen, then turn off the selection highlight") + + (COND + ((NOT DONTSCROLL) (* ; + "If DONTSCROLL is T, then don't bother scrolling the window to show the change.") + (TEDIT.NORMALIZECARET TEXTOBJ CH#ORSEL))) + (\SHOWSEL CH#ORSEL NIL NIL))) + (SETQ CH# (IMAX 1 (SELECTQ (fetch (SELECTION POINT) of CH#ORSEL) + (LEFT (fetch (SELECTION CH#) of CH#ORSEL)) + (RIGHT (IMIN (fetch (SELECTION CHLIM) of CH#ORSEL) + (ADD1 (fetch (TEXTOBJ TEXTLEN) of + TEXTOBJ + )))) + NIL))) + (SETQ XPOINT (SELECTQ (fetch (SELECTION POINT) of CH#ORSEL) + (LEFT (fetch (SELECTION X0) of CH#ORSEL)) + (RIGHT (fetch (SELECTION XLIM) of CH#ORSEL)) + NIL)) + [COND + [(type? STRINGP TEXT) (* ; + "It's a string: Count the characters and Insert them one by one into the text stream") + (SETQ CHARS (NCHARS TEXT)) + (for ACHAR instring TEXT as NCH# from CH# by 1 + do (SELCHARQ ACHAR + ((CR %#^M 1,CR) + (SETQ CRSEEN T) + (\INSERTCR ACHAR NCH# TEXTOBJ)) + (SPACE (SETQ BLANKSEEN T) + (\INSERTCH ACHAR NCH# TEXTOBJ)) + (\INSERTCH ACHAR NCH# TEXTOBJ] + (T (* ; + "It's a singe character. Just insert it.") + (SETQ CHARS 1) + (SELCHARQ TEXT + ((CR %#^M 1,CR) + (SETQ CRSEEN T) + (\INSERTCR TEXT CH# TEXTOBJ)) + (SPACE (SETQ BLANKSEEN T) + (\INSERTCH TEXT CH# TEXTOBJ)) + (\INSERTCH TEXT CH# TEXTOBJ] + (\FIXILINES TEXTOBJ CH#ORSEL CH# CHARS OTEXTLEN) + (* ; + "Fix up the line descriptors and the Selection.") + (COND + ((NOT (fetch (TEXTOBJ TXTREADONLY) of (TEXTOBJ STREAM))) + (* ; "Update the edit window.") + (TEDIT.INSERT.UPDATESCREEN TEXT CH# CHARS XPOINT TEXTOBJ CH#ORSEL OTEXTLEN + BLANKSEEN CRSEEN DONTSCROLL] + ((NOT (fetch (TEXTOBJ TXTREADONLY) of (TEXTOBJ STREAM))) + (TEDIT.PROMPTPRINT (TEXTOBJ STREAM) + "Please select a place for the insertion." T]) (TEDIT.KILL + [LAMBDA (STREAM) (* ; "Edited 12-Jun-90 17:49 by mitani") + (* Force the edit session supported + by STREAM to terminate, and to + return VALUE) + (COND + ((type? STREAM STREAM) (* If he gave us a textofd, get the + textobj) + (SETQ STREAM (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) + [(WINDOWP STREAM) (* Take a window, and do the obvious + with it.) + (SETQ STREAM (WINDOWPROP STREAM 'TEXTOBJ] + ((type? TEXTOBJ STREAM) (* A Textobj is just fine) + ) + (T (* Anything else is ungood, + double-plus) + (\ILLEGAL.ARG STREAM))) + (replace (TEXTOBJ EDITFINISHEDFLG) of STREAM with T) + (PROG (TEDW TEDPROC) + (AND (SETQ TEDW (CAR (fetch (TEXTOBJ \WINDOW) of STREAM))) + [PROCESSP (SETQ TEDPROC (WINDOWPROP TEDW 'PROCESS] + (NEQ TEDPROC (THIS.PROCESS)) + (DEL.PROCESS TEDPROC) + (TEDIT.DEACTIVATE.WINDOW TEDW]) (TEDIT.MAPLINES + [LAMBDA (TEXTOBJ FN) (* ; "Edited 29-May-91 18:19 by jds") + + (* Go thru the visible lines in a textobj and call a mapping fn on them) + + (* FN has 2 args%: the LINEDESCRIPTOR, and a VISIBLEFLG to say if the line is + visible on the screen.) + + (bind (LINE _ (fetch (LINEDESCRIPTOR NEXTLINE) of (fetch (TEXTOBJ LINES) + of TEXTOBJ))) + (BOT _ (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + [TOP _ (fetch (REGION HEIGHT) of (DSPCLIPPINGREGION (\TEDIT.PRIMARYW TEXTOBJ] + while LINE do (COND + ((EQ (APPLY* FN LINE (AND (ILESSP (fetch (LINEDESCRIPTOR YBOT) + of LINE) + TOP) + (IGEQ (fetch (LINEDESCRIPTOR YBOT) + of LINE) + BOT))) + 'STOP) + (RETURN))) + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE]) (TEDIT.MAPPIECES + [LAMBDA (TEXTOBJ FN FNARG) (* ; "Edited 22-Apr-93 16:02 by jds") + + (* ;; "Go thru all the pieces in a document, applying a function to them serially") + + (* ;; "FN is a function of 3 args (PIECE CH#-of-1st-char-in-piece PIECE# in table FNARG)") + + (PROG ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + (CH# 1) + PCNODE PC) + (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB) + 0)) + (OR (ATOM PC) + (RETURN (for I from 1 while PC + do [COND + ((EQ (APPLY* FN CH# PC I FNARG) + 'STOP) + (RETURN (LIST CH# PC I] + (add CH# (fetch (PIECE PLEN) of PC)) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC]) (TEDIT.MOVE + [LAMBDA (FROM TO) (* ; "Edited 29-May-91 18:21 by jds") + + (* ;; + "Move the text described by the selection FROM to the place described by the selection TO") + + (SETQ TEDIT.MOVE.PENDING NIL) (* ; + "First, Turn off the global flag that got us here.") + (COND + ((NOT (AND FROM (fetch (SELECTION SET) of FROM))) + (* ; + "There MUST be a source selected first.") + (TEDIT.PROMPTPRINT (fetch (SELECTION \TEXTOBJ) of TO) + "Move source selection hasn't been set yet." T)) + ((ZEROP (fetch (SELECTION DCH) of FROM)) (* ; + "The source selection is empty. Just turn it off.") + (\SHOWSEL FROM NIL NIL)) + ((fetch (TEXTOBJ TXTREADONLY) of (fetch (SELECTION \TEXTOBJ) of TO)) + (* ; + "The target is read-only. Skip it..") + (\SHOWSEL FROM NIL NIL)) + (T (\SHOWSEL FROM NIL NIL) (* ; + "Before all else, make sure the copy source selection is turned off") + (COND + ((AND TO (fetch (SELECTION SET) of TO)) (* ; + "Can only do copy if there's a target selection") + (PROG ((TOOBJ (fetch (SELECTION \TEXTOBJ) of TO)) + (FROMOBJ (fetch (SELECTION \TEXTOBJ) of FROM)) + (TOLEN (fetch (TEXTOBJ TEXTLEN) of (fetch (SELECTION \TEXTOBJ) + of TO))) + (TOPCTB (fetch (TEXTOBJ PCTB) of (fetch (SELECTION \TEXTOBJ) + of TO))) + (FROMPCTB (fetch (TEXTOBJ PCTB) of (fetch (SELECTION \TEXTOBJ) + of FROM))) + (CROSSCOPY (NEQ (fetch (SELECTION \TEXTOBJ) of FROM) + (fetch (SELECTION \TEXTOBJ) of TO))) + LEN INSPC INSPC# PC NPC PCCH NPCCH OPLEN EVENT REPLACING INSERTCH# PCLST OBJ + COPYFN UNDOCHAIN) (* ; "Find the insertion point") + (SETQ PCLST (TEDIT.SELECTED.PIECES FROMOBJ FROM CROSSCOPY (FUNCTION + \TEDIT.MOVE.PIECEMAPFN + ) + FROMOBJ TOOBJ)) (* ; + "Grab the pieces that reflect the source selection") + (SETQ REPLACING (TEDIT.DO.BLUEPENDINGDELETE TO TOOBJ)) + (* ; "Do any blue-pending-delete") + (SETQ TOPCTB (fetch (TEXTOBJ PCTB) of TOOBJ)) + (* ; + "Get the new PCTB and text length") + (SETQ EVENT (fetch (TEXTOBJ TXTHISTORY) of TOOBJ)) + (SETQ LEN (IDIFFERENCE (fetch (SELECTION CHLIM) of FROM) + (fetch (SELECTION CH#) of FROM))) + (\DELETECH (fetch (SELECTION CH#) of FROM) + (fetch (SELECTION CHLIM) of FROM) + (fetch (SELECTION DCH) of FROM) + FROMOBJ) (* ; + "Now delete the text from its old place") + (\FIXDLINES (fetch (TEXTOBJ LINES) of FROMOBJ) + FROM + (fetch (SELECTION CH#) of FROM) + (fetch (SELECTION CHLIM) of FROM) + FROMOBJ) + (SETQ TOLEN (fetch (TEXTOBJ TEXTLEN) of TOOBJ)) + (\SHOWSEL TO NIL NIL) (* ; + "NOW turn off the target selection.") + (replace (SELECTION SET) of FROM with NIL) + [COND + ((EQ (fetch (SELECTION POINT) of TO) + 'LEFT) + (SETQ INSERTCH# (fetch (SELECTION CH#) of TO))) + (T (SETQ INSERTCH# (fetch (SELECTION CHLIM) of TO] + (* ; + "Figure out where to do the insertion.") + (\TEDIT.INSERT.PIECES TOOBJ INSERTCH# PCLST LEN NIL NIL CROSSCOPY) + (* ; + "Get the pieces that actually got inserted, so we can UNDO the move") + + (* ;; "Keep the target from sharing a piece with type-in by accident:") + + (replace (TEXTOBJ \INSERTPCVALID) of TOOBJ with NIL) + + (* ;; "Keep \DELETECH from playing clever games with the piece if it's new type-in: Don't let it be reclaimed by the deletion:") + + (replace (TEXTOBJ \INSERTPCVALID) of FROMOBJ with NIL) + (replace (TEXTOBJ \INSERTPC) of FROMOBJ with NIL) + (\TEDIT.HISTORYADD TOOBJ + (create TEDITHISTORYEVENT + THTEXTOBJ _ TOOBJ + THACTION _ (COND + (REPLACING 'ReplaceMove) + (T 'Move)) + THLEN _ LEN + THCH# _ INSERTCH# + THFIRSTPIECE _ PCLST + THAUXINFO _ FROMOBJ + THOLDINFO _ (fetch (SELECTION CH#) of FROM))) + (* ; + "Make a history-list entry for the COPY.") + (replace (TEXTOBJ \DIRTY) of TOOBJ with T) + (* ; "Mark the document changed") + (replace (TEXTOBJ TEXTLEN) of TOOBJ with (IPLUS LEN TOLEN)) + (* ; "Set the new length") + (\FIXILINES TOOBJ TO INSERTCH# LEN TOLEN)(* ; "Fix LINES and SELs") + (COND + ((EQ (fetch (TEXTOBJ FORMATTEDP) of TOOBJ) + (fetch (TEXTOBJ FORMATTEDP) of FROMOBJ)) + (* ; + "Either both of the files are formatted or neither is. This case is OK") + ) + ((fetch (TEXTOBJ FORMATTEDP) of TOOBJ) + (* ; + "The source wasn't formatted, but the target is. Go convert the copied text.") + (\TEDIT.CONVERT.TO.FORMATTED TOOBJ INSERTCH# (IPLUS INSERTCH# LEN))) + (T (* ; + "The source is formatted and the target isn't. Give the guy a choice.") + (* ; + "For now, convert the target file to formatted.") + (\TEDIT.CONVERT.TO.FORMATTED TOOBJ))) + (TEDIT.UPDATE.SCREEN FROMOBJ) + (TEDIT.UPDATE.SCREEN TOOBJ) (* ; "Refresh the display") + (replace (SELECTION CH#) of TO with INSERTCH#) + (* ; "Correct the target selection") + (replace (SELECTION CHLIM) of TO with (IPLUS INSERTCH# LEN)) + (replace (SELECTION DCH) of TO with LEN) + (replace (SELECTION DX) of TO with 0) + (replace (SELECTION POINT) of TO with 'RIGHT) + (COND + ((NEQ TO FROM) + (\FIXSEL FROM FROMOBJ) + (\FIXSEL (fetch (TEXTOBJ SEL) of FROMOBJ) + FROMOBJ))) + (\FIXSEL TO TOOBJ) + (\SHOWSEL TO NIL T))) + (T (* ; + "There is no target selection -- complain") + (TEDIT.PROMPTPRINT (fetch (SELECTION \TEXTOBJ) of FROM) + "Please select a destination for the MOVE first." T]) (TEDIT.QUIT + [LAMBDA (STREAM VALUE) (* ; "Edited 12-Jun-90 17:49 by mitani") + + (* ;; "Force the edit session supported by STREAM to terminate, and to return VALUE") + + (COND + ((type? STREAM STREAM) (* ; + "If he gave us a textofd, get the textobj") + (SETQ STREAM (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) + ((type? TEXTOBJ STREAM) (* ; "A Textobj is just fine") + ) + (T (* ; + "Anything else is ungood, double-plus") + (\ILLEGAL.ARG STREAM))) + (replace (TEXTOBJ EDITFINISHEDFLG) of STREAM with (OR VALUE T)) + (* ; + "tell the command loop to stop next time through") + (PROG (MAINW) + (COND + ([AND (fetch (TEXTOBJ \WINDOW) of STREAM) + (NEQ (SETQ MAINW (\TEDIT.PRIMARYW STREAM)) + (PROCESSPROP (TTY.PROCESS) + 'WINDOW] + + (* ;; "there is a main window of the stream, and it is not the window of the tty process, so give it the tty") + + (TTY.PROCESS (WINDOWPROP MAINW 'PROCESS)) + (AND (NEQ (TTY.PROCESS) + (THIS.PROCESS)) + (until [OR (NOT (WINDOWPROP MAINW 'PROCESS)) + (PROCESS.FINISHEDP (WINDOWPROP MAINW 'PROCESS] do + (* ; + "Wait until the Edit process has had a chance to go away before continuing here.") + (DISMISS]) (TEDIT.STRINGWIDTH + [LAMBDA (STR FONT TERMSA) (* jds "19-AUG-83 14:40") + (COND + (TERMSA + + (* We have a terminal table to take account of. + Do so.) + + (for CH instring STR sum (TEDIT.CHARWIDTH CH FONT TERMSA))) + (T (* Just use the native character + widths) + (for CH instring STR sum (SELCHARQ CH + (TAB 36) + (CHARWIDTH CH FONT]) (TEDIT.\INSERT + [LAMBDA (CH SEL STREAM) (* ; "Edited 29-May-91 18:22 by jds") + (* Insert the character CH at the + appropriate spot in the text.) + (DECLARE (LOCALVARS . T)) + (PROG [(TEXTOBJ (COND + ((type? STREAM STREAM) (* If we got a STREAM, change it + into a textobj) + (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) + (T STREAM] + (COND + ((NOT (AND SEL (fetch (SELECTION SET) of SEL))) + (TEDIT.PROMPTPRINT TEXTOBJ "Please select a place for the insertion." T) + (RETURN))) + (COND + ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + + (* There is a window; make sure the insert point is on-screen, and turn off any + highlighted selection) + + (TEDIT.NORMALIZECARET TEXTOBJ SEL) + (\SHOWSEL SEL NIL NIL))) + (PROG ((CH# (TEDIT.GETPOINT STREAM SEL)) + (XPOINT (SELECTQ (fetch (SELECTION POINT) of SEL) + (LEFT (fetch (SELECTION X0) of SEL)) + (RIGHT (fetch (SELECTION XLIM) of SEL)) + NIL)) + (OTEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) + (SELCHARQ CH + ((CR %#^M 1,CR) (* This was a CR. Go do the para + breaking as needed) + (\INSERTCR CH CH# TEXTOBJ)) + (\INSERTCH CH CH# TEXTOBJ)) + (\FIXILINES TEXTOBJ SEL CH# 1 OTEXTLEN) + (TEDIT.INSERT.UPDATESCREEN CH CH# 1 XPOINT TEXTOBJ SEL OTEXTLEN NIL NIL NIL T]) (TEXTOBJ + [LAMBDA (STREAM) (* jds "11-Jul-85 12:06") + (* Convert from a text stream to the + associated textobj) + (COND + ((type? TEXTOBJ STREAM) (* It's already a TEXTOBJ) + STREAM) + ((AND (type? STREAM STREAM) + (fetch (TEXTSTREAM TEXTOBJ) of STREAM) + (type? TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) + (* It's a TEXTSTREAM) + (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) + ((AND (PROCESSP STREAM) + (PROCESS.WINDOW STREAM)) (* It's an edit PROCESS) + (WINDOWPROP (PROCESS.WINDOW STREAM) + 'TEXTOBJ)) + [(AND (WINDOWP STREAM) + (WINDOWPROP STREAM 'TEXTOBJ] + [(AND (DISPLAYSTREAMP STREAM) + (WINDOWPROP STREAM 'TEXTOBJ] + ((\ILLEGAL.ARG STREAM]) (TEXTSTREAM + [LAMBDA (STREAM) (* ; "Edited 12-Jun-90 17:50 by mitani") + (* Force a textobj or stream to be a + stream) + (COND + ((AND (type? STREAM STREAM) + (fetch (TEXTSTREAM TEXTOBJ) of STREAM) + (type? TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) + (* It's a stream, and is really a + TEXT stream. Just return it.) + STREAM) + ((type? TEXTOBJ STREAM) (* It's a TEXTOBJ, so grab the + stream hint field and return that.) + (fetch (TEXTOBJ STREAMHINT) of STREAM)) + ((AND (PROCESSP STREAM) + (PROCESS.WINDOW STREAM)) (* It's an edit process, so grab the + text stream from the edit window.) + (WINDOWPROP (PROCESS.WINDOW STREAM) + 'TEXTSTREAM)) + [(AND (WINDOWP STREAM) + (WINDOWPROP STREAM 'TEXTSTREAM] + [(AND (DISPLAYSTREAMP STREAM) + (WINDOWPROP STREAM 'TEXTSTREAM] + ((\ILLEGAL.ARG STREAM) (* Not a reasonable coercion to the + text stream. Punt.) + ]) (\TEDIT.INCLUDE + [LAMBDA (TEXTOBJ FILE START END) (* ; "Edited 29-May-91 18:22 by jds") + + (* A NATIVE text includer%: Includes part of a file, without checking to see if + it's a bravo file, a TEdit file or whatever.) + (* (PROG ((LEN (IDIFFERENCE + (OR END (GETEOFPTR FILE)) + (OR START 0))) (SEL + (fetch (TEXTOBJ SEL) of TEXTOBJ)) + NPC) (SETQ NPC (create PIECE PFILE _ + (\GETOFD FILE (QUOTE INPUT)) PFPOS _ + (OR START 0) PLEN _ LEN PLOOKS _ + (\TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ + SEL) PPARALOOKS _ NIL)) + (* Create a PIECE to describe the + text) (\TEDIT.INSERT.PIECES TEXTOBJ + (fetch (SELECTION CH#) of SEL) NPC + LEN) (* Insert it in the document) + (add (fetch (TEXTOBJ TEXTLEN) of + TEXTOBJ) LEN) (* And update the + document's length) + (\TEDIT.MARK.LINES.DIRTY TEXTOBJ + (fetch (SELECTION CH#) of SEL) + (IPLUS (fetch (SELECTION CH#) of SEL) + LEN)) (* Mark the screen dirty, so updating it will find something to do) (replace + (SELECTION CHLIM) of SEL with + (IPLUS (fetch (SELECTION CH#) of SEL) + LEN)) (replace (SELECTION DCH) of SEL with LEN) (replace (SELECTION DX) of SEL with 0) + (replace (SELECTION POINT) of SEL + with (QUOTE RIGHT)) + (replace (SELECTION SELKIND) of SEL + with (QUOTE CHAR)) + (replace (SELECTION SELOBJ) of SEL + with NIL) (COND ((fetch + (TEXTOBJ \WINDOW) of TEXTOBJ) + (\SHOWSEL SEL NIL NIL) + (TEDIT.UPDATE.SCREEN TEXTOBJ) + (\FIXSEL SEL TEXTOBJ) + (\SHOWSEL SEL NIL T))) + (* Update the screen) + (replace (TEXTOBJ \DIRTY) of TEXTOBJ + with T) (\SETUPGETCH + (fetch (SELECTION CH#) of SEL) + TEXTOBJ))) + (HELP]) (\TEDIT.INSERT.PIECES [LAMBDA (TEXTOBJ CH# FIRSTPIECE %#CHARS INSPC INSPC# CROSSCOPY DONTDIRTY COPYING) (* ; "Edited 11-Jun-99 14:03 by rmk:") (* ;  "Edited 24-Apr-95 12:04 by sybalsky:mv:envos") (* ;; "Inserts a series of pieces into TEXTOBJ in front of character CH#.") (* ;; "If FIRSTPIECE is a PIECE, this will follow the next-piece pointer chain; if FIRSTPIECE is a list, it is a list of pieces to insert.") (* ;; "If CROSSCOPY is non-NIL, the pieces' contents will be copied, to preserve text in case the original is deleted.") (* ;; "INSPC and INSPC# are accelerators for where in the PCTB the new pieces should go.") (* ;; "DONTDIRTY is T if this is a change not visible to the user--one that shouldn't %"dirty%" the document. This is used tor NS-character encoding recognition durint line formatting.") (* ;; "COPYING is T if these pieces are being inserted by a COPY operation. This lets us call the AFTERCOPYFN on image objects.") (* ;; "It is the CALLER'S RESPONSIBILITY to make sure the pieces to be inserted are 'safe' --that they are, if necessary, copies of the originals, and can safely be modified.") (* ;  "NB THAT THIS DOES NOT UPDATE TEXTLEN") (COND ((OR DONTDIRTY (NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ))) (* ;; "Only do this if you're allowed to change the document, or it's a TEdit-intertnal fixup change, as for NS char recognition.") (LET ((TOLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) (TOPCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (CURCH# CH#) LEN PC PREVPC NPC UNDOCHAIN PSTR SRCPFILE START-OF-PIECE) (* ;  "Get a handle on the piece we're to insert within or in front of") (* THIS USED TO WORK, BUT WITH NEW PCTREE CODE, IT CAUSES AN EMPTY PIECE AT  START OF DOC THAT'S NOT FORWARD-CONNECTED.  COND ((ZEROP (fetch (BTREENODE TOTLEN) of TOPCTB))  (* ; "PCTB is empty.") (\INSERT.FIRST.PIECE TEXTOBJ))) (SETQ INSPC (\CHTOPC CH# TOPCTB T)) (* ; "And the piece, itself. (Used to be (OR INSPC (\CH...)), but we MUST set START-OF-PIECE, so must make the call to \CHTOPC.") (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (* ;  "Force later insertions to make new pieces.") [COND ((IGREATERP CH# TOLEN) (* ;  "We're inserting at end of file; leave the piece to insert before as LASTPIECE") ) ((IEQP CH# START-OF-PIECE) (* ;  "The insertion is IN FRONT of this piece; just continue on") ) (T (SETQ INSPC (\SPLITPIECE INSPC (- CH# START-OF-PIECE) TEXTOBJ] (* ;  "Nope, we're inserting INSIDE this piece. Split it in two.") (COND ((NEQ INSPC 'LASTPIECE) (* ;  "Not the last piece, so back up using the pointer.") (SETQ PREVPC (fetch (PIECE PREVPIECE) of INSPC))) ((NOT (ZEROP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) (* ;  "If we are at the end, AND there is text before us, find it thru the pctb.") (SETQ PREVPC (\CHTOPC (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) TOPCTB))) (T (* ;  "Otherwise, there is no piece before where we're inserting.") (SETQ PREVPC NIL))) (* ; "For pushing para looks in") (bind [PC _ (create PIECE using (COND ((LISTP FIRSTPIECE) (pop FIRSTPIECE)) (T FIRSTPIECE] (LEN _ 0) (PCCOUNT _ 0) first (SETQ UNDOCHAIN PC) while (AND PC (OR (NOT %#CHARS) (ILESSP LEN %#CHARS))) do (* ;  "Now insert the copied pieces into the new place") (COND ((AND CROSSCOPY (SETQ SRCPFILE (fetch (PIECE PFILE) of PC))) (* ;; "If this is a cross-document copy, and the text comes from a file, we must REALLY make a copy of the text, lest the source file be deleted.") (* ;; "(replace PSTR of PC with (SETQ PSTR (ALLOCSTRING (fetch PLEN of PC) NIL NIL (fetch PFATP of PC))))") (replace (PIECE PFILE) of PC with (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW)) (* ; "Create the holding file") [COND ((NOT (OPENP SRCPFILE)) (* ;  "The source file was CLOSED -- reopen it, for our us") (replace (PIECE PFILE) of PC with (SETQ SRCPFILE (OPENSTREAM SRCPFILE 'INPUT 'OLD '((TYPE TEXT] (SETFILEPTR SRCPFILE (fetch (PIECE PFPOS) of PC)) [COPYCHARS SRCPFILE (fetch (PIECE PFILE) of PC) (fetch (PIECE PFPOS) of PC) (IPLUS (fetch (PIECE PFPOS) of PC) (COND ((fetch (PIECE PFATP) of PC) (LLSH (fetch (PIECE PLEN) of PC) 1)) (T (fetch (PIECE PLEN) of PC] (replace (PIECE PFPOS) of PC with 0))) (replace (PIECE PLOOKS) of PC with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (PIECE PLOOKS) of PC) TEXTOBJ)) (replace (PIECE PPARALOOKS) of PC with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (PIECE PPARALOOKS ) of PC) TEXTOBJ)) (* ;  "Assure that the new document knows about this piece's looks") [COND ((NULL FIRSTPIECE) (SETQ NPC NIL)) [(LISTP FIRSTPIECE) (* ;  "If the piece list really IS a list, grab the next piece from the front") (SETQ NPC (create PIECE using (pop FIRSTPIECE] (T (* ;  "Otherwise, follow the NEXTPIECE chain among pieces") (SETQ NPC (create PIECE using (fetch (PIECE NEXTPIECE) of PC] (\INSERTPIECE PC INSPC TEXTOBJ NIL) (* ;  "Insert the piece into the new document") [COND (COPYING (* ;; "For objects, call the optional AFTERCOPYFN.") (LET (OBJ AFTERFN) (AND (SETQ OBJ (ffetch (PIECE POBJ) of PC)) (SETQ AFTERFN (IMAGEOBJPROP OBJ 'AFTERCOPYFN)) (APPLY* AFTERFN OBJ PC CURCH#] (add CURCH# (fetch (PIECE PLEN) of PC)) (add LEN (fetch (PIECE PLEN) of PC)) (SETQ PC NPC)) (\TEDIT.DIFFUSE.PARALOOKS PREVPC INSPC) UNDOCHAIN]) (\TEDIT.MOVE.PIECEMAPFN + [LAMBDA (PC TEXTOBJ FROMOBJ TOOBJ) (* ; "Edited 12-Jun-90 17:50 by mitani") + (* Called by TEDIT.MOVE via + TEDIT.SELECTED.PIECES, to do the + move-operation processing on the + candidate pieces.) + (PROG (OBJ MOVEFN) + (SETQ PC (create PIECE using PC PNEW _ T)) (* No matter what, we need a fresh + copy.) + [COND + [(fetch (PIECE POBJ) of PC) (* This piece describes an object) + (* Call its WHENMOVEDFN.) + (SETQ OBJ (fetch (PIECE POBJ) of PC)) + (COND + ((SETQ MOVEFN (IMAGEOBJPROP OBJ 'WHENMOVEDFN)) + (* If there's an eventfn for moving, + use it.) + (APPLY* MOVEFN OBJ (CAR (fetch (TEXTOBJ \WINDOW) of TOOBJ)) + (fetch (TEXTOBJ STREAMHINT) of FROMOBJ) + (fetch (TEXTOBJ STREAMHINT) of TOOBJ] + ((fetch (PIECE PSTR) of PC) + + (* If the piece is a string, make our own copy of the string header, even tho + we share characters.) + + (replace (PIECE PSTR) of PC with (SUBSTRING (fetch (PIECE PSTR) + of PC) + 1 + (fetch (PIECE PLEN) + of PC] + (RETURN PC]) (\TEDIT.OBJECT.SHOWSEL + [LAMBDA (TEXTOBJ SEL ON SELWINDOW) (* ; "Edited 12-Jun-90 17:50 by mitani") + + (* ;; "We are hilighting (or dehilighting) a selected object. Let it know.") + + (LET ((X (fetch (SELECTION X0) of SEL)) + (Y (fetch (SELECTION Y0) of SEL)) + (FIRSTLINE (CAR (fetch (SELECTION L1) of SEL))) + (OBJ (fetch (SELECTION SELOBJ) of SEL)) + (WIDTH (fetch (SELECTION DX) of SEL)) + (XOFFSET (DSPXOFFSET NIL SELWINDOW)) + (YOFFSET (DSPYOFFSET NIL SELWINDOW)) + (IMAGEFN (IMAGEOBJPROP (fetch (SELECTION SELOBJ) of SEL) + 'WHENOPERATEDONFN)) + (WWIDTH (WINDOWPROP SELWINDOW 'WIDTH)) + (WHEIGHT (WINDOWPROP SELWINDOW 'HEIGHT)) + IMAGEBOX) + (COND + ((INSIDE? (CREATEREGION 0 0 WWIDTH WHEIGHT) + X Y) (* ; + "Only do this if teh selection is on-screen.") + (SETQ IMAGEBOX (OR (IMAGEOBJPROP OBJ 'BOUNDBOX) + (APPLY* (IMAGEOBJPROP OBJ 'IMAGEBOXFN) + OBJ SELWINDOW))) + [COND + (FIRSTLINE + + (* ;; "There's really a line this selection is being displayed on, so we need to use the YBASE of the line- the object's descent, rather than the YBOT, which is what Y0 is.") + + (SETQ Y (- (fetch (LINEDESCRIPTOR YBASE) of FIRSTLINE) + (fetch (IMAGEBOX YDESC) of IMAGEBOX] + (RESETLST + [RESETSAVE (DSPXOFFSET (IDIFFERENCE (IPLUS X XOFFSET) + (fetch XKERN of IMAGEBOX)) + SELWINDOW) + (LIST (FUNCTION DSPXOFFSET) + XOFFSET + (WINDOWPROP SELWINDOW 'DSP] + (RESETSAVE (DSPYOFFSET (IPLUS Y YOFFSET) + SELWINDOW) + (LIST (FUNCTION DSPYOFFSET) + YOFFSET SELWINDOW)) + (RESETSAVE (DSPCLIPPINGREGION (create REGION + LEFT _ 0 + BOTTOM _ 0 + WIDTH _ (IMIN WIDTH (IDIFFERENCE + (fetch (TEXTOBJ + WRIGHT) + of TEXTOBJ) + X)) + HEIGHT _ (fetch YSIZE of IMAGEBOX)) + SELWINDOW) + (LIST (FUNCTION DSPCLIPPINGREGION) + (DSPCLIPPINGREGION NIL SELWINDOW) + SELWINDOW)) + [AND IMAGEFN (ERSETQ (APPLY* IMAGEFN OBJ SELWINDOW (COND + (ON 'HIGHLIGHTED) + (T 'UNHIGHLIGHTED)) + SEL + (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ])]) (\TEDIT.RESTARTFN + [LAMBDA (TEXT WINDOW PROPS) (* ; "Edited 12-Jun-90 17:51 by mitani") + (* Restarts a TEdit session.) + (replace (TEXTOBJ \WINDOW) of (fetch (TEXTSTREAM TEXTOBJ) of TEXT) + with NIL) (* Unattach the window, so we do a + redisplay.) + (PROG [(ODIRTY (fetch (TEXTOBJ \DIRTY) of (fetch (TEXTSTREAM TEXTOBJ) + of TEXT] + (SETQ TEXT (OPENTEXTSTREAM TEXT WINDOW NIL NIL PROPS)) + (replace (TEXTOBJ \DIRTY) of (fetch (TEXTSTREAM TEXTOBJ) of TEXT) + with ODIRTY)) (* Now reconnect the world together + again) + (\TEDIT.COMMAND.LOOP (fetch (TEXTSTREAM TEXTOBJ) of TEXT)) + (* Run the editing engine) + (CLOSEW WINDOW) (* Close the edit window) + (\TEXTCLOSEF TEXT) (* Close the underlying files) + (replace (STREAM ACCESSBITS) of TEXT with BothBits) + (* But leave the stream itself + accessible) + (AND (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) + 'AFTERQUITFN) + (APPLY* (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) + 'AFTERQUITFN) + WINDOW TEXT)) (* Apply any post-window-close + (and post-QUIT) function) + ]) (\TEDIT.CHARDELETE + [LAMBDA (TEXTOBJ SCRATCHSTRING SEL) (* ; "Edited 19-Apr-93 10:50 by jds") + + (* ;; "Do character-backspace deletion for TEDIT") + + (SETQ TEXTOBJ (TEXTOBJ TEXTOBJ)) + (PROG ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + TLEN INSCH# INSPC INSPC# TLOOKS START-OF-PIECE) + (COND + [NIL [NOT (ZEROP (SETQ TLEN (fetch (STRINGP OFFST) of SCRATCHSTRING] + (* ; + "If we didn't really insert the text yet, just remove from the text to be inserted") + (replace (STRINGP OFFST) of SCRATCHSTRING with (SUB1 TLEN)) + (replace (STRINGP LENGTH) of SCRATCHSTRING + with (ADD1 (fetch (STRINGP LENGTH) of SCRATCHSTRING] + (T (* ; + "Delete the character just before the current insertpoint.") + (SELECTQ (fetch (SELECTION POINT) of SEL) + (LEFT (SETQ INSCH# (SUB1 (fetch (SELECTION CH#) of SEL)))) + (RIGHT (SETQ INSCH# (SUB1 (fetch (SELECTION CHLIM) of SEL)))) + NIL) + (COND + ((ILEQ INSCH# 0) (* ; + "Can't backspace past start of document") + (RETURN))) + + (* ;; "(SETQ INSPC (\EDITELT PCTB (ADD1 (SETQ INSPC# (\CHTOPCNO INSCH# PCTB)))))") + + (SETQ INSPC (\CHTOPC INSCH# PCTB T)) + (SETQ TLOOKS (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS) of INSPC) + INSPC TEXTOBJ)) + [while (AND INSPC (fetch CLINVISIBLE of TLOOKS)) + do (* ; + "Back over any invisible text, which we're no allowed to delete.") + (SETQ INSPC (fetch (PIECE PREVPIECE) of INSPC)) + (SETQ INSCH# (SUB1 START-OF-PIECE)) + (add START-OF-PIECE (IMINUS (fetch (PIECE PLEN) of INSPC))) + (COND + (INSPC (SETQ TLOOKS (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS) + of INSPC) + INSPC TEXTOBJ] + (COND + ((ILEQ INSCH# 0) (* ; + "We backed up to the start of the document. Can't go no further.") + (RETURN)) + ((NOT (fetch CLPROTECTED of TLOOKS)) + (* ; + "Can only backspace if the char to go isn't protected.") + (replace (SELECTION CHLIM) of SEL + with (ADD1 (replace (SELECTION CH#) of SEL with INSCH#))) + (* ; + "Set up the selection to point to the character which is to be deleted.") + (replace (SELECTION DCH) of SEL with 1) + (\SHOWSEL SEL NIL NIL) (* ; + "Turn off the underlining, if any, so there's no garbage.") + (\FIXSEL SEL TEXTOBJ) (* ; + "Fix the selection up so it points to the right line and all") + (\TEDIT.DELETE SEL TEXTOBJ T) (* ; "And delete it.") + ]) (\TEDIT.COPY.PIECEMAPFN + [LAMBDA (PC TEXTOBJ FROMOBJ TOOBJ) (* ; "Edited 12-Jun-90 17:50 by mitani") + (* Called by TEDIT.COPY via + TEDIT.SELECTED.PIECES, to do the + copy-operation processing on the + candidate pieces.) + (PROG (OBJ NEWOBJ COPYFN) + (SETQ PC (create PIECE using PC PNEW _ T)) (* No matter what, we need a fresh + copy.) + [COND + ((fetch (PIECE POBJ) of PC) (* This piece describes an object) + (SETQ OBJ (fetch (PIECE POBJ) of PC)) + [COND + [(SETQ COPYFN (IMAGEOBJPROP OBJ 'COPYFN)) + (SETQ NEWOBJ (APPLY* COPYFN OBJ (fetch (TEXTOBJ STREAMHINT) of FROMOBJ) + (fetch (TEXTOBJ STREAMHINT) of TOOBJ))) + (COND + ((EQ NEWOBJ 'DON'T) (* He said not to copy this piece -- + abort the whole copy.) + (TEDIT.PROMPTPRINT TEXTOBJ "COPY of this object not allowed." T) + (RETFROM 'TEDIT.COPY)) + (NEWOBJ (replace (PIECE POBJ) of PC with NEWOBJ)) + (T (replace (PIECE POBJ) of PC with (COPYALL OBJ] + (OBJ (* No copy fn; just strike off a + copy of our own) + (replace (PIECE POBJ) of PC with (COPYALL OBJ] + (COND + ((SETQ COPYFN (IMAGEOBJPROP OBJ 'WHENCOPIEDFN)) + (* If there's an eventfn for + copying, use it.) + (APPLY* COPYFN OBJ (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of TOOBJ)) + 'DSP) + (fetch (TEXTOBJ STREAMHINT) of FROMOBJ) + (fetch (TEXTOBJ STREAMHINT) of TOOBJ] + [COND + ((fetch CLPROTECTED of (fetch (PIECE PLOOKS) of PC)) + (* The source text was protected; + unprotect the copy.) + (replace (PIECE PLOOKS) of PC + with (\TEDIT.UNIQUIFY.CHARLOOKS (create CHARLOOKS + using (fetch (PIECE PLOOKS) + of PC) + CLPROTECTED _ NIL CLSELHERE _ NIL) + TOOBJ] + (RETURN PC]) (\TEDIT.DELETE + [LAMBDA (SEL STREAM SELOFF) (* ; "Edited 29-May-91 18:22 by jds") + (* ; + "DELETE THE CHARACTERS SPECIFIED FROM THE MAIN TEXT.") + (* ; + "SELOFF => The selection is already turned off.") + (LET* + ((TEXTOBJ (TEXTOBJ STREAM)) + (CH# (fetch (SELECTION CH#) of SEL)) + (CHLIM (fetch (SELECTION CHLIM) of SEL)) + (LINES (fetch (TEXTOBJ LINES) of TEXTOBJ)) + (WINDOW (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) + (HEIGHTCHANGED NIL) + (NLINE1 NIL) + (CRFLAG NIL) + (LINES\DELETED NIL) + OLINE1 OLINEN LEN NEXTLINE NL OLINE DX OCHLIM OXLIM OLHEIGHT OLASCENT OLDESCENT DY PREVLINE + TEXTLEN OCR\END SAVEWIDTH IMAGECACHE) + [SETQ LEN (COND + ((IGREATERP CH# (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (* ; + "Past end of text, so don't delete any") + 0) + ((IGEQ CH# CHLIM) (* ; + "Start is past end, so don't delete any.") + 0) + ((ZEROP (fetch (SELECTION DCH) of SEL)) + (* ; + "Just a caret--no text really selected--so don't delete any") + 0) + ((ZEROP CHLIM) (* ; + "CHLIM is before start of text, so don't delete any") + 0) + (T (* ; "The normal case.") + (IDIFFERENCE CHLIM CH#] (* ; "# of characters to be deleted") + (COND + ((OR (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ) + (NOT (fetch (SELECTION SET) of SEL)) + (ZEROP LEN)) (* ; "If the selection isn't set, OR the document is read-only, OR the selection contains no characters, don't do anything.") + ) + (T (AND WINDOW (TEDIT.NORMALIZECARET TEXTOBJ SEL)) (* ; + "If the text appears in a window, move the deletion point on-screen") + (SETQ OLINE1 (fetch (SELECTION L1) of SEL)) + (SETQ OLINEN (fetch (SELECTION LN) of SEL)) + (\TEDIT.SHOWSELS TEXTOBJ NIL NIL) (* ; + "Turn off the selection's highlighting") + (AND LINES (\FIXDLINES LINES SEL CH# CHLIM TEXTOBJ)) + (* ; + "Update the line descriptors to account for the deletion") + (\DELETECH CH# CHLIM LEN TEXTOBJ) (* ; + "Do the actual deletion of characters") + (replace THPOINT of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ) + with (fetch (SELECTION POINT) of SEL)) + (* ; + "Remember which side of the selection we were on, in case it gets undone.") + (replace (SELECTION CH#) of SEL with (IMAX 1 CH#)) + (replace (SELECTION CHLIM) of SEL with (fetch (SELECTION CH#) of + SEL)) + (replace (SELECTION POINT) of SEL with 'LEFT) + (replace (SELECTION DCH) of SEL with 0) + (COND + (WINDOW (* ; + "If there's no window to update, don't bother") + (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (* ; "The new text length") + (for OLINE1 inside (fetch (SELECTION L1) of SEL) as OLINEN + inside (fetch (SELECTION LN) of SEL) as TOPLINE + inside (fetch (TEXTOBJ LINES) of TEXTOBJ) as THISW inside + WINDOW + do (SETQ LINES\DELETED + (\TEDIT.CLOSEUPLINES + TEXTOBJ + (OR (AND OLINE1 (COND + ((fetch (LINEDESCRIPTOR DELETED) of OLINE1) + (fetch (LINEDESCRIPTOR PREVLINE) of OLINE1)) + (T OLINE1))) + (COND + ([AND (fetch (LINEDESCRIPTOR NEXTLINE) of TOPLINE) + (OR (IGEQ (fetch (LINEDESCRIPTOR CHAR1) + of (fetch (LINEDESCRIPTOR NEXTLINE) + of TOPLINE)) + (fetch (SELECTION CHLIM) of SEL)) + (ILESSP (fetch (LINEDESCRIPTOR CHARLIM) + of (fetch (LINEDESCRIPTOR NEXTLINE) + of TOPLINE)) + (fetch (SELECTION CH#) of SEL] + (* ; + "The first line on the screen is already past where we're to delete. DON'T delete any lines") + NIL) + (T TOPLINE))) + (AND OLINEN (COND + ((fetch (LINEDESCRIPTOR DELETED) of OLINEN) + (fetch (LINEDESCRIPTOR NEXTLINE) of OLINEN)) + (T OLINEN))) + NIL THISW))) (* ; + "Remove any lines which were completely deleted.") + + (* ;; "This line must needs be reformatted the hard way--it isn't a left ragged line or one of the lines is off-screen.") + + (replace (SELECTION DX) of SEL with 0) + (TEDIT.UPDATE.SCREEN TEXTOBJ NIL T) (* ; + "Correct the text that's displayed already") + (\FIXSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) + TEXTOBJ) (* ; + "Then fix up the selection as needed.") + (\TEDIT.SHOWSELS TEXTOBJ NIL T]) (\TEDIT.DIFFUSE.PARALOOKS + [LAMBDA (PRIORPC SUCCEEDINGPC) (* ; "Edited 12-Jun-90 17:48 by mitani") + + (* Given a discontinuity in paragraph looks, caused by an insertion or by a + deletion%: Diffuse the existing paragraph looks across the discontinuity, so + that all the pieces in a single paragraph have consistent looks. + Give preference to diffusion toward the END of the document. + This means that if you delete a CR between paragraphs, the second para is + absorbed into the first.) + + (* PRIORPC and SUCCEEDINGPC are the PIECEs that bound the area of potential + discontinuity%: the change will occur at one boundary or the other....) + + [COND + ((AND PRIORPC (NOT (fetch (PIECE PPARALAST) of PRIORPC))) + (* The discontinuity is inside a + paragraph. Must copy para looks + forward into the text.) + (bind (PPLOOKS _ (fetch (PIECE PPARALOOKS) of PRIORPC)) + (PC _ (fetch (PIECE NEXTPIECE) of PRIORPC)) while PC + do (* Copy para looks info in from the + left, up the the first para break.) + (replace (PIECE PPARALOOKS) of PC with PPLOOKS) + (COND + ((fetch (PIECE PPARALAST) of PC) (* If this piece ends a paragraph, + we're done.) + (RETURN))) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC] + (COND + ((AND SUCCEEDINGPC (NEQ SUCCEEDINGPC 'LASTPIECE)) + + (* Only copy para looks in from the right if there is text to the right.) + + (bind (PPLOOKS _ (fetch (PIECE PPARALOOKS) of SUCCEEDINGPC)) + (PC _ (fetch (PIECE PREVPIECE) of SUCCEEDINGPC)) while (NEQ PC PRIORPC) + do (* Copy para looks in from the + right, up to the first para break) + (COND + ((fetch (PIECE PPARALAST) of PC) (* If this piece ends a paragraph, + we're done.) + (RETURN))) + (replace (PIECE PPARALOOKS) of PC with PPLOOKS) + (SETQ PC (fetch (PIECE PREVPIECE) of PC]) (\TEDIT.FOREIGN.COPY? + [LAMBDA (SEL) (* ; "Edited 21-Jan-93 11:46 by jds") + + (* ;; "IF the current process's window isn't a TEdit window, do a 'Copy' by BKSYSBUFing the selected text. Then turn off all the various indicators.") + + (PROG (PROCW (SOURCE.TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) + CH STREAM DEST.TEDIT? DEST.TEXTOBJ) + [SETQ DEST.TEDIT? (AND (SETQ PROCW (PROCESSPROP (TTY.PROCESS) + 'WINDOW)) + (SETQ DEST.TEXTOBJ (WINDOWPROP PROCW 'TEXTOBJ)) + (NOT (TEXTPROP DEST.TEXTOBJ 'COPYBYBKSYSBUF] + (* ; "Treat the destination specially if (1) the recipient process has a window, and (2) it's a TEdit window, and (3) the TEdit isn't declining special treatment by having COPYBYBKSYSBUF set in its props.") + (COND + ((ZEROP (fetch (SELECTION DCH) of SEL)) (* ; + "Nothing to copy (0 characters in selection); don't bother.") + (SETQ TEDIT.COPY.PENDING NIL)) + ((IGREATERP (fetch (SELECTION CH#) of SEL) + (FETCH (TEXTOBJ TEXTLEN) OF SOURCE.TEXTOBJ)) + (* ; + "Trying to copy from beyond the end of the document; don't bother") + (SETQ TEDIT.COPY.PENDING NIL)) + ((OR (NOT DEST.TEDIT?) + (AND PROCW DEST.TEXTOBJ (NEQ SOURCE.TEXTOBJ DEST.TEXTOBJ) + (fetch (TEXTOBJ EDITOPACTIVE) of DEST.TEXTOBJ))) + (* ; + "OK -- receiver isn't TEdit. Do it the hard way.") + [COND + [(AND (WINDOWPROP [OR PROCW (WFROMDS (PROCESS.TTY (TTY.PROCESS] + 'COPYINSERTFN) + (PROGN (* ; + "This is the exit for looked-string objects") + (OBJECTOUTOFTEDIT SOURCE.TEXTOBJ SEL] + (T (* ; + "Old tedit method, run if OBJECTOUTOFTEDIT is NILL (ie., not installed yet)") + + (* ;; "Still used because COPYINSERT does (PRIN2 BKSYSBUF) if there's no insertfn, which cretes undesired string quotes.") + + (\SETUPGETCH (fetch (SELECTION CH#) of SEL) + SOURCE.TEXTOBJ) (* ; + "Go to the first character to be copied") + (SETQ STREAM (fetch (TEXTOBJ STREAMHINT) of SOURCE.TEXTOBJ)) + (for I from 1 to (fetch (SELECTION DCH) of SEL) + do + + (* ;; "Run thru the selected text, copying only those items that really ARE characters--IMAGEOBJs don't get copied by this route.") + + (COND + ((FIXP (SETQ CH (\BIN STREAM))) + (BKSYSBUF (CHARACTER CH))) + (T (COPYINSERT CH] + (\SHOWSEL SEL NIL NIL) (* ; + "Then reset the copy-pending flags.") + (SETQ TEDIT.COPY.PENDING NIL]) (\TEDIT.QUIT + [LAMBDA (W NOFORCE) (* ; "Edited 12-Jun-90 17:50 by mitani") + (* Called by the default + TEDIT.DEFAULT.MENUFN to perform the + QUIT command.) + (PROG* ((TEXTOBJ (WINDOWPROP W 'TEXTOBJ)) + (QUITFNS (TEXTPROP TEXTOBJ 'QUITFN)) + QUITFLG RESP) + [for QUITFN inside QUITFNS while (AND (NEQ QUITFLG 'DON'T) + (NEQ QUITFLG T)) + do (COND + ((EQ QUITFN T) + (SETQ QUITFLG T)) + (T (AND QUITFN (NEQ QUITFN T) + (SETQ QUITFLG (APPLY* QUITFN W (fetch (TEXTOBJ STREAMHINT) + of TEXTOBJ) + TEXTOBJ + (fetch (TEXTOBJ EDITPROPS) of + TEXTOBJ + ] + (COND + ((EQ QUITFLG 'DON'T) + + (* The user supplied a QUITFN, and it returned "DON'T" %, so just ignore all + this Fooferaw and keep editing.) + + (RETURN)) + [(AND (fetch (TEXTOBJ \DIRTY) of TEXTOBJ) + (NOT (fetch (TEXTOBJ MENUFLG) of TEXTOBJ)) + (NEQ QUITFNS T) + (NEQ QUITFLG T)) + + (* If this document has changed, check with the user to make sure he really + wants to do it.) + + (replace (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ + with (MOUSECONFIRM "Not saved yet; LEFT to Quit anyway." T (fetch + (TEXTOBJ + PROMPTWINDOW + ) + of TEXTOBJ] + (T (* Go ahead and quit the next time + we see the main command loop.) + (replace (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ with T))) + [AND (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + (NOT NOFORCE) + (NEQ (\TEDIT.PRIMARYW TEXTOBJ) + (PROCESSPROP (TTY.PROCESS) + 'WINDOW)) + (TTY.PROCESS (WINDOWPROP (\TEDIT.PRIMARYW TEXTOBJ) + 'PROCESS] + (RETURN (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ]) (\TEDIT.WORDDELETE + [LAMBDA (TEXTOBJ) (* ; "Edited 29-May-91 18:22 by jds") + + (* ;; "Delete the word to the left of the caret.") + + (* ;; "Back word.") + + (* ;; "THIS FUNCTION IS FRAUGHT WITH FENCEPOST PROBLEM POTENTIAL, AND THE WHILE vs FOR LOGIC IS CONVOLUTED. CAUTION, CAUTION.") + + (LET* ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (STREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) + (READSA (fetch READSA of (OR (fetch (TEXTOBJ TXTWTBL) of TEXTOBJ) + TEDIT.WORDBOUND.READTABLE))) + (INSCH# (SELECTQ (fetch (SELECTION POINT) of SEL) + (LEFT (SUB1 (fetch (SELECTION CH#) of SEL))) + (RIGHT (SUB1 (fetch (SELECTION CHLIM) of SEL))) + NIL)) + CH CHNO) + + (* ;; "INSCH# is the final (i.e., highest-numbered) character to be deleted.") + + (COND + ((IGREATERP INSCH# 0) (* ; + "Don't try to back up past start of file.") + (\SETUPGETCH INSCH# TEXTOBJ) + (SETQ CH (\BIN STREAM)) + (for old CHNO from INSCH# to 1 by -1 + while [AND (SELECTC (COND + ((FIXP CH) + (\SYNCODE READSA CH)) + (T (* ; "It's an object!") + TEXT.TTC)) + (TEXT.TTC NIL) + T) + (NOT (fetch CLPROTECTED of (fetch (PIECE PLOOKS) + of (fetch (TEXTSTREAM + PIECE) + of STREAM] + do + + (* ;; "Skip over any initial separator characters") + + (SETQ CH (\GETCHB TEXTOBJ))) + + (* ;; "At this point, CH is the first non-separator character, and CHNO is the character number of the character BEFORE that one.") + + (for old CHNO from CHNO to 1 by -1 + while [AND (SELECTC (COND + ((FIXP CH) + (\SYNCODE READSA CH)) + (T (* ; "It's an object!") + TEXT.TTC)) + (TEXT.TTC T) + NIL) + (NOT (fetch CLPROTECTED of (fetch (PIECE PLOOKS) + of (fetch (TEXTSTREAM + PIECE) + of STREAM] + do + + (* ;; "Skip over the next group of non-separators (= a 'word')") + + (SETQ CH (\GETCHB TEXTOBJ))) + + (* ;; "At this point, CH is the first separator character you encountered, and CHNO is the character number of the character BEFORE the separator, or 0 if you hit the front of the document.") + + (\SHOWSEL SEL NIL NIL) + + (* ;; "First character to delete:") + + [replace (SELECTION CH#) of SEL with (COND + ((ILESSP CHNO 1) + (* ; + "Front of document, so start deleting at char # 1") + 1) + (T + (* ; +"Otherwise, we need to start 1 later than the separator we hit, which is 2 higher than CHNO is now.") + (IPLUS 2 CHNO] + (replace (SELECTION CHLIM) of SEL with (ADD1 INSCH#)) + (replace (SELECTION DCH) of SEL with (IDIFFERENCE INSCH# CHNO)) + (\FIXSEL SEL TEXTOBJ) + (\SHOWSEL SEL NIL T) + (\TEDIT.DELETE SEL TEXTOBJ]) (\TEDIT1 + [LAMBDA (TEXT WINDOW UNSPAWNED PROPS) (* ; "Edited 12-Jun-90 17:50 by mitani") + + (* 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 (fetch (TEXTSTREAM TEXTOBJ) of TEXT)) + (* Run the editing engine) + (CLOSEW WINDOW) + (replace (TEXTOBJ \WINDOW) of (fetch (TEXTSTREAM TEXTOBJ) of TEXT) + with NIL) + (AND (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) + 'AFTERQUITFN) + (APPLY* (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT) + '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 (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM + TEXTOBJ) + of TEXT)) + T) + (PROG1 (fetch (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM + TEXTOBJ) + of TEXT)) + (replace (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM + TEXTOBJ) + of TEXT) with + NIL))) + ((STRINGP (fetch (TEXTOBJ TXTFILE) of (fetch (TEXTSTREAM TEXTOBJ + ) of TEXT))) + (COERCETEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT) + 'STRINGP)) + (T TEXT]) ) (MOVD? 'NILL 'OBJECTOUTOFTEDIT) (* ; "HOOK for looked-string copy, etc. Used in \TEDIT.FOREIGN.COPY?.") (DEFINEQ (\CREATE.TEDIT.RESTART.MENU + [LAMBDA NIL + (CREATE MENU + ITEMS _ '(NewEditProcess]) ) (* ; "Added by yabu.fx, for SUNLOADUP without DWIM.") (* ; "Debugging functions") (DEFINEQ (PLCHAIN + [LAMBDA (LN) (* ; "Edited 29-May-91 18:20 by jds") + (PRINTLINE LN) + (COND + ((fetch (LINEDESCRIPTOR NEXTLINE) of LN) + (PLCHAIN (fetch (LINEDESCRIPTOR NEXTLINE) of LN]) (PRINTLINE + [LAMBDA (LN) (* ; "Edited 29-May-91 18:20 by jds") + (* Print out a line descriptor in a + reasonable form.) + (printout T "-----" T LN " Bot: " (fetch (LINEDESCRIPTOR YBOT) of LN) + " Base: " + (fetch (LINEDESCRIPTOR YBASE) of LN) + " Height: " + (fetch (LINEDESCRIPTOR LHEIGHT) of LN) + " Ascent: " + (fetch (LINEDESCRIPTOR ASCENT) of LN) + " Descent: " + (fetch (LINEDESCRIPTOR DESCENT) of LN) + T "Char1: " (fetch (LINEDESCRIPTOR CHAR1) of LN) + " Lim: " + (fetch (LINEDESCRIPTOR CHARLIM) of LN) + " Top: " + (fetch (LINEDESCRIPTOR CHARTOP) of LN)) + (COND + ((fetch (LINEDESCRIPTOR DIRTY) of LN) + (PRIN1 " DIRTY"))) + (COND + ((fetch (LINEDESCRIPTOR CR\END) of LN) + (PRIN1 " CR-at-end"))) + (COND + ((fetch (LINEDESCRIPTOR DELETED) of LN) + (PRIN1 " DELETED"))) + (COND + ((fetch (LINEDESCRIPTOR LHASPROT) of LN) + (PRIN1 " [Protected text]"))) + (COND + ((fetch (LINEDESCRIPTOR LHASTABS) of LN) + (PRIN1 " Has Tabs"))) + (PRIN1 ". +") + (printout T "RMar: " (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LN) + " XLim: " + (fetch (LINEDESCRIPTOR LXLIM) of LN) + " Left: " + (fetch (LINEDESCRIPTOR SPACELEFT) of LN) + T "Prev: " (fetch (LINEDESCRIPTOR PREVLINE) of LN) + T "Next: " (fetch (LINEDESCRIPTOR NEXTLINE) of LN) + T) + (COND + ((AND (IGEQ (fetch (LINEDESCRIPTOR CHAR1) of LN) + 1) + (ILEQ (fetch (LINEDESCRIPTOR CHAR1) of LN) + (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) + (* The line is real -- + print it.) + (\SETUPGETCH (fetch (LINEDESCRIPTOR CHAR1) of LN) + TEXTOBJ) + (PRIN1 "|") + [bind CH for CHNO from (fetch (LINEDESCRIPTOR CHAR1) of LN) + to (IMIN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) + (fetch (LINEDESCRIPTOR CHARLIM) of LN)) + do (SETQ CH (\GETCH TEXTOBJ)) + (COND + ((SMALLP CH) + (PRIN1 (CHARACTER CH))) + (T (PRINT CH] + (PRIN1 "| +"]) (SEEFILE + [LAMBDA (FILE ST ND) (* jds " 4-NOV-83 20:21") + (PROG (CH) + [SETQ FILE (OR (OPENP FILE) + (OPENSTREAM FILE 'INPUT] + (SETFILEPTR FILE (OR ST 0)) + (for I from (OR ST 0) to (OR ND (SUB1 (GETEOFPTR FILE))) + do (printout T I 5 (SETQ CH (BIN FILE)) + 9 + (COND + [(ILEQ CH (CHARCODE ^Z)) + (CONCAT "^" (CHARACTER (IPLUS CH (CHARCODE @] + (T (CHARACTER CH))) + T]) ) (* ; "Object-oriented editing") (DEFINEQ (TEDIT.INSERT.OBJECT + [LAMBDA (OBJECT STREAM CH#) (* ; "Edited 21-Apr-93 00:52 by jds") + + (* ;; "Inserts the Image-object OBJECT into text STREAM in front of character CH.") + + (LET* ((TEXTOBJ (TEXTOBJ STREAM)) + (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + SUBSTREAM START-OF-PIECE) + (TEDIT.DO.BLUEPENDINGDELETE SEL TEXTOBJ) (* ; + "Do the pending delete, if there is one.") + (COND + ((NULL CH#) (* ; + "Omitted CH# means put it at the current spot.") + (SETQ CH# SEL))) + [COND + ((type? SELECTION CH#) + + (* ;; "If the CH# passed in was a selection (or we set it because he defaulted CH#), then compute the REAL CH#.") + + (SETQ CH# (SELECTQ (fetch (SELECTION POINT) of CH#) + (LEFT (fetch (SELECTION CH#) of CH#)) + (RIGHT (fetch (SELECTION CHLIM) of CH#)) + (SHOULDNT] + (PROG ((PCTB (ffetch (TEXTOBJ PCTB) of TEXTOBJ)) + TEXTLEN PC PCNO CHNO NEWPC PREVPC INSERTFN) + (COND + ((fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ) + + (* ;; + "If no changes are allowed to this TEdit, bail out without doing anything.") + + (RETURN))) + (\SHOWSEL SEL NIL NIL) (* ; "Turn off the selection for now") + (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (SETQ CH# (IMIN CH# (ADD1 TEXTLEN))) (* ; + "CH# we're to insert these characters in front of") + (freplace (TEXTOBJ \INSERTFIRSTCH) of TEXTOBJ with -1) + [SETQ PC (COND + ((ILEQ CH# TEXTLEN) + (\CHTOPC CH# PCTB T)) + (T 'LASTPIECE] (* ; + "Piece we're to insert in front of or inside") + (SETQ NEWPC (create PIECE + PSTR _ NIL + PFILE _ NIL + POBJ _ OBJECT + PLEN _ 1)) (* ; "The new piece we're inserting") + [COND + ((SETQ SUBSTREAM (IMAGEOBJPROP OBJECT 'SUBSTREAM)) + (* ; + "If this is computed text in bulk, fix the length.") + (replace (PIECE PLEN) of NEWPC with (fetch (TEXTOBJ TEXTLEN) + of (fetch ( + TEXTSTREAM + TEXTOBJ) + of SUBSTREAM] + (COND + ((OR (IGREATERP CH# TEXTLEN) + (IEQP CH# START-OF-PIECE)) (* ; + "We're inserting on a piece boundary; do it, then remember the prior piece.") + (\INSERTPIECE NEWPC PC TEXTOBJ)) + (T (* ; + "Not on a piece boundary; split the piece we're inside of, then insert.") + (\INSERTPIECE NEWPC (\SPLITPIECE PC (IDIFFERENCE CH# START-OF-PIECE) + TEXTOBJ) + TEXTOBJ))) + (COND + ((SETQ INSERTFN (IMAGEOBJPROP OBJECT 'WHENINSERTEDFN)) + (* ; + "If there is a WHENINSERTEDFN, apply it.") + (APPLY* INSERTFN OBJECT (AND (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ + )) + (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) + of TEXTOBJ)) + 'DSP)) + NIL STREAM))) + (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + (SETQ PREVPC (fetch (PIECE PREVPIECE) of NEWPC)) + (* ; "Fill in the para looks") + [COND + [PREVPC (COND + [(AND (fetch (PIECE PPARALAST) of PREVPC) + (fetch (PIECE NEXTPIECE) of NEWPC)) + (replace (PIECE PPARALOOKS) of NEWPC + with (fetch (PIECE PPARALOOKS) of (fetch + (PIECE NEXTPIECE) + of NEWPC] + (T (replace (PIECE PPARALOOKS) of NEWPC + with (fetch (PIECE PPARALOOKS) of PREVPC] + (T (COND + ((SETQ PREVPC (fetch (PIECE NEXTPIECE) of NEWPC)) + (replace (PIECE PPARALOOKS) of NEWPC with (fetch + (PIECE PPARALOOKS) + of PREVPC))) + (T (replace (PIECE PPARALOOKS) of NEWPC with (fetch + (TEXTOBJ + FMTSPEC) + of TEXTOBJ] + (replace (PIECE PLOOKS) of NEWPC with (fetch (TEXTOBJ CARETLOOKS) + of TEXTOBJ)) + (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT + THACTION _ 'Insert + THCH# _ CH# + THLEN _ 1 + THFIRSTPIECE _ NEWPC)) + (SETQ TEXTLEN (freplace (TEXTOBJ TEXTLEN) of TEXTOBJ + with (IPLUS (fetch (PIECE PLEN) of NEWPC) + TEXTLEN))) + (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) + (* ; + "Since adding an IMAGEOBJ creates a new piece, the old insertion cache piece is no longer valid.") + (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T) + (replace (THISLINE DESC) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ) + with NIL) + (replace (SELECTION SELKIND) of SEL with 'CHAR) + (COND + ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + (\FIXILINES TEXTOBJ SEL CH# (fetch (PIECE PLEN) of NEWPC) + (SUB1 TEXTLEN)) + (replace (SELECTION DCH) of SEL with 0) + (replace (SELECTION DX) of SEL with 0) + (TEDIT.UPDATE.SCREEN TEXTOBJ) + (\FIXSEL SEL TEXTOBJ) + (\SHOWSEL SEL NIL T)) + (T [replace (SELECTION CHLIM) of SEL + with (replace (SELECTION CH#) of SEL + with (IPLUS CH# (fetch (PIECE PLEN) of NEWPC] + (replace (SELECTION DCH) of SEL with 0) + (replace (SELECTION DX) of SEL with 0) + (replace (SELECTION POINT) of SEL with 'LEFT) + (replace (THISLINE DESC) of (fetch (TEXTOBJ THISLINE) + of TEXTOBJ) with NIL))) + (\COPYSEL SEL TEDIT.SELECTION]) (TEDIT.EDIT.OBJECT + [LAMBDA (STREAM OBJ) (* ; "Edited 29-May-91 18:23 by jds") + (PROG ([TEXTOBJ (COND + ((type? TEXTOBJ STREAM) + STREAM) + ((type? STREAM STREAM) + (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) + ((SHOULDNT] + SEL LL CH# SELOBJ EDITFN) + [COND + [(AND OBJ (IMAGEOBJP OBJ)) + (SETQ CH# (TEDIT.FIND.OBJECT TEXTOBJ OBJ)) + (COND + (CH# (SETQ SEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + (replace (SELECTION CH#) of SEL with CH#) + (replace (SELECTION CHLIM) of SEL with (ADD1 CH#)) + (SETQ SELOBJ OBJ) + (replace (SELECTION DCH) of SEL with 1) + (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ) + (\FIXSEL SEL TEXTOBJ)) + (T (TEDIT.PROMPTPRINT TEXTOBJ "Can't find specified object." T] + (T (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (SETQ OBJ (fetch (SELECTION SELOBJ) of SEL] + (COND + [OBJ (* OK There's an object selected. + Edit it.) + (SETQ EDITFN (IMAGEOBJPROP OBJ 'EDITFN)) + (COND + ((AND EDITFN (APPLY* EDITFN OBJ)) (* If the editfn makes a change, + update the screen.) + (for LINE inside (fetch (SELECTION L1) of SEL) + do (replace (LINEDESCRIPTOR DIRTY) of LINE with T)) + (replace (TEXTOBJ TXTNEEDSUPDATE) of TEXTOBJ with T) + (TEDIT.UPDATE.SCREEN TEXTOBJ] + (T (* No object selected.) + (TEDIT.PROMPTPRINT TEXTOBJ "Please select an editable object first." T]) (TEDIT.FIND.OBJECT + [LAMBDA (TEXTOBJ OBJ) (* ; "Edited 3-May-93 12:52 by jds") + (* ; + "Find OBJ, if it's in TEXTOBJ, and return CH#. Else return nil") + (SETQ TEXTOBJ (TEXTOBJ TEXTOBJ)) + (LET ((PC (\GETBASEPTR (\FIRSTNODE (fetch PCTB of TEXTOBJ)) + 0)) + (CH 1)) + (while PC do (COND + ((AND (NOT (ATOM PC)) + (EQ (fetch (PIECE POBJ) of PC) + OBJ)) + (RETURN CH)) + (T (add CH (ffetch (PIECE PLEN) of PC)) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC]) (TEDIT.FIND.OBJECT.SUBTREE + [LAMBDA (PCTB OBJ) (* ; "Edited 12-Jun-90 17:52 by mitani") + (COND + ((NULL PCTB) + NIL) + ((ATOM (fetch (PCTNODE PCE) of PCTB)) + (OR (TEDIT.FIND.OBJECT.SUBTREE (fetch (PCTNODE LO) of PCTB) + OBJ) + (TEDIT.FIND.OBJECT.SUBTREE (fetch (PCTNODE HI) of PCTB) + OBJ))) + ((EQ (fetch (PIECE POBJ) of (fetch (PCTNODE PCE) of PCTB)) + OBJ) + (fetch (PCTNODE CHNUM) of PCTB)) + (T (OR (TEDIT.FIND.OBJECT.SUBTREE (fetch (PCTNODE LO) of PCTB) + OBJ) + (TEDIT.FIND.OBJECT.SUBTREE (fetch (PCTNODE HI) of PCTB) + OBJ]) (TEDIT.PUT.OBJECT + [LAMBDA (PIECE OFILE FONTFILE CURCH#) (* ; "Edited 12-Jun-90 17:49 by mitani") + (* Given a piece which describes an + object, put the object out there.) + (PROG ((OBJECT (fetch (PIECE POBJ) of PIECE)) + (FONTCH# (GETFILEPTR FONTFILE)) + TOFILE LEN) + (\DWOUT FONTFILE 0) (* Placeholder for length of the + object's description) + (\SMALLPOUT FONTFILE \PieceDescriptorOBJECT) (* Mark this as setting the piece's + looks) + (\ATMOUT FONTFILE (IMAGEOBJPROP OBJECT 'GETFN)) (* The FN to apply to reconstruct + the object) + (APPLY* (IMAGEOBJPROP OBJECT 'PUTFN) + OBJECT OFILE) + (SETFILEPTR FONTFILE FONTCH#) + + (* Now go back and fill in the length of the text description of the object.) + + [\DWOUT FONTFILE (SETQ LEN (ADD1 (IDIFFERENCE (GETEOFPTR OFILE) + CURCH#] + (SETFILEPTR FONTFILE -1) (* Make sure we're at the end of the + font file) + (AND (RANDACCESSP OFILE) + (SETFILEPTR OFILE -1)) (* And the text part of the file) + (RETURN LEN]) (TEDIT.GET.OBJECT + [LAMBDA (STREAM PIECE FILE CURCH#) (* ; "Edited 12-Jun-90 17:50 by mitani") + (* ; "Get an object from the file") + (* ; + "CURCH# = fileptr within the text section of the file where the object's text starts.") + (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) + FILEPTRSAVE NAMELEN GETFN OBJ NBYTES) + + (* ;; "rrb 10-AUG-87 --- calculate the length of the image object's data. This assumes that the file is currently pointed at the end of the data which is where the GETFN is written {I think}") + + (SETQ NBYTES (DIFFERENCE (GETFILEPTR FILE) + CURCH#)) + (SETQ GETFN (\ATMIN FILE)) (* ; + "The GETFN for this kind of IMAGEOBJ") + (SETQ FILEPTRSAVE (GETFILEPTR FILE)) (* ; + "Save our file location thru the building of the object") + (SETFILEPTR FILE CURCH#) + (SETQ OBJ (READIMAGEOBJ FILE GETFN NIL NBYTES)) + (COND + ((IMAGEOBJPROP OBJ 'UNKNOWNGETFN) (* ; + "If the object has an unknown getfn property, then it's an encapsulated object. Warn the user") + (TEDIT.PROMPTPRINT STREAM "WARNING: Document contains unknown image objects." T))) + (SETFILEPTR FILE FILEPTRSAVE) + (replace (PIECE POBJ) of PIECE with OBJ) + (replace (PIECE PFILE) of PIECE with NIL) + (replace (PIECE PSTR) of PIECE with NIL) + [replace (PIECE PLOOKS) of PIECE with (COND + ((fetch (PIECE PREVPIECE) + of PIECE) + (fetch (PIECE PLOOKS) + of (fetch (PIECE PREVPIECE + ) + of PIECE))) + (T (OR (fetch (TEXTOBJ + DEFAULTCHARLOOKS + ) + of TEXTOBJ) + (\TEDIT.UNIQUIFY.CHARLOOKS + (CHARLOOKS.FROM.FONT + DEFAULTFONT) + TEXTOBJ] + (RETURN (fetch (PIECE POBJ) of PIECE]) (TEDIT.OBJECT.CHANGED + [LAMBDA (STREAM OBJECT) (* ; "Edited 12-Jun-90 17:51 by mitani") + + (* Notify TEdit that an object has changed, and the display may need to be + updated.) + + (PROG ((TEXTOBJ (TEXTOBJ STREAM)) + (LINES (fetch (TEXTOBJ LINES) of (TEXTOBJ STREAM))) + PCINFO CHANGED CHANGEDCH#) + (SETQ PCINFO (TEDIT.MAPPIECES TEXTOBJ [FUNCTION (LAMBDA (CH# PC PCNO OBJ) + (AND (EQ OBJ (fetch (PIECE POBJ) + of PC)) + 'STOP] + OBJECT)) (* Find the piece containing this + object) + (OR PCINFO (HELP "Changed OBJECT not found!?")) + (SETQ CHANGEDCH# (CAR PCINFO)) (* Get the CH# of the changed object) + (\TEDIT.MARK.LINES.DIRTY TEXTOBJ CHANGEDCH# CHANGEDCH#) + (* Mark affected lines) + (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T) + (* And mark the document dirty.) + (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) + NIL NIL) + (TEDIT.UPDATE.SCREEN TEXTOBJ) + (\FIXSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) + TEXTOBJ) + (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) + NIL T]) ) (FILESLOAD TEDITFIND TEDITHISTORY TEDITFILE TEDITWINDOW TEDITSELECTION IMAGEOBJ TFBRAVO TEDITHCPY TEDITPAGE TEDITMENU TEDITFNKEYS) (* ; "TEDIT Support information") (RPAQQ TEDITSYSTEMDATE "19-Apr-2018 12:22:04") (RPAQ TEDITSUPPORT "TEditSupport.PA") (DEFINEQ (MAKETEDITFORM + [LAMBDA NIL (* jds "12-Mar-85 04:00") + (* Builds a trouble-report form for + TEdit.) + (MAKEXXXSUPPORTFORM "TEdit" TEDITSUPPORT TEDITSYSTEMDATE]) ) (ADDTOVAR LAFITESPECIALFORMS ("TEdit Report" 'MAKETEDITFORM "Report a problem with TEdit")) (SETQ LAFITEFORMSMENU NIL) (* ; "LISTFILES Interface, so the system can decide if a file is a TEdit file.") (ADDTOVAR PRINTFILETYPES (TEDIT (TEST \TEDIT.FORMATTEDP1) (EXTENSION (TEDIT)))) (PUTPROPS TEDIT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1995 1999 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4382 115216 (\TEDIT2 4392 . 7143) (COERCETEXTOBJ 7145 . 15921) (TEDIT 15923 . 20892) ( TEDIT.CHARWIDTH 20894 . 22918) (TEDIT.COPY 22920 . 31356) (TEDIT.DELETE 31358 . 32048) ( TEDIT.DO.BLUEPENDINGDELETE 32050 . 35117) (TEDIT.INSERT 35119 . 40649) (TEDIT.KILL 40651 . 42208) ( TEDIT.MAPLINES 42210 . 43609) (TEDIT.MAPPIECES 43611 . 44567) (TEDIT.MOVE 44569 . 54353) (TEDIT.QUIT 54355 . 56355) (TEDIT.STRINGWIDTH 56357 . 57028) (TEDIT.\INSERT 57030 . 59055) (TEXTOBJ 59057 . 60182) (TEXTSTREAM 60184 . 61799) (\TEDIT.INCLUDE 61801 . 65701) (\TEDIT.INSERT.PIECES 65703 . 75618) ( \TEDIT.MOVE.PIECEMAPFN 75620 . 77699) (\TEDIT.OBJECT.SHOWSEL 77701 . 81330) (\TEDIT.RESTARTFN 81332 . 83327) (\TEDIT.CHARDELETE 83329 . 87291) (\TEDIT.COPY.PIECEMAPFN 87293 . 90518) (\TEDIT.DELETE 90520 . 98038) (\TEDIT.DIFFUSE.PARALOOKS 98040 . 100804) (\TEDIT.FOREIGN.COPY? 100806 . 104533) ( \TEDIT.QUIT 104535 . 107681) (\TEDIT.WORDDELETE 107683 . 112516) (\TEDIT1 112518 . 115214)) (115330 115446 (\CREATE.TEDIT.RESTART.MENU 115340 . 115444)) (115545 119234 (PLCHAIN 115555 . 115829) ( PRINTLINE 115831 . 118595) (SEEFILE 118597 . 119232)) (119275 138918 (TEDIT.INSERT.OBJECT 119285 . 128362) (TEDIT.EDIT.OBJECT 128364 . 130620) (TEDIT.FIND.OBJECT 130622 . 131515) ( TEDIT.FIND.OBJECT.SUBTREE 131517 . 132323) (TEDIT.PUT.OBJECT 132325 . 133984) (TEDIT.GET.OBJECT 133986 . 137185) (TEDIT.OBJECT.CHANGED 137187 . 138916)) (139196 139559 (MAKETEDITFORM 139206 . 139557))))) STOP \ No newline at end of file diff --git a/library/TEDIT.DATABASE b/library/TEDIT.DATABASE new file mode 100644 index 00000000..eebcd55e --- /dev/null +++ b/library/TEDIT.DATABASE @@ -0,0 +1,12 @@ +(PROGN (PRIN1 "Use LOADDB to load database files! +" T) (ERROR!)) +("21-Feb-99 12:57:02" . {DSK}sybalsky>TEDIT.;1) +FNS (\TEDIT2 COERCETEXTOBJ TEDIT TEDIT.CHARWIDTH TEDIT.COPY TEDIT.DELETE TEDIT.DO.BLUEPENDINGDELETE +TEDIT.INSERT TEDIT.KILL TEDIT.MAPLINES TEDIT.MAPPIECES TEDIT.MOVE TEDIT.QUIT TEDIT.STRINGWIDTH +TEDIT.\INSERT TEXTOBJ TEXTSTREAM \TEDIT.INCLUDE \TEDIT.INSERT.PIECES \TEDIT.MOVE.PIECEMAPFN +\TEDIT.OBJECT.SHOWSEL \TEDIT.RESTARTFN \TEDIT.CHARDELETE \TEDIT.COPY.PIECEMAPFN \TEDIT.DELETE +\TEDIT.DIFFUSE.PARALOOKS \TEDIT.FOREIGN.COPY? \TEDIT.QUIT \TEDIT.WORDDELETE \TEDIT1 +\CREATE.TEDIT.RESTART.MENU PLCHAIN PRINTLINE SEEFILE TEDIT.INSERT.OBJECT TEDIT.EDIT.OBJECT +TEDIT.FIND.OBJECT TEDIT.FIND.OBJECT.SUBTREE TEDIT.PUT.OBJECT TEDIT.GET.OBJECT TEDIT.OBJECT.CHANGED +MAKETEDITFORM) + \ No newline at end of file diff --git a/library/TEDITABBREV b/library/TEDITABBREV new file mode 100644 index 00000000..93743367 --- /dev/null +++ b/library/TEDITABBREV @@ -0,0 +1,46 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 6-Aug-2020 14:52:14"  {DSK}kaplan>Local>medley3.5>lispcore>library>TEDITABBREV.;4 10066 changes to%: (VARS TEDITABBREVCOMS) (FNS \TEDIT.TRY.ABBREV) previous date%: "25-Aug-94 10:52:43" {DSK}kaplan>Local>medley3.5>lispcore>library>TEDITABBREV.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993, 1994, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDITABBREVCOMS) (RPAQQ TEDITABBREVCOMS [(FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (FNS \TEDIT.ABBREV.EXPAND \TEDIT.EXPAND.DATE \TEDIT.TRY.ABBREV) (GLOBALVARS TEDIT.ABBREVS) (INITVARS (TEDIT.ABBREVS '(("b" . "357,146") ("n" . "357,44") ("m" . "357,45") ("T" . "357,57") ("d" . "357,60") ("D" . "357,61") ("s" . "0,247") ("'" . "0,271") ("`" . "0,251") ("%"" . "0,252") ("~" . "0,272") ("1/4" . "0,274") ("1/2" . "0,275") ("3/4" . "0,276") ("1/3" . "357,375") ("2/3" . "357,376") ("c" . "0,323") ("c/o" . "357,100") ("%%" . "357,100") ("->" . "0,256") ("ra" . "0,256") ("|" . "0,257") ("da" . "0,257") ("^" . "0,255") ("ua" . "0,255") ("<-" . "0,254") ("la" . "0,254") ("_" . "0,254") ("L" . "0,243") ("o" . "0,260") ("Y" . "0,245") ("+" . "0,261") ("x" . "0,264") ("/" . "0,270") ("=" . "357,121") ("p" . "0,266") ("r" . "0,322") ("t" . "0,324") ("tm" . "0,324") ("box" . "42,42") ("cbox" . "42,61") ("-" . "357,43") ("=" . "357,42") (" " . "357,41") ("DATE" . \TEDIT.EXPAND.DATE) (">>DATE<<" . \TEDIT.EXPAND.DATE]) (FILESLOAD TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SCRATCHLEN 64) (CONSTANTS (\SCRATCHLEN 64)) ) (FILESLOAD (LOADCOMP) TEDITDCL) ) (DEFINEQ (\TEDIT.ABBREV.EXPAND + [LAMBDA (STREAM) (* ; "Edited 30-May-91 19:27 by jds") + (* ; "Expand an abbvreviation") + (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) + SEL CH# (CH NIL) + OLDLOOKS EXPANSION) + (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (SETQ CH# (SELECTQ (fetch (SELECTION POINT) of SEL) + (LEFT (SUB1 (fetch (SELECTION CH#) of SEL))) + (RIGHT (SUB1 (fetch (SELECTION CHLIM) of SEL))) + 0)) + [COND + ((ZEROP (fetch (SELECTION DCH) of SEL)) (* ; + "Point Selection, so use the character to the left") + (COND + ((ZEROP CH#) (* ; + "If we're off the front of the document, don't bother trying.") + (RETURN))) + (\SETUPGETCH CH# TEXTOBJ) + [SETQ CH (MKSTRING (CHARACTER (\BIN STREAM] + (TEDIT.SETSEL STREAM CH# 1 'RIGHT)) + (T (* ; + "We have a selection that isn't just a caret. Use it.") + (SETQ CH (TEDIT.SEL.AS.STRING STREAM] + (SETQ EXPANSION (\TEDIT.TRY.ABBREV CH STREAM)) (* ; "Find the abbreviation's expansion --first try it as-is, then try the upper-case version to be safe.") + (COND + (EXPANSION (* ; + "It exists, so insert it where the abbrev used to be") + (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) + (* ; "Force it to abandon caching") + (SETQ OLDLOOKS (TEDIT.GET.LOOKS TEXTOBJ)) + (TEDIT.DELETE TEXTOBJ SEL) (* ; + "First, delete the thing being expanded.") + (TEDIT.INSERT STREAM EXPANSION SEL OLDLOOKS]) (\TEDIT.EXPAND.DATE + [LAMBDA (STREAM CH) (* ; "Edited 23-Feb-88 10:41 by jds") + + (* ;; "Provide the date as the expansion for an abbreviation") + + (PROG* ((DATE (\UNPACKDATE)) + (YEAR (pop DATE)) + (MONTH (pop DATE)) + (DAY (pop DATE))) + (RETURN (CONCAT (CAR (NTH '("January" "February" "March" "April" "May" "June" "July" + "August" "September" "October" "November" "December") + (ADD1 MONTH))) + " " DAY ", " YEAR]) (\TEDIT.TRY.ABBREV [LAMBDA (ABBREV STREAM) (* ; "Edited 6-Aug-2020 14:41 by rmk:") (* jds "11-Jul-85 12:46") (* ;;  "Try expanding ABBREV as an abbreviation. Return the expansion; NIL = no such abbreviation.") (* ;; "RMK: Established that a character-code looking string (%"357,201%" or %"02FE%") or a number is a character code that converts to a character.") (PROG (SEL CH# (CH NIL) EXPANSION) (SETQ EXPANSION (OR (SASSOC ABBREV TEDIT.ABBREVS) (SASSOC (U-CASE ABBREV) TEDIT.ABBREVS))) (* Find the abbreviation's expansion --first try it as-is, then try the  upper-case version to be safe.) (RETURN (COND (EXPANSION (* There's an expansion.  Turn it into an insertable string.) (COND [(STRINGP (CDR EXPANSION)) (* ;; "Could be a character code") (COND ((SETQ CH (CHARCODE.DECODE (CDR EXPANSION) T)) (CHARACTER CH)) (T (CDR EXPANSION] ((SMALLP (CDR EXPANSION)) (* ;; "Treat a number as a character code.") (CHARACTER (CDR EXPANSION))) ((AND (LITATOM (CDR EXPANSION)) (GETD (CDR EXPANSION))) (* It's a function to be called.) (APPLY* (CDR EXPANSION) STREAM CH)) (T (* Anything else is a form to EVAL.) (EVAL (CDR EXPANSION]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.ABBREVS) ) (RPAQ? TEDIT.ABBREVS '(("b" . "357,146") ("n" . "357,44") ("m" . "357,45") ("T" . "357,57") ("d" . "357,60") ("D" . "357,61") ("s" . "0,247") ("'" . "0,271") ("`" . "0,251") ("%"" . "0,252") ("~" . "0,272") ("1/4" . "0,274") ("1/2" . "0,275") ("3/4" . "0,276") ("1/3" . "357,375") ("2/3" . "357,376") ("c" . "0,323") ("c/o" . "357,100") ("%%" . "357,100") ("->" . "0,256") ("ra" . "0,256") ("|" . "0,257") ("da" . "0,257") ("^" . "0,255") ("ua" . "0,255") ("<-" . "0,254") ("la" . "0,254") ("_" . "0,254") ("L" . "0,243") ("o" . "0,260") ("Y" . "0,245") ("+" . "0,261") ("x" . "0,264") ("/" . "0,270") ("=" . "357,121") ("p" . "0,266") ("r" . "0,322") ("t" . "0,324") ("tm" . "0,324") ("box" . "42,42") ("cbox" . "42,61") ("-" . "357,43") ("=" . "357,42") (" " . "357,41") ("DATE" . \TEDIT.EXPAND.DATE) (">>DATE<<" . \TEDIT.EXPAND.DATE))) (PUTPROPS TEDITABBREV COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1991 1992 1993 1994 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3480 8598 (\TEDIT.ABBREV.EXPAND 3490 . 5811) (\TEDIT.EXPAND.DATE 5813 . 6458) ( \TEDIT.TRY.ABBREV 6460 . 8596))))) STOP \ No newline at end of file diff --git a/library/TEDITCHAT b/library/TEDITCHAT new file mode 100644 index 00000000..6a6ec61e --- /dev/null +++ b/library/TEDITCHAT @@ -0,0 +1,439 @@ +(DEFINE-FILE-INFO PACKAGE "LISP" READTABLE "XCL" BASE 10) +(IL:FILECREATED "28-Mar-94 16:05:24" IL:|{PELE:MV:ENVOS}LIBRARY>TEDITCHAT.;3| 31193 + + IL:|changes| IL:|to:| (IL:FNS IL:\\TEXTSTREAMBOUT) + + IL:|previous| IL:|date:| "12-Jun-90 18:01:39" IL:|{PELE:MV:ENVOS}LIBRARY>TEDITCHAT.;2| +) + + +; Copyright (c) 1985, 1986, 1990, 1994 by Venue & Xerox Corporation. All rights reserved. + +(IL:PRETTYCOMPRINT IL:TEDITCHATCOMS) + +(IL:RPAQQ IL:TEDITCHATCOMS + ((IL:COMS (IL:* IL:\; "character routines") + (IL:FNS IL:TEDITCHAT.CHARFN IL:\\TEXTSTREAMBOUT)) + (IL:COMS (IL:FNS IL:TEDITSTREAM.INIT IL:TEDITCHAT.MENUFN)) + (IL:COMS (IL:* IL:\; "TEDIT update routines") + (IL:FNS IL:TEDIT.DISPLAYTEXT)) + (IL:GLOBALVARS IL:TEDITCHAT.MENU IL:CHAT.DRIVERTYPES IL:CHAT.DISPLAYTYPES) + (IL:VARS IL:TEDITCHAT.MENUITEMS (IL:TEDITCHAT.MENU)) + (IL:ADDVARS (IL:CHAT.DRIVERTYPES (IL:TEDIT IL:TEDITCHAT.CHARFN IL:NILL))) + (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:FILES (IL:SOURCE) + IL:CHATDECLS)))) + + + +(IL:* IL:\; "character routines") + +(IL:DEFINEQ + +(IL:TEDITCHAT.CHARFN + (IL:LAMBDA (IL:CH IL:CHAT.STATE) (IL:* IL:\; "Edited 12-Jun-90 18:00 by mitani") + (LET* ((IL:TEXTSTREAM (IL:|fetch| (IL:CHAT.STATE IL:TEXTSTREAM) IL:|of| IL:CHAT.STATE)) + (IL:SEL (IL:|fetch| (IL:TEXTOBJ IL:SEL) IL:|of| (IL:TEXTOBJ IL:TEXTSTREAM)))) + (IL:\\CARET.DOWN (IL:|fetch| (IL:TEXTOBJ IL:DS) IL:|of| (IL:TEXTOBJ IL:TEXTSTREAM)) + ) + (IL:SELCHARQ IL:CH + (IL:BS (IL:\\TEDIT.CHARDELETE IL:TEXTSTREAM "" IL:SEL) + (IL:MOVETO (IL:|fetch| IL:X0 IL:|of| IL:SEL) + (IL:|fetch| IL:Y0 IL:|of| IL:SEL) + (CAR (IL:|fetch| (IL:TEXTOBJ IL:\\WINDOW) IL:|of| (IL:TEXTOBJ + + IL:TEXTSTREAM + ))))) + (IL:LF NIL) + (IL:BOUT IL:TEXTSTREAM IL:CH))))) + +(IL:\\TEXTSTREAMBOUT + (IL:LAMBDA (STREAM BYTE) (IL:* IL:\; "Edited 28-Mar-94 15:29 by jds") + + (IL:* IL:|;;| "Do BOUT to a text stream, which is an insertion at the caret.") + + (PROG ((IL:TEXTOBJ (IL:|fetch| (IL:TEXTSTREAM IL:TEXTOBJ) IL:|of| STREAM)) + IL:CH# IL:WINDOW IL:TEXTLEN IL:PS IL:PC IL:PSTR IL:OFFST IL:SEL) + (IL:SETQ IL:TEXTLEN (IL:|fetch| (IL:TEXTOBJ IL:TEXTLEN) IL:|of| IL:TEXTOBJ)) + (IL:SETQ IL:WINDOW (IL:|fetch| (IL:TEXTOBJ IL:\\WINDOW) IL:|of| IL:TEXTOBJ)) + (IL:SETQ IL:SEL (IL:|fetch| (IL:TEXTOBJ IL:SEL) IL:|of| IL:TEXTOBJ)) + (COND + ((NOT (CAR (IL:|fetch| IL:L1 IL:|of| IL:SEL))) + (RETURN))) (IL:* IL:\; + "Return if caret out of bounds, ie, user scrolls past end of text") + (IL:SETQ IL:CH# (IL:|fetch| IL:CH# IL:|of| IL:SEL)) + (AND IL:WINDOW (IL:\\TEDIT.MARK.LINES.DIRTY IL:TEXTOBJ IL:CH# IL:CH#)) + (COND + ((IL:IEQP BYTE 13) + (IL:\\INSERTCR BYTE IL:CH# IL:TEXTOBJ)) + (T (IL:\\INSERTCH BYTE IL:CH# IL:TEXTOBJ))) + (AND IL:WINDOW + (PROG ((IL:THISLINE (IL:|fetch| (IL:TEXTOBJ IL:THISLINE) IL:|of| IL:TEXTOBJ)) + IL:EOLFLAG IL:CHORIG IL:CHWIDTH IL:OXLIM IL:OCHLIM IL:OCR\\END IL:PREVSPACE + IL:FIXEDLINE IL:NEXTLINE IL:LINES IL:NEWLINEFLG IL:DX IL:PREVLINE IL:SAVEWIDTH + IL:OFLOWFN IL:OLHEIGHT IL:DY IL:TABSEEN IL:IMAGECACHE IL:CURLINE IL:FONT + (IL:L1 (CAR (IL:|fetch| IL:L1 IL:|of| IL:SEL))) + (IL:LN (CAR (IL:|fetch| IL:LN IL:|of| IL:SEL))) + (IL:LOOKS (IL:\\TEDIT.APPLY.STYLES (IL:|fetch| (IL:TEXTOBJ IL:CARETLOOKS) + IL:|of| IL:TEXTOBJ) + (IL:|fetch| (IL:TEXTOBJ IL:\\INSERTPC) IL:|of| + IL:TEXTOBJ) + IL:TEXTOBJ))) + (IL:|add| (IL:|fetch| IL:CH# IL:|of| IL:SEL) + 1) (IL:* IL:\; + "These must be here, since SELs are valid even without a window.") + (IL:|replace| IL:CHLIM IL:|of| IL:SEL IL:|with| (IL:|fetch| + IL:CH# IL:|of| + IL:SEL)) + (IL:|replace| IL:POINT IL:|of| IL:SEL IL:|with| 'IL:LEFT) + (IL:|replace| IL:DCH IL:|of| IL:SEL IL:|with| 0) + (IL:|replace| IL:SELKIND IL:|of| IL:SEL IL:|with| 'IL:CHAR) + (IL:SETQ IL:CURLINE IL:L1) + (IL:|add| (IL:|fetch| IL:CHARLIM IL:|of| IL:CURLINE) + 1) + (IL:|add| (IL:|fetch| IL:CHARTOP IL:|of| IL:CURLINE) + 1) + (IL:SETQ IL:FONT (IL:|fetch| IL:CLFONT IL:|of| IL:LOOKS)) + (IL:DSPFONT IL:FONT (CAR IL:WINDOW)) + (COND + ((OR (IL:IGREATERP (IL:PLUS (IL:|fetch| IL:X0 IL:|of| IL:SEL) + (IL:CHARWIDTH BYTE IL:FONT)) + (IL:IDIFFERENCE (IL:|fetch| (IL:TEXTOBJ IL:WRIGHT) + IL:|of| IL:TEXTOBJ) + 8)) + (IL:IEQP BYTE (IL:CHARCODE IL:CR))) + (IL:* IL:\; + "gone off the edge of the line reformat and add new line") + (IL:TEDIT.UPDATE.SCREEN IL:TEXTOBJ) + (IL:\\FIXSEL IL:SEL IL:TEXTOBJ (CAR IL:WINDOW)) + (IL:SETQ IL:L1 (CAR (IL:|fetch| IL:L1 IL:|of| IL:SEL))) + (IL:SETQ IL:LN (CAR (IL:|fetch| IL:LN IL:|of| IL:SEL))) + (COND + ((OR (NULL (IL:SELECTQ (IL:|fetch| IL:POINT IL:|of| IL:SEL) + (IL:LEFT IL:L1) + (IL:RIGHT IL:LN) + NIL)) + (IL:ILEQ (IL:SELECTQ (IL:|fetch| IL:POINT IL:|of| IL:SEL) + (IL:LEFT (IL:|fetch| IL:YBOT IL:|of| IL:L1)) + (IL:RIGHT (IL:|fetch| IL:YBOT IL:|of| IL:LN)) + 0) + (IL:|fetch| (IL:REGION IL:BOTTOM) + IL:|of| (IL:DSPCLIPPINGREGION NIL (CAR IL:WINDOW))))) + (IL:* IL:\; + "The caret is off-window in the selection window. Need to scroll it up so the caret is visible.") + (IL:|while| (IL:ILESSP (IL:|fetch| IL:Y0 IL:|of| IL:SEL) + (IL:|fetch| (IL:TEXTOBJ IL:WBOTTOM) + IL:|of| IL:TEXTOBJ)) + IL:|do| (IL:* IL:\; + "The caret just went off-screen. Move it up some.") + (IL:|replace| (IL:TEXTOBJ IL:EDITOPACTIVE) IL:|of| + IL:TEXTOBJ + IL:|with| NIL) + (IL:SCROLLW (CAR IL:WINDOW) + 0 + (IL:LLSH (COND + ((IL:SELECTQ (IL:|fetch| IL:POINT + IL:|of| IL:SEL) + (IL:LEFT IL:L1) + (IL:RIGHT IL:LN) + NIL) + (IL:|fetch| IL:LHEIGHT + IL:|of| (IL:SELECTQ (IL:|fetch| + IL:POINT + IL:|of| + IL:SEL) + (IL:LEFT IL:L1) + (IL:RIGHT IL:LN) + (IL:SHOULDNT)))) + (T 12)) + 1)))))) + (T (IL:TEDIT.DISPLAYTEXT IL:TEXTOBJ BYTE (IL:CHARWIDTH BYTE IL:FONT) + IL:CURLINE + (IL:|fetch| IL:X0 IL:|of| IL:SEL) + (CAR IL:WINDOW) + IL:SEL) (IL:* IL:\; + "Print out the character on the screen") + (IL:|add| (IL:|fetch| IL:X0 IL:|of| IL:SEL) + (IL:CHARWIDTH BYTE IL:FONT)) + + (IL:* IL:|;;| "And move the selection's notion of our X position to the right to account for that character's width.") + + (IL:|replace| IL:XLIM IL:|of| IL:SEL IL:|with| (IL:|fetch| + IL:X0 + IL:|of| + IL:SEL)))) + +(IL:* IL:|;;;| "Fix up the TEXTSTREAM so that the FILEPTR looks like it ought to after the BOUT, even though we've been updating the screen (which usually moves the fileptr....)") + + (IL:SETQ IL:PS (IL:|ffetch| (IL:PIECE IL:PSTR) IL:|of| + (IL:SETQ IL:PC + (IL:|fetch| (IL:TEXTOBJ + + IL:\\INSERTPC + ) + IL:|of| IL:TEXTOBJ))) + ) (IL:* IL:\; + "This piece resides in a STRING. Because it's newly 'typed' material.") + (IL:|replace| (IL:TEXTSTREAM IL:PIECE) IL:|of| STREAM IL:|with| + IL:PC) + (IL:* IL:\; + "Remember the current piece for others.") + (IL:* IL:\; + "And which number piece this is.") + (IL:|freplace| (STREAM IL:CPPTR) IL:|of| STREAM + IL:|with| (IL:ADDBASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| + IL:PS) + (IL:LRSH (IL:SETQ IL:OFFST (IL:|ffetch| (IL:STRINGP + IL:OFFST) + IL:|of| IL:PS)) + 1))) (IL:* IL:\; + "Pointer to the actual characters in the string (allowing for substrings.)") + (IL:|freplace| (STREAM IL:CPAGE) IL:|of| STREAM IL:|with| 0) + (IL:|freplace| (STREAM IL:COFFSET) IL:|of| STREAM + IL:|with| (IL:IPLUS (IL:|freplace| (IL:TEXTSTREAM IL:PCSTARTCH) + IL:|of| STREAM IL:|with| (LOGAND 1 + IL:OFFST)) + (IL:|fetch| (IL:TEXTOBJ IL:\\INSERTLEN) IL:|of| + IL:TEXTOBJ)) + ) + (IL:|freplace| (IL:TEXTSTREAM IL:PCSTARTPG) IL:|of| STREAM IL:|with| + 0) + (IL:* IL:\; + "Page # within the 'file' where this piece starts") + (IL:|freplace| (STREAM IL:CBUFSIZE) IL:|of| STREAM + IL:|with| (IL:|fetch| (STREAM IL:COFFSET) IL:|of| STREAM)) + (IL:|freplace| (STREAM IL:EPAGE) IL:|of| STREAM IL:|with| 1) + (IL:|freplace| (IL:TEXTSTREAM IL:CHARSLEFT) IL:|of| STREAM IL:|with| + 0) + (IL:* IL:\; + "We're, perforce, at the end of the piece.") + (IL:|freplace| (IL:TEXTSTREAM IL:REALFILE) IL:|of| STREAM IL:|with| + NIL) + (IL:* IL:\; "We're not on a file....") + ))))) +) +(IL:DEFINEQ + +(IL:TEDITSTREAM.INIT + (IL:LAMBDA (IL:WINDOW IL:MENUFN) (IL:* IL:\; "Edited 12-Jun-90 18:01 by mitani") + + (IL:* IL:|;;| "Initialize and return TEDIT TEXTSTREAM") + + (PROG* ((IL:TEXTSTREAM (IL:OPENTEXTSTREAM NIL IL:WINDOW NIL NIL)) + (IL:TEXTOBJ (IL:TEXTOBJ IL:TEXTSTREAM))) (IL:* IL:\; + "force shift select typein to be put in keyboard buffer") + (IL:TEXTPROP IL:TEXTSTREAM 'IL:COPYBYBKSYSBUF T) + (IL:|replace| (STREAM IL:STRMBOUTFN) IL:|of| IL:TEXTSTREAM IL:|with| + 'IL:\\TEXTSTREAMBOUT) + (IL:|replace| SET IL:|of| (IL:|fetch| (IL:TEXTOBJ IL:SEL) IL:|of| + IL:TEXTOBJ) + IL:|with| T) + (IL:|replace| IL:L1 IL:|of| (IL:|fetch| (IL:TEXTOBJ IL:SEL) IL:|of| + IL:TEXTOBJ) + IL:|with| (LIST (IL:|fetch| IL:DESC IL:|of| (IL:|fetch| (IL:TEXTOBJ + IL:THISLINE) + IL:|of| IL:TEXTOBJ)))) + (IL:* IL:\; + "hookup middle button menu instead of TEDIT menu") + (IL:WINDOWPROP IL:WINDOW 'IL:TEDIT.TITLEMENUFN IL:MENUFN) + (RETURN IL:TEXTSTREAM)))) + +(IL:TEDITCHAT.MENUFN + (IL:LAMBDA (IL:WINDOW) (IL:* IL:|| "20-Oct-86 15:03") + (DECLARE (IL:GLOBALVARS IL:TEDITCHAT.MENU) + (IL:SPECVARS IL:WINDOW IL:STATE)) (IL:* IL:MIDDLEBUTTON) + (PROG ((IL:STATE (IL:WINDOWPROP IL:WINDOW 'IL:CHATSTATE)) + IL:COMMAND) + (COND + ((NOT IL:STATE) (IL:* IL:N\o IL:|Connection| + IL:|here;| IL:|try| IL:|to| + IL:|reestablish|) + (RETURN (COND + ((IL:LASTMOUSESTATE IL:MIDDLE) + (IL:CHAT.RECONNECT IL:WINDOW)) + (T (IL:TOTOPW IL:WINDOW)))))) + (IL:|replace| (IL:CHAT.STATE IL:HELD) IL:|of| IL:STATE IL:|with| T) + (IL:\\CHECKCARET IL:WINDOW) + (IL:SELECTQ (IL:SETQ IL:COMMAND (IL:MENU (OR IL:TEDITCHAT.MENU (IL:SETQ IL:TEDITCHAT.MENU + (IL:|create| IL:MENU + IL:ITEMS IL:_ + IL:TEDITCHAT.MENUITEMS + ))))) + (IL:|Close| (IL:|replace| (IL:CHAT.STATE IL:RUNNING?) IL:|of| IL:STATE + IL:|with| 'IL:CLOSE) (IL:* IL:|Ask| IL:CHAT.TYPEIN IL:|to| + IL:|shut| IL:|things| IL:|down.|) + ) + (IL:|New| (IL:|replace| (IL:CHAT.STATE IL:RUNNING?) IL:|of| IL:STATE + IL:|with| 'IL:CLOSE) + (IL:WINDOWPROP IL:WINDOW 'IL:KEEPCHAT 'IL:NEW)) + (IL:|Suspend| (IL:|replace| (IL:CHAT.STATE IL:RUNNING?) IL:|of| IL:STATE + IL:|with| 'IL:CLOSE) + (IL:WINDOWPROP IL:WINDOW 'IL:KEEPCHAT T)) + (IL:|Freeze| (IL:* IL:|Leave| IL:|in| IL:HELD + IL:|state|) + (RETURN)) + (NIL) + (IL:APPLY* IL:COMMAND IL:STATE IL:WINDOW)) + (IL:|replace| (IL:CHAT.STATE IL:HELD) IL:|of| IL:STATE IL:|with| NIL)))) +) + + + +(IL:* IL:\; "TEDIT update routines") + +(IL:DEFINEQ + +(IL:TEDIT.DISPLAYTEXT + (IL:LAMBDA (IL:TEXTOBJ IL:CH IL:CHWIDTH IL:LINE IL:XPOINT IL:DS IL:SEL) + (IL:* IL:\; "Edited 12-Jun-90 18:01 by mitani") + (IL:* IL:|This| IL:|function| + IL:|does| IL:|the| IL:|actual| + IL:|displaying| IL:|of| + IL:|typed-in| IL:|text| IL:|on| + IL:|the| IL:|edit| IL:|window.|) + (PROG ((IL:LOOKS (IL:\\TEDIT.APPLY.STYLES (IL:|fetch| (IL:TEXTOBJ IL:CARETLOOKS) IL:|of| + IL:TEXTOBJ) + (IL:|fetch| (IL:TEXTOBJ IL:\\INSERTPC) IL:|of| IL:TEXTOBJ) + IL:TEXTOBJ)) + (IL:TERMSA (IL:|fetch| (IL:TEXTOBJ IL:TXTTERMSA) IL:|of| IL:TEXTOBJ)) + IL:DY IL:FONT) + (IL:MOVETO IL:XPOINT (IL:IPLUS (IL:|fetch| IL:YBASE IL:|of| IL:LINE) + (OR (IL:|fetch| IL:CLOFFSET IL:|of| IL:LOOKS) + 0)) + IL:DS) (IL:* IL:|Set| IL:|the| IL:|display| + IL:|stream| IL:|position|) + (COND + (IL:TERMSA (IL:* IL:|Special| IL:|terminal| + IL:|table| IL:|for| IL:|controlling| + IL:|character| IL:|display.| + IL:|Use| IL:|it.|) + (IL:RESETLST + (IL:RESETSAVE IL:\\PRIMTERMSA IL:TERMSA) + (IL:|replace| (IL:TEXTSTREAM IL:REALFILE) IL:|of| (IL:|fetch| + (IL:TEXTOBJ + IL:STREAMHINT + ) + IL:|of| + IL:TEXTOBJ) + IL:|with| IL:DS) + (COND + ((IL:STRINGP IL:CH) + (IL:|for| IL:CHAR IL:|instring| IL:CH + IL:|do| (IL:SELCHARQ IL:CHAR + (IL:TAB (IL:* IL:|Put| IL:|down| IL:|white|) + (IL:BITBLT NIL 0 0 IL:DS IL:XPOINT + (IL:|fetch| IL:YBOT IL:|of| + IL:LINE) + 36 + (IL:|fetch| IL:LHEIGHT + IL:|of| IL:LINE) + 'IL:TEXTURE + 'IL:REPLACE IL:WHITESHADE) + (IL:RELMOVETO 36 0 IL:DS)) + (IL:CR (IL:BITBLT NIL 0 0 IL:DS IL:XPOINT + (IL:|fetch| IL:YBOT IL:|of| + IL:LINE) + (IL:IMAX 6 (IL:CHARWIDTH IL:CHAR + IL:FONT)) + (IL:|fetch| IL:LHEIGHT + IL:|of| IL:LINE) + 'IL:TEXTURE + 'IL:REPLACE IL:WHITESHADE)) + (IL:\\DSPPRINTCHAR (IL:|fetch| (IL:TEXTOBJ + IL:STREAMHINT) + IL:|of| IL:TEXTOBJ) + IL:CHAR)))) + (T (IL:SELCHARQ IL:CH + (IL:TAB (IL:* IL:|Put| IL:|down| IL:|white|) + (IL:BITBLT NIL 0 0 IL:DS IL:XPOINT (IL:|fetch| + IL:YBOT + IL:|of| IL:LINE + ) + 36 + (IL:|fetch| IL:LHEIGHT IL:|of| IL:LINE) + 'IL:TEXTURE + 'IL:REPLACE IL:WHITESHADE) + (IL:RELMOVETO 36 0 IL:DS)) + (IL:CR (IL:BITBLT NIL 0 0 IL:DS IL:XPOINT (IL:|fetch| IL:YBOT + IL:|of| IL:LINE) + (IL:IMAX 6 (IL:CHARWIDTH IL:CH IL:FONT)) + (IL:|fetch| IL:LHEIGHT IL:|of| IL:LINE) + 'IL:TEXTURE + 'IL:REPLACE IL:WHITESHADE)) + (IL:\\DSPPRINTCHAR (IL:|fetch| (IL:TEXTOBJ IL:STREAMHINT) + IL:|of| IL:TEXTOBJ) + IL:CH)))))) + (T (IL:* IL:N\o IL:|special| + IL:|handling;| IL:|just| IL:|use| + IL:|native| IL:|character| + IL:|codes|) + (COND + ((IL:STRINGP IL:CH) + (IL:|for| IL:CHAR IL:|instring| IL:CH + IL:|do| (IL:SELCHARQ IL:CHAR + (IL:TAB (IL:* IL:|Put| IL:|down| IL:|white|) + (IL:BITBLT NIL 0 0 IL:DS (IL:DSPXPOSITION NIL IL:DS) + (IL:|fetch| IL:YBOT IL:|of| IL:LINE) + 36 + (IL:|fetch| IL:LHEIGHT IL:|of| + IL:LINE) + 'IL:TEXTURE + 'IL:REPLACE IL:WHITESHADE) + (IL:RELMOVETO 36 0 IL:DS)) + (IL:CR (IL:BITBLT NIL 0 0 IL:DS (IL:DSPXPOSITION NIL IL:DS) + (IL:|fetch| IL:YBOT IL:|of| IL:LINE) + (IL:IMAX 6 (IL:CHARWIDTH IL:CHAR IL:FONT)) + (IL:|fetch| IL:LHEIGHT IL:|of| IL:LINE + ) + 'IL:TEXTURE + 'IL:REPLACE IL:WHITESHADE)) + (IL:BLTCHAR IL:CHAR IL:DS)))) + (T (IL:SELCHARQ IL:CH + (IL:TAB (IL:* IL:|Put| IL:|down| IL:|white|) + (IL:BITBLT NIL 0 0 IL:DS (IL:DSPXPOSITION NIL IL:DS) + (IL:|fetch| IL:YBOT IL:|of| IL:LINE) + 36 + (IL:|fetch| IL:LHEIGHT IL:|of| IL:LINE) + 'IL:TEXTURE + 'IL:REPLACE IL:WHITESHADE) + (IL:RELMOVETO 36 0 IL:DS)) + (IL:CR (IL:* IL:|Blank| IL:|out| IL:|the| + IL:|CR's| IL:|width.|) + (IL:BITBLT NIL 0 0 IL:DS (IL:DSPXPOSITION NIL IL:DS) + (IL:|fetch| IL:YBOT IL:|of| IL:LINE) + (IL:IMAX 6 (IL:CHARWIDTH IL:CH IL:FONT)) + (IL:|fetch| IL:LHEIGHT IL:|of| IL:LINE) + 'IL:TEXTURE + 'IL:REPLACE IL:WHITESHADE)) + (IL:BLTCHAR IL:CH IL:DS))))))))) +) +(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY + +(IL:GLOBALVARS IL:TEDITCHAT.MENU IL:CHAT.DRIVERTYPES IL:CHAT.DISPLAYTYPES) +) + +(IL:RPAQQ IL:TEDITCHAT.MENUITEMS + ((IL:|Close| 'IL:|Close| "Closes the connection and returns") + (IL:|Suspend| 'IL:|Suspend| "Closes the connection but leaves window up") + (IL:|New| 'IL:|New| "Closes this connection and prompts for a new host") + (IL:|Freeze| 'IL:|Freeze| "Holds typeout in this window until you bug it again") + ("Dribble" (IL:FUNCTION IL:CHAT.TYPESCRIPT) + "Starts a typescript of window typeout") + ("Input" (IL:FUNCTION IL:CHAT.TAKE.INPUT) + "Allows input from a file") + ("Option" (IL:FUNCTION IL:DO.CHAT.OPTION) + "Do protocol specific option"))) + +(IL:RPAQQ IL:TEDITCHAT.MENU NIL) + +(IL:ADDTOVAR IL:CHAT.DRIVERTYPES (IL:TEDIT IL:TEDITCHAT.CHARFN IL:NILL)) +(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY + +(IL:FILESLOAD (IL:SOURCE) + IL:CHATDECLS) +) +(IL:PUTPROPS IL:TEDITCHAT IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990 1994)) +(IL:DECLARE\: IL:DONTCOPY + (IL:FILEMAP (NIL (1308 15667 (IL:TEDITCHAT.CHARFN 1321 . 2481) (IL:\\TEXTSTREAMBOUT 2483 . 15665)) ( +15668 20008 (IL:TEDITSTREAM.INIT 15681 . 17389) (IL:TEDITCHAT.MENUFN 17391 . 20006)) (20054 30055 ( +IL:TEDIT.DISPLAYTEXT 20067 . 30053))))) +IL:STOP diff --git a/library/TEDITCOMMAND b/library/TEDITCOMMAND new file mode 100644 index 00000000..2fb91275 --- /dev/null +++ b/library/TEDITCOMMAND @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "20-Apr-2018 08:07:35"  {DSK}kaplan>Local>medley3.5>lispcore>library>TEDITCOMMAND.;2 50383 changes to%: (FNS \TEDIT.READTABLE \TEDIT.COMMAND.LOOP TEDIT.GETFUNCTION TEDIT.SETFUNCTION) previous date%: "25-Aug-94 10:52:51" {DSK}kaplan>Local>medley3.5>lispcore>library>TEDITCOMMAND.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1994, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDITCOMMANDCOMS) (RPAQQ TEDITCOMMANDCOMS ((FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (FNS \TEDIT.INSERT.TTY.BUFFER \TEDIT.INTERRUPT.SETUP \TEDIT.MARKACTIVE \TEDIT.MARKINACTIVE \PNC \TEDIT.COMMAND.LOOP \TEDIT.COMMAND.RESET.SETUP) [INITVARS (TEDIT.INTERRUPTS '((2 BREAK) (5 ERROR) (7 HELP) (20 CONTROL-T] (VARS (TEDIT.COPY.PENDING NIL) (TEDIT.COPYLOOKS.PENDING NIL) (TEDIT.MOVE.PENDING NIL) (TEDIT.DEL.PENDING NIL) (TEDIT.BLUEPENDINGDELETE NIL)) (GLOBALVARS TEDIT.COPY.PENDING TEDIT.COPYLOOKS.PENDING TEDIT.MOVE.PENDING TEDIT.DEL.PENDING TEDIT.BLUEPENDINGDELETE TEDIT.INTERRUPTS) (COMS (* ; "Read-table Utilities") (FNS \TEDIT.READTABLE \TEDIT.WORDBOUND.READTABLE TEDIT.GETSYNTAX TEDIT.SETSYNTAX TEDIT.GETFUNCTION TEDIT.SETFUNCTION TEDIT.WORDGET TEDIT.WORDSET) [DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (TEDIT.READTABLE (\TEDIT.READTABLE)) (TEDIT.WORDBOUND.READTABLE ( \TEDIT.WORDBOUND.READTABLE ] (GLOBALVARS TEDIT.READTABLE TEDIT.WORDBOUND.READTABLE)))) (FILESLOAD TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SCRATCHLEN 64) (CONSTANTS (\SCRATCHLEN 64)) ) (FILESLOAD (LOADCOMP) TEDITDCL) ) (DEFINEQ (\TEDIT.INSERT.TTY.BUFFER [LAMBDA (SCRATCH PASS TEXTOBJ SEL) (* ; "Edited 23-Feb-88 11:11 by jds") (* ;; "OBSOLETE 2/9/86 ?? JDS") (* ;; "(PROG ((TLEN (fetch (STRINGP OFFST) of SCRATCH))) (COND ((NOT (ZEROP TLEN)) (* If there are typed-ahead characters cached, insert them in the text object and clear the cache.) (replace (STRINGP OFFST) of SCRATCH with 0) (replace (STRINGP LENGTH) of SCRATCH with \SCRATCHLEN) (replace (STRINGP LENGTH) of PASS with TLEN) (TEDIT.\INSERT PASS SEL TEXTOBJ BLANKSEEN CRSEEN))))") (HELP]) (\TEDIT.INTERRUPT.SETUP (LAMBDA (PROC FORCEOFF) (* jds "12-Sep-84 15:36") (* Disarm any inconvenient interrupts, and save re-arming info on the window.) (PROG ((TEXTOBJ (AND (PROCESSPROP PROC 'WINDOW) (WINDOWPROP (PROCESSPROP PROC 'WINDOW) 'TEXTOBJ) (TEXTOBJ (PROCESSPROP PROC 'WINDOW))))) (UNINTERRUPTABLY (COND ((AND FORCEOFF (PROCESSPROP PROC 'TEDIT.INTERRUPTS)) (* There are disarmed interrupts;  re-arm them.) (RESET.INTERRUPTS (PROCESSPROP PROC 'TEDIT.INTERRUPTS)) (PROCESSPROP PROC 'TEDIT.INTERRUPTS NIL)) ((AND (NOT FORCEOFF) (NOT (PROCESSPROP PROC 'TEDIT.INTERRUPTS))) (* There aren't any interrupts  disarmed; go do it.) (PROCESSPROP PROC 'TEDIT.INTERRUPTS (RESET.INTERRUPTS (OR (AND TEXTOBJ (TEXTPROP TEXTOBJ 'INTERRUPTS)) TEDIT.INTERRUPTS) T)))))) PROC)) (\TEDIT.MARKACTIVE [LAMBDA (TEXTOBJ) (* ; "Edited 12-Jun-90 18:04 by mitani") (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with T) TEXTOBJ]) (\TEDIT.MARKINACTIVE [LAMBDA (TEXTOBJ) (* ; "Edited 12-Jun-90 18:04 by mitani") (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with NIL) TEXTOBJ]) (\PNC (LAMBDA (CH STR) (* jds " 7-JUN-82 14:03") (PROG ((LEN (fetch (STRINGP LENGTH) of STR)) (OFFST (fetch (STRINGP OFFST) of STR))) (COND ((ZEROP LEN) (ERROR "NO ROOM LEFT IN STRING TO PUT CHARACTER")) (T (UNINTERRUPTABLY (\PUTBASEBYTE (fetch (STRINGP BASE) of STR) OFFST CH) (replace (STRINGP OFFST) of STR with (ADD1 OFFST)) (replace (STRINGP LENGTH) of STR with (SUB1 LEN)))))))) (\TEDIT.COMMAND.LOOP [LAMBDA (STREAM RTBL) (* ; "Edited 30-May-91 19:33 by jds") (* ;; "Main command loop for the TEDIT editor. Includes keyboard polling and command dispatch") (PROG ((TEXTOBJ (COND ((type? STREAM STREAM) (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) (T STREAM))) (ISCRSTRING (ALLOCSTRING \SCRATCHLEN " ")) SEL WINDOW LINES IPASSSTRING TTYWINDOW) (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 '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)) (RESETLST (RESETSAVE (\TEDIT.COMMAND.RESET.SETUP (LIST TEXTOBJ WINDOW) T)) (PROG (CH FN TCH (DIRTY NIL) (BLANKSEEN NIL) INSCH# (CRSEEN NIL) TLEN CHNO (READSA (fetch READSA of %#CURRENTRDTBL#)) (TERMSA (OR (fetch (TEXTOBJ TXTTERMSA) of TEXTOBJ) \PRIMTERMSA)) (TEDITSA (fetch READSA of RTBL)) (TEDITFNHASH (fetch READMACRODEFS of RTBL)) (LOOPFN (TEXTPROP TEXTOBJ 'LOOPFN)) (CHARFN (TEXTPROP TEXTOBJ 'CHARFN)) COMMANDFN) (while (NOT (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ)) do [ERSETQ (while (NOT (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ)) do (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.") (AND LOOPFN (ERSETQ (APPLY* LOOPFN STREAM))) (* ;  "If the guy wants control during the loop, give it to him.") (* ; "Process any pending selections") [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)) (ERSETQ (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)) [ERSETQ (COND ((EQ '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) (ERSETQ (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") (ERSETQ (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) '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 )) (while (\SYSBUFP) do (* ; "Handle user type-in") (SETQ CH (\GETKEY)) (COND (CHARFN (* ;  "Give the OEM user control for each character typed.") (SETQ TCH (APPLY* CHARFN STREAM CH)) (OR (EQ TCH T) (SETQ CH TCH)) (* ;  "And let him return one of NIL for 'ignore this char' , T for 'leave it be' or a new charcode.") )) (SELECTC (AND CH (\SYNCODE TEDITSA CH)) (CHARDELETE.TTC (* ;  "Backspace handler: Remove the character just before SEL:CH#.") (\TEDIT.CHARDELETE TEXTOBJ ISCRSTRING SEL) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (WORDDELETE.TTC (\TEDIT.WORDDELETE TEXTOBJ) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (DELETE.TTC (* ;  "DEL Key handler: Delete the selected characters") (\TEDIT.DELETE SEL TEXTOBJ) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (UNDO.TTC (* ;  "He hit the CANCEL key, so go UNDO something") (TEDIT.UNDO TEXTOBJ) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (REDO.TTC (* ;  "He hit the REDO key, so go REDO something") (TEDIT.REDO TEXTOBJ) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (FUNCTIONCALL.TTC (* ;  "This is a special character -- it calls a function") (COND ([SETQ FN (CAR (FETCH MACROFN OF (GETHASH CH TEDITFNHASH] (* ;  "There IS a command function to be called.") (APPLY* FN (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) TEXTOBJ SEL) (* ; "do it") (\SHOWSEL SEL NIL NIL) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* ;  "After a user function, no more blue-pending-delete") (\SHOWSEL SEL NIL T) (* ;  "And forget any pending deletion.") ))) (NEXT.TTC (* ;  "Move to the next blank to fill in. For now, blanks are delimited by >>...<<") (TEDIT.NEXT TEXTOBJ)) (EXPAND.TTC (* ; "EXPAND AN ABBREVIATION") (\TEDIT.ABBREV.EXPAND (fetch (TEXTOBJ STREAMHINT ) of TEXTOBJ))) (SELECTC (AND TERMSA CH (fetch TERMCLASS of (\SYNCODE TERMSA CH) )) (CHARDELETE.TC (* ;  "Backspace handler: Remove the character just before SEL:CH#.") (\TEDIT.CHARDELETE TEXTOBJ ISCRSTRING SEL) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (WORDDELETE.TC (* ; "Back-WORD handler") (\TEDIT.WORDDELETE TEXTOBJ) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (LINEDELETE.TC (* ;  "DEL Key handler: Delete the selected characters") (\TEDIT.DELETE SEL TEXTOBJ) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL)) (COND (CH (* ;  "Any other key was hit: Just insert the character.") (TEDIT.DO.BLUEPENDINGDELETE SEL TEXTOBJ) (* ;  "Handle blue pending delete, if there is one.") (TEDIT.\INSERT CH SEL TEXTOBJ BLANKSEEN CRSEEN] (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with NIL] (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with NIL))))]) (\TEDIT.COMMAND.RESET.SETUP [LAMBDA (TEXT&WIND STARTING) (* ; "Edited 12-Jun-90 18:04 by mitani") (* ;; "If STARTING is T, set up the reset-driven connections and values for editing; otherwise, break links and reset values for non-editing") (PROG ((TEXTOBJ (CAR TEXT&WIND)) (WINDOW (CADR TEXT&WIND)) (OTTYWINDOW (CADDR TEXT&WIND)) (OTTYENTRYFN (CADDDR TEXT&WIND)) (OTTYEXITFN (CAR (CDDDDR TEXT&WIND))) (OWINDOW (CADR (CDDDDR TEXT&WIND))) TTYWINDOW) [COND (STARTING (* ;  "We're going INTO the command loop. Set up all the stuff") (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with T) (* ;  "Mark us busy until we're set up, so that nobody tries any funny stuff.") (SETQ OWINDOW (PROCESSPROP (THIS.PROCESS) 'WINDOW (CAR WINDOW))) (* ;  "Attach the process to this window.") (\TEDIT.INTERRUPT.SETUP (THIS.PROCESS)) (* ;  "Disarm all interrupt chars, re-arm them when we leave the edit") (SETQ OTTYEXITFN (PROCESSPROP (THIS.PROCESS) 'TTYEXITFN '\TEDIT.PROCEXITFN)) (* ;  "Set up functions for getting in and out of the edit process") (SETQ OTTYENTRYFN (PROCESSPROP (THIS.PROCESS) 'TTYENTRYFN '\TEDIT.PROCENTRYFN)) [COND ((NEQ (TEXTPROP TEXTOBJ 'TTYWINDOW) 'DON'T) (* ;  "He can suppress the ability to copy-select things into this window if he wants....") (SETQ TTYWINDOW (OR (TEXTPROP TEXTOBJ 'TTYWINDOW) (CREATEW DEFAULTTTYREGION "TTY Window for TEdit" NIL T))) (SETQ OTTYWINDOW (TTYDISPLAYSTREAM TTYWINDOW)) (PROCESSPROP (THIS.PROCESS) 'TEDITTTYWINDOW TTYWINDOW) (WINDOWPROP TTYWINDOW 'PROCESS NIL) [WINDOWPROP TTYWINDOW 'CLOSEFN (FUNCTION (LAMBDA (WW) (WINDOWPROP WW 'PROCESS NIL] (* ;  "So that there isn't a circularity in the PROCESS -> TTYWINDOW -> PROCESS") (WINDOWPROP TTYWINDOW 'COPYINSERTFN (FUNCTION \TEDIT.COPYINSERTFN)) (WINDOWPROP TTYWINDOW 'MAINWINDOW (CAR WINDOW] (replace (TEXTOBJ TXTEDITING) of TEXTOBJ with T) (* ;  "Tell TEdit that this document is actively being edited.") (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with NIL) (* ;  "Mark us un-busy so life can go on.") ) (T (* ;  "Coming OUT OF the command loop -- reset everything") (PROCESSPROP (THIS.PROCESS) 'WINDOW (CAR WINDOW)) (* ;  "Detach the window from the edit process, to prevent circularity there") (WINDOWPROP (CAR WINDOW) 'PROCESS NIL) (\TEDIT.INTERRUPT.SETUP (THIS.PROCESS) T) (* ;  "Re-arm the interrupts we turned off coming in.") (COND ((AND (TXTFILE TEXTOBJ) (NOT (WINDOWPROP (CAR WINDOW) 'TEDIT-CLOSING-FILE T)))(* ;  "Remember to close the file we were editing (Only if the window function isn't closing it.)") (CLOSEF? (TXTFILE TEXTOBJ)) (WINDOWPROP (CAR WINDOW) 'TEDIT-CLOSING-FILE NIL) (* ;  "And let anyone else who wants to try closing the file do so.") )) (PROCESSPROP (THIS.PROCESS) 'TTYEXITFN OTTYEXITFN) (PROCESSPROP (THIS.PROCESS) 'TTYENTRYFN OTTYENTRYFN) (replace (TEXTOBJ TXTHISTORY) of TEXTOBJ with NIL) (* ;  "To prevent circularities arising from the need to remember textobjs in the history list.") (replace (TEXTOBJ SELWINDOW) of TEXTOBJ with NIL) (* ;  "To prevent a circularity thru the window back to the textobj.") (replace (TEXTOBJ TXTEDITING) of TEXTOBJ with NIL) (* ;  "Tell TEdit that this document is NO LONGER actively being edited.") (COND ((NEQ (TEXTPROP TEXTOBJ 'TTYWINDOW) 'DON'T) (* ;  "He can suppress the ability to copy-select things into this window if he wants....") (TTYDISPLAYSTREAM OTTYWINDOW) (PROCESSPROP (THIS.PROCESS) 'TEDITTTYWINDOW NIL] (RETURN (LIST TEXTOBJ WINDOW OTTYWINDOW OTTYENTRYFN OTTYEXITFN OWINDOW]) ) (RPAQ? TEDIT.INTERRUPTS '((2 BREAK) (5 ERROR) (7 HELP) (20 CONTROL-T))) (RPAQQ TEDIT.COPY.PENDING NIL) (RPAQQ TEDIT.COPYLOOKS.PENDING NIL) (RPAQQ TEDIT.MOVE.PENDING NIL) (RPAQQ TEDIT.DEL.PENDING NIL) (RPAQQ TEDIT.BLUEPENDINGDELETE NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.COPY.PENDING TEDIT.COPYLOOKS.PENDING TEDIT.MOVE.PENDING TEDIT.DEL.PENDING TEDIT.BLUEPENDINGDELETE TEDIT.INTERRUPTS) ) (* ; "Read-table Utilities") (DEFINEQ (\TEDIT.READTABLE [LAMBDA NIL (* ; "Edited 20-Apr-2018 07:59 by rmk:") (* jds "12-Sep-86 13:48") (* Create a TEdit read-table, to control which characters have what functions  and call which commands.) (PROG [(RTBL (create READTABLEP READMACRODEFS _ (HASHARRAY 50] (for CH in (CHARCODE (BS ^A ^W DEL %#A %#B %#C ESC)) as CL in (LIST CHARDELETE.TTC CHARDELETE.TTC WORDDELETE.TTC DELETE.TTC UNDO.TTC NEXT.TTC CMD.TTC REDO.TTC) do (* Set up the default syntax classes  for command characters) (\SETSYNCODE (fetch READSA of RTBL) CH CL)) (for CH in (CHARCODE (^X)) as FN in '(\TEDIT.ABBREV.EXPAND) do (* Set up the default  function-calling characters  (^X to expand abbrevs for now)) (TEDIT.SETFUNCTION CH FN RTBL)) (TEDIT.SETFUNCTION (CHARCODE ^O) (FUNCTION GET.OBJ.FROM.USER) RTBL) (* And for image object capture) (RETURN RTBL]) (\TEDIT.WORDBOUND.READTABLE [LAMBDA NIL (* ; "Edited 22-May-92 15:10 by jds") (* ;; "Create a readtable which will let TEdit find word boundaries. A word boundary is any point where the SYNCODE of the adjacent characters is different") (PROG [(RTBL (create READTABLEP READMACRODEFS _ (HARRAY 50] (for CH from 0 to 255 do (\SETSYNCODE (fetch READSA of RTBL) CH PUNCT.TTC)) (* ;; "By default, every character except those noted below is a punctuation character") (for CH from (CHARCODE A) to (CHARCODE Z) do (\SETSYNCODE (fetch READSA of RTBL) CH TEXT.TTC)) (* ; "Upper case alpha") (for CH from (CHARCODE a) to (CHARCODE z) do (\SETSYNCODE (fetch READSA of RTBL) CH TEXT.TTC)) (* ; "Lower case alpha") (for CH from (CHARCODE 0) to (CHARCODE 9) do (\SETSYNCODE (fetch READSA of RTBL) CH TEXT.TTC)) (* ; "And digits are text characters") (* ;; "European chars and accents are text characters:") (for CH from (CHARCODE "361,41") to (CHARCODE "361,376") do (\SETSYNCODE (fetch READSA of RTBL) CH TEXT.TTC)) (for CH from (CHARCODE "0,301") to (CHARCODE "0,317") do (\SETSYNCODE (fetch READSA of RTBL) CH TEXT.TTC)) (for CH from (CHARCODE "0,341") to (CHARCODE "0,376") do (\SETSYNCODE (fetch READSA of RTBL) CH TEXT.TTC)) (for CH in (CHARCODE (CR SPACE TAB ^L)) do (\SETSYNCODE (fetch READSA of RTBL) CH WHITESPACE.TTC)) (* ; "And these are white space") (for CH in (LIST MSPACE NSPACE THINSPACE FIGSPACE) do (\SETSYNCODE (fetch READSA of RTBL) CH TEXT.TTC)) (RETURN RTBL]) (TEDIT.GETSYNTAX [LAMBDA (CH TABLE) (* ; "Edited 31-Mar-87 10:01 by jds") (* ;  "Find TEdit's interpretation of a given character") (SELECTC (\SYNCODE [fetch READSA of (COND ((type? TEXTOBJ TABLE) (* ;  "If given a TEXTOBJ in place of a read table, coerce it to the read table for that edit session") (OR (fetch (TEXTOBJ TXTRTBL) of TABLE) TEDIT.READTABLE)) ((type? STREAM TABLE) (* ;  "If given a TEXTOBJ in place of a read table, coerce it to the read table for that edit session") (OR (fetch (TEXTOBJ TXTRTBL) of (fetch (TEXTSTREAM TEXTOBJ) of TABLE)) TEDIT.READTABLE)) (T (OR TABLE TEDIT.READTABLE] (COND ((LITATOM CH) (* ;  "Symbols are converted to numeric charcodes") (APPLY* 'CHARCODE CH)) ((STRINGP CH) (* ; "As are string char-names") (APPLY* 'CHARCODE CH)) (T CH))) (WORDDELETE.TTC 'WORDDELETE) (CHARDELETE.TTC 'CHARDELETE) (DELETE.TTC 'DELETE) (UNDO.TTC 'UNDO) (REDO.TTC 'REDO) (FUNCTIONCALL.TTC 'FN) (CMD.TTC 'CMD) (NEXT.TTC 'NEXT) (EXPAND.TTC 'EXPAND) NIL]) (TEDIT.SETSYNTAX [LAMBDA (CHAR CLASS TABLE) (* ; "Edited 31-Mar-87 10:00 by jds") (* ;  "SETS TEDIT-STYLE SYNTAX BITS IN A TERMTABLE") (PROG1 (TEDIT.GETSYNTAX (SETQ CHAR (COND ((LITATOM CHAR) (APPLY* 'CHARCODE CHAR)) ((STRINGP CHAR) (APPLY* 'CHARCODE CHAR)) (T CHAR))) TABLE) (\SETSYNCODE [fetch READSA of (COND ((type? TEXTOBJ TABLE) (* ;  "If given a TEXTOBJ in place of a read table, coerce it to the read table for that edit session") (OR (fetch (TEXTOBJ TXTRTBL) of TABLE) TEDIT.READTABLE)) ((type? STREAM TABLE) (* ;  "If given a TEXTOBJ in place of a read table, coerce it to the read table for that edit session") (OR (fetch (TEXTOBJ TXTRTBL) of (fetch (TEXTSTREAM TEXTOBJ) of TABLE)) TEDIT.READTABLE)) (T (OR TABLE TEDIT.READTABLE] CHAR (SELECTQ CLASS (CHARDELETE CHARDELETE.TTC) (WORDDELETE WORDDELETE.TTC) ((DELETE LINEDELETE) DELETE.TTC) (UNDO UNDO.TTC) (REDO REDO.TTC) (CMD CMD.TTC) (FN FUNCTIONCALL.TTC) (NEXT NEXT.TTC) (EXPAND EXPAND.TTC) NONE.TTC]) (TEDIT.GETFUNCTION [LAMBDA (CHARCODE TABLE) (* jds "19-Sep-85 17:06") (* Gets the FN that is called when  CH is hit inside TEDIT.) [SETQ TABLE (COND ((type? TEXTOBJ TABLE) (* If given a TEXTOBJ in place of a read table, coerce it to the read table for  that edit session) (fetch (TEXTOBJ TXTRTBL) of TABLE)) ((type? STREAM TABLE) (* If given a TEXTOBJ in place of a read table, coerce it to the read table for  that edit session) (fetch (TEXTOBJ TXTRTBL) of (fetch (TEXTSTREAM TEXTOBJ) of TABLE) )) (T (OR TABLE TEDIT.READTABLE] (SETQ CHARCODE (COND ((LITATOM CHARCODE) (APPLY* 'CHARCODE CHARCODE)) (T CHARCODE))) (AND TABLE (type? READTABLEP TABLE) (IEQP FUNCTIONCALL.TTC (\SYNCODE (fetch READSA of TABLE) CHARCODE)) (fetch READMACRODEFS of TABLE) (CAR (FETCH MACROFN OF (GETHASH CHARCODE (fetch READMACRODEFS of TABLE]) (TEDIT.SETFUNCTION [LAMBDA (CHARCODE FN RTBL) (* ; "Edited 31-Mar-87 10:58 by jds") (* ;  "Set TEDITs (read) table so that FN is called whenever CHARCODE is typed.") (* ;  "If FN is NIL, make the character be normal again.") [SETQ RTBL (COND ((type? TEXTOBJ RTBL) (* ;  "If given a TEXTOBJ in place of a read table, coerce it to the read table for that edit session") (fetch (TEXTOBJ TXTRTBL) of RTBL)) ((type? STREAM RTBL) (* ;  "If given a TEXTOBJ in place of a read table, coerce it to the read table for that edit session") (fetch (TEXTOBJ TXTRTBL) of (fetch (TEXTSTREAM TEXTOBJ) of RTBL))) (T (OR RTBL TEDIT.READTABLE] (\SETSYNCODE (fetch READSA of RTBL) (SETQ CHARCODE (COND ((LITATOM CHARCODE) (APPLY* 'CHARCODE CHARCODE)) ((STRINGP CHARCODE) (APPLY* 'CHARCODE CHARCODE)) (T CHARCODE))) (COND (FN (* ;  "He gave us a function to call. Set up the syntax so it IS called.") FUNCTIONCALL.TTC) (T (* ;  "He gave us a function of NIL, meaning 'turn it off' . Cause this character to become normal.") NONE.TTC))) (* ;  "Mark the character as invoking a function") (OR (fetch READMACRODEFS of RTBL) (replace READMACRODEFS of RTBL with (HARRAY 50))) (* ;  "Make sure there's a hash table to store the function in.") (PUTHASH CHARCODE (CREATE READMACRODEF MACROTYPE _ 'TEDIT MACROFN _ (LIST FN)) (fetch READMACRODEFS of RTBL]) (TEDIT.WORDGET (LAMBDA (CH TABLE) (* jds "27-MAY-83 13:24") (\SYNCODE (fetch READSA of (OR TABLE TEDIT.WORDBOUND.READTABLE)) (COND ((SMALLP CH)) (T (CHCON1 CH)))))) (TEDIT.WORDSET (LAMBDA (CHARCODE CLASS TABLE) (* jds " 1-JUN-83 12:23") (* SETS TEDIT-STYLE SYNTAX BITS IN A  TERMTABLE) (\SETSYNCODE (fetch READSA of (OR TABLE TEDIT.WORDBOUND.READTABLE)) (COND ((SMALLP CHARCODE)) (T (CHCON1 CHARCODE))) (COND ((FIXP CLASS)) (T (SELECTQ CLASS (PUNCTUATION PUNCT.TTC) (WHITESPACE WHITESPACE.TTC) (TEXT TEXT.TTC) TEXT.TTC)))))) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ TEDIT.READTABLE (\TEDIT.READTABLE)) (RPAQ TEDIT.WORDBOUND.READTABLE (\TEDIT.WORDBOUND.READTABLE)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.READTABLE TEDIT.WORDBOUND.READTABLE) ) (PUTPROPS TEDITCOMMAND COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1991 1992 1994 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2383 35906 (\TEDIT.INSERT.TTY.BUFFER 2393 . 3003) (\TEDIT.INTERRUPT.SETUP 3005 . 4578) (\TEDIT.MARKACTIVE 4580 . 4788) (\TEDIT.MARKINACTIVE 4790 . 5002) (\PNC 5004 . 5644) ( \TEDIT.COMMAND.LOOP 5646 . 29326) (\TEDIT.COMMAND.RESET.SETUP 29328 . 35904)) (36480 49998 ( \TEDIT.READTABLE 36490 . 38095) (\TEDIT.WORDBOUND.READTABLE 38097 . 40622) (TEDIT.GETSYNTAX 40624 . 42820) (TEDIT.SETSYNTAX 42822 . 45163) (TEDIT.GETFUNCTION 45165 . 46547) (TEDIT.SETFUNCTION 46549 . 49018) (TEDIT.WORDGET 49020 . 49289) (TEDIT.WORDSET 49291 . 49996))))) STOP \ No newline at end of file diff --git a/library/TEDITDCL b/library/TEDITDCL new file mode 100644 index 00000000..2b6b8f47 --- /dev/null +++ b/library/TEDITDCL @@ -0,0 +1,493 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "25-Aug-94 10:53:00" {DSK}export>lispcore>library>TEDITDCL.;2 49062 + + previous date%: "25-Aug-94 10:38:37" {DSK}export>lispcore>library>TEDITDCL.;1) + + +(* ; " +Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994 by Venue. All rights reserved. +") + +(PRETTYCOMPRINT TEDITDCLCOMS) + +(RPAQQ TEDITDCLCOMS ((* ;;; "This file is the collected record declarations and compile-time necessities for TEDIT.") (* ;; "FROM TEDIT") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))) (* ;; "FROM TEDITSELECTION") (RECORDS SELECTION) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (COPYSELSHADE 30583) (COPYLOOKSSELSHADE 30583) (EDITMOVESHADE -1) (EDITGRAY 32800))) (VARS TEDITFILES) (* ;; "FROM TEDITSCREEN") (RECORDS THISLINE LINEDESCRIPTOR LINECACHE) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (LMInvisibleRun 401) (LMLooksChange 400))) (* ;; "FROM TEXTOFD") (RECORDS EDITMARK) (RECORDS PIECE TEXTOBJ TEXTIMAGEDATA TEXTSTREAM) (OPTIMIZERS TEXTPROP) (COMS (* ;; "Private data structures and constants FROM TEXTOFD") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\PCTBFreePieces 0) (\PCTBLastPieceOffset 1) (\FirstPieceOffset 2) (\SecondPieceOffset 4) (\EltsPerPiece 2)) (MACROS \EDITELT \GETCH \GETCHB \EDITSETA \WORDSETA) (GLOBALVARS \TEXTIMAGEOPS \TEXTOFD \TEXTFDEV))) (* ;;; "FROM TEDITPAGE") (RECORDS PAGEFORMATTINGSTATE PAGEREGION) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITPAPERSIZE) (FUNCTIONS \NEW-COLUMN-START \FIRST-COLUMN-START)) (* ;; "FROM TEDITFIND") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\AlphaNumericFlag 256) (\AlphaFlag 512) (\OneCharPattern 1024) (\AnyStringPattern 1025) (\OneAlphaPattern 1026) (\AnyAlphaPattern 1027) (\OneNonAlphaPattern 1028) (\AnyNonAlphaPattern 1029) (\LeftBracketPattern 1030) (\RightBracketPattern 1031) (\SpecialPattern 1024))) (* ;; " FROM TEDITLOOKS") (RECORDS CHARLOOKS FMTSPEC PENDINGTAB) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \SMALLPIN \SMALLPOUT ONOFF)) (* ;; "FROM TEDITMENU") (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MBUTTON)) (INITRECORDS MBUTTON) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS NWAYBUTTON)) (INITRECORDS NWAYBUTTON) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MARGINBAR)) (INITRECORDS MARGINBAR) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TAB)) (RECORDS MB.3STATE MB.BUTTON MB.INSERT MB.MARGINBAR MB.NWAY MB.TEXT MB.TOGGLE) (FUNCTIONS WITHOUT-UPDATES) (* ;; "FROM TEDITHISTORY") (RECORDS TEDITHISTORYEVENT) (* ;; "FROM TEDITFILE") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\PieceDescriptorLOOKS 0) (\PieceDescriptorOBJECT 1) (\PieceDescriptorPARA 2) (\PieceDescriptorPAGEFRAME 3) (\PieceDescriptorCHARLOOKSLIST 4) (\PieceDescriptorPARALOOKSLIST 5) (\PieceDescriptorSAFEOBJECT 6))) (* ;; "FROM TEDITCOMMAND") (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \INSERT\TTY\BUFFER \TEDIT.MOUSESTATE \TEDIT.CHECK)) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITTERMCODE)) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NONE.TTC 0) (CHARDELETE.TTC 1) (WORDDELETE.TTC 2) (DELETE.TTC 3) (FUNCTIONCALL.TTC 4) (REDO.TTC 5) (UNDO.TTC 6) (CMD.TTC 7) (NEXT.TTC 8) (EXPAND.TTC 9) (PUNCT.TTC 20) (TEXT.TTC 21) (WHITESPACE.TTC 22))) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MSPACE 153) (NSPACE 152) (THINSPACE 159) (FIGSPACE 154))) (* ;; "FROM TEDITWINDOW") (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITCARET)) (INITRECORDS TEDITCARET) (* ;; "FROM PCTREE added by Nakamura") (RECORDS PCTNODE) (* ;;; "THE END") (COMS (* ;; "Bits in the CHARTABLE that control line breaking, and what happens when a line is broken on this character ") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NOTBEFORE.LB 1) (* ; "Must not break before this character (e.g. Japanese right-paren)") (NOTAFTER.LB 2) (* ; "Must not break after this character (e.g. Japanese open-quote)") (BEFORE.LB 4) (* ; "OK to break before this character, provided it's OK to break after the prior char (true of most non-white-space)") (AFTER.LB 8) (* ; "OK to break after this char, if it's OK to break before the next one (true of most white space)") (DISAPPEAR-IF-NOT-SPLIT.LB 16) (* ; "This character shouldn't be rendered if it isn't the last char on the line (non-breaking hyphen has this)") (NEWCHAR-IF-SPLIT.LB 32) (* ; "Look this char up in *TEDIT-SPLITCHAR-HASH* if this IS the last character on a line, and render it as the char we found."))))) +) + + + +(* ;;; "This file is the collected record declarations and compile-time necessities for TEDIT.") + + + + +(* ;; "FROM TEDIT") + +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ \SCRATCHLEN 64) + + +(CONSTANTS (\SCRATCHLEN 64)) +) +) + + + +(* ;; "FROM TEDITSELECTION") + +(DECLARE%: EVAL@COMPILE + +(DATATYPE SELECTION ((* ;; "Description of a piece of selected text for TEdit. Text has to be selected before it can be operated on by the user.") Y0 (* ; "Y value of topmost line of selection") X0 (* ; "X value of left edge of selection") DX (* ; "Width of the selection, if it's on one line.") CH# (* ; "CH# of the first selected character") XLIM (* ; "X value of right edge of last selected character") CHLIM (* ; "CH# of the last character in the selection") DCH (* ; "# of characters selected (can be zero, for point selection.)") L1 (* ; "-> line descriptor for the line where the first selected character is") LN (* ; "-> line descriptor for the line which contains the end of the selection") YLIM (* ; "Y value of the bottom of the line that ends the selection") POINT (* ; "Which end should the caret appear at? (LEFT or RIGHT)") (SET FLAG) (* ; "T if this selection is real; NIL if not") (\TEXTOBJ FULLXPOINTER) (* ; "TEXTOBJ that describes the selected text") SELKIND (* ; "What kind of selection? CHAR or WORD or LINE or PARA") HOW (* ; "SHADE used to highlight this selection") HOWHEIGHT (* ; "Height of the highlight (1 usually, full line for delete selection...)") (HASCARET FLAG) (* ; "T if there should be a caret for this selection") SELOBJ (* ; "If this selection is inside an object, which object?") (ONFLG FLAG) (* ; "T if the selection is highlighted on the screen, else NIL") SELOBJINFO (* ; "A Place for the selected object to put info about selection inside itself.")) + SET _ NIL HOW _ BLACKSHADE HOWHEIGHT _ 1 HASCARET _ T Y0 _ 0 X0 _ 0 POINT _ (QUOTE LEFT) L1 _ (LIST NIL) + LN _ (LIST NIL)) +) + +(/DECLAREDATATYPE (QUOTE SELECTION) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FULLXPOINTER POINTER POINTER POINTER FLAG POINTER FLAG POINTER)) (QUOTE ((SELECTION 0 POINTER) (SELECTION 2 POINTER) (SELECTION 4 POINTER) (SELECTION 6 POINTER) (SELECTION 8 POINTER) (SELECTION 10 POINTER) (SELECTION 12 POINTER) (SELECTION 14 POINTER) (SELECTION 16 POINTER) (SELECTION 18 POINTER) (SELECTION 20 POINTER) (SELECTION 20 (FLAGBITS . 0)) (SELECTION 22 FULLXPOINTER) (SELECTION 24 POINTER) (SELECTION 26 POINTER) (SELECTION 28 POINTER) (SELECTION 28 (FLAGBITS . 0)) (SELECTION 30 POINTER) (SELECTION 30 (FLAGBITS . 0)) (SELECTION 32 POINTER))) (QUOTE 34)) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ COPYSELSHADE 30583) + +(RPAQQ COPYLOOKSSELSHADE 30583) + +(RPAQQ EDITMOVESHADE -1) + +(RPAQQ EDITGRAY 32800) + + +(CONSTANTS (COPYSELSHADE 30583) (COPYLOOKSSELSHADE 30583) (EDITMOVESHADE -1) (EDITGRAY 32800)) +) +) + +(RPAQQ TEDITFILES (PCTREE TEXTOFD TEDIT TEDITABBREV TEDITCOMMAND TEDITDCL TEDITFILE TEDITFIND TEDITFNKEYS TEDITHCPY TEDITHISTORY TEDITLOOKS TEDITMENU TEDITPAGE TEDITSCREEN TEDITSELECTION TEDITWINDOW) +) + + + +(* ;; "FROM TEDITSCREEN") + +(DECLARE%: EVAL@COMPILE + +(DATATYPE THISLINE ((* ;; "Cache for line-related character location info, for selection and line-display code to use.") (DESC FULLXPOINTER) (* ; "Line descriptor for the line this describes now") LEN (* ; "Length of the line in characters") CHARS (* ;; "Array of character codes (or objects) on the line (charcode of 400 => dummy entry for looks change--go get next entry in LOOKS)") WIDTHS (* ; "Array of each character's width in points") LOOKS (* ; "Array of any looks changes within the line. LOOKS (0) = starting character looks for the line") TLSPACEFACTOR (* ; "The SPACEFACTOR to be used in printing this line") TLFIRSTSPACE (* ; "The first space to which SPACEFACTOR is to apply. This is used so that spaces to the left of a TAB have their default width.")) + LEN _ 0 CHARS _ (ARRAY 512 (QUOTE POINTER) 0 0) WIDTHS _ (ARRAY 512 (QUOTE POINTER) 0 0) LOOKS _ (ARRAY 512 (QUOTE POINTER) NIL 0) + TLFIRSTSPACE _ 0) + +(DATATYPE LINEDESCRIPTOR ((* ;; "Description of a single line of formatted text, either on the display or for a printed page.") YBOT (* ; "Y value for the bottom of the line (below the descent)") YBASE (* ; "Yvalue for the base line the characters sit on") LEFTMARGIN (* ; "Left margin, in screen points") RIGHTMARGIN (* ; "Right margin, in screen points") LXLIM (* ; "X value of right edge of rightmost character on the line (may exceed right margin, if char is a space.)") SPACELEFT (* ; "Space left on the line, ignoring trailing blanks & CRs.") LHEIGHT (* ; "Total height of hte line, Ascent+Descent.") ASCENT (* ; "Ascent of the line above YBASE") DESCENT (* ; "How far line descends below YBASE") LTRUEDESCENT (* ; "The TRUE DESCENT for this line, unadjusted for line leading.") LTRUEASCENT (* ; "The TRUE ASCENT for this line, unadjusted for pre-paragraph leading.") CHAR1 (* ; "CH# of the first character on the line.") CHARLIM (* ; "CH# of the last character on the line") CHARTOP (* ; "CH# of the character which forced the line break (may exceed CHARLIM)") NEXTLINE (* ; "Next line chain pointer") (PREVLINE FULLXPOINTER) (* ; "Previous line chain pointer") LMARK (* ; "One of SOLID, GREY, NIL. Tells what kind of special-line marker should be put in the left margin for this paragraph. (For hardcopy, can also be an indicator for special processing?)") LTEXTOBJ (* ; "A cached TEXTOBJ that this line took its text from. Used in hardcopy to disambiguate when chno's should be updated...") CACHE (* ; "A cached THISLINE, for keeping hardcopy info around while we crunch with the line descriptors to make things fit.") LDOBJ (* ; "The object which lies behind this line of text, for updating, etc.") LFMTSPEC (* ; "The format spec for this line's paragraph (eventually)") (DIRTY FLAG) (* ; "T if this line has changed since it was last formatted.") (CR\END FLAG) (* ; "T if this line ends with a CR.") (DELETED FLAG) (* ; "T if this line has been completely deleted since it was last formatted or displayed. (Used by deletion routines to detect garbage lines)") (LHASPROT FLAG) (* ; "This line contains protected text.") (LHASTABS FLAG) (* ; "If this line has a tab in it, this is the line-relative ch# of the final tab. This is to let us punt properly with tabs in a line.") (1STLN FLAG) (* ; "This line is the first line in a paragraph") (LSTLN FLAG) (* ; "This is the last line in a paragraph")) + CHARLIM _ 1000000 NEXTLINE _ NIL PREVLINE _ NIL DIRTY _ NIL YBOT _ 0 YBASE _ 0 LEFTMARGIN _ 0 DELETED + _ NIL) + +(DATATYPE LINECACHE ((* ;; "Image cache for display lines.") LCBITMAP (* ; "The bitmap that will be used by this instance of the cache") (LCNEXTCACHE FULLXPOINTER) (* ; "The next cache in the chain, for screen updates.")) +) +) + +(/DECLAREDATATYPE (QUOTE THISLINE) (QUOTE (FULLXPOINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((THISLINE 0 FULLXPOINTER) (THISLINE 2 POINTER) (THISLINE 4 POINTER) (THISLINE 6 POINTER) (THISLINE 8 POINTER) (THISLINE 10 POINTER) (THISLINE 12 POINTER))) (QUOTE 14)) + +(/DECLAREDATATYPE (QUOTE LINEDESCRIPTOR) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FULLXPOINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG)) (QUOTE ((LINEDESCRIPTOR 0 POINTER) (LINEDESCRIPTOR 2 POINTER) (LINEDESCRIPTOR 4 POINTER) (LINEDESCRIPTOR 6 POINTER) (LINEDESCRIPTOR 8 POINTER) (LINEDESCRIPTOR 10 POINTER) (LINEDESCRIPTOR 12 POINTER) (LINEDESCRIPTOR 14 POINTER) (LINEDESCRIPTOR 16 POINTER) (LINEDESCRIPTOR 18 POINTER) (LINEDESCRIPTOR 20 POINTER) (LINEDESCRIPTOR 22 POINTER) (LINEDESCRIPTOR 24 POINTER) (LINEDESCRIPTOR 26 POINTER) (LINEDESCRIPTOR 28 POINTER) (LINEDESCRIPTOR 30 FULLXPOINTER) (LINEDESCRIPTOR 32 POINTER) (LINEDESCRIPTOR 34 POINTER) (LINEDESCRIPTOR 36 POINTER) (LINEDESCRIPTOR 38 POINTER) (LINEDESCRIPTOR 40 POINTER) (LINEDESCRIPTOR 40 (FLAGBITS . 0)) (LINEDESCRIPTOR 40 (FLAGBITS . 16)) (LINEDESCRIPTOR 40 (FLAGBITS . 32)) (LINEDESCRIPTOR 40 (FLAGBITS . 48)) (LINEDESCRIPTOR 38 (FLAGBITS . 0)) (LINEDESCRIPTOR 38 (FLAGBITS . 16)) (LINEDESCRIPTOR 38 (FLAGBITS . 32)))) (QUOTE 42)) + +(/DECLAREDATATYPE (QUOTE LINECACHE) (QUOTE (POINTER FULLXPOINTER)) (QUOTE ((LINECACHE 0 POINTER) (LINECACHE 2 FULLXPOINTER))) (QUOTE 4)) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ LMInvisibleRun 401) + +(RPAQQ LMLooksChange 400) + + +(CONSTANTS (LMInvisibleRun 401) (LMLooksChange 400)) +) +) + + + +(* ;; "FROM TEXTOFD") + +(DECLARE%: EVAL@COMPILE + +(RECORD EDITMARK ((* ;; "Used for fast access to a given place in the text--a %"Marker%". It consists of the piece, and the offset within the piece, and the piece number within the piece table. That's everything that's needed to set a text stream up quickly to start reading from a given place.") PC PCOFF . PCNO) +) +) +(DECLARE%: EVAL@COMPILE + +(DATATYPE PIECE ((* ; "The piece describes either a string or part of a file. , or a generalized OBJECT.") PSTR (* ; "The string where this piece's text resides, or NIL") PFILE (* ; "The file which contains this piece's text, or NIL") PFPOS (* ; "The FILEPTR of the start of the piece in the file") PLEN (* ; "Length of the piece, in characters.") NEXTPIECE (* ; "-> Next piece in this textobj.") (PREVPIECE FULLXPOINTER) (* ; "-> Prior piece in this text object.") PLOOKS (* ; "Formatting info and formatting events in this piece") POBJ (* ; "The OBJECT this piece describes") (PPARALAST FLAG) (* ; "This piece contains a paragraph break") PPARALOOKS (* ; "Paragraph looks for this piece") (PNEW FLAG) (* ; "This text is new here; used by the tentative edit system, and anyone else interested.") (PFATP FLAG) (* ; "T if the characters in this piece are FAT -- i.e., are 16 bits each.") (PTREENODE XPOINTER) (* ; "Points to the PCTB tree-node that contains this piece.")) + PSTR _ NIL PFILE _ NIL PFPOS _ 0 PLEN _ 0 PPARALOOKS _ TEDIT.DEFAULT.FMTSPEC PTREENODE _ NIL) + +(DATATYPE TEXTOBJ ((* ;; "This is where TEdit stores its state information, and internal data about the text being edited.") PCTB (* ; "The piece table") TEXTLEN (* ; "# of chars in the text") \INSERTPC (* ; "Piece to hold type-in") \INSERTPCNO (* ; "Piece # of the input piece") \INSERTNEXTCH (* ; "CH# of next char which is typed into that piece.") \INSERTLEFT (* ; "Space left in the type-in piece") \INSERTLEN (* ; "# of characters already in the piece.") \INSERTSTRING (* ; "The string which the piece describes.") \INSERTFIRSTCH (* ; "CH# of first char in the piece.") (\INSERTPCVALID FLAG) (* ; "T if it's OK to use the cached piece. Set to NIL by people who require that the next insertion/deletion use a different piece.") \WINDOW (* ; "The window where this textobj is displayed") MOUSEREGION (* ; "Section of the window the mouse is in.") LINES (* ; "-> to top of chain of line descriptors for displayed text") DS (* ; "Display stream where this textobj is displayed") SEL (* ; "The current selection within the text") SCRATCHSEL (* ; "Scratch space for the selection code") MOVESEL (* ; "Source for the next MOVE of text") SHIFTEDSEL (* ; "Source for the next COPY") DELETESEL (* ; "Text to be deleted imminently") WRIGHT (* ; "Right edge of the window (or subregion) where this is displayed") WTOP (* ; "Top of the window/region") WBOTTOM (* ; "Bottom of the window/region") WLEFT (* ; "Left edge of the window/region") TXTFILE (* ; "The original text file we're editing") (\XDIRTY FLAG) (* ; "T => changed since last saved.") (STREAMHINT FULLXPOINTER) (* ; "-> the TEXTOFD stream which gives access to this textobj") EDITFINISHEDFLG (* ; "T => The guy has asked the editor to go way") CARET (* ; "Describes the flashing caret for the editing window") CARETLOOKS (* ; "Font to be used for inserted text.") WINDOWTITLE (* ; "Original title for this window, of there was one.") THISLINE (* ; "Cache of line-related info, to speed up selection &c") (MENUFLG FLAG) (* ; "T if this TEXTOBJ is a tedit-style menu") FMTSPEC (* ; "Default Formatting Spec to be used when formatting paragraphs") (FORMATTEDP FLAG) (* ; "Flag for paragraph formatting. T if this document is to contain paragraph formatting information.") (TXTREADONLY FLAG) (* ; "This is only available for shift selection.") (TXTEDITING FLAG) (* ; "T => This document is in a window and there is an edit process behind it. For example, it only makes sense to have a caret show up if you are editing.") (TXTNONSCHARS FLAG) (* ; "T => If TEdit rns into a 255, it won't attempt to convert to NS characters. Used for REALLY plain-text manipulation.") TXTTERMSA (* ; "Special instructions for displaying characters on the screen") EDITOPACTIVE (* ; "T if there is an editing operation in progress. Used to interlock the TEdit menu") DEFAULTCHARLOOKS (* ; "The default character looks -- if any -- to be applied to characters coming into the file from outside.") TXTRTBL (* ; "The READTABLE to be used by the command loop for command dispatch") TXTWTBL (* ; "The READTABLE to be used to decide on word breaks") EDITPROPS (* ; "The PROPS that were passed into this edit session") (BLUEPENDINGDELETE FLAG) (* ; "T if the next insertion in this document is to be preceded by a deletion of the then-current selection") TXTHISTORY (* ; "The history list for this edit session.") (SELWINDOW FULLXPOINTER) (* ; "The window in which the last 'real' selection got made for this edit; used to control caret placement") PROMPTWINDOW (* ; "A window to be used for unscheduled interactions; normally a small window above the edit window") DISPLAYCACHE (* ; "The bitmap to be used when building the image of a line for display") DISPLAYCACHEDS (* ; "The DISPLAYSTREAM that is used to build line images") DISPLAYHCPYDS (* ; "The DISPLAYSTREAM used to build line images of lines that are displayed in 'hardcopy' simulation mode") TXTPAGEFRAMES (* ; "A tree of page frames, specifying how the document is to be laid out.") TXTCHARLOOKSLIST (* ; "List of all the CHARLOOKSs in the document, so they can be kept unique") TXTPARALOOKSLIST (* ; "List of all the FMTSPECs in the document, so they can be kept unique") (TXTNEEDSUPDATE FLAG) (* ; "T => Screen invalid, need to run updater") (TXTDON'TUPDATE FLAG) (* ; "T if we're holding off on screen updates until later. Used, e.g., by the menu-SHOW code so that you don't get piecemeal updates, but only one at the end of the SHOW.") TXTRAWINCLUDESTREAM (* ; "NODIRCORE stream used to cache RAW includes (and maybe later, all includes?)") DOCPROPS (* ; "Document properties that are stored with the document (not used yet)") TXTSTYLESHEET (* ; "Style sheet local to this document. Not currently saved as part of the file.")) + (ACCESSFNS TEXTOBJ ((\DIRTY (ffetch (TEXTOBJ \XDIRTY) of DATUM) (PROGN (IF (NEQ (FETCH (TEXTOBJ \XDIRTY) OF DATUM) NEWVALUE) THEN (* ; "update the title to reflect the change") (\TEDIT.WINDOW.TITLE DATUM (\TEDIT.ORIGINAL.WINDOW.TITLE (ffetch (TEXTOBJ TXTFILE) of DATUM) NEWVALUE))) (freplace \XDIRTY OF DATUM WITH NEWVALUE))))) + SEL _ (create SELECTION) SCRATCHSEL _ (create SELECTION) MOVESEL _ (create SELECTION HOWHEIGHT _ 32767 HASCARET _ NIL) + SHIFTEDSEL _ (create SELECTION HASCARET _ NIL) DELETESEL _ (create SELECTION HOWHEIGHT _ 32767 HASCARET _ NIL) + \INSERTNEXTCH _ -1 \INSERTPC _ NIL \INSERTLEFT _ 0 \INSERTLEN _ 0 \INSERTSTRING _ NIL \INSERTFIRSTCH _ + 1000000 TEXTLEN _ 0 WRIGHT _ 0 WTOP _ 0 WLEFT _ 0 WBOTTOM _ 0 TXTFILE _ NIL \XDIRTY _ NIL MOUSEREGION + _ (QUOTE TEXT) THISLINE _ (create THISLINE) MENUFLG _ NIL FMTSPEC _ TEDIT.DEFAULT.FMTSPEC FORMATTEDP _ + NIL) + +(DATATYPE TEXTIMAGEDATA ((* ;; "Fills the IMAGEDATA field of text streams.") TICURPARALOOKS (* ; "The current paragraph looks") TICURIMAGESTREAM (* ; "The image stream for this hardcopy transduction") TILOOKSUPDATEFN (* ; "The function to call to update looks for this stream") TIPCOFFSET (* ; "The offset into the current piece, as of the last page cross.")) +) + +(ACCESSFNS TEXTSTREAM ((* ;; "Overlay for the STREAM record to allow mnemonic access to stream fields for Text streams.") (REALFILE (fetch F1 of DATUM) (REPLACE F1 OF DATUM WITH NEWVALUE)) (* ; "The real, underlying file behind the current piece") (CHARSLEFT (fetch F2 of DATUM) (REPLACE F2 OF DATUM WITH NEWVALUE)) (* ;; "The # of characters that will be left in the current piece the next time its file crosses a page boundary") (TEXTOBJ (fetch F3 of DATUM) (REPLACE F3 OF DATUM WITH NEWVALUE)) (* ; "The TEXTOBJ that is editing this text") (PIECE (fetch F5 of DATUM) (REPLACE F5 OF DATUM WITH NEWVALUE)) (* ; "The PIECE we're currently fetching chars from/putting chars into") (PCNO (fetch FW8 of DATUM) (REPLACE FW8 OF DATUM WITH NEWVALUE)) (* ; "The position of that piece in the piece table") (PCSTARTPG (fetch FW6 of DATUM) (REPLACE FW6 OF DATUM WITH NEWVALUE)) (* ; "The underlying file page# that this piece starts on") (PCSTARTCH (fetch FW7 of DATUM) (REPLACE FW7 OF DATUM WITH NEWVALUE)) (* ; "The char within page of the underlying file that this piece starts on -- for backbin & co") (PCOFFSET (fetch TIPCOFFSET of (fetch IMAGEDATA of DATUM)) (REPLACE TIPCOFFSET OF (fetch IMAGEDATA of DATUM) with NEWVALUE)) (* ; "The offset into the current piece, as of the last page cross.") (CURRENTLOOKS (fetch F10 of DATUM) (replace F10 of DATUM with NEWVALUE)) (* ; "The CHARLOOKS that are currently applicable to characters being taken from the stream.") (CURRENTPARALOOKS (fetch TICURPARALOOKS of (fetch IMAGEDATA of DATUM)) (REPLACE TICURPARALOOKS OF (fetch IMAGEDATA of DATUM) with NEWVALUE)) (* ; "The FMTSPEC that is currently applicable to characters being taken from the stream.") (CURRENTIMAGESTREAM (fetch TICURIMAGESTREAM of (fetch IMAGEDATA of DATUM)) (REPLACE TICURIMAGESTREAM OF (fetch IMAGEDATA of DATUM) with NEWVALUE) (* ; "The image stream that this text is being put onto; used for scaling decisions")) (LOOKSUPDATEFN (fetch TILOOKSUPDATEFN of (fetch IMAGEDATA of DATUM)) (REPLACE TILOOKSUPDATEFN OF (fetch IMAGEDATA of DATUM) with NEWVALUE)) (* ; "Function to be called each time character looks change.") (FATSTREAMP (fetch F4 of DATUM) (REPLACE F4 OF DATUM WITH NEWVALUE)) (* ; "T if the current piece is 16 bit characters.")) + (CREATE (create STREAM using \TEXTOFD IMAGEDATA _ (create TEXTIMAGEDATA)))) +) + +(/DECLAREDATATYPE (QUOTE PIECE) (QUOTE (POINTER POINTER POINTER POINTER POINTER FULLXPOINTER POINTER POINTER FLAG POINTER FLAG FLAG XPOINTER)) (QUOTE ((PIECE 0 POINTER) (PIECE 2 POINTER) (PIECE 4 POINTER) (PIECE 6 POINTER) (PIECE 8 POINTER) (PIECE 10 FULLXPOINTER) (PIECE 12 POINTER) (PIECE 14 POINTER) (PIECE 14 (FLAGBITS . 0)) (PIECE 16 POINTER) (PIECE 16 (FLAGBITS . 0)) (PIECE 16 (FLAGBITS . 16)) (PIECE 18 XPOINTER))) (QUOTE 20)) + +(/DECLAREDATATYPE (QUOTE TEXTOBJ) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FULLXPOINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER FULLXPOINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG POINTER POINTER POINTER)) (QUOTE ((TEXTOBJ 0 POINTER) (TEXTOBJ 2 POINTER) (TEXTOBJ 4 POINTER) (TEXTOBJ 6 POINTER) (TEXTOBJ 8 POINTER) (TEXTOBJ 10 POINTER) (TEXTOBJ 12 POINTER) (TEXTOBJ 14 POINTER) (TEXTOBJ 16 POINTER) (TEXTOBJ 16 (FLAGBITS . 0)) (TEXTOBJ 18 POINTER) (TEXTOBJ 20 POINTER) (TEXTOBJ 22 POINTER) (TEXTOBJ 24 POINTER) (TEXTOBJ 26 POINTER) (TEXTOBJ 28 POINTER) (TEXTOBJ 30 POINTER) (TEXTOBJ 32 POINTER) (TEXTOBJ 34 POINTER) (TEXTOBJ 36 POINTER) (TEXTOBJ 38 POINTER) (TEXTOBJ 40 POINTER) (TEXTOBJ 42 POINTER) (TEXTOBJ 44 POINTER) (TEXTOBJ 44 (FLAGBITS . 0)) (TEXTOBJ 46 FULLXPOINTER) (TEXTOBJ 48 POINTER) (TEXTOBJ 50 POINTER) (TEXTOBJ 52 POINTER) (TEXTOBJ 54 POINTER) (TEXTOBJ 56 POINTER) (TEXTOBJ 56 (FLAGBITS . 0)) (TEXTOBJ 58 POINTER) (TEXTOBJ 58 (FLAGBITS . 0)) (TEXTOBJ 58 (FLAGBITS . 16)) (TEXTOBJ 58 (FLAGBITS . 32)) (TEXTOBJ 58 (FLAGBITS . 48)) (TEXTOBJ 60 POINTER) (TEXTOBJ 62 POINTER) (TEXTOBJ 64 POINTER) (TEXTOBJ 66 POINTER) (TEXTOBJ 68 POINTER) (TEXTOBJ 70 POINTER) (TEXTOBJ 70 (FLAGBITS . 0)) (TEXTOBJ 72 POINTER) (TEXTOBJ 74 FULLXPOINTER) (TEXTOBJ 76 POINTER) (TEXTOBJ 78 POINTER) (TEXTOBJ 80 POINTER) (TEXTOBJ 82 POINTER) (TEXTOBJ 84 POINTER) (TEXTOBJ 86 POINTER) (TEXTOBJ 88 POINTER) (TEXTOBJ 88 (FLAGBITS . 0)) (TEXTOBJ 88 (FLAGBITS . 16)) (TEXTOBJ 90 POINTER) (TEXTOBJ 92 POINTER) (TEXTOBJ 94 POINTER))) (QUOTE 96)) + +(/DECLAREDATATYPE (QUOTE TEXTIMAGEDATA) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((TEXTIMAGEDATA 0 POINTER) (TEXTIMAGEDATA 2 POINTER) (TEXTIMAGEDATA 4 POINTER) (TEXTIMAGEDATA 6 POINTER))) (QUOTE 8)) + +(DEFOPTIMIZER TEXTPROP (TEXTOBJ PROP &OPTIONAL (VAL NIL WRITING)) (* ;; "compiles calls to TEXTPROP") (COND ((NOT (LISTP PROP)) (* ; "property is not quoted.") (QUOTE IGNOREMACRO)) ((NOT (EQ (CAR PROP) (QUOTE QUOTE))) (* ; "property is not quoted.") (QUOTE IGNOREMACRO)) ((NOT WRITING) (* ; "fetching a TEXTPROP property.") (SELECTQ (CADR PROP) ((READONLY READ-ONLY) (BQUOTE (fetch (TEXTOBJ TXTREADONLY) of (TEXTOBJ (\, TEXTOBJ))))) ((BEING-EDITED ACTIVE) (BQUOTE (fetch (TEXTOBJ TXTEDITING) of (TEXTOBJ (\, TEXTOBJ))))) ((NO-NS-CHARS NONSCHARS NO-NSCHARS) (BQUOTE (fetch (TEXTOBJ TXTNONSCHARS) of (TEXTOBJ (\, TEXTOBJ))))) (BQUOTE (LISTGET (fetch (TEXTOBJ EDITPROPS) of (TEXTOBJ (\, TEXTOBJ))) (\, PROP))))) (T (* ; "storing a window property") (SELECTQ (CADR PROP) ((READONLY READ-ONLY) (BQUOTE (REPLACE (TEXTOBJ TXTREADONLY) OF (TEXTOBJ (\, TEXTOBJ)) WITH (\, VAL)))) ((BEING-EDITED ACTIVE) (BQUOTE (REPLACE (TEXTOBJ TXTEDITING) OF (TEXTOBJ (\, TEXTOBJ)) WITH (\, VAL)))) ((NO-NS-CHARS NONSCHARS NO-NSCHARS) (BQUOTE (REPLACE (TEXTOBJ TXTNONSCHARS) OF (TEXTOBJ (\, TEXTOBJ)) WITH (\, VAL)))) (BQUOTE (LET* (($$TEXTOBJ$$ (TEXTOBJ (\, TEXTOBJ))) ($$PROPLST$$ (FETCH EDITPROPS OF $$TEXTOBJ$$))) (COND ($$PROPLST$$ (LISTPUT $$PROPLST$$ (\, PROP) (\, VAL))) (T (REPLACE EDITPROPS OF $$TEXTOBJ$$ WITH (LIST (\, PROP) (\, VAL))))))))))) + + + +(* ;; "Private data structures and constants FROM TEXTOFD") + +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ \PCTBFreePieces 0) + +(RPAQQ \PCTBLastPieceOffset 1) + +(RPAQQ \FirstPieceOffset 2) + +(RPAQQ \SecondPieceOffset 4) + +(RPAQQ \EltsPerPiece 2) + + +(CONSTANTS (\PCTBFreePieces 0) (\PCTBLastPieceOffset 1) (\FirstPieceOffset 2) (\SecondPieceOffset 4) (\EltsPerPiece 2)) +) + +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \EDITELT DMACRO (OPENLAMBDA (ARR NO) (* This is equivalent to ELT, but bypasses the checking, since we "know" that ARR is an array. Hence, much faster.) (GETBASEPTR (\ADDBASE2 (fetch (ARRAYP BASE) of ARR) NO) 0))) + +(PUTPROPS \GETCH MACRO ((TEXTOBJ) (* jds "23-FEB-82 08:56") (* Get the next available character from the text being edited.) (\BIN (fetch STREAMHINT of TEXTOBJ)))) + +(PUTPROPS \GETCHB MACRO ((TEXTOBJ) (* Get the next prior character in the text being edited.) (\BACKBIN (fetch STREAMHINT of TEXTOBJ)))) + +(PUTPROPS \EDITSETA DMACRO (OPENLAMBDA (ARR N VAL) (* Equivalent to SETA (for pointer-type arrays) %, but bypasses the bounds and type checking. Hence MUCH faster.) (\RPLPTR (\ADDBASE2 (fetch (ARRAYP BASE) of ARR) N) 0 VAL))) + +(PUTPROPS \WORDSETA DMACRO (OPENLAMBDA (A J V) (CHECK (AND (ARRAYP A) (ZEROP (fetch (ARRAYP ORIG) of A)) (EQ \ST.POS16 (fetch (ARRAYP TYP) of A)))) (CHECK (IGREATERP (fetch (ARRAYP LENGTH) of A) J)) (\PUTBASE (fetch (ARRAYP BASE) of A) (IPLUS (fetch (ARRAYP OFFST) of A) J) V))) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \TEXTIMAGEOPS \TEXTOFD \TEXTFDEV) +) +) + + + +(* ;;; "FROM TEDITPAGE") + +(DECLARE%: EVAL@COMPILE + +(RECORD PAGEFORMATTINGSTATE ((* ;; "Contains the state for a TEdit page-formatting job.") PAGE# (* ; "The current page number. Counted from 1") FIRSTPAGE (* ;; "T if the current page is the 'first page' . Is set initially, and can be set again by the user at will. Gets reset after each page image is printed.") MINPAGE# (* ; "The page # of the first page to be printed, or NIL") MAXPAGE# (* ; "The page # of the last page to be printed, or NIL") STATE (* ; "One of FORMATTING or SEARCHING.") REQUIREDREGIONTYPE (* ; "If STATE is SEARCHING, the kind of box we're looking for. If STATE is :SEARCHING-FOR-EQUIVALENT-PAGE, this is the page count for the matching page.") MAINSTREAM (* ; "The principal textobj/stream source") CHNO (* ; "Our position in that stream") PRESSREGION (* ; "The press code's REGION info.") PAGEHEADINGS (* ; "The list of current values to be printed, indexed by heading type") PAGE#GENERATOR (* ; "List of page numbers; later, maybe, a function to generate page numbers. Used to fill in PAGE#TEXT, below") PAGE#TEXT (* ; "If special page numbers are in use, this is the place to take them from. PAGE# is still used for recto/verso decisions &c") PAGEISRECTO (* ; "T if this is a recto page, NIL if it's a VERSO page.") PAGEFOOTNOTELINES (* ; "A list of extant footnote lines that should appear at the next opportunity") PAGEFLOATINGTOPLINES (* ; "A list of lines that should float to the top of the next available place") PAGECOUNT (* ; "The number of pages we've formatted so far.") PAGELINECACHE (* ; "A cache for pre-created LINEDESCRIPTOR/THISLINE sets, to avoid the overhead of re-allocating them all the time") NEWPAGELAYOUT (* ; "If we switch page layouts in mid-document, this is where the new layout gets cached until we get started again.")) + PAGECOUNT _ 0) + +(DATATYPE PAGEREGION ((* ;; "Describe a part of a page for page formatting. Can be made into compound descriptions.") REGIONFILLMETHOD (* ; "What kind of a region this is -- TEXT, FOLIO, PAGEHEADING, etc.") REGIONSPEC (* ; "The page-relative region this occupies") REGIONLOCALINFO (* ; "A PLIST for local information") (REGIONPARENT FULLXPOINTER) (* ; "The parent node for this box, for sub-boxes") REGIONSUBBOXES (* ; "The sub-regions of this region") REGIONTYPE (* ; "A user-settable region type")) +) +) + +(/DECLAREDATATYPE (QUOTE PAGEREGION) (QUOTE (POINTER POINTER POINTER FULLXPOINTER POINTER POINTER)) (QUOTE ((PAGEREGION 0 POINTER) (PAGEREGION 2 POINTER) (PAGEREGION 4 POINTER) (PAGEREGION 6 FULLXPOINTER) (PAGEREGION 8 POINTER) (PAGEREGION 10 POINTER))) (QUOTE 12)) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RECORD TEDITPAPERSIZE ((* ;; "Describe the size of a sheet of paper (in points), given a paper size-name.") TPSNAME (* ; "The name, as a litatom") TPSWIDTH (* ; "Paper width, in points") TPSHEIGHT (* ; "Paper Height, in points") TPSLANDSCAPE? (* ; "T if we have to rotate things to print them on this paper.")) +) +) + + +(DEFMACRO \NEW-COLUMN-START (LINE FMTSPEC) (BQUOTE (AND (FFETCH (LINEDESCRIPTOR 1STLN) OF (\, LINE)) (EQ (FFETCH (FMTSPEC FMTCOLUMN) OF (\, FMTSPEC)) (QUOTE NEXT))))) + +(DEFMACRO \FIRST-COLUMN-START (LINE FMTSPEC) (BQUOTE (AND (FFETCH (LINEDESCRIPTOR 1STLN) OF (\, LINE)) (EQ (FFETCH (FMTSPEC FMTCOLUMN) OF (\, FMTSPEC)) (QUOTE FIRST))))) +) + + + +(* ;; "FROM TEDITFIND") + +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ \AlphaNumericFlag 256) + +(RPAQQ \AlphaFlag 512) + +(RPAQQ \OneCharPattern 1024) + +(RPAQQ \AnyStringPattern 1025) + +(RPAQQ \OneAlphaPattern 1026) + +(RPAQQ \AnyAlphaPattern 1027) + +(RPAQQ \OneNonAlphaPattern 1028) + +(RPAQQ \AnyNonAlphaPattern 1029) + +(RPAQQ \LeftBracketPattern 1030) + +(RPAQQ \RightBracketPattern 1031) + +(RPAQQ \SpecialPattern 1024) + + +(CONSTANTS (\AlphaNumericFlag 256) (\AlphaFlag 512) (\OneCharPattern 1024) (\AnyStringPattern 1025) (\OneAlphaPattern 1026) (\AnyAlphaPattern 1027) (\OneNonAlphaPattern 1028) (\AnyNonAlphaPattern 1029) (\LeftBracketPattern 1030) (\RightBracketPattern 1031) (\SpecialPattern 1024)) +) +) + + + +(* ;; " FROM TEDITLOOKS") + +(DECLARE%: EVAL@COMPILE + +(DATATYPE CHARLOOKS ((* ;; "Describes the appearance (%"Looks%") of characters in a TEdit document.") CLFONT (* ; "The font descriptor for these characters") CLNAME (* ;; "Name of the font (e.g., HELVETICA) THIS FIELD IS A HINT, OR FOR USE IN CHARLOOKS-BUILDING CODE. USE FONTPROP TO GET THE RIGHT VALUE FROM CLFONT.") CLSIZE (* ; "Font size, in points") (CLITAL FLAG) (* ; "T if the characters are italic, else NIL") (CLBOLD FLAG) (* ; "T if the characters are bold, else NIL") (CLULINE FLAG) (* ; "T if the characters are to be underscored, else NIL") (CLOLINE FLAG) (* ; "T if the characters are to be overscored, else NIL") (CLSTRIKE FLAG) (* ; "T if the characters are to be struck thru, else nil.") CLOFFSET (* ; "A superscripting offset in points (?) else NIL (SUBSCRIPTING IF NEGATIVE.)") (CLSMALLCAP FLAG) (* ; "T if small caps, else NIL") (CLINVERTED FLAG) (* ; "T if the characters are to be shown white-on-black") (CLPROTECTED FLAG) (* ; "T if chars can't be selected, else NIL") (CLINVISIBLE FLAG) (* ; "T if TEDIT is to ignore these chars; else NIL") (CLSELHERE FLAG) (* ;; "T if TEDIT can put selection after this char (for menu blanks) else NIL; anything typed after this char will NOT BE PROTECTED.") (CLCANCOPY FLAG) (* ;; "T if this text can be selected for copying, even tho protected (it will become unprotected after the copy; for Dribble/TTY interface)") CLSTYLE (* ; "The style to be used in marking these characters; overridden by the other fields") CLUSERINFO (* ; "Any information that an outsider wants to include") CLLEADER (* ; "For creating dotted and other kinds of leader") CLRULES (* ;; "For arbitrarily-places horizontal rules. List of pairs, of (widthinpts . offsetfrombaselineinpts). Should be taken account of in ascent/descent calcs.") (CLMARK FLAG) (* ;; "Used for a mark-&-sweep of looks at PUT time -- T means this set of looks really IS in use in the document")) + CLOFFSET _ 0) + +(DATATYPE FMTSPEC ((* ;; "Describe the paragraph formatting for a paragraph in a TEdit document.") 1STLEFTMAR (* ; "Left margin of the first line of the paragraph") LEFTMAR (* ; "Left margin of the rest of the lines in the paragraph") RIGHTMAR (* ; "Right margin for the paragraph") LEADBEFORE (* ; "Leading above the paragraph's first line, in points") LEADAFTER (* ; "Leading below the paragraph's bottom line, in points. NOT IMPLEMENTED.") LINELEAD (* ; "Leading between lines, in points. Actually, this space is added BELOW each line in the para.") FMTBASETOBASE (* ; "The baseline-to-baseline spacing between lines in this paragraph. THIS OVERRIDES THE LINE LEADING") TABSPEC (* ; "The list of tabs for this paragraph, including CAR for a default tab width") QUAD (* ; "How the para is formatted: one of LEFT, RIGHT, CENTERED, JUSTIFIED") FMTSTYLE (* ; "The STYLE that controls this paragraph's appearance") FMTCHARSTYLES (* ; "The characterstyles that control the appearance of characters in this para (maybe? may be part of the fmtstyle.)") FMTUSERINFO (* ; "Space for a PLIST of user info") FMTSPECIALX (* ; "A special horizontal location on the printed page for this para.") FMTSPECIALY (* ; "A special vertical location on the page for this para") (FMTHEADINGKEEP FLAG) (* ; "This para should be kept with the top line or so of the next para..") FMTPARATYPE (* ; "What kind of para this is: TEXT, PAGEHEADING, whatever") FMTPARASUBTYPE (* ; "Sub type of the type, e.g., what KIND of page heading this is.") FMTNEWPAGEBEFORE (* ; "Start a new box (if T) or back up the page formatting tree to make a new box of the type named in the value -- by going the least distance back up the tree, then back down until you find that kind of box.") FMTNEWPAGEAFTER (* ; "Similarly") FMTKEEP (* ; "For information about how this paragraph is to be kept with other paragraphs.") FMTCOLUMN (* ; "For setting up side-by-side paragraphs easily ala BravoX") FMTVERTRULES (* ; "For Keeping track of vertical rules in force") (FMTMARK FLAG) (* ; "Used to keep track of which PARALOOKSs are really being used -- a mark & collect is done just before a PUT, so that only 'real' PARALOOKSs make it into the file") (* ; "Used for a mark&sweep of para looks at PUT time -- T means this looks really IS in use in the document, so it makes sense to save it on the file.") (FMTHARDCOPY FLAG) (* ; "T if this paragraph is to be displayed in hardcopy-format.") FMTREVISED (* ; "T (or perhaps a revision level or revision-mark spec??) if this paragraph is to be marked as changed on output.")) + TABSPEC _ (CONS NIL NIL)) + +(DATATYPE PENDINGTAB ((* ;; "The data structure for a tab, within the line formatter, that we haven't finished dealing with yet, e.g. a centered tab where you need to wait for AFTER the centered text to do the formatting.") PTNEWTX (* ;; "An updated TX, being passed back to the line formatter. This results from the resolution of an old RIGHT, CENTERED, or DECIMAL tab, which changed the width of a prior tab.") PTOLDTAB (* ; "The pending tab") PTTYPE (* ; "Its tab type") PTTABX (* ; "Its nominal X position") (PTWBASE FULLXPOINTER) (* ; "The WBASE for its width, for updating when we've figured out how wide the tab really is") PTOLDTX (* ; "The TX as of when the tab was encountered.")) +) +) + +(/DECLAREDATATYPE (QUOTE CHARLOOKS) (QUOTE (POINTER POINTER POINTER FLAG FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER FLAG)) (QUOTE ((CHARLOOKS 0 POINTER) (CHARLOOKS 2 POINTER) (CHARLOOKS 4 POINTER) (CHARLOOKS 4 (FLAGBITS . 0)) (CHARLOOKS 4 (FLAGBITS . 16)) (CHARLOOKS 4 (FLAGBITS . 32)) (CHARLOOKS 4 (FLAGBITS . 48)) (CHARLOOKS 2 (FLAGBITS . 0)) (CHARLOOKS 6 POINTER) (CHARLOOKS 6 (FLAGBITS . 0)) (CHARLOOKS 6 (FLAGBITS . 16)) (CHARLOOKS 6 (FLAGBITS . 32)) (CHARLOOKS 6 (FLAGBITS . 48)) (CHARLOOKS 2 (FLAGBITS . 16)) (CHARLOOKS 2 (FLAGBITS . 32)) (CHARLOOKS 8 POINTER) (CHARLOOKS 10 POINTER) (CHARLOOKS 12 POINTER) (CHARLOOKS 14 POINTER) (CHARLOOKS 14 (FLAGBITS . 0)))) (QUOTE 16)) + +(/DECLAREDATATYPE (QUOTE FMTSPEC) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG POINTER)) (QUOTE ((FMTSPEC 0 POINTER) (FMTSPEC 2 POINTER) (FMTSPEC 4 POINTER) (FMTSPEC 6 POINTER) (FMTSPEC 8 POINTER) (FMTSPEC 10 POINTER) (FMTSPEC 12 POINTER) (FMTSPEC 14 POINTER) (FMTSPEC 16 POINTER) (FMTSPEC 18 POINTER) (FMTSPEC 20 POINTER) (FMTSPEC 22 POINTER) (FMTSPEC 24 POINTER) (FMTSPEC 26 POINTER) (FMTSPEC 26 (FLAGBITS . 0)) (FMTSPEC 28 POINTER) (FMTSPEC 30 POINTER) (FMTSPEC 32 POINTER) (FMTSPEC 34 POINTER) (FMTSPEC 36 POINTER) (FMTSPEC 38 POINTER) (FMTSPEC 40 POINTER) (FMTSPEC 40 (FLAGBITS . 0)) (FMTSPEC 40 (FLAGBITS . 16)) (FMTSPEC 42 POINTER))) (QUOTE 44)) + +(/DECLAREDATATYPE (QUOTE PENDINGTAB) (QUOTE (POINTER POINTER POINTER POINTER FULLXPOINTER POINTER)) (QUOTE ((PENDINGTAB 0 POINTER) (PENDINGTAB 2 POINTER) (PENDINGTAB 4 POINTER) (PENDINGTAB 6 POINTER) (PENDINGTAB 8 FULLXPOINTER) (PENDINGTAB 10 POINTER))) (QUOTE 12)) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \SMALLPIN MACRO (OPENLAMBDA (STREAM) (SIGNED (create WORD HIBYTE _ (\BIN STREAM) LOBYTE _ (\BIN STREAM)) BITSPERWORD))) + +(PUTPROPS \SMALLPOUT MACRO (OPENLAMBDA (STREAM W) (\BOUT STREAM (LOGAND 255 (LRSH W 8))) (\BOUT STREAM (LOGAND W 255)))) + +(PUTPROPS ONOFF MACRO (OPENLAMBDA (VAL) (COND (VAL (QUOTE ON)) (T (QUOTE OFF))))) +) +) + + + +(* ;; "FROM TEDITMENU") + +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RECORD MBUTTON NIL (TYPE? (AND (IMAGEOBJP DATUM) (OR (EQ (IMAGEOBJPROP DATUM (QUOTE DISPLAYFN)) (QUOTE MB.DISPLAY)) (EQ (IMAGEOBJPROP DATUM (QUOTE DISPLAYFN)) (QUOTE MB.THREESTATE.DISPLAY)) (EQ (IMAGEOBJPROP DATUM (QUOTE DISPLAYFN)) (QUOTE \TEXTMENU.TOGGLE.DISPLAY))))) +) +) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RECORD NWAYBUTTON NIL (TYPE? (AND (IMAGEOBJP DATUM) (EQ (IMAGEOBJPROP DATUM (QUOTE DISPLAYFN)) (QUOTE MB.NB.DISPLAYFN)))) +) +) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RECORD MARGINBAR (MARL1 MARLN MARR MARTABS MARUNIT MARTABTYPE) (TYPE? (AND (IMAGEOBJP DATUM) (EQ (IMAGEOBJPROP DATUM (QUOTE DISPLAYFN)) (QUOTE MB.MARGINBAR.DISPLAYFN)))) +) +) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RECORD TAB (TABX . TABKIND)) +) +) +(DECLARE%: EVAL@COMPILE + +(TYPERECORD MB.3STATE ((* ;; "Describes a 3-state menu button.") MBLABEL (* ; "Label for the button on the screen") MBFONT (* ; "Font the label text should appear in") MBCHANGESTATEFN (* ; "Function to call when the button's state changes") MBINITSTATE (* ; "Button's initial state.")) + MBFONT _ (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD))) + +(TYPERECORD MB.BUTTON (MBLABEL MBBUTTONEVENTFN MBFONT) MBBUTTONEVENTFN _ (QUOTE MB.DEFAULTBUTTON.FN) + MBFONT _ (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD))) + +(TYPERECORD MB.INSERT (MBINITENTRY)) + +(TYPERECORD MB.MARGINBAR (ignoredfield)) + +(TYPERECORD MB.NWAY (MBBUTTONS MBFONT MBCHANGESTATEFN MBINITSTATE MBMAXITEMSPERLINE) MBFONT _ (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD)) +) + +(TYPERECORD MB.TEXT (MBSTRING MBFONT)) + +(TYPERECORD MB.TOGGLE (MBTEXT MBFONT MBCHANGESTATEFN MBINITSTATE) MBFONT _ (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD)) +) +) + +(DEFMACRO WITHOUT-UPDATES (TEXTOBJ SCRATCHSEL &BODY BODY) (* ;; "For TEdit windows, run BODY without updating the edit window for TEXTOBJ. This is useful if you're making a log of changes to a document at one time, where the changes are in essence atomic, and you don't need to see intermediate results. It's also a good bit faster than constant updating.") (* ;; "TEXTOBJ is the TEXTOBJ for the document you'll be modifying.") (* ;; "SCRATCHSEL should be the scratch selection (often used in this work)") (BQUOTE (LET ((OLD-UNWIND-FLAG (FETCH (TEXTOBJ TXTDON'TUPDATE) OF (\, TEXTOBJ)))) (CL:UNWIND-PROTECT (PROGN (replace (TEXTOBJ TXTDON'TUPDATE) of (\, TEXTOBJ) with T) (\,@ BODY)) (\SHOWSEL (\, SCRATCHSEL) NIL NIL) (replace SET of (\, SCRATCHSEL) with NIL) (\TEDIT.MARK.LINES.DIRTY (\, TEXTOBJ) 1 (fetch (TEXTOBJ TEXTLEN) of (\, TEXTOBJ))) (replace (TEXTOBJ TXTDON'TUPDATE) of (\, TEXTOBJ) with OLD-UNWIND-FLAG) (TEDIT.UPDATE.SCREEN (\, TEXTOBJ)))))) + + + +(* ;; "FROM TEDITHISTORY") + +(DECLARE%: EVAL@COMPILE + +(RECORD TEDITHISTORYEVENT ((* ;; "Describes one event on the TEdit edit history list.") THACTION (* ; "A LITATOM, specifying what the event was") THPOINT (* ; "Was the selection to the left or right?") THLEN (* ; "The # of chars involved") THCH# (* ; "The starting ch#") THFIRSTPIECE (* ; "First piece involved") THOLDINFO (* ; "Old info, for undo") THAUXINFO (* ; "Auxiliary info about the event, primarily for redo") THTEXTOBJ (* ;; "Place to remember a second textobj, for those like MOVE who need to remember both a source and a destination.")) + THPOINT _ (QUOTE LEFT)) +) + + + +(* ;; "FROM TEDITFILE") + +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ \PieceDescriptorLOOKS 0) + +(RPAQQ \PieceDescriptorOBJECT 1) + +(RPAQQ \PieceDescriptorPARA 2) + +(RPAQQ \PieceDescriptorPAGEFRAME 3) + +(RPAQQ \PieceDescriptorCHARLOOKSLIST 4) + +(RPAQQ \PieceDescriptorPARALOOKSLIST 5) + +(RPAQQ \PieceDescriptorSAFEOBJECT 6) + + +(CONSTANTS (\PieceDescriptorLOOKS 0) (\PieceDescriptorOBJECT 1) (\PieceDescriptorPARA 2) (\PieceDescriptorPAGEFRAME 3) (\PieceDescriptorCHARLOOKSLIST 4) (\PieceDescriptorPARALOOKSLIST 5) (\PieceDescriptorSAFEOBJECT 6)) +) +) + + + +(* ;; "FROM TEDITCOMMAND") + +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \INSERT\TTY\BUFFER MACRO (NIL (\TEDIT.INSERT.TTY.BUFFER ISCRSTRING IPASSSTRING TEXTOBJ SEL))) + +(PUTPROPS \TEDIT.MOUSESTATE MACRO (BUTTON (* Test to see if only the specified mouse button is down. DOES NOT call GETMOUSESTATE, so the mouse-button info is the same as the last time it WAS called.) (SELECTQ (CAR BUTTON) (LEFT (QUOTE (IEQP LASTMOUSEBUTTONS 4))) (MIDDLE (QUOTE (IEQP LASTMOUSEBUTTONS 1))) (RIGHT (QUOTE (IEQP LASTMOUSEBUTTONS 2))) (SHOULDNT)))) + +(PUTPROPS \TEDIT.CHECK MACRO (ARGS (COND ((AND (BOUNDP (QUOTE CHECK)) CHECK) (CONS (QUOTE PROGN) (for I in ARGS as J on ARGS when (NOT (STRINGP I)) collect (LIST (QUOTE OR) I (LIST (QUOTE HELP) "TEdit consistency-check failure [RETURN to continue]: " (COND ((STRINGP (CADR J))) (T (KWOTE I)))))))) (T (CONS COMMENTFLG ARGS))))) +) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(ACCESSFNS TEDITTERMCODE ((TTCLASS (LOGAND DATUM 224)) (TTDECODE (LOGAND DATUM 31)))) +) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ NONE.TTC 0) + +(RPAQQ CHARDELETE.TTC 1) + +(RPAQQ WORDDELETE.TTC 2) + +(RPAQQ DELETE.TTC 3) + +(RPAQQ FUNCTIONCALL.TTC 4) + +(RPAQQ REDO.TTC 5) + +(RPAQQ UNDO.TTC 6) + +(RPAQQ CMD.TTC 7) + +(RPAQQ NEXT.TTC 8) + +(RPAQQ EXPAND.TTC 9) + +(RPAQQ PUNCT.TTC 20) + +(RPAQQ TEXT.TTC 21) + +(RPAQQ WHITESPACE.TTC 22) + + +(CONSTANTS (NONE.TTC 0) (CHARDELETE.TTC 1) (WORDDELETE.TTC 2) (DELETE.TTC 3) (FUNCTIONCALL.TTC 4) (REDO.TTC 5) (UNDO.TTC 6) (CMD.TTC 7) (NEXT.TTC 8) (EXPAND.TTC 9) (PUNCT.TTC 20) (TEXT.TTC 21) (WHITESPACE.TTC 22)) +) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ MSPACE 153) + +(RPAQQ NSPACE 152) + +(RPAQQ THINSPACE 159) + +(RPAQQ FIGSPACE 154) + + +(CONSTANTS (MSPACE 153) (NSPACE 152) (THINSPACE 159) (FIGSPACE 154)) +) +) + + + +(* ;; "FROM TEDITWINDOW") + +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(DATATYPE TEDITCARET (TCNOWTIME (* Used to hold the current time, when checking to see if a transition is due) TCTHENTIME (* Time when the next transition is to take place) TCFORCEDDOWN (* TCFORCEDOWN = T means (Make the caret visible at the next call to \EDIT.FLIPCARET.)) TCUP (* TCUP = T => The caret is NOT VISIBLE. Used to track the current state of the caret) TCCARETDS (* The display stream that the caret appears in) TCCURSORBM (* The CURSOR representing the caret) TCCARETRATE (* %# of MSEC between caret up/down transitions) TCFORCEUP (* T => The caret is not allowed to become visible. Used to keep the caret up during screen updates) TCCARETX (* X position in the window that the caret appears at) TCCARETY (* Y position in the window where the caret appears) TCCARET (* A lisp CARET to be flashed (eventually))) + TCNOWTIME _ (CREATECELL \FIXP) TCTHENTIME _ (CREATECELL \FIXP) TCCURSORBM _ BXCARET TCCARETRATE _ \CARETRATE + TCUP _ T TCCARET _ (\CARET.CREATE BXCARET)) +) + +(/DECLAREDATATYPE (QUOTE TEDITCARET) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((TEDITCARET 0 POINTER) (TEDITCARET 2 POINTER) (TEDITCARET 4 POINTER) (TEDITCARET 6 POINTER) (TEDITCARET 8 POINTER) (TEDITCARET 10 POINTER) (TEDITCARET 12 POINTER) (TEDITCARET 14 POINTER) (TEDITCARET 16 POINTER) (TEDITCARET 18 POINTER) (TEDITCARET 20 POINTER))) (QUOTE 22)) +) + +(/DECLAREDATATYPE (QUOTE TEDITCARET) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((TEDITCARET 0 POINTER) (TEDITCARET 2 POINTER) (TEDITCARET 4 POINTER) (TEDITCARET 6 POINTER) (TEDITCARET 8 POINTER) (TEDITCARET 10 POINTER) (TEDITCARET 12 POINTER) (TEDITCARET 14 POINTER) (TEDITCARET 16 POINTER) (TEDITCARET 18 POINTER) (TEDITCARET 20 POINTER))) (QUOTE 22)) + + + +(* ;; "FROM PCTREE added by Nakamura") + +(DECLARE%: EVAL@COMPILE + +(DATATYPE PCTNODE (CHNUM (* ; "Character #of piece in this node.") PCE (* ; "PIECE ") LO (* ; "Subtree these nodes' ch#are less than this node.") HI (* ; " Subtree these nodes' ch#are more than this node.") BF (* ; "Balance factor.") (* ; "1: Right(HI) Subtree is higher than left(lo) subtree.") (* ; "0: Right subtree and left subtree are same height") (* ; "-1: Right(HI) Subtree is shorter than left(lo) subtree.") RANK (* ; "(# of nodes in left subtree) +1")) + CHNUM _ 0 BF _ 0 RANK _ 1) +) + +(/DECLAREDATATYPE (QUOTE PCTNODE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((PCTNODE 0 POINTER) (PCTNODE 2 POINTER) (PCTNODE 4 POINTER) (PCTNODE 6 POINTER) (PCTNODE 8 POINTER) (PCTNODE 10 POINTER))) (QUOTE 12)) + + + +(* ;;; "THE END") + + + + +(* ;; +"Bits in the CHARTABLE that control line breaking, and what happens when a line is broken on this character " +) + +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ NOTBEFORE.LB 1) + +(RPAQQ NOTAFTER.LB 2) + +(RPAQQ BEFORE.LB 4) + +(RPAQQ AFTER.LB 8) + +(RPAQQ DISAPPEAR-IF-NOT-SPLIT.LB 16) + +(RPAQQ NEWCHAR-IF-SPLIT.LB 32) + + +(CONSTANTS (NOTBEFORE.LB 1) (NOTAFTER.LB 2) (BEFORE.LB 4) (AFTER.LB 8) (DISAPPEAR-IF-NOT-SPLIT.LB 16) (NEWCHAR-IF-SPLIT.LB 32)) +) +) +(PUTPROPS TEDITDCL COPYRIGHT ("Venue" 1986 1987 1988 1989 1990 1991 1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL))) +STOP diff --git a/library/TEDITFILE b/library/TEDITFILE new file mode 100644 index 00000000..92c58b88 --- /dev/null +++ b/library/TEDITFILE @@ -0,0 +1,1636 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-May-2001 11:45:53" {DSK}medley3.5>library>TEDITFILE.;5 245586 changes to%: (FNS TEDIT.GET TEDIT.INCLUDE) previous date%: "26-Dec-2000 15:18:25" {DSK}medley3.5>library>TEDITFILE.;4) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1999, 2000, 2001 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDITFILECOMS) (RPAQQ TEDITFILECOMS ((FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (COMS (* ;; "GETting a file") (FNS TEDIT.BUILD.PCTB \TEDIT.CONVERT.FOREIGN.FORMAT TEDIT.FORMATTEDFILEP TEDIT.GET TEDIT.PARSE.PAGEFRAMES1 \ARBIN \ATMIN \DWIN \STRINGIN \TEDIT.FORMATTEDP1 \TEDIT.SET.WINDOW)) (COMS (* ;; "INCLUDEing a file") (FNS TEDIT.INCLUDE TEDIT.RAW.INCLUDE)) (COMS (* ;; "PUTting a file:") (FNS TEDIT.PUT TEDIT.PUT.PCTB \TEDIT.PUTRESET TEDIT.PUT.PIECE.DESCRIPTOR \ARBOUT \ATMOUT \DWOUT \STRINGOUT \TEDIT-OPEN-FONT-FILE)) (FNS \TEDIT.GET.CHARLOOKS.LIST \TEDIT.GET.SINGLE.CHARLOOKS \TEDIT.PUT.CHARLOOKS.LIST \TEDIT.PUT.SINGLE.CHARLOOKS) (FNS \TEDIT.GET.PARALOOKS.LIST \TEDIT.GET.SINGLE.PARALOOKS \TEDIT.PUT.PARALOOKS.LIST \TEDIT.PUT.SINGLE.PARALOOKS) (GLOBALVARS TEDIT.INPUT.FORMATS *TEDIT-FILE-READTABLE*) (INITVARS (TEDIT.INPUT.FORMATS NIL) (*TEDIT-FILE-READTABLE* (COPYREADTABLE \ORIGREADTABLE)) (* ;  "For consistent reading and writing of info on TEdit files.") ) (COMS (* ;;  "For converting old incoming format. Cutover 5/22/85 to permit looks changes in the future.") (FNS TEDIT.BUILD.PCTB2 \TEDIT.GET.CHARLOOKS.LIST2 \TEDIT.GET.SINGLE.CHARLOOKS2 \TEDIT.PUT.SINGLE.PARALOOKS2 \TEDIT.PUT.SINGLE.CHARLOOKS2 \TEDIT.GET.PARALOOKS.LIST2 \TEDIT.GET.SINGLE.PARALOOKS2 TEDIT.PUT.PCTB2 \TEDIT.PUT.CHARLOOKS.LIST2 \TEDIT.PUT.PARALOOKS.LIST2)) (COMS (* ;; "For converting incoming old-format files (1/27/85 cutover)") (FNS TEDIT.BUILD.PCTB1 TEDIT.GET.PAGEFRAMES1 \TEDIT.GET.CHARLOOKS1 \TEDIT.GET.PARALOOKS1 TEDIT.GET.OBJECT1)) (COMS (* ;; "VERSION 0 Compatibility reading functions") (FNS TEDIT.BUILD.PCTB0 TEDIT.GET.CHARLOOKS0 TEDIT.GET.OBJECT0 TEDIT.GET.PARALOOKS0)))) (FILESLOAD TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SCRATCHLEN 64) (CONSTANTS (\SCRATCHLEN 64)) ) (FILESLOAD (LOADCOMP) TEDITDCL) ) (* ;; "GETting a file") (DEFINEQ (TEDIT.BUILD.PCTB [LAMBDA (TEXT TEXTOBJ START END DEFAULTLOOKS DEFAULTPARALOOKS CLEARGET?) (* ; "Edited 11-Jun-99 14:51 by rmk:") (* ; "Edited 11-Jun-99 14:37 by rmk:") (* ; "Edited 19-Apr-93 13:46 by jds") (* ;  "START = 1st char of file to read from, if specified") (* ;  "END = use this as eofptr of file. For use in reading files within files.") (PROG (SEL LINES PCTB PC OLDPC PCCOUNT TYPECODE PCLEN CHLOOKSSEEN NEWPC PARALOOKSSEEN PIECEINFOCH# CACHE CACHE? TTEXTOBJ USER.CMFILE TSTREAM USERFILEFORMAT USERTEMP EXISTINGCHARLOOKS EXLOOK EXISTINGFMTSPECS (*READTABLE* *TEDIT-FILE-READTABLE*) (*PRINT-BASE* 10) (CURFILECH# (OR START 0)) (CURCH# 1) (TEXTSTREAM (AND TEXTOBJ (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ))) LOOKSHASH PARAHASH) [SETQ DEFAULTPARALOOKS (OR DEFAULTPARALOOKS (COND (TEXTOBJ (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)) (T (create FMTSPEC using TEDIT.DEFAULT.FMTSPEC ] (* ;  "Set the default paragraph formatting for filling in piece PPARALOOKS fields") (COND (TEXTOBJ (* ;  "If there's a TEXTOBJ behind this, set its TXTFILE field to point to the right place.") (replace (TEXTOBJ TXTFILE) of TEXTOBJ with TEXT))) (SETQ DEFAULTLOOKS (OR DEFAULTLOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT))) (* ;  "Set the default CHARLOOKS, for filling in pieces' PLOOKS fields") (SETQ TEXT (\CREATEPIECEORSTREAM TEXT DEFAULTLOOKS DEFAULTPARALOOKS START END)) (* ;  "Grab the file, or a single piece (if the text is a string, or such simple cases)") (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with NIL)) (* ;  "Start by assuming no page formatting") (COND ((STREAMP TEXT) (* ;  "OK, it wasn't a string, so check for cases where we have to cache the file locally.") (AND TEXTOBJ (replace (TEXTOBJ TXTFILE) of TEXTOBJ with TEXT)) (COND ((OR [AND TEXTOBJ (SETQ CACHE? (TEXTPROP TEXTOBJ 'CACHE] (NOT (RANDACCESSP TEXT))) (* ;  "If the file device isn't rancom access, cache the file locally.") (* ;  "Also do this if he asks for a local cache.") [SETQ CACHE (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (* ; "The cache file") (COND ((OR START END) (COPYBYTES TEXT CACHE (OR START 0) (OR END -1))) (T (COPYBYTES TEXT CACHE))) (* ; "Copy the text there") (SETQ CACHE? T) (* ; "Remember that we cached it!") (* ;; "COPYBYTES can only have start/end args of NIL if the file is not random access. So it's impossible to grab out of the middle of a file on an NS server. Sorry.") (COND (CACHE? (* ;; "for the folx who don't trust the connections, since all their pcs will point to core, we can close the txtfile connection") (CLOSEF TEXT))) (replace (STREAM EOLCONVENTION) of CACHE with (fetch (STREAM EOLCONVENTION ) of TEXT)) (* ;  "Remember the EOL convention from the original file, so that we can do a copychars if need be.") (SETQ TEXT CACHE) (* ;  "And pretend the cache IS the real file from here on") (SETQ START (SETQ END NIL)) (* ;; "Since we only copied the relevant part of the file into the cache, we don't need to remember the limits of interest.") )) (SETQ PCCOUNT (\TEDIT.FORMATTEDP1 TEXT END)) (COND ((AND (NOT PCCOUNT) (NEQ (fetch (STREAM EOLCONVENTION) of TEXT) CR.EOLC)) (* ;; "This is an UNFORMATTED file, and it has a foreign EOL convention. Convert it, and save the converted copy locally.") [SETQ CACHE (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (* ; "Build a cache file") (COND ((OR START END) (COPYCHARS TEXT CACHE (OR START 0) (OR END -1)) (* ;; "mcf: just like before, we have all the relevant portion") (SETQ START (SETQ END NIL))) (T (COPYCHARS TEXT CACHE))) (* ;  "Copy the text, converting from the foreign EOL convention into CR as end of line.") (SETQ TEXT CACHE) (* ;; "And think of THIS as the cache. At this point, we may have cached twice in succession--no need to clip off START and END.") (SETQ CACHE? T) (* ;  "Remember that we cached the file!") )) (* ;  "Check to see if this is a formatted file, and find out how may pieces we should allocate for it.") )) (AND TEXTOBJ (TEXTPROP TEXTOBJ 'CACHE CACHE?)) (* ;  "REMEMBER THAT THIS TEXT WAS CACHED, SO THAT LATER PUTS DON'T INVALIDATE THE CACHE.") [COND [(type? PIECE TEXT) (* ;  "If this isn't a text stream, build a piece table with the one piece in it.") (COND ((EQ (fetch (PIECE PLEN) of TEXT) 0) (* ;  "I hate piece whose length is zero.") (SETQ PCTB (\MAKEPCTB (SETQ TEXT NIL))) (* INSERT-BRT (CREATEPCNODE 1  (QUOTE LASTPIECE)) PCTB) ) (T (SETQ PCTB (\MAKEPCTB TEXT)) (* INSERT-BRT (CREATEPCNODE  (ADD1 (fetch (PIECE PLEN) of TEXT))  (QUOTE LASTPIECE)) PCTB) (replace (PIECE PLOOKS) of TEXT with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (PIECE PLOOKS) of TEXT) TEXTOBJ)) (* ;  "And note the CHARLOOKS and PARALOOKS of this text--as well as filling them in.") (replace (PIECE PPARALOOKS) of TEXT with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (PIECE PPARALOOKS ) of TEXT) TEXTOBJ] (CLEARGET? (* ;; "If the user wants an uninterpreted stream onto the file , build a piece table with the one piece in it.") (SETQ TEXT (create PIECE PFILE _ TEXT PFPOS _ (COND (START START) (T 0)) PLEN _ (IDIFFERENCE (OR END (GETEOFPTR TEXT)) (COND (START START) (T 0))) PREVPIECE _ NIL PLOOKS _ DEFAULTLOOKS PPARALAST _ NIL PPARALOOKS _ DEFAULTPARALOOKS)) (* ;  "A single piece to describe the whole file") (SETQ PCTB (\MAKEPCTB TEXT)) (replace (PIECE PLOOKS) of TEXT with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (PIECE PLOOKS) of TEXT) TEXTOBJ)) (* ;  "And note the CHARLOOKS and PARALOOKS for later saving. Keep those caches consistent.") (replace (PIECE PPARALOOKS) of TEXT with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (PIECE PPARALOOKS ) of TEXT) TEXTOBJ)) (* INSERT-BRT (CREATEPCNODE  (ADD1 (fetch (PIECE PLEN) of TEXT))  (QUOTE LASTPIECE)) PCTB) ) [(NOT PCCOUNT) (* ; "This is an unformatted file") (COND [(SETQ USERFILEFORMAT (for FILETYPE in TEDIT.INPUT.FORMATS when (SETQ USERTEMP (APPLY* (CAR FILETYPE) TEXT)) do (RETURN FILETYPE))) (* ;  "The input file is in a user-sensible format, which he is willing to convert for TEdit's use.") (* ; "See if there are Bravo headers") (SETQ PCTB (\TEDIT.CONVERT.FOREIGN.FORMAT (CADR USERFILEFORMAT) TEXT USERTEMP TEXTOBJ DEFAULTLOOKS DEFAULTPARALOOKS)) (* ;  "Convert the foreign format file, and grab its PCTB") (bind (PC _ (\GETBASEPTR (\FIRSTNODE PCTB) 0)) while [AND PC (NOT (EQ PC 'LASTPIECE] do (* ;  "Run thru the converted pieces, noting their CHARLOOKS and PARALOOKS for the get/put caches.") (replace (PIECE PLOOKS) of PC with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (PIECE PLOOKS) of PC) TEXTOBJ)) (replace (PIECE PPARALOOKS) of PC with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (PIECE PPARALOOKS) of PC) TEXTOBJ)) (SETQ PC (fetch (PIECE NEXTPIECE) of PC] (T (* ;  "Nope--it's straight unformatted text") [SETQ PCTB (\MAKEPCTB (create PIECE PFILE _ TEXT PFPOS _ CURFILECH# PLEN _ (IDIFFERENCE (OR END (GETEOFPTR TEXT)) CURFILECH#) PREVPIECE _ NIL PLOOKS _ (\TEDIT.UNIQUIFY.CHARLOOKS DEFAULTLOOKS TEXTOBJ) PPARALAST _ NIL PPARALOOKS _ (\TEDIT.UNIQUIFY.PARALOOKS DEFAULTPARALOOKS TEXTOBJ] (* ;  "So create a single piece to describe its contents") (* INSERT-BRT (CREATEPCNODE  (ADD1 (IDIFFERENCE  (OR END (GETEOFPTR TEXT)) CURFILECH#))  (QUOTE LASTPIECE)) PCTB) (* ; "Insert LASTPIECE here") ] [(LISTP PCCOUNT) (* ;  "This is an obsolete version of the TEdit file format.") (SELECTQ (CAR PCCOUNT) (0 (* ; "VERSION 0") (SETQ PCTB (TEDIT.BUILD.PCTB0 TEXT TEXTOBJ (CDR PCCOUNT) START END))) (1 (* ;  "Version 1; obsoleted at INTERMEZZO release 2/85") (SETQ PCTB (TEDIT.BUILD.PCTB1 TEXT TEXTOBJ (CDR PCCOUNT) START END))) (2 (* ; "Version 2; obsoleted 5/22/85") (SETQ PCTB (TEDIT.BUILD.PCTB2 TEXT TEXTOBJ (CDR PCCOUNT) START END))) (SHOULDNT "File format version incompatible with this version of TEdit.")) (bind (PC _ (\GETBASEPTR (\FIRSTNODE PCTB) 0)) while [AND PC (NOT (EQ PC 'LASTPIECE] do (* ;  "Run thru the converted pieces, noting CHARLOOKS and PARALOOKS for the caches.") (replace (PIECE PLOOKS) of PC with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (PIECE PLOOKS) of PC) TEXTOBJ)) (replace (PIECE PPARALOOKS) of PC with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (PIECE PPARALOOKS ) of PC) TEXTOBJ)) (SETQ PC (fetch (PIECE NEXTPIECE) of PC] (T (* ;  "This IS a TEdit-format file, so read in all the parts.") (SETQ PCTB (\MAKEPCTB NIL PCCOUNT)) (replace (TEXTOBJ PCTB) of TEXTOBJ with PCTB) (SETFILEPTR TEXT (IDIFFERENCE (OR END (GETEOFPTR TEXT)) 8)) (SETQ PIECEINFOCH# (\DWIN TEXT)) (SETFILEPTR TEXT PIECEINFOCH#) (bind (OLDPC _ NIL) (OLDPARALOOKS _ DEFAULTPARALOOKS) for I from 1 to PCCOUNT as PCN from 1 do (SETQ PC NIL) (* ;  "This loop may not really read a piece, so we have to distinguish that case.") (SETQ PCLEN (\DWIN TEXT)) (SETQ TYPECODE (\SMALLPIN TEXT)) (* ; "What kind of piece is it?") [SELECTC TYPECODE (\PieceDescriptorPAGEFRAME (* ;  "This is page layout info for the file") (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with (TEDIT.GET.PAGEFRAMES TEXT))) (add PCN -1) (* ;; "(|add| pcn (iminus |\\EltsPerPiece|))") (* ;  "This didn't create a piece -- don't count it in the PCTB placement.") ) (\PieceDescriptorCHARLOOKSLIST (* ;  "This is the list of CHARLOOKSs used in this document.") (replace (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ with (\TEDIT.GET.CHARLOOKS.LIST TEXT)) (* ;  "Read the list of looks used in this document.") [SETQ LOOKSHASH (ARRAY (FLENGTH (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ] (* ;  "Build an array of the looks, so the reader can index them.") (for I from 1 as LOOKS in (fetch (TEXTOBJ TXTCHARLOOKSLIST ) of TEXTOBJ) do (SETA LOOKSHASH I LOOKS)) (add PCN -1) (* ;; "(|add| pcn (iminus |\\EltsPerPiece|))") (* ;  "This didn't create a piece -- don't count it in the PCTB placement.") (add I -1)) (\PieceDescriptorPARALOOKSLIST (* ;  "This is the list of PARALOOKSs used in this document.") (replace (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ with (\TEDIT.GET.PARALOOKS.LIST TEXT TEXTOBJ)) (* ;  "Read the list of looks used in this document.") [SETQ PARAHASH (ARRAY (FLENGTH (fetch (TEXTOBJ TXTPARALOOKSLIST ) of TEXTOBJ] (* ;  "Build an array of the looks, so the reader can index them.") (for I from 1 as LOOKS in (fetch (TEXTOBJ TXTPARALOOKSLIST ) of TEXTOBJ) do (SETA PARAHASH I LOOKS)) (add PCN -1) (* ;; "(|add| pcn (iminus |\\EltsPerPiece|))") (* ;  "This didn't create a piece -- don't count it in the PCTB placement.") (add I -1)) (\PieceDescriptorPARA (* ;  "Reading a new set of paragraph looks.") (AND OLDPC (replace (PIECE PPARALAST) of OLDPC with T)) (* ;  "Mark the end of the preceding paragraph.") (SETQ OLDPARALOOKS (\TEDIT.GET.PARALOOKS TEXT PARAHASH)) (* ;  "Get the new set of looks, for use by later pieces.") (AND TEXTOBJ (replace (TEXTOBJ FORMATTEDP) of TEXTOBJ with T)) (* ;  "Mark the document as containing paragraph formatting info") (add PCN -1) (* ;; "(|add| pcn (iminus |\\EltsPerPiece|))") (* ;  "This didn't create a piece -- don't count it in the PCTB placement.") ) (\PieceDescriptorLOOKS (* ;  "New character looks. Build a piece to describe those characters.") (SETQ PC (create PIECE PFILE _ TEXT PFPOS _ CURFILECH# PLEN _ PCLEN PREVPIECE _ OLDPC PPARALOOKS _ OLDPARALOOKS)) (* ; "Build the new piece") (\TEDIT.GET.CHARLOOKS PC TEXT LOOKSHASH OLDPC) (* ;  "Read the character looks for this guy.") (COND (OLDPC (* ;  "If there's a prior piece, hook this one on the chain.") (replace (PIECE NEXTPIECE) of OLDPC with PC))) (add CURFILECH# PCLEN) (* ;  "And note the passing of characters.") ) (\PieceDescriptorOBJECT (* ;  "It describes an object. Read that, and perhaps some description of the charlooks to go with it.") (SETQ PC (create PIECE PFILE _ TEXT PFPOS _ CURFILECH# PLEN _ PCLEN PREVPIECE _ OLDPC PPARALOOKS _ OLDPARALOOKS)) (COND (OLDPC (* ;  "If there's a prior piece, hook this one on the chain.") (replace (PIECE NEXTPIECE) of OLDPC with PC))) (TEDIT.GET.OBJECT TEXTSTREAM PC TEXT CURFILECH#) (add CURFILECH# (fetch (PIECE PLEN) of PC)) [COND ((NOT (ZEROP (\BIN TEXT))) (* ;  "There are new character looks for this object. Read them in.") (replace (PIECE PLOOKS) of PC with (  \TEDIT.GET.SINGLE.CHARLOOKS TEXT))) (T (* ;  "No new looks; steal them from the prior piece.") (replace (PIECE PLOOKS) of PC with (OR (AND OLDPC (fetch (PIECE PLOOKS) of OLDPC)) DEFAULTLOOKS] (replace (PIECE PLEN) of PC with 1) (* ;  "OBJECTs are officially one character long.") ) (PROGN (TEDIT.PROMPTPRINT TEXTOBJ "WARNING: Unknown-type piece skipped." T) (SETFILEPTR TEXT (IPLUS (GETFILEPTR TEXT) (\SMALLPIN TEXT] (COND (PC (\INSERTPIECE PC 'LASTPIECE TEXTOBJ) (* ;  "If we created a piece, save it in the table.") (add CURCH# (fetch (PIECE PLEN) of PC)) (SETQ OLDPC PC))) finally (* ;; "(\\editseta pctb pcn curch#)") (* ;;  " (\\editseta pctb (add1 pcn) 'lastpiece)") (* ;;  "(\\editseta pctb |\\PCTBLastPieceOffset| (add1 pcn)) ") (* ;;  "(\\editseta pctb |\\PCTBFreePieces| 0)") (* INSERT-BRT (CREATEPCNODE CURCH#  (QUOTE LASTPIECE)) PCTB) ] (AND (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) TEXTOBJ)) (* ;  "And make sure that the default and caret looks are reflected in that list.") (AND (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ)) (AND DEFAULTLOOKS (\TEDIT.UNIQUIFY.CHARLOOKS DEFAULTLOOKS TEXTOBJ)) (* ;  "And the default looks we used in this function...") (\TEDIT.UNIQUIFY.PARALOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ) TEXTOBJ) (* ;  "And make sure the default paralooks are reflected in that list.") [AND TEXT (bind (CHARLOOKSLIST _ (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ)) (PARALOOKSLIST _ (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ)) for (PC _ (\GETBASEPTR (\FIRSTNODE PCTB) 0)) by (fetch (PIECE NEXTPIECE) of PC) while [AND PC (NOT (EQ PC 'LASTPIECE] do (* ;  "Look at every piece, and assure that its CHARLOOKS and PARALOOKS are in the cache.") [COND ((FMEMB (fetch (PIECE PLOOKS) of PC) CHARLOOKSLIST) (* ;  "This piece's CHARLOOKS are known in the cache already. Don't bother doing anything else.") ) (T (* ;  "Nope; add these looks to the cache") (replace (PIECE PLOOKS) of PC with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (PIECE PLOOKS) of PC) TEXTOBJ] (COND ((FMEMB (fetch (PIECE PPARALOOKS) of PC) PARALOOKSLIST) (* ;  "This piece's PARALOOKS are known in the cache already. Don't bother doing anything else.") ) (T (* ;  "Nope; add these looks to the cache") (replace (PIECE PPARALOOKS) of PC with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (PIECE PPARALOOKS ) of PC) TEXTOBJ] (RETURN PCTB]) (\TEDIT.CONVERT.FOREIGN.FORMAT + [LAMBDA (CONVERSIONFN FILE PREDICATERESULT TEXTOBJ DEFAULTLOOKS DEFAULTPARALOOKS) + (* ; "Edited 12-Jun-90 18:16 by mitani") + + (* Perform the conversion from a foreign file format into TEdit-internal form + as an open TextStream.) + + (PROG (TSTREAM TTEXTOBJ SEL WORKINGSTREAM) (* See if there are Bravo headers) + (SETQ WORKINGSTREAM (OPENTEXTSTREAM "")) + (RESETLST + (RESETSAVE (\TEDIT.SET.WINDOW (CONS (TEXTOBJ WORKINGSTREAM) + NIL))) + (SETQ TSTREAM (APPLY* CONVERSIONFN FILE PREDICATERESULT WORKINGSTREAM))) + (COND + (TEXTOBJ + + (* If we're filling in an existing TEXTOBJ, there are fields that need to be + copied.) + + [OR (fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ) + (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ + with (fetch (TEXTOBJ TXTPAGEFRAMES) of (TEXTOBJ TSTREAM] + (* Such as the page formatting, + which the converter may well set.) + )) + (RETURN (fetch (TEXTOBJ PCTB) of (TEXTOBJ TSTREAM]) (TEDIT.FORMATTEDFILEP + [LAMBDA (STREAM) (* ; "Edited 19-Apr-93 11:57 by jds") + (* ; + "Test to see if this stream's text would need a TEdit-format file (T) or is just plain text (NIL)") + (PROG ((TEXTOBJ (TEXTOBJ STREAM)) + (FONTFILE 0) + OLDPARALOOKS PC OLDLOOKS PREVPC TENTATIVE) + (SETQ OLDPARALOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)) + (SETQ TENTATIVE (TEXTPROP TEXTOBJ 'TEDIT.TENTATIVE)) + (* ; "If edits are to be shown") + (SETQ PC (\GETBASEPTR (\FIRSTNODE (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + 0)) (* ; "First piece in the document") + (COND + ((ATOM PC) (* ; "Empty document") + (RETURN NIL))) + (SETQ OLDLOOKS (OR (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) + TEDIT.DEFAULT.CHARLOOKS)) + (while PC do [COND + ((fetch (PIECE POBJ) of PC) + (* ; + "OBJECTS require the special format") + (SETQ FONTFILE 4)) + ([AND (OR (NOT PREVPC) + (fetch (PIECE PPARALAST) of PREVPC)) + (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS) of PC) + (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ] + (* ; "We just hit a paragraph break.") + (SETQ FONTFILE (IMAX FONTFILE 3))) + ([OR (NOT (EQCLOOKS OLDLOOKS (fetch (PIECE PLOOKS) of + PC))) + (AND TENTATIVE (OR (AND PREVPC (NEQ (fetch (PIECE PNEW) + of PREVPC) + (fetch (PIECE PNEW) + of PC))) + (AND (NOT PREVPC) + (fetch (PIECE PNEW) of PC)) + (AND PREVPC (NEQ (fetch (PIECE PFATP) + of PREVPC) + (fetch (PIECE PFATP) + of PC] + (* ; "Change in font, size, etc.") + (SETQ FONTFILE (IMAX FONTFILE 2))) + ((fetch (PIECE PFATP) of PC) + (* ; "NS Chars in the piece.") + (SETQ FONTFILE (IMAX FONTFILE 1] + (SETQ PREVPC PC) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC))) + (RETURN (SELECTQ FONTFILE + (0 NIL) + (1 'NSCHARS) + (2 'CHARLOOKS) + (3 'PARALOOKS) + (4 'IMAGEOBJ) + NIL]) (TEDIT.GET [LAMBDA (TEXTOBJ FILE UNFORMATTED?) (* ; "Edited 19-May-2001 11:43 by rmk:") (* ; "Edited 19-Apr-93 13:12 by jds") (* ;; "Get a new file (overwriting the one being edited.)") (PROG ((TEXTOBJ (TEXTOBJ TEXTOBJ)) OFILE OCURSOR LINES USER.CMFILE RESP TITLE FILENAME MENUSTREAM (GETFN (TEXTPROP TEXTOBJ 'GETFN)) (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (TEDIT.GET.FINISHEDFORMS NIL)) (COND ([AND (fetch (TEXTOBJ \DIRTY) of TEXTOBJ) (PROGN (AND (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ) (FRESHLINE (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ))) (NOT (MOUSECONFIRM "Not saved yet; LEFT go Get anyway." T (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ] (* ;; "Only do the GET if he knows he'll zorch himself.") (RETURN))) [SETQ OFILE (OR FILE (\TEDIT.MAKEFILENAME (TEDIT.GETINPUT TEXTOBJ "File to GET: " (OR (TEXTPROP TEXTOBJ 'LASTGETFILENAME) (\TEXTSTREAM.FILENAME TEXTOBJ] (TEXTPROP TEXTOBJ 'LASTGETFILENAME OFILE) (COND [(AND OFILE (OR (OPENP OFILE) (INFILEP OFILE))) (* ;  "Only if there's a file to load and the file exists.") (COND ((AND GETFN (EQ (APPLY* GETFN (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) (FULLNAME OFILE) 'BEFORE) 'DON'T)) (* ;  "He doesn't want this document put. Bail out.") (RETURN))) (TEXTPROP TEXTOBJ 'LASTGETFILENAME NIL) (RESETLST (RESETSAVE (TTYDISPLAYSTREAM (OR (AND (NEQ (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ) 'DON'T) (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ)) PROMPTWINDOW))) (RESETSAVE (CURSOR WAITINGCURSOR)) (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) NIL NIL) (\TEXTCLOSEF (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) (* ; "CLOSE the old files") [OR (AND (STREAMP FILE) (OPENP FILE)) (SETQ OFILE (OPENSTREAM OFILE 'INPUT NIL '((TYPE TEXT] (for WINDOW inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) do (* ;  "Remove the previous hardcopyfile") (WINDOWPROP WINDOW 'HARDCOPYFILE NIL)) (* ;; "Open the new one.") (SETQ PCTB (replace (TEXTOBJ PCTB) of TEXTOBJ with (TEDIT.BUILD.PCTB OFILE TEXTOBJ NIL NIL (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ) UNFORMATTED?))) (for FORM in TEDIT.GET.FINISHEDFORMS do (EVAL FORM)) (* ;  "Do any necessary cleanup for outside packages") (SETQ LINES (fetch (TEXTOBJ LINES) of TEXTOBJ)) (replace (TEXTOBJ \DIRTY) of TEXTOBJ with NIL) (for FIRSTLINE inside LINES do (replace (LINEDESCRIPTOR NEXTLINE) of FIRSTLINE with NIL)) (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (* ;; "The old cached piece is no longer valid--keep people from stepping on it, to prevent lost type-in and smashing other docuemnts to which it has been moved...") (* ;; "(replace TEXTLEN of TEXTOBJ with (SUB1 (\EDITELT PCTB (SUB1 (\EDITELT PCTB \PCTBLastPieceOffset)))))") (replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (fetch (BTREENODE TOTLEN ) of PCTB)) (replace (SELECTION CH#) of SEL with (replace (SELECTION CHLIM) of SEL with 1)) (replace (SELECTION DCH) of SEL with 0) (replace (SELECTION POINT) of SEL with 'LEFT) (replace (SELECTION SET) of SEL with T) (replace (SELECTION SET) of (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ) with NIL) (replace (SELECTION SET) of (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) with NIL) (replace (SELECTION SET) of (fetch (TEXTOBJ MOVESEL) of TEXTOBJ) with NIL) (replace (SELECTION SET) of TEDIT.SELECTION with NIL) (replace (SELECTION SET) of TEDIT.SHIFTEDSELECTION with NIL) (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with ( \TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ SEL)) (for WINDOW inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) as LINE inside LINES do (* ;  "Fill the edit window (s) with the new text") (\FILLWINDOW (fetch (LINEDESCRIPTOR YBOT) of LINE) LINE TEXTOBJ NIL WINDOW)) (\FIXSEL SEL TEXTOBJ) (\SHOWSEL SEL NIL T) (SETQ TITLE (TEXTSTREAM.TITLE TEXTOBJ)) (* ; "find and set the title") (\TEDIT.WINDOW.TITLE TEXTOBJ (\TEDIT.ORIGINAL.WINDOW.TITLE TITLE NIL)) (SETQ MENUSTREAM (TEDITMENU.STREAM TEXTOBJ)) (COND ((AND MENUSTREAM (type? LITATOM TITLE)) (* ;  "if we have a filename then put it in the GET and PUT fields of the menu") (SETQ FILENAME (PACKFILENAME 'VERSION NIL 'BODY TITLE)) (MBUTTON.SET.FIELD MENUSTREAM 'Get FILENAME) (MBUTTON.SET.FIELD MENUSTREAM 'Put FILENAME))) (\TEDIT.SET.WINDOW.EXTENT TEXTOBJ (\TEDIT.PRIMARYW TEXTOBJ)) (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT THACTION _ 'Get))) (AND GETFN (APPLY* GETFN (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) (FULLNAME (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) 'AFTER] (OFILE (TEDIT.PROMPTPRINT TEXTOBJ "[File not found.]") (TEXTPROP TEXTOBJ 'LASTGETFILENAME OFILE)(* ;  "Remember the file name he tried for, so we offer it next time.") ) (T (TEDIT.PROMPTPRINT TEXTOBJ "[Get aborted.]" T]) (TEDIT.PARSE.PAGEFRAMES1 + [LAMBDA (PAGELIST PARENT) (* ; "Edited 2-Jan-87 12:21 by jds") + (* Take an external pageframe and + internalize it.) + (PROG (FRAMETYPE PAGEFRAME) + (COND + ((type? PAGEREGION PAGELIST) + (RETURN PAGELIST)) + ((NEQ 'LIST (SETQ FRAMETYPE (pop PAGELIST))) + [SETQ PAGEFRAME (create PAGEREGION + REGIONFILLMETHOD _ FRAMETYPE + REGIONTYPE _ (pop PAGELIST) + REGIONLOCALINFO _ (pop PAGELIST) + REGIONSPEC _ (for VAL + in (OR (pop PAGELIST) + (LIST 0 0 0 0)) + collect (\TEDIT.SCALE VAL + (CONSTANT (FQUOTIENT 1 35.27778] + (replace REGIONSUBBOXES of PAGEFRAME with (for ALIST in (pop PAGELIST) + collect (TEDIT.PARSE.PAGEFRAMES1 ALIST + PAGEFRAME))) + (RETURN PAGEFRAME)) + (T (RETURN (for FRAMESPEC in (CAR PAGELIST) collect (TEDIT.PARSE.PAGEFRAMES1 FRAMESPEC + NIL]) (\ARBIN + [LAMBDA (STREAM) (* jds "13-Nov-86 20:21") + (* ; + "Read an arbitrary object from a file, parse it, and return it.") + + (PROG ((LEN (\SMALLPIN STREAM)) + USERSTR) + (COND + ((NOT (ZEROP LEN)) + (SETQ USERSTR (OPENSTRINGSTREAM (\STRINGIN STREAM LEN) + 'INPUT)) + (RETURN (PROG1 (READ USERSTR *TEDIT-FILE-READTABLE*) + (CLOSEF? USERSTR]) (\ATMIN + [LAMBDA (STREAM) (* jds " 3-Apr-84 10:41") + (PROG ((LEN (\SMALLPIN STREAM))) + (RETURN (COND + ((ZEROP LEN) + NIL) + (T (PACK (for I from 1 to LEN collect (CHARACTER (\BIN STREAM]) (\DWIN + [LAMBDA (FILE) (* jds " 3-JAN-83 16:08") + (IPLUS (LLSH (\BIN FILE) + 24) + (LLSH (\BIN FILE) + 16) + (LLSH (\BIN FILE) + 8) + (\BIN FILE]) (\STRINGIN + [LAMBDA (STREAM SETLEN) (* ; "Edited 20-Apr-88 19:54 by jds") + (* Read a string in length-contents form%: One word for the length, and one + byte per character contained. However, the length may be specified by the + caller instead of being read from the file.) + (PROG ((LEN (OR SETLEN (\SMALLPIN STREAM))) + STR) + (SETQ STR (ALLOCSTRING LEN)) + [OR (ZEROP LEN) + (for I from 1 to LEN do (RPLCHARCODE STR I (READCCODE STREAM] + (RETURN STR]) (\TEDIT.FORMATTEDP1 + [LAMBDA (FILE LEN) (* ; "Edited 12-Feb-88 11:43 by jds") + (* ; + "Checks for a version-1 formatted file") + + (* ;; "Returns NIL if it isn't a formatted file, or the # of pieces needed if it is; leaves file at start of text or of piece descriptions, resp.") + + (SETQ LEN (OR LEN (GETEOFPTR FILE))) + (PROG (DESCPTR NPIECES PASSWORD) + (COND + ((ILEQ LEN 8) (* ; "Too short to be formatted.") + + (RETURN NIL)) + (T (SETFILEPTR FILE (IDIFFERENCE LEN 8)) (* ; + "Move to start of FILEPTR to descriptions") + + (SETQ DESCPTR (\DWIN FILE)) (* ; + "Read the file pos of the descriptions") + + (SETQ NPIECES (\SMALLPIN FILE)) + (SETQ PASSWORD (\SMALLPIN FILE)) + (COND + ((IEQP PASSWORD 31418) (* ; + "Version 3 TEdit format; instituted on 5/22/85") + + (SETFILEPTR FILE DESCPTR) + (RETURN NPIECES)) + ((IEQP PASSWORD 31417) + + (* ;; "Version 2 format. Obsoleted 5/22/85 to permit revision of looks in the future without loss of compatibility") + + (SETFILEPTR FILE DESCPTR) + (RETURN (CONS 2 NPIECES))) + ((IEQP PASSWORD 31416) (* ; "VERSION 1 TEDIT FORMAT") + + (SETFILEPTR FILE DESCPTR) + (RETURN (CONS 1 NPIECES))) + ((IEQP PASSWORD 31415) (* ; "VERSION 0 TEDIT FORMAT") + + (SETFILEPTR FILE DESCPTR) + (RETURN (CONS 0 NPIECES))) + (T (* ; "NOT A FORMATTED FILE") + + (SETFILEPTR FILE 0) + (RETURN NIL]) (\TEDIT.SET.WINDOW + [LAMBDA (TOWIND) (* ; "Edited 12-Jun-90 18:16 by mitani") + (* USED IN RESETSAVES TO NULL OUT A + TEXTSTREAM'S WINDOW BRIEFLY.) + (PROG1 (CONS (CAR TOWIND) + (fetch (TEXTOBJ \WINDOW) of (CAR TOWIND))) + (replace (TEXTOBJ \WINDOW) of (CAR TOWIND) with (CDR TOWIND)))]) ) (* ;; "INCLUDEing a file") (DEFINEQ (TEDIT.INCLUDE [LAMBDA (STREAM FILE START END SAFE) (* ; "Edited 19-May-2001 11:43 by rmk:") (* ;  "Edited 1-Jun-93 11:31 by sybalsky:mv:envos") (* ;; "Obtain a file name, and include that file's contents at the place where the caret is.") (* ;; "Returns T if the insertion happened, NIL if there was no place to put it.") (SETQ STREAM (TEXTOBJ STREAM)) (PROG ((SEL (fetch (TEXTOBJ SEL) of STREAM)) PCTB TEXTLEN NFILE NNFILE INSERTCH# INSPC LEN INSPC# PCLST NPC WASOPEN PCCOUNT NSTREAM START-OF-PIECE) (DECLARE (SPECVARS START-OF-PIECE)) (COND ((fetch (TEXTOBJ TXTREADONLY) of STREAM)(* ; "This is read-only.") ) ((fetch (SELECTION SET) of SEL) (* ;  "There is a place to do the include.") [SETQ NFILE (OR FILE (\TEDIT.MAKEFILENAME (TEDIT.GETINPUT STREAM "Name of the file to load: "] (COND ((NOT NFILE) (* ;  "If no file was given, don't bother INCLUDEing.") (TEDIT.PROMPTPRINT STREAM "[Include aborted.]" T) (RETURN)) ((STREAMP NFILE)) ((NOT (INFILEP NFILE)) (* ;  "Can't find the file. Put out a message.") (TEDIT.PROMPTPRINT STREAM "[File not found.]") (RETURN))) (COND ((NOT SAFE) (* ;; "If the caller sets SAFE, we don't need to do any of this copying, because he's guaranteeing that the files'll be there until we don't need 'em any more.") [SETQ NFILE (COND ((OPENP NFILE) (SETQ WASOPEN T) NFILE) (T (* ;  "Wasn't open -- need to open it for input...") (OPENSTREAM NFILE 'INPUT NIL '((TYPE TEXT] (* ;; "Create the holding file") (SETQ NNFILE (OPENSTREAM '{NODIRCORE} 'OUTPUT 'NEW)) (* ;; "And copy the file-section into it.") (* ;; "Have to explicitly fill in 0 and EOFPTR, because if the file was open already, NILs would only copy from current fileptr to EOF.") (* ;;  "Use COPYBYTES for formatted files, otherwise allow natural EOL conversion to take place") [IF (\TEDIT.FORMATTEDP1 NFILE) THEN [COPYBYTES NFILE NNFILE (OR START 0) (OR END (GETFILEINFO NFILE 'LENGTH] ELSE (COPYCHARS NFILE NNFILE (OR START 0) (OR END (GETFILEINFO NFILE 'LENGTH] (OR WASOPEN (CLOSEF NFILE)) (* ;  "If the file didn't come to us open, close it.") (CLOSEF NNFILE) (SETQ NFILE NNFILE) (SETQ START (SETQ END NIL)) (* ; "Then pretend nothing happened.") )) (TEDIT.DO.BLUEPENDINGDELETE SEL STREAM) (* ; "Delete any text, if need be") (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of STREAM)) (* ;  "We need the POST-deletion text length for later, so this must come after the b-p-d.") (\SHOWSEL SEL NIL NIL) (* ;  "Turn off SELs before we go any further") [SETQ NFILE (TEXTOBJ (SETQ NSTREAM (OPENTEXTSTREAM (OPENSTREAM NFILE 'INPUT) NIL NIL NIL (LIST 'FONT ( \TEDIT.GET.INSERT.CHARLOOKS STREAM SEL) 'PARALOOKS (fetch (TEXTOBJ FMTSPEC ) of STREAM] (* ;; "Get a textobj to describe the include source file (need NSTREAM so that if we have to convert it to formatted, we won't have lost the textstream--and thus smash the free list.)") (COND ((AND (fetch (TEXTOBJ FORMATTEDP) of NFILE) (NOT (fetch (TEXTOBJ FORMATTEDP) of STREAM))) (* ;  "If the includED text is formatted but this file isn't, let's format it!") (\TEDIT.CONVERT.TO.FORMATTED STREAM)) ((AND (fetch (TEXTOBJ FORMATTEDP) of STREAM) (NOT (fetch (TEXTOBJ FORMATTEDP) of NFILE))) (* ;; "The TARGET document is formatted, but the INCLUDEd text isn't. Better format it before completing the include.") (\TEDIT.CONVERT.TO.FORMATTED NFILE))) (SETQ PCTB (fetch (TEXTOBJ PCTB) of STREAM)) (* ;  "HERE, because the conversion to formatted will lengthen the pctb") [SETQ INSERTCH# (COND ((EQ (fetch (SELECTION POINT) of SEL) 'LEFT) (fetch (SELECTION CH#) of SEL)) (T (fetch (SELECTION CHLIM) of SEL] (* ;  "Find the place to make the insertion.") (SETQ INSPC (\CHTOPC INSERTCH# PCTB T)) (* ;  "The piece to make the insertion in") [COND ((NEQ INSPC 'LASTPIECE) (COND ((IGREATERP INSERTCH# START-OF-PIECE) (* ; "Must split the piece.") (SETQ INSPC (\SPLITPIECE INSPC INSERTCH# STREAM INSPC#)) (SETQ PCTB (fetch (TEXTOBJ PCTB) of STREAM)) (* ;  "Refresh the PCTB in case it grew.") ] (SETQ PCLST (fetch (TEXTOBJ PCTB) of NFILE)) (* ;  "A temporary pctb, holding the pieces which describe the INCLUDEd text") (SETQ LEN (fetch (BTREENODE TOTLEN) of PCLST)) (\TEDIT.INSERT.PIECES STREAM INSERTCH# (SETQ PCLST (\GETBASEPTR (\FIRSTNODE PCLST) 0)) LEN INSPC INSPC# NIL) [COND ((AND (fetch (TEXTOBJ FORMATTEDP) of STREAM) (NOT (fetch (TEXTOBJ FORMATTEDP) of NFILE))) (* ;  "If the includED text is formatted but this file isn't, let's format it!") (\TEDIT.CONVERT.TO.FORMATTED STREAM INSERTCH# (IPLUS INSERTCH# LEN] (\TEDIT.HISTORYADD STREAM (create TEDITHISTORYEVENT THACTION _ 'Include THCH# _ INSERTCH# THLEN _ LEN THFIRSTPIECE _ PCLST)) (* ;  "Remember that we did this, so it can be undone.") (replace (TEXTOBJ TEXTLEN) of STREAM with (IPLUS TEXTLEN LEN)) (* ;  "Inserting the pieces didn't fix up things like the length of the document, so do it now.") (AND (fetch (TEXTOBJ \WINDOW) of STREAM) (\FIXILINES STREAM SEL INSERTCH# LEN TEXTLEN)) (* ; "Mark any changed lines dirty.") (replace (SELECTION CHLIM) of SEL with (IPLUS (replace (SELECTION CH#) of SEL with INSERTCH# ) LEN)) (* ;  "Now fix up the selection to be the included text, point_left, character selection grain.") (replace (SELECTION DCH) of SEL with LEN) (replace (SELECTION DX) of SEL with 0) (replace (SELECTION POINT) of SEL with 'RIGHT) (* ;  "So that several things INCLUDED in sequence fall in sequence.") (replace (SELECTION SELKIND) of SEL with 'CHAR) (replace (SELECTION SELOBJ) of SEL with NIL) (COND ((fetch (TEXTOBJ \WINDOW) of STREAM)(* ;  "We're displaying; update the display and the selection's line references") (TEDIT.UPDATE.SCREEN STREAM) (\FIXSEL SEL STREAM) (\SHOWSEL SEL NIL T))) (replace (TEXTOBJ \DIRTY) of STREAM with T) (* ; "Mark the document changed") (\SETUPGETCH (IPLUS -1 INSERTCH# LEN) STREAM) (* ;  "Set the fileptr to the end of the insertion.") T) (T (TEDIT.PROMPTPRINT STREAM "Please choose the place for the INCLUDE first." T]) (TEDIT.RAW.INCLUDE [LAMBDA (STREAM INFILE START END) (* ; "Edited 11-Jun-99 15:05 by rmk:") (* ; "Edited 11-Jun-99 15:05 by rmk:") (* ; "Edited 11-Jun-99 14:49 by rmk:") (* ; "Edited 11-Jun-99 14:41 by rmk:") (* ;  "Edited 27-May-93 16:36 by sybalsky:mv:envos") (* ;; "takes a text stream and an OPEN stream to include. Note: Start and End are inclusive ptrs, unlike in copybytes and friends") (* ;;  "no interpretation (alternate file type e.g. Bravo) takes place. Simply include the characters") (* ;; "Default character and paragraph looks are applied") (LET* ((TEXTOBJ (TEXTOBJ STREAM)) (START START) (END END) (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) [HOLDING.FILE (OR (fetch (TEXTOBJ TXTRAWINCLUDESTREAM) of TEXTOBJ) (replace (TEXTOBJ TXTRAWINCLUDESTREAM) of TEXTOBJ with (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] PCTB TEXTLEN INSERTCH# INSPC LEN INSPC# PCLST NPC WASOPEN HOLDSTART HOLDLEN START-OF-PIECE ) (COND ((NOT (fetch (SELECTION SET) of SEL)) (SHOULDNT "\TEDIT.RAW.INCLUDE called with no selection set")) ((fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ) (* ; "Not allowed to change it.") NIL) (T (* ;  "There is a place to do the include.") (\SHOWSEL SEL NIL NIL) (* ;  "Turn any pre-existing selection off") (COND (END (* ;; "This is the copy-part-of-a-file case, with file liable to be volatile. Copy it to core for protection") [SETQ INFILE (COND ((OPENP INFILE) (SETQ WASOPEN T) INFILE) (T (OPENSTREAM INFILE 'INPUT NIL '((TYPE TEXT] (* ;  "And copy the file-section into it.") (SETFILEPTR HOLDING.FILE (SETQ HOLDSTART (GETEOFPTR HOLDING.FILE))) (* ;  "Move to the end of the pre-existing part of the file.") (COPYBYTES INFILE HOLDING.FILE START END) (* ;  "must be copychars to respect eol conventions") (SETQ HOLDLEN (IDIFFERENCE (OR END (GETEOFPTR INFILE)) START)) (COND ((NOT WASOPEN) (* ;  "Close the input file if it wasn't open when we got here.") (CLOSEF INFILE))) (SETQ INFILE HOLDING.FILE) (SETQ START (SETQ END NIL)) (* ; "Then pretend nothing happened.") )) (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (SETQ INSERTCH# (TEDIT.GETPOINT NIL SEL)) (* ;  "Find the place to make the insertion.") (SETQ INSPC (OR (\CHTOPC INSERTCH# PCTB T) (LASTPIECE PCTB))) (* ;  "The piece to make the insertion in") [COND ((NEQ INSPC 'LASTPIECE) (COND ((IGREATERP INSERTCH# START-OF-PIECE) (* ; "Must split the piece.") (SETQ INSPC (\SPLITPIECE INSPC (- INSERTCH# START-OF-PIECE) TEXTOBJ INSPC#)) (add INSPC# 1) (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (* ;  "Refresh the PCTB in case it grew.") ] (SETQ PCLST (create PIECE PFILE _ INFILE PFPOS _ (OR HOLDSTART START 0) PLEN _ [OR HOLDLEN (IDIFFERENCE [COND (END END) (T (* ; "get the eof pointer") (COND ((OPENP INFILE) (GETEOFPTR INFILE)) (T [OPENSTREAM INFILE 'INPUT NIL '((TYPE TEXT] (PROG1 (GETEOFPTR INFILE) (CLOSEF INFILE] (COND (START START) (T 0] PREVPIECE _ NIL NEXTPIECE _ NIL PLOOKS _ (\TEDIT.UNIQUIFY.CHARLOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT) TEXTOBJ) PPARALAST _ NIL PPARALOOKS _ (create FMTSPEC using TEDIT.DEFAULT.FMTSPEC)) ) (SETQ LEN (fetch (PIECE PLEN) of PCLST)) (\TEDIT.INSERT.PIECES TEXTOBJ INSERTCH# PCLST LEN INSPC INSPC# NIL) (replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (IPLUS TEXTLEN LEN)) (AND (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) (\FIXILINES TEXTOBJ SEL INSERTCH# LEN TEXTLEN)) (replace (SELECTION CHLIM) of SEL with (IPLUS (replace (SELECTION CH#) of SEL with INSERTCH#) LEN)) (* ;  "Now fix up the selection to be the included text, point_left, character selection grain.") (replace (SELECTION DCH) of SEL with LEN) (replace (SELECTION DX) of SEL with 0) (replace (SELECTION POINT) of SEL with 'RIGHT) (* ;  "So that several things INCLUDED in sequence fall in sequence.") (replace (SELECTION SELKIND) of SEL with 'CHAR) (replace (SELECTION SELOBJ) of SEL with NIL) (COND ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) (TEDIT.UPDATE.SCREEN TEXTOBJ) (\FIXSEL SEL TEXTOBJ) (\SHOWSEL SEL NIL T))) (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T) (* ; "Mark the document changed") (\SETUPGETCH (create EDITMARK PC _ INSPC PCOFF _ 0 PCNO _ NIL) TEXTOBJ) (* ;  "Set the fileptr to the end of the insertion.") T]) ) (* ;; "PUTting a file:") (DEFINEQ (TEDIT.PUT [LAMBDA (STREAM FILE FORCENEW UNFORMATTED? OLDFORMAT?) (* ; "Edited 21-Jun-99 19:02 by rmk:") (* ; "Edited 21-Jun-99 18:58 by rmk:") (* ; "Edited 11-Jun-99 15:05 by rmk:") (* ; "Edited 19-Apr-93 13:04 by jds") (* ;; "If the guy was editing a file, make a new updated version; else, ask for a file name") (* ;; "If FILE is specd, it's used; else the user must give us one") (* ;; "Returns an open stream on the file you PUT to.") (PROG ((TEXTOBJ (TEXTOBJ STREAM)) (TEDIT.PUT.FINISHEDFORMS NIL) (TEDIT.GET.FINISHEDFORMS NIL) (OUTPUT.FILE.WRITTEN NIL) OCURSOR OFILE FONTFILEUSED PROPS WINDOW PUTFN CACHE MENUSTREAM FILENAME TITLE CH#S PC) [COND (FILE (* ; "We were given a file to use.") (SETQ OFILE FILE)) [FORCENEW (* ;  "He insists on a new file. (without giving us one NIL)") (SETQ OFILE (\TEDIT.MAKEFILENAME (TEDIT.GETINPUT TEXTOBJ "File to PUT to: "] (T (* ; "Get a file to put the text into") (SETQ OFILE (\TEDIT.MAKEFILENAME (TEDIT.GETINPUT TEXTOBJ "File to PUT to: " (\TEXTSTREAM.FILENAME TEXTOBJ] (SETQ PUTFN (TEXTPROP TEXTOBJ 'PUTFN)) (SETQ CACHE (TEXTPROP TEXTOBJ 'CACHE)) (COND ((NOT OFILE) (* ;  "There's no file to put to; don't bother.") (RETURN)) ((AND PUTFN (EQ (APPLY* PUTFN (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) (FULLNAME OFILE) 'BEFORE) 'DON'T)) (* ;  "He doesn't want this document put. Bail out.") (RETURN))) (RESETLST [RESETSAVE [SETQ OFILE (OPENSTREAM OFILE 'OUTPUT 'NEW (COND [UNFORMATTED? (* ;  "If the user forced no formatting, respect his wish.") '((TYPE TEXT] [(TEDIT.FORMATTEDFILEP TEXTOBJ) (* ;  "If this file has objects, para looks, or font changes, then we need a binary file.") '((TYPE BINARY] [(AND NIL (EQL (U-CASE (FILENAMEFIELD OFILE 'EXTENSION)) 'TEDIT)) (* ; "If file extension is TEDIT, then we presume that it really is a tedit file, thus making it a binary file. BUT: rmk we really prefer TYPE TEXT even for a file with extension tedit.") '((TYPE BINARY] (T (* ;  "Otherwise, we can get by with a text file") '((TYPE TEXT] '(AND RESETSTATE (DELFILE (CLOSEF? OLDVALUE] [RESETSAVE (\TEDIT.PUTRESET (CONS (THIS.PROCESS) 'DON'T] (replace DESC of (fetch (TEXTOBJ THISLINE) of TEXTOBJ) with NIL) (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "PUTting file " (fetch (STREAM FULLNAME) of OFILE) "...") T) [COND ((IGREATERP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) 0) (SETQ FONTFILEUSED (COND (OLDFORMAT? (TEDIT.PUT.PCTB2 TEXTOBJ OFILE UNFORMATTED?)) (T (TEDIT.PUT.PCTB TEXTOBJ OFILE UNFORMATTED?] (CLOSEF OFILE) (* ;  "Close the file, to free it up. And re-open it for INPUT only") [COND ((NOT CACHE) (* ;  "CSLI if caching do not need to reopen the output file anyway") (* ;; "Declare as type text, even if it hasn't been specified as a binary file--could simply be an unformatted stream.") (SETQ OFILE (OPENSTREAM (fetch (STREAM FULLFILENAME) of OFILE) 'INPUT NIL '((TYPE TEXT](* ;  "changed TEMPORary for ns filing with caching. may not work in general") (CLOSEF? (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) (* ; "Close the old text file") (replace (TEXTOBJ TXTFILE) of TEXTOBJ with OFILE) (* ;  "And remember the new one for next time.") (* ;  "We can safely QUIT now without losing anything.") (replace (TEXTOBJ \DIRTY) of TEXTOBJ with NIL)) (SETQ CH#S (REVERSE (CDR FONTFILEUSED))) (* ;  "The true filepos's of the pieces in the output file.") [COND ((AND (NOT CACHE) (RANDACCESSP OFILE) (EQ CR.EOLC (fetch (STREAM EOLCONVENTION) of OFILE))) (* ;; "If we've cached this file, DON'T go thru and fill in the real file's location, because the EOL convention may well be wrong.") (* ;; "(SETQ PC (ELT (fetch PCTB of TEXTOBJ) (ADD1 \FirstPieceOffset)))") (UNINTERRUPTABLY (SETQ PC (\GETBASEPTR (\FIRSTNODE (fetch (TEXTOBJ PCTB) of TEXTOBJ)) 0)) (while (AND PC CH#S) do (* ;;  "Run thru the pieces in the PCTB, pointing them to the new file and their new locations.") (COND ((fetch (PIECE POBJ) of PC)) (T (replace (PIECE PFPOS) of PC with (pop CH#S)) (CLOSEF? (fetch (PIECE PFILE) of PC)) (* ;  "If this is a piece on an open file, close it, since we're never going to read from it again.") (replace (PIECE PFILE) of PC with OFILE) (replace (PIECE PSTR) of PC with NIL))) (SETQ PC (fetch (PIECE NEXTPIECE) of PC))))] (TEDIT.PROMPTPRINT TEXTOBJ "done.") (* ; "Tell him we're finished.") (SETQ TITLE (TEXTSTREAM.TITLE TEXTOBJ)) (* ; "find and set the title") (\TEDIT.WINDOW.TITLE TEXTOBJ (\TEDIT.ORIGINAL.WINDOW.TITLE TITLE NIL)) (SETQ MENUSTREAM (TEDITMENU.STREAM TEXTOBJ)) (COND ((AND MENUSTREAM (type? LITATOM TITLE)) (* ;  "if we have a filename then put it in the GET and PUT fields of the menu") (SETQ FILENAME (PACKFILENAME 'VERSION NIL 'BODY TITLE)) (MBUTTON.SET.FIELD MENUSTREAM 'Get FILENAME) (MBUTTON.SET.FIELD MENUSTREAM 'Put FILENAME))) (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (* ; "Make sure any new insertions happen for real, and not as appends. Since all the pieces now point to the file rather than the strings.") (replace (TEXTOBJ \INSERTPC) of TEXTOBJ with NIL) (* ;; "make sure that TEDIT doesn't try to just add to the \INSERTPC since it will now have a pfile property") (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT THACTION _ 'Put THCH# _ 0 THLEN _ 0 THFIRSTPIECE _ NIL)) (* ; "Remember we did this.") (AND PUTFN (APPLY* PUTFN (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) (fetch (STREAM FULLNAME) of (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) 'AFTER)) (* ;  "CSLI changed to not presume ofile is the txtfile anymore") (RETURN OFILE]) (TEDIT.PUT.PCTB [LAMBDA (TEXTOBJ OFILE UNFORMATTED? SEPARATEFORMAT) (* ; "Edited 11-Jun-99 15:55 by rmk:") (* ; "Edited 19-May-99 21:58 by rmk:") (* ;  "Edited 27-May-93 16:00 by sybalsky:mv:envos") (* ;; "Put a representation of the piece table onto OFILE, preserving font changes and paragraph looks. UNFORMATTED? means write no font or formatting info.") (PROG (OCURSOR CH PC PFILE PSTR POBJ OFILELEN OLDLOOKS (OLDPARALOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)) (*READTABLE* *TEDIT-FILE-READTABLE*) (*PRINT-BASE* 10) OLDCH# CURCH# PREVPC FONTFILE (PCCOUNT 0) TRUEFILE CHARLOOKSLST PARALOOKSLST (TEDIT.PUT.FINISHEDFORMS NIL) (EDITSTENTATIVE (TEXTPROP TEXTOBJ 'TEDIT.TENTATIVE)) (PARALOOKSSEEN NIL) (FORMATTINGLEVEL (TEDIT.FORMATTEDFILEP TEXTOBJ)) (CACHE (TEXTPROP TEXTOBJ 'CACHE)) CH#S PREVFATP PARAHASH LOOKSHASH PREVPREVPC) (replace (STREAM LINELENGTH) of OFILE with MAX.SMALLP) (* ;  "Prevent spurious carriage-returns in the piece descriptions.") (* ;; "(SETQ PC (\EDITELT (fetch PCTB of TEXTOBJ) (ADD1 \FirstPieceOffset)))") (SETQ PC (\GETBASEPTR (\FIRSTNODE (fetch (TEXTOBJ PCTB) of TEXTOBJ)) 0)) (* ; "First piece in the document") (SETQ OLDLOOKS (OR (AND (type? PIECE PC) (fetch (PIECE PLOOKS) of PC)) (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) TEDIT.DEFAULT.CHARLOOKS)) (* ; "Starting looks") (COND ((NEQ (fetch (STREAM EOLCONVENTION) of OFILE) CR.EOLC) (* ;  "This file is on a non-CR host; make a note to cache it") (SETQ TRUEFILE OFILE) (* ;  "Remember where the file should wind up.") [SETQ OFILE (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (* ;  "And open a temp file to write it to.") (replace (STREAM LINELENGTH) of OFILE with MAX.SMALLP) (* ;  "Prevent spurious carriage-returns in the piece descriptions.") )) [SETQ CURCH# (SETQ OLDCH# (ADD1 (GETFILEPTR OFILE] (COND ((fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ) (* ;  "There is layout info for this file. Save it") (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE)) (* ;  "Open a font-info file if one is needed.") (TEDIT.PUT.PAGEFRAMES FONTFILE (fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ)) (add PCCOUNT 1))) (\TEDIT.FLUSH.UNUSED.LOOKS TEXTOBJ PC) (* ;  "Run thru the lists of char & para looks and remove any that aren't in use") (COND ([AND (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ) (OR (IGREATERP (FLENGTH (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ)) 1) (NOT (EQFMTSPEC (CAR (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ)) TEDIT.DEFAULT.FMTSPEC] (* ;; "There are paragraph looks in this document that don't match the default -- save the list of them for later retrieval.") (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE)) (* ;  "Open a font-info file if one is needed.") (SETQ PARAHASH (\TEDIT.PUT.PARALOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTPARALOOKSLIST ) of TEXTOBJ))) (SETQ PARALOOKSSEEN T))) [COND ((OR PARALOOKSSEEN FORMATTINGLEVEL) (* ;; "There are character looks in this document that don't match the default (or paragraph formatting, which forces looks to be saved) -- save the list for later retrieval.") (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE)) (* ;  "Open a font-info file if one is needed.") (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST ) of TEXTOBJ] [while PC do (COND ([AND (NOT (ZEROP (fetch (PIECE PLEN) of PC))) (OR (NOT PREVPC) (fetch (PIECE PPARALAST) of PREVPC)) (OR PARALOOKSSEEN (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS) of PC) (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ ] (* ;  "The last piece ended a paragraph, so send out new para looks") (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE)) (* ;  "Open a font-info file if one is needed.") (COND ((NEQ CURCH# OLDCH#) (* ;  "There were prior characters that hadn't been described in a piece yet. Describe them") [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVFATP) (add PCCOUNT 1) (SETQ OLDCH# CURCH#) (* ;  "And now we've described all the characters up to the current one.") )) (\TEDIT.PUT.PARALOOKS FONTFILE PC PARAHASH) (SETQ PARALOOKSSEEN T) (* ;  "Remember that we've seen a foreign paralooks, and must henceforth note para boundaries") (add PCCOUNT 1))) (COND [(fetch (PIECE POBJ) of PC) (* ;  "It's an object -- go use its PUTFN") (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE)) (* ;  "Open a font-info file if one is needed.") (COND ((AND (NEQ CURCH# OLDCH#) PREVPC) (* ;  "There were prior characters that hadn't been described in a piece yet. Describe them") [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVFATP) (add PCCOUNT 1) (SETQ OLDCH# CURCH#) (* ;  "And now we've described all the characters up to the current one.") )) (* ;  "If the prior thing was text, send along its descriptor.") (* ; "Send out the object") (IF UNFORMATTED? THEN (CL:WHEN (AND PREVPC (fetch (PIECE PFATP) of PREVPC)) (* ;; "Last piece was FAT, but object doesn't know that. Start it out thin. The stream must also be thin after the PRIN1 of the object's preprint string. Setting PREVPC to NIL means that no comparisons will be done (which asserts THIN among other things), but that's OK because we aren't doing formatting anyway.") (BOUT OFILE 255) (BOUT OFILE 0) (add CURCH# 2) (SETQ PREVPC NIL)) (LET [(FN (IMAGEOBJPROP (fetch (PIECE POBJ) of PC) 'PREPRINTFN] (PRIN1 (IF FN THEN (PROG1 (APPLY* FN (fetch (PIECE POBJ) of PC)) (* ;; "Insure thin") (CHARSET OFILE 0)) ELSE "[UNPRINTABLE OBJECT]") OFILE) (add CURCH# 1 (IDIFFERENCE (GETEOFPTR OFILE) CURCH#))) ELSE (add CURCH# (TEDIT.PUT.OBJECT PC OFILE FONTFILE CURCH#))) (add PCCOUNT 1) (SETQ OLDCH# CURCH#) (COND ([OR (NOT (EQCLOOKS OLDLOOKS (fetch (PIECE PLOOKS) of PC))) (NEQ (fetch (PIECE PFATP) of PC) (AND PREVPC (fetch (PIECE PFATP) of PREVPC))) [AND EDITSTENTATIVE (NEQ (fetch (PIECE PNEW) of PC) (AND PREVPC (fetch (PIECE PNEW) of PREVPC] (AND (OR (NOT PREVPC) (fetch (PIECE PPARALAST) of PREVPC)) (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS) of PC) (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ] (* ;  "The OBJECT has different ooks from before") (\BOUT FONTFILE 1) (\TEDIT.PUT.SINGLE.CHARLOOKS FONTFILE (fetch (PIECE PLOOKS) of PC)) (SETQ OLDLOOKS (fetch (PIECE PLOOKS) of PC))) (T (* ;  "No differences. Don't write any charlooks, and mark that fact") (\BOUT FONTFILE 0) (* ;  "MAKE BLOODY SURE THAT THE NEXT RUN OF CHARACTERS GETS ITS OWN LOOKS") ] ((NOT (ZEROP (fetch (PIECE PLEN) of PC))) (* ; "It's not an object.") (* ;; "For 0-length pieces, don't even acknowledge their existence!!") (* ;; "So only do this processing if there's text in the piece.") [COND ([OR [NEQ (fetch (PIECE PFATP) of PC) (SETQ PREVFATP (AND PREVPC (fetch (PIECE PFATP) of PREVPC ] (NOT (EQCLOOKS OLDLOOKS (fetch (PIECE PLOOKS) of PC))) [AND EDITSTENTATIVE (NEQ (fetch (PIECE PNEW) of PC) (AND PREVPC (fetch (PIECE PNEW) of PREVPC] (AND (OR (NOT PREVPC) (fetch (PIECE PPARALAST) of PREVPC)) (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS) of PC) (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ] (* ; "We have a piece with new looks.") (* ;  "The PREVFATP clause needs to come first, so that PREVFATP gets set for later use.") (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE)) (* ;  "Open a font-info file if one is needed.") (COND ((NOT (IEQP OLDCH# CURCH#)) (* ;  "If there were looks past, and if the run was not empty, save a piece for its looks") [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVFATP) (add PCCOUNT 1))) (SETQ OLDLOOKS (fetch (PIECE PLOOKS) of PC)) (SETQ OLDCH# CURCH#) (COND [PREVFATP (COND ((fetch (PIECE PFATP) of PC)) (T (* ; "Switching from FAT to thin") (BOUT OFILE 255) (BOUT OFILE 0) (add CURCH# 2] ((fetch (PIECE PFATP) of PC) (* ; "Switching from thin to fat") (BOUT OFILE 255) (BOUT OFILE 255) (BOUT OFILE 0) (add CURCH# 3] (* ;  "Now dump out the non-object contents of the piece.") [COND [(SETQ PFILE (fetch (PIECE PFILE) of PC)) (* ; "It's on a file. Copy it.") [OR (OPENP PFILE) (replace (PIECE PFILE) of PC with (SETQ PFILE (\TEDIT.REOPEN.STREAM TEXTOBJ PFILE] (* ; "Make sure the file is open.") (COPYBYTES PFILE OFILE (fetch (PIECE PFPOS) of PC) (IPLUS (fetch (PIECE PFPOS) of PC) (COND ((fetch (PIECE PFATP) of PC) (* ;  "For fat file pieces, copy twice as many bytes as characters.") (UNFOLD (fetch (PIECE PLEN) of PC) 2)) (T (fetch (PIECE PLEN) of PC] ((SETQ PSTR (fetch (PIECE PSTR) of PC)) (* ;  "It's in a string. Just print it.") (COND [(fetch (PIECE PFATP) of PC) (* ;  "The string is fat: Copy twice as many bytes as chars.") (for I from 1 to (fetch (PIECE PLEN) of PC) as CH instring PSTR do (\BOUT OFILE (\CHARSET CH)) (\BOUT OFILE (\CHAR8CODE CH] (T (* ;  "The string is thin. Just copy it to the file.") (for I from 1 to (fetch (PIECE PLEN) of PC) as CH instring PSTR do (\BOUT OFILE CH] [COND ((AND (NOT CACHE) (RANDACCESSP OFILE)) (* ; "CSLI leave the pieces and the pctb alone and just write the file if its cached or not randomaccess") (push CH#S (SUB1 CURCH#] [COND ((fetch (PIECE PFATP) of PC) (add CURCH# (UNFOLD (fetch (PIECE PLEN) of PC) 2))) (T (add CURCH# (fetch (PIECE PLEN) of PC] (* ;  "Keep running track of where in the file we are.") )) (COND ((NOT (ZEROP (fetch (PIECE PLEN) of PC))) (* ;; "Only remember this piece if it's not zero-length!") (SETQ PREVPREVPC PREVPC) (SETQ PREVPC PC))) (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) finally (* ;  "Put out a piece describing the last characters in the file.") (COND ((AND FONTFILE (NEQ OLDCH# CURCH#)) (* ;  "Only if there WERE characters, and only if there's a need for font information") [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVPREVPC) (* ;  "Put out a description of the characters") (add PCCOUNT 1))) (COND ((AND PARALOOKSSEEN (fetch (PIECE PPARALAST) of PREVPC)) (* ;  "The last piece contained the end of a paragraph. Make sure it gets noted.") (\TEDIT.PUT.PARALOOKS FONTFILE PREVPC PARAHASH) (* ;; "Write out a dummy paragraph-looks piece, so that we protect the PPARALAST of the final piece in the document.") (\DWOUT FONTFILE 0) (\SMALLPOUT FONTFILE \PieceDescriptorPARA) (\SMALLPOUT FONTFILE 1) (* ;; "This adds a total of 2 pieces to the file:") (add PCCOUNT 2] (for FORM in TEDIT.PUT.FINISHEDFORMS do (EVAL FORM)) (* ; "Do any user-specific cleanup") (COND (TRUEFILE (* ;  "This file needs to be converted to the right convention") (COND ((AND FONTFILE (NOT UNFORMATTED?) (NOT SEPARATEFORMAT)) (* ;  "Formatted file: Copy without converting.") (COPYBYTES OFILE TRUEFILE 0 -1)) (T (* ;  "Go ahead and convert the EOLCONVENTION, this is a plain-text file") (COPYCHARS OFILE TRUEFILE 0 -1))) (SETQ OFILE TRUEFILE))) [COND ((AND (OPENP OFILE) FONTFILE) (* ; "We need to write format info.") (\DWOUT FONTFILE (GETFILEPTR OFILE)) (* ;  "So remember the end of the plain-text part of the file") (\SMALLPOUT FONTFILE PCCOUNT) (* ;  "# OF PIECES WE'' NEED TO RECONSTRUCT THIS FILE") (\SMALLPOUT FONTFILE 31418) (* ;  "Now the password for NEW format files: 31416") (COND ((AND (NOT UNFORMATTED?) (NOT SEPARATEFORMAT)) (* ;; "Only write fmtg info at the end if we want it there--not if we want plain text or want it kept separate.") (COPYBYTES FONTFILE OFILE 0 (GETEOFPTR FONTFILE)) (* ;  "Copy the font information to the file trailer") ) (T)) (CLOSEF FONTFILE) (COND ((NOT SEPARATEFORMAT) (* ;  "Unless we want the formatting info separately, delete the file") (* ;  "(since FONTFILE is a stream, we should not need to delete it at all) (DELFILE FONTFILE)") ] (replace (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (TEXTOBJ DEFAULTCHARLOOKS ) of TEXTOBJ) TEXTOBJ)) (* ;  "Re-add the default and caret looks's to the lists, since they may not have been really saved.") (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ)) (replace (TEXTOBJ FMTSPEC) of TEXTOBJ with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ) TEXTOBJ)) (RETURN (CONS (COND (UNFORMATTED? NIL) (T FONTFILE)) CH#S]) (\TEDIT.PUTRESET + [LAMBDA (PROC&VALUE) (* jds "15-May-85 16:38") + (CONS (CAR PROC&VALUE) + (PROCESSPROP (CAR PROC&VALUE) + 'BEFOREEXIT + (CDR PROC&VALUE]) (TEDIT.PUT.PIECE.DESCRIPTOR + [LAMBDA (FILE CH1 CHLIM LOOKS) (* ; "Edited 30-May-91 20:25 by jds") + (* Put a description of LOOKS into + FILE. LOOKS apply to characters CH1 + thru CHLIM-1) + (* (PROG ((FONT (fetch + (CHARLOOKS CLFONT) of LOOKS)) STR) + (SETQ STR (CONCAT "(FONTCREATE " + (KWOTE (FONTPROP FONT + (QUOTE FAMILY))) " " + (FONTPROP FONT (QUOTE SIZE)) " " + (KWOTE (FONTPROP FONT + (QUOTE FACE))) " )")) + (\DWOUT FILE (IDIFFERENCE CHLIM CH1)) + (* The length of this run of looks) + (\SMALLPOUT FILE (NCHARS STR)) + (* The length of the description + which follows) (PRIN1 STR FILE) + (* Print the form which can EVAL to + re-create the font information) + (\BOUT FILE (LOGOR + (COND ((fetch (CHARLOOKS CLPROTECTED) + of LOOKS) 8) (T 0)) (COND ((fetch (CHARLOOKS CLINVISIBLE) of LOOKS) NIL 4) (T 0)) + (COND ((fetch (CHARLOOKS CLSELHERE) + of LOOKS) 2) (T 0)) + (COND ((fetch (CHARLOOKS CLCANCOPY) + of LOOKS) 1) (T 0)))))) + (HELP]) (\ARBOUT + [LAMBDA (STREAM ITEM) (* ; "Edited 20-Apr-88 19:55 by jds") + (* ; + "Write an arbitrary MKSTRING-able thing in length-contents form.") + (LET ((SIZE (AND ITEM (NCHARS ITEM T *TEDIT-FILE-READTABLE*))) + (FPTR) + (END-FPTR)) + (\SMALLPOUT STREAM (OR SIZE 0)) + (SETQ FPTR (GETFILEPTR STREAM)) + (OR (NOT ITEM) + (ZEROP SIZE) + (PRIN2 ITEM STREAM *TEDIT-FILE-READTABLE*)) + (* ;; "Because of NS chars, you gotta back up and really count bytes.") + (* (SETQ END-FPTR (GETFILEPTR STREAM)) + (SETFILEPTR STREAM FPTR) + (\SMALLPOUT STREAM + (- + END-FPTR FPTR)) (SETFILEPTR STREAM + END-FPTR)) + NIL]) (\ATMOUT + [LAMBDA (STREAM ATOM) (* jds "30-Jan-85 14:46") + (* Write an atom's characters in + length-contents form.) + (\SMALLPOUT STREAM (COND + (ATOM (NCHARS ATOM)) + (T 0))) + (OR (NOT ATOM) + (ZEROP (NCHARS ATOM)) + (for CH inatom ATOM do (\BOUT STREAM CH]) (\DWOUT + [LAMBDA (FILE NUMBER) (* jds " 3-JAN-83 15:30") + (\BOUT FILE (LOGAND 255 (LRSH NUMBER 24))) + (\BOUT FILE (LOGAND 255 (LRSH NUMBER 16))) + (\BOUT FILE (LOGAND 255 (LRSH NUMBER 8))) + (\BOUT FILE (LOGAND 255 NUMBER]) (\STRINGOUT + [LAMBDA (STREAM STRING LEN) (* jds " 1-May-84 11:58") + + (* Write a string on a file in length-contents form; + one word for the length, and one byte per character contained.) + + (SETQ LEN (OR LEN (NCHARS STRING))) + (\SMALLPOUT STREAM LEN) + (OR (ZEROP LEN) + (for CH instring STRING as I from 1 to LEN do (\BOUT STREAM CH]) (\TEDIT-OPEN-FONT-FILE + [LAMBDA (EXISTING-FONTFILE-IF-ANY) (* ; "Edited 23-Sep-87 12:31 by jds") + + (* ;; " Open a font-information file for TEDIT PUT operation, if one doesn't exist already. Also set its linelength to effective infinity, so that we don't get spurious CRs in the middle of formatting info.") + + (* ;; + "The calling form must be (SETQ FOO (\TEDIT-OPEN-FONT-FILE FOO)), to preserve information.") + + (COND + ((NOT EXISTING-FONTFILE-IF-ANY) (* ; + "Create the font-info file if it doesn't exist yet") + + (SETQ EXISTING-FONTFILE-IF-ANY (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW)) + (replace (STREAM LINELENGTH) of EXISTING-FONTFILE-IF-ANY with MAX.SMALLP) + (* ; + "Prevent spurious carriage-returns in the piece descriptions.") + + )) + EXISTING-FONTFILE-IF-ANY]) ) (DEFINEQ (\TEDIT.GET.CHARLOOKS.LIST + [LAMBDA (FILE) (* jds "28-Jan-85 17:50") + (* Read the list of CHARLOOKSs from + the file.) + (for I from 1 to (\SMALLPIN FILE) collect (\TEDIT.GET.SINGLE.CHARLOOKS FILE]) (\TEDIT.GET.SINGLE.CHARLOOKS + [LAMBDA (FILE) (* ; "Edited 30-May-91 20:25 by jds") + (* Read a set of CHARLOOKS from FILE) + (PROG* ((LOOKS (create CHARLOOKS)) + (FILEPOS (GETFILEPTR FILE)) + (LOOKSLEN (\SMALLPIN FILE)) + FONT STR NAME NAMELEN SIZE SUPER SUB PROPS STYLESTR USERSTR) + (SETQ NAME (\ARBIN FILE)) (* The font name) + (SETQ SIZE (\SMALLPIN FILE)) (* Size of the type, in points) + (SETQ SUPER (\SMALLPIN FILE)) (* Superscripting distance) + (replace (CHARLOOKS CLSTYLE) of LOOKS with (OR (\ARBIN FILE) + 0)) + (replace (CHARLOOKS CLUSERINFO) of LOOKS with (\ARBIN FILE)) + (SETQ PROPS (\SMALLPIN FILE)) + (with CHARLOOKS LOOKS [SETQ CLLEADER (NOT (ZEROP (LOGAND 2048 PROPS] + [SETQ CLINVERTED (NOT (ZEROP (LOGAND 1024 PROPS] + [SETQ CLBOLD (NOT (ZEROP (LOGAND 512 PROPS] + [SETQ CLITAL (NOT (ZEROP (LOGAND 256 PROPS] + [SETQ CLULINE (NOT (ZEROP (LOGAND 128 PROPS] + [SETQ CLOLINE (NOT (ZEROP (LOGAND 64 PROPS] + [SETQ CLSTRIKE (NOT (ZEROP (LOGAND 32 PROPS] + [SETQ CLSMALLCAP (NOT (ZEROP (LOGAND 16 PROPS] + [SETQ CLPROTECTED (NOT (ZEROP (LOGAND 8 PROPS] + [SETQ CLINVISIBLE (NOT (ZEROP (LOGAND 4 PROPS] + [SETQ CLSELHERE (NOT (ZEROP (LOGAND 2 PROPS] + [SETQ CLCANCOPY (NOT (ZEROP (LOGAND 1 PROPS] + (SETQ CLSIZE SIZE) + (SETQ CLOFFSET SUPER)) + [replace (CHARLOOKS CLFONT) of LOOKS + with (COND + ((LISTP NAME) (* This was a font class. + Restore it.) + (FONTCLASS (pop NAME) + NAME)) + ((AND NAME (NOT (ZEROP SIZE))) + (FONTCREATE NAME SIZE (COND + ((AND (fetch (CHARLOOKS CLBOLD) of LOOKS) + (fetch (CHARLOOKS CLITAL) of LOOKS) + ) + 'BOLDITALIC) + ((fetch (CHARLOOKS CLBOLD) of LOOKS) + 'BOLD) + ((fetch (CHARLOOKS CLITAL) of LOOKS) + 'ITALIC] + (SETFILEPTR FILE (IPLUS FILEPOS LOOKSLEN)) + (RETURN LOOKS]) (\TEDIT.PUT.CHARLOOKS.LIST + [LAMBDA (FILE LOOKSLIST) (* jds " 5-Mar-85 15:58") + (* Write the list of CHARLOOKSs into + the font file.) + + (* Returns a hasharray that will map from a given CHARLOOKS to that CHARLOOKS' + position in the list we wrote on the file. + Those position numbers are then written in the individual looks descriptions, + and are used to reconstruct the piece looks when the file is read back in.) + + (PROG ((LOOKSHASH (HASHARRAY 50))) + (\DWOUT FILE 0) (* No characters are described by this + pseudo-piece entry.) + (\SMALLPOUT FILE \PieceDescriptorCHARLOOKSLIST) (* Mark it as containing the list of + CHARLOOKSs) + (\SMALLPOUT FILE (FLENGTH LOOKSLIST)) (* How many CHARLOOKSs there are in + the list) + (for I from 1 as LOOKS in LOOKSLIST do + + (* Write each charlooks, in the order they appear in the list.) + + (\TEDIT.PUT.SINGLE.CHARLOOKS FILE LOOKS) + (* Write out the description) + (PUTHASH LOOKS I LOOKSHASH) + + (* And save it in the hash table so people can find its index.) +) + (RETURN LOOKSHASH]) (\TEDIT.PUT.SINGLE.CHARLOOKS + [LAMBDA (FILE LOOKS) (* ; "Edited 30-May-91 20:26 by jds") + (* Put out a single CHARLOOKS + description.) + (PROG ((FILEPOS (GETFILEPTR FILE)) + (FONT (fetch (CHARLOOKS CLFONT) of LOOKS)) + STR LEN) + (\SMALLPOUT FILE 0) (* Reserve space for the length of + this looks) + [COND + ((type? FONTCLASS FONT) (* For font classes, we need to save + a list of device-FD sets) + (\ARBOUT FILE (FONTCLASSUNPARSE FONT))) + (T (* For FONTDESCRIPTORs, do it the + easy way) + (\ATMOUT FILE (FONTPROP FONT 'FAMILY] (* The font family) + (\SMALLPOUT FILE (OR (FONTPROP FONT 'SIZE) + 0)) (* Size of the type, in points) + (\SMALLPOUT FILE (OR (fetch (CHARLOOKS CLOFFSET) of LOOKS) + 0)) (* Super/subscripting distance) + (COND + ([AND (fetch (CHARLOOKS CLSTYLE) of LOOKS) + (NOT (ZEROP (fetch (CHARLOOKS CLSTYLE) of LOOKS] + (\ARBOUT FILE (fetch (CHARLOOKS CLSTYLE) of LOOKS))) + (T (\SMALLPOUT FILE 0))) + (COND + ((fetch (CHARLOOKS CLUSERINFO) of LOOKS) + (\ARBOUT FILE (fetch (CHARLOOKS CLUSERINFO) of LOOKS))) + (T (\SMALLPOUT FILE 0))) + [\SMALLPOUT FILE (LOGOR (COND + ((fetch (CHARLOOKS CLLEADER) of LOOKS) + (* Dotted-leader; relevant only to + TABs) + 2048) + (T 0)) + (COND + ((fetch (CHARLOOKS CLINVERTED) of LOOKS) + (* Inverse-video) + 1024) + (T 0)) + (COND + ((fetch (CHARLOOKS CLBOLD) of LOOKS) + 512) + (T 0)) + (COND + ((fetch (CHARLOOKS CLITAL) of LOOKS) + 256) + (T 0)) + (COND + ((fetch (CHARLOOKS CLULINE) of LOOKS) + 128) + (T 0)) + (COND + ((fetch (CHARLOOKS CLOLINE) of LOOKS) + 64) + (T 0)) + (COND + ((fetch (CHARLOOKS CLSTRIKE) of LOOKS) + 32) + (T 0)) + (COND + ((fetch (CHARLOOKS CLSMALLCAP) of LOOKS) + 16) + (T 0)) + (COND + ((fetch (CHARLOOKS CLPROTECTED) of LOOKS) + 8) + (T 0)) + (COND + ((fetch (CHARLOOKS CLINVISIBLE) of LOOKS) + NIL 4) + (T 0)) + (COND + ((fetch (CHARLOOKS CLSELHERE) of LOOKS) + 2) + (T 0)) + (COND + ((fetch (CHARLOOKS CLCANCOPY) of LOOKS) + 1) + (T 0] + + (* * Now go fill in the length field at the front of the LOOKS. + (ALL looks info should be written out BEFORE this comment.)) + + (SETQ LEN (IDIFFERENCE (GETFILEPTR FILE) + FILEPOS)) (* The length of this set of looks) + (SETFILEPTR FILE FILEPOS) (* Go write the length field) + (\SMALLPOUT FILE LEN) + (SETFILEPTR FILE -1) (* And back to the end of the file) + ]) ) (DEFINEQ (\TEDIT.GET.PARALOOKS.LIST + [LAMBDA (FILE TEXTOBJ) (* jds "13-Jun-85 11:14") + (* Read the list of CHARLOOKSs from + the file.) + (for I from 1 to (\SMALLPIN FILE) collect (\TEDIT.GET.SINGLE.PARALOOKS FILE TEXTOBJ]) (\TEDIT.GET.SINGLE.PARALOOKS + [LAMBDA (FILE TEXTOBJ) (* ; + "Edited 2-Jul-93 21:31 by sybalskY:MV:ENVOS") + (* ; + "Read a paragraph format spec from the FILE, and return it for later use.") + (PROG ((LOOKS (create FMTSPEC)) + (FILEPOS (GETFILEPTR FILE)) + (LOOKSLEN (\SMALLPIN FILE)) + TABFLG DEFAULTTAB TABCOUNT TABS TABSPEC TABTYPE QUAD) + (replace (FMTSPEC 1STLEFTMAR) of LOOKS with (\SMALLPIN FILE)) + (* ; + "Left margin for the first line of the paragraph") + (replace (FMTSPEC LEFTMAR) of LOOKS with (\SMALLPIN FILE)) + (* ; + "Left margin for the rest of the paragraph") + (replace (FMTSPEC RIGHTMAR) of LOOKS with (\SMALLPIN FILE)) + (* ; "Right margin for the paragraph") + (replace (FMTSPEC LEADBEFORE) of LOOKS with (\SMALLPIN FILE)) + (* ; "Leading before the paragraph") + (replace (FMTSPEC LEADAFTER) of LOOKS with (\SMALLPIN FILE)) + (* ; "Lead after the paragraph") + (replace (FMTSPEC LINELEAD) of LOOKS with (\SMALLPIN FILE)) + (* ; "inter-line leading") + (replace (FMTSPEC TABSPEC) of LOOKS with (SETQ TABSPEC (CONS NIL NIL))) + (* ; "Will be tab specs") + (SETQ TABFLG (\BIN FILE)) + (replace (FMTSPEC QUAD) of LOOKS with (SELECTC (SETQ QUAD (\BIN FILE)) + (1 'LEFT) + (2 'RIGHT) + (3 'CENTERED) + (4 'JUSTIFIED) + (SHOULDNT))) + (COND + ((NOT (ZEROP (LOGAND TABFLG 1))) (* ; "There are tabs to read") + (SETQ DEFAULTTAB (\SMALLPIN FILE)) + (SETQ TABCOUNT (\BIN FILE)) + [SETQ TABS (for TAB# from 1 to TABCOUNT + collect (create TAB + TABX _ (\SMALLPIN FILE) + TABKIND _ (SELECTQ (SETQ TABTYPE (\BIN FILE)) + (0 'LEFT) + (1 'RIGHT) + (2 'CENTERED) + (3 'DECIMAL) + (4 'DOTTEDLEFT) + (5 'DOTTEDRIGHT) + (6 'DOTTEDCENTERED) + (7 'DOTTEDDECIMAL) + (SHOULDNT] + (OR (ZEROP DEFAULTTAB) + (RPLACA TABSPEC DEFAULTTAB)) + (RPLACD TABSPEC TABS))) + [COND + ((NOT (ZEROP (LOGAND TABFLG 2))) (* ; + "There are other paragraph parameters to be read.") + (replace (FMTSPEC FMTSPECIALX) of LOOKS with (\SMALLPIN FILE)) + (* ; + "Special X location on page for this paragraph") + (replace (FMTSPEC FMTSPECIALY) of LOOKS with (\SMALLPIN FILE)) + (replace (FMTSPEC FMTUSERINFO) of LOOKS with (\ARBIN FILE)) + (replace (FMTSPEC FMTPARATYPE) of LOOKS with (\ATMIN FILE)) + (replace (FMTSPEC FMTPARASUBTYPE) of LOOKS with (\ATMIN FILE)) + (replace (FMTSPEC FMTSTYLE) of LOOKS with (\ARBIN FILE)) + (replace (FMTSPEC FMTCHARSTYLES) of LOOKS with (\ARBIN FILE)) + (replace (FMTSPEC FMTNEWPAGEBEFORE) of LOOKS with (\ARBIN FILE)) + (replace (FMTSPEC FMTNEWPAGEAFTER) of LOOKS with (\ARBIN FILE)) + (replace (FMTSPEC FMTHEADINGKEEP) of LOOKS with (\ARBIN FILE)) + (replace (FMTSPEC FMTKEEP) of LOOKS with (\ARBIN FILE)) + [COND + ((ILESSP (GETFILEPTR FILE) + (IPLUS FILEPOS LOOKSLEN)) + (replace (FMTSPEC FMTBASETOBASE) of LOOKS with (\ARBIN FILE] + [COND + ((ILESSP (GETFILEPTR FILE) + (IPLUS FILEPOS LOOKSLEN)) + (replace (FMTSPEC FMTREVISED) of LOOKS with (\ARBIN FILE] + [COND + ((ILESSP (GETFILEPTR FILE) + (IPLUS FILEPOS LOOKSLEN)) + (replace (FMTSPEC FMTCOLUMN) of LOOKS with (\ARBIN FILE] + (COND + ((ILESSP (GETFILEPTR FILE) + (IPLUS FILEPOS LOOKSLEN)) + (replace (FMTSPEC FMTCHARSTYLES) of LOOKS with (\ARBIN FILE] + [COND + ((ILESSP (GETFILEPTR FILE) + (IPLUS FILEPOS LOOKSLEN)) (* ; + "There is more PARALOOKS info in this piece -- we probably lost data.") + (TEDIT.PROMPTPRINT TEXTOBJ "WARNING: Newer file version; you lost PARALOOKS info" T) + (SETFILEPTR FILE (IPLUS FILEPOS LOOKSLEN] + (RETURN LOOKS]) (\TEDIT.PUT.PARALOOKS.LIST + [LAMBDA (FILE LOOKSLIST) (* ; "Edited 1-Sep-87 20:34 by jds") + (* ; + "Write the list of FMTSPECs into the font file.") + + (PROG ((LOOKSHASH (HASHARRAY 50))) + (\DWOUT FILE 0) + (\SMALLPOUT FILE \PieceDescriptorPARALOOKSLIST) + (\SMALLPOUT FILE (FLENGTH LOOKSLIST)) + (for I from 1 as LOOKS in LOOKSLIST do (\TEDIT.PUT.SINGLE.PARALOOKS FILE LOOKS) + (* ; "Write out the description") + + (PUTHASH LOOKS I LOOKSHASH) + (* ; + "And save it in the hash table so people can find its index.") +) + (RETURN LOOKSHASH]) (\TEDIT.PUT.SINGLE.PARALOOKS + [LAMBDA (FILE LOOKS) (* ; + "Edited 2-Jul-93 21:30 by sybalskY:MV:ENVOS") + + (* ;; "Put a description of LOOKS into FILE.") + + (PROG ((FILEPOS (GETFILEPTR FILE)) + DEFAULTTAB TABSPECS OUTPUTFORMAT LEN) + (\SMALLPOUT FILE 0) (* ; + "Reserve space for the length of this looks") + (\SMALLPOUT FILE (fetch (FMTSPEC 1STLEFTMAR) of LOOKS)) + (* ; + "Left margin for the first line of the paragraph") + (\SMALLPOUT FILE (fetch (FMTSPEC LEFTMAR) of LOOKS)) + (* ; + "Left margin for the rest of the paragraph") + (\SMALLPOUT FILE (fetch (FMTSPEC RIGHTMAR) of LOOKS)) + (* ; "Right margin for the paragraph") + (\SMALLPOUT FILE (fetch (FMTSPEC LEADBEFORE) of LOOKS)) + (* ; "Leading before the paragraph") + (\SMALLPOUT FILE (fetch (FMTSPEC LEADAFTER) of LOOKS)) + (* ; "Lead after the paragraph") + (\SMALLPOUT FILE (fetch (FMTSPEC LINELEAD) of LOOKS)) + (* ; "inter-line leading") + (SETQ DEFAULTTAB (CAR (fetch (FMTSPEC TABSPEC) of LOOKS))) + (SETQ TABSPECS (CDR (fetch (FMTSPEC TABSPEC) of LOOKS))) + (COND + ((AND (fetch (FMTSPEC TABSPEC) of LOOKS) + (OR DEFAULTTAB TABSPECS)) (* ; + "There are tab specs to save, or there is a default tab setting to save") + (\BOUT FILE 3)) + (T (* ; + "There are no tab looks. Just let him go.") + (\BOUT FILE 2))) + (\BOUT FILE (SELECTQ (fetch (FMTSPEC QUAD) of LOOKS) + (LEFT 1) + (RIGHT 2) + ((CENTER CENTERED) + 3) + ((JUST JUSTIFIED) + 4) + (SHOULDNT))) + [COND + ((OR TABSPECS DEFAULTTAB) (* ; "There are tab specs to save.") + (COND + (DEFAULTTAB (\SMALLPOUT FILE DEFAULTTAB)) + (T (\SMALLPOUT FILE 0))) + (COND + ((IGREATERP (LENGTH TABSPECS) + 255) + (SHOULDNT "Paragraph has more than 255 TABs set--can't be saved."))) + (\BOUT FILE (LENGTH TABSPECS)) + (COND + (TABSPECS (* ; "# of tab settings <256!") + (for TAB in TABSPECS do (\SMALLPOUT FILE (fetch TABX + of TAB)) + (* ; "And setting.") + (\BOUT FILE (SELECTQ (fetch TABKIND + of TAB) + (LEFT 0) + (RIGHT 1) + (CENTERED 2) + (DECIMAL 3) + (DOTTEDLEFT 4) + (DOTTEDRIGHT 5) + (DOTTEDCENTERED + 6) + (DOTTEDDECIMAL 7) + (SHOULDNT))) + (* ; "Tab type")] + (\SMALLPOUT FILE (OR (fetch (FMTSPEC FMTSPECIALX) of LOOKS) + 0)) + (\SMALLPOUT FILE (OR (fetch (FMTSPEC FMTSPECIALY) of LOOKS) + 0)) + (\ARBOUT FILE (fetch (FMTSPEC FMTUSERINFO) of LOOKS)) + (\ATMOUT FILE (fetch (FMTSPEC FMTPARATYPE) of LOOKS)) + (\ATMOUT FILE (fetch (FMTSPEC FMTPARASUBTYPE) of LOOKS)) + (\ARBOUT FILE (fetch (FMTSPEC FMTSTYLE) of LOOKS)) + (\ARBOUT FILE (fetch (FMTSPEC FMTCHARSTYLES) of LOOKS)) + (\ARBOUT FILE (fetch (FMTSPEC FMTNEWPAGEBEFORE) of LOOKS)) + (\ARBOUT FILE (fetch (FMTSPEC FMTNEWPAGEAFTER) of LOOKS)) + (\ARBOUT FILE (fetch (FMTSPEC FMTHEADINGKEEP) of LOOKS)) + (\ARBOUT FILE (fetch (FMTSPEC FMTKEEP) of LOOKS)) + (\ARBOUT FILE (fetch (FMTSPEC FMTBASETOBASE) of LOOKS)) + (\ARBOUT FILE (fetch (FMTSPEC FMTREVISED) of LOOKS)) + (\ARBOUT FILE (fetch (FMTSPEC FMTCOLUMN) of LOOKS)) + (\ARBOUT FILE (fetch (FMTSPEC FMTCHARSTYLES) of LOOKS)) + +(* ;;; "Now go fill in the length field at the front of the LOOKS. (ALL looks info should be written out BEFORE this comment.)") + + (SETQ LEN (IDIFFERENCE (GETFILEPTR FILE) + FILEPOS)) (* ; "The length of this set of looks") + (SETFILEPTR FILE FILEPOS) (* ; "Go write the length field") + (\SMALLPOUT FILE LEN) + (SETFILEPTR FILE -1) (* ; "And back to the end of the file") + ]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.INPUT.FORMATS *TEDIT-FILE-READTABLE*) ) (RPAQ? TEDIT.INPUT.FORMATS NIL) (RPAQ? *TEDIT-FILE-READTABLE* (COPYREADTABLE \ORIGREADTABLE)) (* ;; "For converting old incoming format. Cutover 5/22/85 to permit looks changes in the future.") (DEFINEQ (TEDIT.BUILD.PCTB2 + [LAMBDA (TEXT TEXTOBJ PCCOUNT START END DEFAULTLOOKS) (* ; "Edited 4-May-93 16:27 by jds") + + (* ;; "READ OBSOLETE FORMATS OF TEDIT FILE") + + (* ;; "START = 1st char of file to read from, if specified") + + (* ;; "END = use this as eofptr of file. For use in reading files within files.") + + (PROG (SEL LINES PCTB PC OLDPC TYPECODE PCLEN CHLOOKSSEEN NEWPC PARALOOKSSEEN PIECEINFOCH# CACHE + CACHE? TTEXTOBJ USER.CMFILE TSTREAM USERFILEFORMAT USERTEMP EXISTINGCHARLOOKS EXLOOK + EXISTINGFMTSPECS (CURFILECH# (OR START 0)) + (CURCH# 1) + (TEXTSTREAM (AND TEXTOBJ (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ))) + LOOKSHASH PARAHASH) (* ; + "Get the number of pieces needed (if AN formatted file), otherwise PCCOUNT will be NIL") + [SETQ DEFAULTPARALOOKS (OR DEFAULTPARALOOKS (COND + (TEXTOBJ (fetch (TEXTOBJ FMTSPEC) + of TEXTOBJ)) + (T (create FMTSPEC using + TEDIT.DEFAULT.FMTSPEC + ] + (SETQ DEFAULTLOOKS (OR DEFAULTLOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT))) + (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with NIL)) + (* ; + "Start by assuming no page formatting") + (SETQ PCTB (\MAKEPCTB NIL PCCOUNT)) + (replace (TEXTOBJ PCTB) of TEXTOBJ with PCTB) + (SETFILEPTR TEXT (IDIFFERENCE (OR END (GETEOFPTR TEXT)) + 8)) + (SETQ PIECEINFOCH# (\DWIN TEXT)) + (SETFILEPTR TEXT PIECEINFOCH#) + (bind (OLDPC _ NIL) + (OLDPARALOOKS _ DEFAULTPARALOOKS) for I from 1 to PCCOUNT as PCN + from \FirstPieceOffset by \EltsPerPiece + do (SETQ PC NIL) (* ; + "This loop may not really read a piece, so we have to distinguish that case.") + (SETQ PCLEN (\DWIN TEXT)) + (SETQ TYPECODE (\SMALLPIN TEXT)) (* ; "What kind of piece is it?") + (SELECTC TYPECODE + (\PieceDescriptorPAGEFRAME (* ; + "This is page layout info for the file") + (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ + with (TEDIT.GET.PAGEFRAMES TEXT))) + (add PCN (IMINUS \EltsPerPiece)) + (* ; + "This didn't create a piece -- don't count it in the PCTB placement.") + ) + (\PieceDescriptorCHARLOOKSLIST (* ; + "This is the list of CHARLOOKSs used in this document.") + (replace (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ + with (\TEDIT.GET.CHARLOOKS.LIST2 TEXT)) + (* ; + "Read the list of looks used in this document.") + [SETQ LOOKSHASH (ARRAY (FLENGTH (fetch (TEXTOBJ TXTCHARLOOKSLIST) + of TEXTOBJ] + (* ; + "Build an array of the looks, so the reader can index them.") + (for I from 1 as LOOKS in (fetch (TEXTOBJ + TXTCHARLOOKSLIST + ) + of TEXTOBJ) + do (SETA LOOKSHASH I LOOKS)) + (add PCN (IMINUS \EltsPerPiece)) + (* ; + "This didn't create a piece -- don't count it in the PCTB placement.") + (add I -1)) + (\PieceDescriptorPARALOOKSLIST (* ; + "This is the list of PARALOOKSs used in this document.") + (replace (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ + with (\TEDIT.GET.PARALOOKS.LIST2 TEXT)) + (* ; + "Read the list of looks used in this document.") + [SETQ PARAHASH (ARRAY (FLENGTH (fetch (TEXTOBJ TXTPARALOOKSLIST) + of TEXTOBJ] + (* ; + "Build an array of the looks, so the reader can index them.") + (for I from 1 as LOOKS in (fetch (TEXTOBJ + TXTPARALOOKSLIST + ) + of TEXTOBJ) + do (SETA PARAHASH I LOOKS)) + (add PCN (IMINUS \EltsPerPiece)) + (* ; + "This didn't create a piece -- don't count it in the PCTB placement.") + (add I -1)) + (\PieceDescriptorPARA (* ; + "Reading a new set of paragraph looks.") + (AND OLDPC (replace (PIECE PPARALAST) of OLDPC with T)) + (* ; + "Mark the end of the preceding paragraph.") + (SETQ OLDPARALOOKS (\TEDIT.GET.PARALOOKS TEXT PARAHASH)) + (* ; + "Get the new set of looks, for use by later pieces.") + (AND TEXTOBJ (replace (TEXTOBJ FORMATTEDP) of TEXTOBJ + with T)) (* ; + "Mark the document as containing paragraph formatting info") + (add PCN (IMINUS \EltsPerPiece)) + (* ; + "This didn't create a piece -- don't count it in the PCTB placement.") + ) + (\PieceDescriptorLOOKS (* ; + "New character looks. Build a piece to describe those characters.") + (SETQ PC + (create PIECE + PFILE _ TEXT + PFPOS _ CURFILECH# + PLEN _ PCLEN + PREVPIECE _ OLDPC + PPARALOOKS _ OLDPARALOOKS)) + (* ; "Build the new piece") + (\TEDIT.GET.CHARLOOKS PC TEXT LOOKSHASH OLDPC) + (* ; + "Read the character looks for this guy.") + (COND + [OLDPC (* ; + "If there's a prior piece, hook this one on the chain.") + (replace (PIECE NEXTPIECE) of OLDPC with PC) + (COND + ((AND (fetch (PIECE PFATP) of PC) + (NOT (fetch (PIECE PFATP) of OLDPC))) + (* ; + "Switching from not-fat to fat. Add 3 bytes for the 255-255-0") + (add (fetch (PIECE PFPOS) of PC) + 3) + (add CURFILECH# -3)) + ((AND (fetch (PIECE PFATP) of OLDPC) + (NOT (fetch (PIECE PFATP) of PC))) + (* ; + "Switching from fat to not-fat. Add 3 bytes for the 255-0") + (add (fetch (PIECE PFPOS) of PC) + 2] + ((fetch (PIECE PFATP) of PC) + (* ; + "Switching from not-fat to fat. Add 3 bytes for the 255-255-0") + (add (fetch (PIECE PFPOS) of PC) + 3) + (add CURFILECH# -3))) + (add CURFILECH# PCLEN) (* ; + "And note the passing of characters.") + ) + (\PieceDescriptorOBJECT (* ; + "It describes an object. Read that, and perhaps some description of the charlooks to go with it.") + (SETQ PC + (create PIECE + PFILE _ TEXT + PFPOS _ CURFILECH# + PLEN _ PCLEN + PREVPIECE _ OLDPC + PPARALOOKS _ OLDPARALOOKS)) + (COND + (OLDPC (* ; + "If there's a prior piece, hook this one on the chain.") + (replace (PIECE NEXTPIECE) of OLDPC with PC))) + (TEDIT.GET.OBJECT TEXTSTREAM PC TEXT CURFILECH#) + (add CURFILECH# (fetch (PIECE PLEN) of PC)) + [COND + ((NOT (ZEROP (\BIN TEXT))) (* ; + "There are new character looks for this object. Read them in.") + (replace (PIECE PLOOKS) of PC with ( + \TEDIT.GET.SINGLE.CHARLOOKS2 + TEXT))) + (T (* ; + "No new looks; steal them from the prior piece.") + (replace (PIECE PLOOKS) of PC + with (OR (AND OLDPC (fetch (PIECE PLOOKS) of OLDPC)) + DEFAULTLOOKS] + (replace (PIECE PLEN) of PC with 1) + (* ; + "OBJECTs are officially one character long.") + ) + (SHOULDNT "Impossible piece-type code in BUILD.PCTB")) + (COND + (PC (* ; + "If we created a piece, save it in the table.") + (\INSERTPIECE PC 'LASTPIECE TEXTOBJ) + (add CURCH# (fetch (PIECE PLEN) of PC)) + (SETQ OLDPC PC))) finally (* INSERT-BRT (CREATEPCNODE CURCH# + (QUOTE LASTPIECE)) PCTB)) + (RETURN PCTB]) (\TEDIT.GET.CHARLOOKS.LIST2 + [LAMBDA (FILE) (* jds "22-May-85 14:28") + (* Read the list of CHARLOOKSs from + the file.) + (for I from 1 to (\SMALLPIN FILE) collect (\TEDIT.GET.SINGLE.CHARLOOKS2 FILE]) (\TEDIT.GET.SINGLE.CHARLOOKS2 + [LAMBDA (FILE) (* ; "Edited 30-May-91 20:26 by jds") + (* Read a set of CHARLOOKS from FILE) + (PROG* ((LOOKS (create CHARLOOKS)) + FONT STR NAME NAMELEN SIZE SUPER SUB PROPS STYLESTR USERSTR) + (SETQ NAME (\ARBIN FILE)) (* The font name) + (SETQ SIZE (\SMALLPIN FILE)) (* Size of the type, in points) + (SETQ SUPER (\SMALLPIN FILE)) (* Superscripting distance) + (replace (CHARLOOKS CLSTYLE) of LOOKS with (OR (\ARBIN FILE) + 0)) + (replace (CHARLOOKS CLUSERINFO) of LOOKS with (\ARBIN FILE)) + (SETQ PROPS (\SMALLPIN FILE)) + (with CHARLOOKS LOOKS [SETQ CLLEADER (NOT (ZEROP (LOGAND 2048 PROPS] + [SETQ CLINVERTED (NOT (ZEROP (LOGAND 1024 PROPS] + [SETQ CLBOLD (NOT (ZEROP (LOGAND 512 PROPS] + [SETQ CLITAL (NOT (ZEROP (LOGAND 256 PROPS] + [SETQ CLULINE (NOT (ZEROP (LOGAND 128 PROPS] + [SETQ CLOLINE (NOT (ZEROP (LOGAND 64 PROPS] + [SETQ CLSTRIKE (NOT (ZEROP (LOGAND 32 PROPS] + [SETQ CLSMALLCAP (NOT (ZEROP (LOGAND 16 PROPS] + [SETQ CLPROTECTED (NOT (ZEROP (LOGAND 8 PROPS] + [SETQ CLINVISIBLE (NOT (ZEROP (LOGAND 4 PROPS] + [SETQ CLSELHERE (NOT (ZEROP (LOGAND 2 PROPS] + [SETQ CLCANCOPY (NOT (ZEROP (LOGAND 1 PROPS] + (SETQ CLSIZE SIZE) + (SETQ CLOFFSET SUPER)) + [replace (CHARLOOKS CLFONT) of LOOKS + with (COND + ((LISTP NAME) (* This was a font class. + Restore it.) + (FONTCLASS (pop NAME) + NAME)) + ((AND NAME (NOT (ZEROP SIZE))) + (FONTCREATE NAME SIZE (COND + ((AND (fetch (CHARLOOKS CLBOLD) of LOOKS) + (fetch (CHARLOOKS CLITAL) of LOOKS) + ) + 'BOLDITALIC) + ((fetch (CHARLOOKS CLBOLD) of LOOKS) + 'BOLD) + ((fetch (CHARLOOKS CLITAL) of LOOKS) + 'ITALIC] + (RETURN LOOKS]) (\TEDIT.PUT.SINGLE.PARALOOKS2 + [LAMBDA (FILE LOOKS) (* ; "Edited 30-May-91 20:33 by jds") + (* Put a description of LOOKS into + FILE. LOOKS apply to characters CH1 + thru CHLIM-1) + (PROG (DEFAULTTAB TABSPECS OUTPUTFORMAT LEN) + (\SMALLPOUT FILE (fetch (FMTSPEC 1STLEFTMAR) of LOOKS)) + (* Left margin for the first line of + the paragraph) + (\SMALLPOUT FILE (fetch (FMTSPEC LEFTMAR) of LOOKS)) + (* Left margin for the rest of the + paragraph) + (\SMALLPOUT FILE (fetch (FMTSPEC RIGHTMAR) of LOOKS)) + (* Right margin for the paragraph) + (\SMALLPOUT FILE (fetch (FMTSPEC LEADBEFORE) of LOOKS)) + (* Leading before the paragraph) + (\SMALLPOUT FILE (fetch (FMTSPEC LEADAFTER) of LOOKS)) + (* Lead after the paragraph) + (\SMALLPOUT FILE (fetch (FMTSPEC LINELEAD) of LOOKS)) + (* inter-line leading) + (SETQ DEFAULTTAB (CAR (fetch (FMTSPEC TABSPEC) of LOOKS))) + (SETQ TABSPECS (CDR (fetch (FMTSPEC TABSPEC) of LOOKS))) + (COND + ((AND (fetch (FMTSPEC TABSPEC) of LOOKS) + (OR DEFAULTTAB TABSPECS)) + + (* There are tab specs to save, or there is a default tab setting to save) + + (\BOUT FILE 3)) + (T (* There are no tab looks. + Just let him go.) + (\BOUT FILE 2))) + (\BOUT FILE (SELECTQ (fetch (FMTSPEC QUAD) of LOOKS) + (LEFT 1) + (RIGHT 2) + ((CENTER CENTERED) + 3) + ((JUST JUSTIFIED) + 4) + (SHOULDNT))) + [COND + ((OR TABSPECS DEFAULTTAB) (* There are tab specs to save.) + (COND + (DEFAULTTAB (\SMALLPOUT FILE DEFAULTTAB)) + (T (\SMALLPOUT FILE 0))) + (\BOUT FILE (LENGTH TABSPECS)) + (COND + (TABSPECS (* %# of tab settings <256!) + (for TAB in TABSPECS do (\SMALLPOUT FILE (fetch TABX + of TAB)) + (* And setting.) + (\BOUT FILE (SELECTQ (fetch TABKIND + of TAB) + (LEFT 0) + (RIGHT 1) + (CENTERED 2) + (DECIMAL 3) + (SHOULDNT))) + (* Tab type)] + (\SMALLPOUT FILE (OR (fetch (FMTSPEC FMTSPECIALX) of LOOKS) + 0)) + (\SMALLPOUT FILE (OR (fetch (FMTSPEC FMTSPECIALY) of LOOKS) + 0)) + (\ARBOUT FILE (fetch (FMTSPEC FMTUSERINFO) of LOOKS)) + (\ATMOUT FILE (fetch (FMTSPEC FMTPARATYPE) of LOOKS)) + (\ATMOUT FILE (fetch (FMTSPEC FMTPARASUBTYPE) of LOOKS)) + (\ARBOUT FILE (fetch (FMTSPEC FMTSTYLE) of LOOKS)) + (\ARBOUT FILE (fetch (FMTSPEC FMTCHARSTYLES) of LOOKS)) + (\ARBOUT FILE (fetch (FMTSPEC FMTNEWPAGEBEFORE) of LOOKS)) + (\ARBOUT FILE (fetch (FMTSPEC FMTNEWPAGEAFTER) of LOOKS]) (\TEDIT.PUT.SINGLE.CHARLOOKS2 + [LAMBDA (FILE LOOKS) (* ; "Edited 30-May-91 20:26 by jds") + (* Put out a single CHARLOOKS + description.) + (PROG ((FONT (fetch (CHARLOOKS CLFONT) of LOOKS)) + STR LEN) + [COND + ((type? FONTCLASS FONT) (* For font classes, we need to save + a list of device-FD sets) + (\ARBOUT FILE (FONTCLASSUNPARSE FONT))) + (T (* For FONTDESCRIPTORs, do it the + easy way) + (\ATMOUT FILE (FONTPROP FONT 'FAMILY] (* The font family) + (\SMALLPOUT FILE (OR (FONTPROP FONT 'SIZE) + 0)) (* Size of the type, in points) + (\SMALLPOUT FILE (OR (fetch (CHARLOOKS CLOFFSET) of LOOKS) + 0)) (* Super/subscripting distance) + (COND + ([AND (fetch (CHARLOOKS CLSTYLE) of LOOKS) + (NOT (ZEROP (fetch (CHARLOOKS CLSTYLE) of LOOKS] + (\ARBOUT FILE (fetch (CHARLOOKS CLSTYLE) of LOOKS))) + (T (\SMALLPOUT FILE 0))) + (COND + ((fetch (CHARLOOKS CLUSERINFO) of LOOKS) + (\ARBOUT FILE (fetch (CHARLOOKS CLUSERINFO) of LOOKS))) + (T (\SMALLPOUT FILE 0))) + (\SMALLPOUT FILE (LOGOR (COND + ((fetch (CHARLOOKS CLLEADER) of LOOKS) + (* Dotted-leader; relevant only to + TABs) + 2048) + (T 0)) + (COND + ((fetch (CHARLOOKS CLINVERTED) of LOOKS) + (* Inverse-video) + 1024) + (T 0)) + (COND + ((fetch (CHARLOOKS CLBOLD) of LOOKS) + 512) + (T 0)) + (COND + ((fetch (CHARLOOKS CLITAL) of LOOKS) + 256) + (T 0)) + (COND + ((fetch (CHARLOOKS CLULINE) of LOOKS) + 128) + (T 0)) + (COND + ((fetch (CHARLOOKS CLOLINE) of LOOKS) + 64) + (T 0)) + (COND + ((fetch (CHARLOOKS CLSTRIKE) of LOOKS) + 32) + (T 0)) + (COND + ((fetch (CHARLOOKS CLSMALLCAP) of LOOKS) + 16) + (T 0)) + (COND + ((fetch (CHARLOOKS CLPROTECTED) of LOOKS) + 8) + (T 0)) + (COND + ((fetch (CHARLOOKS CLINVISIBLE) of LOOKS) + NIL 4) + (T 0)) + (COND + ((fetch (CHARLOOKS CLSELHERE) of LOOKS) + 2) + (T 0)) + (COND + ((fetch (CHARLOOKS CLCANCOPY) of LOOKS) + 1) + (T 0]) (\TEDIT.GET.PARALOOKS.LIST2 + [LAMBDA (FILE) (* jds "22-May-85 14:28") + (* Read the list of CHARLOOKSs from + the file.) + (for I from 1 to (\SMALLPIN FILE) collect (\TEDIT.GET.SINGLE.PARALOOKS2 FILE]) (\TEDIT.GET.SINGLE.PARALOOKS2 + [LAMBDA (FILE) (* ; "Edited 30-May-91 20:33 by jds") + (* Read a paragraph format spec from + the FILE, and return it for later + use.) + (PROG ((LOOKS (create FMTSPEC)) + TABFLG DEFAULTTAB TABCOUNT TABS TABSPEC) + (replace (FMTSPEC 1STLEFTMAR) of LOOKS with (\SMALLPIN FILE)) + (* Left margin for the first line of + the paragraph) + (replace (FMTSPEC LEFTMAR) of LOOKS with (\SMALLPIN FILE)) + (* Left margin for the rest of the + paragraph) + (replace (FMTSPEC RIGHTMAR) of LOOKS with (\SMALLPIN FILE)) + (* Right margin for the paragraph) + (replace (FMTSPEC LEADBEFORE) of LOOKS with (\SMALLPIN FILE)) + (* Leading before the paragraph) + (replace (FMTSPEC LEADAFTER) of LOOKS with (\SMALLPIN FILE)) + (* Lead after the paragraph) + (replace (FMTSPEC LINELEAD) of LOOKS with (\SMALLPIN FILE)) + (* inter-line leading) + (replace (FMTSPEC TABSPEC) of LOOKS with (SETQ TABSPEC (CONS NIL NIL))) + (* Will be tab specs) + (SETQ TABFLG (\BIN FILE)) + (replace (FMTSPEC QUAD) of LOOKS with (SELECTC (\BIN FILE) + (1 'LEFT) + (2 'RIGHT) + (3 'CENTERED) + (4 'JUSTIFIED) + (SHOULDNT))) + (COND + ((NOT (ZEROP (LOGAND TABFLG 1))) (* There are tabs to read) + (SETQ DEFAULTTAB (\SMALLPIN FILE)) + (SETQ TABCOUNT (\BIN FILE)) + [SETQ TABS (for TAB# from 1 to TABCOUNT + collect (create TAB + TABX _ (\SMALLPIN FILE) + TABKIND _ (SELECTQ (\BIN FILE) + (0 'LEFT) + (1 'RIGHT) + (2 'CENTERED) + (3 'DECIMAL) + (SHOULDNT] + (OR (ZEROP DEFAULTTAB) + (RPLACA TABSPEC DEFAULTTAB)) + (RPLACD TABSPEC TABS))) + [COND + ((NOT (ZEROP (LOGAND TABFLG 2))) (* There are other paragraph + parameters to be read.) + (replace (FMTSPEC FMTSPECIALX) of LOOKS with (\SMALLPIN FILE)) + (* Special X location on page for + this paragraph) + (replace (FMTSPEC FMTSPECIALY) of LOOKS with (\SMALLPIN FILE)) + (replace (FMTSPEC FMTUSERINFO) of LOOKS with (\ARBIN FILE)) + (replace (FMTSPEC FMTPARATYPE) of LOOKS with (\ATMIN FILE)) + (replace (FMTSPEC FMTPARASUBTYPE) of LOOKS with (\ATMIN FILE)) + (replace (FMTSPEC FMTSTYLE) of LOOKS with (\ARBIN FILE)) + (replace (FMTSPEC FMTCHARSTYLES) of LOOKS with (\ARBIN FILE)) + (replace (FMTSPEC FMTNEWPAGEBEFORE) of LOOKS with (\ARBIN FILE)) + (replace (FMTSPEC FMTNEWPAGEAFTER) of LOOKS with (\ARBIN FILE] + (RETURN LOOKS]) (TEDIT.PUT.PCTB2 [LAMBDA (TEXTOBJ OFILE UNFORMATTED? SEPARATEFORMAT) (* ; "Edited 11-Jun-99 15:03 by rmk:") (* ; "Edited 11-Jun-99 15:03 by rmk:") (* ; "Edited 11-Jun-99 14:31 by rmk:") (* ; "Edited 11-Jun-99 14:29 by rmk:") (* ; "Edited 30-May-91 20:24 by jds") (* ;; "Put a representation of the piece table onto OFILE, preserving font changes and paragraph looks. UNFORMATTED? means write no font or formatting info.") (PROG (OCURSOR CH PC PFILE PSTR POBJ OFILELEN OLDLOOKS (OLDPARALOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)) OLDCH# CURCH# PREVPC (FONTFILE NIL) (PCCOUNT 0) TRUEFILE CHARLOOKSLST PARALOOKSLST (TEDIT.PUT.FINISHEDFORMS NIL) (EDITSTENTATIVE (TEXTPROP TEXTOBJ 'TEDIT.TENTATIVE)) (PARALOOKSSEEN NIL) (FORMATTINGLEVEL (TEDIT.FORMATTEDFILEP TEXTOBJ)) (CACHE (TEXTPROP TEXTOBJ 'CACHE)) CH#S PREVFATP PREVPREVPC LOOKSHASH PARAHASH) (SETQ PC (\EDITELT (fetch (TEXTOBJ PCTB) of TEXTOBJ) (ADD1 \FirstPieceOffset))) (* ; "First piece in the document") (SETQ OLDLOOKS (OR (AND (type? PIECE PC) (fetch (PIECE PLOOKS) of PC)) (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) TEDIT.DEFAULT.CHARLOOKS)) (* ; "Starting looks") (COND ((NEQ (fetch (STREAM EOLCONVENTION) of OFILE) CR.EOLC) (* ;  "This file is on a non-CR host; make a note to cache it") (SETQ TRUEFILE OFILE) (* ;  "Remember where the file should wind up.") [SETQ OFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (* ;  "And open a temp file to write it to.") )) [SETQ CURCH# (SETQ OLDCH# (ADD1 (GETFILEPTR OFILE] (COND ((fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ) (* ;  "There is layout info for this file. Save it") [SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (TEDIT.PUT.PAGEFRAMES FONTFILE (fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ)) (add PCCOUNT 1))) (\TEDIT.FLUSH.UNUSED.LOOKS TEXTOBJ PC) (* ;  "Run thru the lists of char & para looks and remove any that aren't in use") (COND ([AND (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ) (OR (IGREATERP (FLENGTH (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ)) 1) (NOT (EQFMTSPEC (CAR (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ)) TEDIT.DEFAULT.FMTSPEC] (* ;; "There are paragraph looks in this document that don't match the default -- save the list of them for later retrieval.") [OR FONTFILE (SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (* ;  "Create the font-info file if it doesn't exist yet") (SETQ PARAHASH (\TEDIT.PUT.PARALOOKS.LIST2 FONTFILE (fetch (TEXTOBJ TXTPARALOOKSLIST ) of TEXTOBJ))) (SETQ PARALOOKSSEEN T))) [COND ((OR PARALOOKSSEEN FORMATTINGLEVEL) (* ;; "There are character looks in this document that don't match the default (or paragraph formatting, which forces looks to be saved) -- save the list for later retrieval.") [OR FONTFILE (SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST2 FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST ) of TEXTOBJ] [while PC do (COND ([AND (NOT (ZEROP (fetch (PIECE PLEN) of PC))) (OR (NOT PREVPC) (fetch (PIECE PPARALAST) of PREVPC)) (OR PARALOOKSSEEN (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS ) of PC) (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ] (* ;  "The last piece ended a paragraph, so send out new para looks") [OR FONTFILE (SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (* ;  "Create the formatting-info file, if it didn't exist before.") (COND ((NEQ CURCH# OLDCH#) (* ;  "There were prior characters that hadn't been described in a piece yet. Describe them") [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST ) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVFATP) (add PCCOUNT 1) (SETQ OLDCH# CURCH#) (* ;  "And now we've described all the characters up to the current one.") )) (\TEDIT.PUT.PARALOOKS FONTFILE PC PARAHASH) (SETQ PARALOOKSSEEN T) (* ;  "Remember that we've seen a foreign paralooks, and must henceforth note para boundaries") (add PCCOUNT 1))) (COND [(fetch (PIECE POBJ) of PC) (* ;  "It's an object -- go use its PUTFN") [OR FONTFILE (SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (* ;  "Create the font-info file, if need be.") (COND ((AND (NEQ CURCH# OLDCH#) PREVPC) (* ;  "There were prior characters that hadn't been described in a piece yet. Describe them") [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST ) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVFATP) (add PCCOUNT 1) (SETQ OLDCH# CURCH#) (* ;  "And now we've described all the characters up to the current one.") )) (* ;  "If the prior thing was text, send along its descriptor.") (add CURCH# (TEDIT.PUT.OBJECT PC OFILE FONTFILE CURCH#)) (* ; "Send out the object") (add PCCOUNT 1) (SETQ OLDCH# CURCH#) (COND ([OR (NOT (EQCLOOKS OLDLOOKS (fetch (PIECE PLOOKS) of PC))) (NEQ (fetch (PIECE PFATP) of PC) (AND PREVPC (fetch (PIECE PFATP) of PREVPC))) [AND EDITSTENTATIVE (NEQ (fetch (PIECE PNEW) of PC) (AND PREVPC (fetch (PIECE PNEW) of PREVPC] (AND (OR (NOT PREVPC) (fetch (PIECE PPARALAST) of PREVPC)) (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS) of PC) (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ ] (* ;  "The OBJECT has different ooks from before") (\BOUT FONTFILE 1) (\TEDIT.PUT.SINGLE.CHARLOOKS FONTFILE (fetch (PIECE PLOOKS) of PC)) (SETQ OLDLOOKS (fetch (PIECE PLOOKS) of PC))) (T (* ;  "No differences. Don't write any charlooks, and mark that fact") (\BOUT FONTFILE 0) (* ;  "MAKE BLOODY SURE THAT THE NEXT RUN OF CHARACTERS GETS ITS OWN LOOKS") ] (T (* ; "It's not an object.") [COND ([OR (NOT (EQCLOOKS OLDLOOKS (fetch (PIECE PLOOKS) of PC))) (NEQ (fetch (PIECE PFATP) of PC) (AND PREVPC (fetch (PIECE PFATP) of PREVPC)) ) [AND EDITSTENTATIVE (NEQ (fetch (PIECE PNEW) of PC) (AND PREVPC (fetch (PIECE PNEW) of PREVPC] (AND (OR (NOT PREVPC) (fetch (PIECE PPARALAST) of PREVPC)) (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS) of PC) (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ] (* ; "We have a piece with new looks.") [OR FONTFILE (SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW '((TYPE TEXT] (COND ((NOT (IEQP OLDCH# CURCH#)) (* ;  "If there were looks past, and if the run was not empty, save a piece for its looks") [OR LOOKSHASH (SETQ LOOKSHASH (  \TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST ) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVFATP) (add PCCOUNT 1))) (SETQ OLDLOOKS (fetch (PIECE PLOOKS) of PC)) (SETQ OLDCH# CURCH#) (COND [PREVFATP (COND ((fetch (PIECE PFATP) of PC)) (T (* ; "Switching from FAT to thin") (BOUT OFILE 255) (BOUT OFILE 0) (add CURCH# 2] ((fetch (PIECE PFATP) of PC) (* ; "Switching from thin to fat") (BOUT OFILE 255) (BOUT OFILE 255) (BOUT OFILE 0) (add CURCH# 3))) (SETQ PREVFATP (fetch (PIECE PFATP) of PC] (* ;  "Now dump out the non-object contents of the piece.") [COND [(SETQ PFILE (fetch (PIECE PFILE) of PC)) (* ; "It's on a file. Copy it.") [OR (OPENP PFILE) (replace (PIECE PFILE) of PC with (SETQ PFILE (OPENSTREAM (fetch (STREAM FULLNAME) of PFILE) 'INPUT NIL '((TYPE TEXT] (* ; "Make sure the file is open.") (COPYBYTES PFILE OFILE (fetch (PIECE PFPOS) of PC) (IPLUS (fetch (PIECE PFPOS) of PC) (COND ((fetch (PIECE PFATP) of PC) (* ;  "For fat file pieces, copy twice as many bytes as characters.") (UNFOLD (fetch (PIECE PLEN) of PC) 2)) (T (fetch (PIECE PLEN) of PC] ((SETQ PSTR (fetch (PIECE PSTR) of PC)) (* ;  "It's in a string. Just print it.") (COND [(fetch (PIECE PFATP) of PC) (* ;  "The string is fat: Copy twice as many bytes as chars.") (for I from 1 to (fetch (PIECE PLEN) of PC) as CH instring PSTR do (\BOUT OFILE (\CHARSET CH)) (\BOUT OFILE (\CHAR8CODE CH] (T (* ;  "The string is thin. Just copy it to the file.") (for I from 1 to (fetch (PIECE PLEN) of PC) as CH instring PSTR do (\BOUT OFILE CH] [COND ((AND (NOT CACHE) (RANDACCESSP OFILE)) (* ; "CSLI leave the pieces and the pctb alone and just write the file if its cached or not randomaccess") (push CH#S (SUB1 CURCH#] [COND ((fetch (PIECE PFATP) of PC) (add CURCH# (UNFOLD (fetch (PIECE PLEN) of PC) 2))) (T (add CURCH# (fetch (PIECE PLEN) of PC] (* ;  "Keep running track of where in the file we are.") )) (SETQ PREVPREVPC PREVPC) (SETQ PREVPC PC) (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) finally (* ;  "Put out a piece describing the last characters in the file.") (COND ((AND FONTFILE (NEQ OLDCH# CURCH#)) (* ;  "Only if there WERE characters, and only if there's a need for font information") [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ] (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE LOOKSHASH PREVPREVPC) (* ;  "Put out a description of the characters") (add PCCOUNT 1))) (COND ((AND PARALOOKSSEEN (fetch (PIECE PPARALAST) of PREVPC)) (* ;  "The last piece contained the end of a paragraph. Make sure it gets noted.") (\TEDIT.PUT.PARALOOKS FONTFILE PREVPC PARAHASH) (add PCCOUNT 1] (for FORM in TEDIT.PUT.FINISHEDFORMS do (EVAL FORM)) (* ; "Do any user-specific cleanup") (COND (TRUEFILE (* ;  "This file needs to be converted to the right convention") (COND ((AND FONTFILE (NOT UNFORMATTED?) (NOT SEPARATEFORMAT)) (* ;  "Formatted file: Copy without converting.") (COPYBYTES OFILE TRUEFILE 0 -1)) (T (* ;  "Go ahead and convert the EOLCONVENTION, this is a plain-text file") (COPYCHARS OFILE TRUEFILE 0 -1))) (SETQ OFILE TRUEFILE))) [COND ((AND (OPENP OFILE) FONTFILE) (* ; "We need to write format info.") (\DWOUT FONTFILE (GETEOFPTR OFILE)) (* ;  "So remember the end of the plain-text part of the file") (\SMALLPOUT FONTFILE PCCOUNT) (* ;  "# OF PIECES WE'' NEED TO RECONSTRUCT THIS FILE") (\SMALLPOUT FONTFILE 31417) (* ;  "Now the password for NEW format files: 31416") (COND ((AND (NOT UNFORMATTED?) (NOT SEPARATEFORMAT)) (* ;; "Only write fmtg info at the end if we want it there--not if we want plain text or want it kept separate.") (COPYBYTES FONTFILE OFILE 0 (GETEOFPTR FONTFILE)) (* ;  "Copy the font information to the file trailer") ) (T)) (CLOSEF FONTFILE) (COND ((NOT SEPARATEFORMAT) (* ;  "Unless we want the formatting info separately, delete the file") (* ;  "(since FONTFILE is a stream, we should not need to delete it at all) (DELFILE FONTFILE)") ] (replace (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (TEXTOBJ DEFAULTCHARLOOKS ) of TEXTOBJ) TEXTOBJ)) (* ;  "Re-add the default and caret looks's to the lists, since they may not have been really saved.") (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ)) (replace (TEXTOBJ FMTSPEC) of TEXTOBJ with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ) TEXTOBJ)) (RETURN (CONS (COND (UNFORMATTED? NIL) (T FONTFILE)) CH#S]) (\TEDIT.PUT.CHARLOOKS.LIST2 + [LAMBDA (FILE LOOKSLIST) (* jds "22-May-85 15:12") + (* Write the list of CHARLOOKSs into + the font file.) + + (* Returns a hasharray that will map from a given CHARLOOKS to that CHARLOOKS' + position in the list we wrote on the file. + Those position numbers are then written in the individual looks descriptions, + and are used to reconstruct the piece looks when the file is read back in.) + + (PROG ((LOOKSHASH (HASHARRAY 50))) + (\DWOUT FILE 0) (* No characters are described by this + pseudo-piece entry.) + (\SMALLPOUT FILE \PieceDescriptorCHARLOOKSLIST) (* Mark it as containing the list of + CHARLOOKSs) + (\SMALLPOUT FILE (FLENGTH LOOKSLIST)) (* How many CHARLOOKSs there are in + the list) + (for I from 1 as LOOKS in LOOKSLIST do + + (* Write each charlooks, in the order they appear in the list.) + + (\TEDIT.PUT.SINGLE.CHARLOOKS2 FILE LOOKS) + (* Write out the description) + (PUTHASH LOOKS I LOOKSHASH) + + (* And save it in the hash table so people can find its index.) +) + (RETURN LOOKSHASH]) (\TEDIT.PUT.PARALOOKS.LIST2 + [LAMBDA (FILE LOOKSLIST) (* jds "22-May-85 15:09") + (* Write the list of FMTSPECs into the + font file.) + (PROG ((LOOKSHASH (HASHARRAY 50))) + (\DWOUT FILE 0) + (\SMALLPOUT FILE \PieceDescriptorPARALOOKSLIST) + (\SMALLPOUT FILE (FLENGTH LOOKSLIST)) + (for I from 1 as LOOKS in LOOKSLIST do (\TEDIT.PUT.SINGLE.PARALOOKS2 FILE LOOKS) + (* Write out the description) + (PUTHASH LOOKS I LOOKSHASH) + + (* And save it in the hash table so people can find its index.) +) + (RETURN LOOKSHASH]) ) (* ;; "For converting incoming old-format files (1/27/85 cutover)") (DEFINEQ (TEDIT.BUILD.PCTB1 + [LAMBDA (TEXT TEXTOBJ PCCOUNT START END DEFAULTLOOKS) (* ; "Edited 22-May-92 18:00 by jds") + +(* ;;; "READ OBSOLETE FORMATS OF TEDIT FILE") + + (* ;; "START = 1st char of file to read from, if specified") + + (* ;; "END = use this as eofptr of file. For use in reading files within files.") + + (PROG [SEL LINES PCTB PC OLDPC TYPECODE PCLEN CHLOOKSSEEN NEWPC PARALOOKSSEEN PIECEINFOCH# CACHE + CACHE? TTEXTOBJ USER.CMFILE TSTREAM USERFILEFORMAT USERTEMP EXISTINGCHARLOOKS EXLOOK + EXISTINGFMTSPECS (CURFILECH# (OR START 0)) + (CURCH# 1) + (TEXTSTREAM (AND TEXTOBJ (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ] + + (* ;; "Get the number of pieces needed (if AN formatted file), otherwise PCCOUNT will be NIL") + + [SETQ DEFAULTPARALOOKS (OR DEFAULTPARALOOKS (COND + (TEXTOBJ (fetch (TEXTOBJ FMTSPEC) + of TEXTOBJ)) + (T (create FMTSPEC using + TEDIT.DEFAULT.FMTSPEC + ] + (SETQ DEFAULTLOOKS (OR DEFAULTLOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT))) + (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with NIL)) + (* ; + "Start by assuming no page formatting") + (SETQ PCTB (\MAKEPCTB NIL PCCOUNT)) + (SETFILEPTR TEXT (IDIFFERENCE (OR END (GETEOFPTR TEXT)) + 8)) + (SETQ PIECEINFOCH# (\DWIN TEXT)) + (SETFILEPTR TEXT PIECEINFOCH#) + (bind (OLDPC _ NIL) + (OLDPARALOOKS _ DEFAULTPARALOOKS) for I from 1 to PCCOUNT as PCN + from \FirstPieceOffset by \EltsPerPiece + do (SETQ PC NIL) (* ; + "This loop may not really read a piece, so we have to distinguish that case.") + (SETQ PCLEN (\DWIN TEXT)) + (SETQ TYPECODE (\SMALLPIN TEXT)) (* ; "What kind of piece is it?") + (SELECTC TYPECODE + (\PieceDescriptorPAGEFRAME (* ; + "This is page layout info for the file") + (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ + with (TEDIT.GET.PAGEFRAMES1 TEXT))) + (add PCN (IMINUS \EltsPerPiece)) + (* ; + "This didn't create a piece -- don't count it in the PCTB placement.") + ) + (\PieceDescriptorPARA (* ; + "Reading a new set of paragraph looks.") + (AND OLDPC (replace (PIECE PPARALAST) of OLDPC with T)) + (* ; + "Mark the end of the preceding paragraph.") + (SETQ OLDPARALOOKS (\TEDIT.GET.PARALOOKS1 TEXT)) + (* ; + "Get the new set of looks, for use by later pieces.") + (AND TEXTOBJ (replace (TEXTOBJ FORMATTEDP) of TEXTOBJ + with T)) (* ; + "Mark the document as containing paragraph formatting info") + (add PCN (IMINUS \EltsPerPiece)) + (* ; + "This didn't create a piece -- don't count it in the PCTB placement.") + ) + (\PieceDescriptorLOOKS (* ; + "New character looks. Build a piece to describe those characters.") + (SETQ PC + (create PIECE + PFILE _ TEXT + PFPOS _ CURFILECH# + PLEN _ PCLEN + PREVPIECE _ OLDPC + PPARALOOKS _ OLDPARALOOKS)) + (* ; "Build the new piece") + (COND + (OLDPC (* ; + "If there's a prior piece, hook this one on the chain.") + (replace (PIECE NEXTPIECE) of OLDPC with PC))) + (\TEDIT.GET.CHARLOOKS1 PC TEXT) + (* ; + "Read the character looks for this guy.") + (add CURFILECH# (fetch (PIECE PLEN) of PC)) + (* ; + "And note the passing of characters.") + ) + (\PieceDescriptorOBJECT (* ; + "It describes an object. Read that, and perhaps some description of the charlooks to go with it.") + (SETQ PC + (create PIECE + PFILE _ TEXT + PFPOS _ CURFILECH# + PLEN _ PCLEN + PREVPIECE _ OLDPC + PPARALOOKS _ OLDPARALOOKS)) + (COND + (OLDPC (* ; + "If there's a prior piece, hook this one on the chain.") + (replace (PIECE NEXTPIECE) of OLDPC with PC))) + (TEDIT.GET.OBJECT1 TEXTSTREAM PC TEXT CURFILECH#) + (add CURFILECH# (fetch (PIECE PLEN) of PC)) + [COND + ((NOT (ZEROP (\BIN TEXT))) (* ; + "There are new character looks for this object. Read them in.") + (\DWIN TEXT) + (\WIN TEXT) (* ; + "Skip over the piece-type code we know has to be here.") + (\TEDIT.GET.CHARLOOKS1 PC TEXT)) + (T (* ; + "No new looks; steal them from the prior piece.") + (replace (PIECE PLOOKS) of PC + with (OR (AND OLDPC (fetch (PIECE PLOOKS) of OLDPC)) + DEFAULTLOOKS] + (replace (PIECE PLEN) of PC with 1) + (* ; + "OBJECTs are officially one character long.") + ) + (SHOULDNT "Impossible piece-type code in BUILD.PCTB")) + (COND + (PC (* ; + "If we created a piece, save it in the table.") + [COND + ((SETQ EXLOOK (for LOOK in EXISTINGCHARLOOKS + thereis (EQCLOOKS (fetch (PIECE PLOOKS) + of PC) + LOOK))) + (* ; + "These charlooks are a duplicate of pre-existing ones. Re-use the old one.") + (replace (PIECE PLOOKS) of PC with EXLOOK)) + (T (push EXISTINGCHARLOOKS (fetch (PIECE PLOOKS) of PC] + [COND + ((SETQ EXLOOK (for LOOK in EXISTINGFMTSPECS + thereis (EQFMTSPEC (fetch (PIECE PPARALOOKS) + of PC) + LOOK))) + (* ; + "These paralooks are a duplicate of pre-existing ones. Re-use the old one.") + (replace (PIECE PPARALOOKS) of PC with EXLOOK)) + (T (push EXISTINGFMTSPECS (fetch (PIECE PPARALOOKS) of + PC] + (INSERT-BRT (CREATEPCNODE CURCH# PC) + PCTB) + (add CURCH# (fetch (PIECE PLEN) of PC)) + (SETQ OLDPC PC))) finally (INSERT-BRT (CREATEPCNODE CURCH# 'LASTPIECE) + PCTB)) + (RETURN PCTB]) (TEDIT.GET.PAGEFRAMES1 + [LAMBDA (FILE) (* jds " 1-Feb-85 14:55") + + (* Read a bunch of page frames from the file, and return it.) + + (TEDIT.PARSE.PAGEFRAMES1 (READ FILE]) (\TEDIT.GET.CHARLOOKS1 + [LAMBDA (PC FILE) (* ; "Edited 30-May-91 20:26 by jds") + (* Read a description of PC's + CHARLOOKS from FILE.) + (PROG (FONT STR NAME NAMELEN SIZE SUPER SUB PROPS STYLESTR USERSTR (LOOKS (create CHARLOOKS)) + ) + (replace (PIECE PLOOKS) of PC with LOOKS) + (SETQ NAME (\ARBIN FILE)) (* The font name) + (SETQ SIZE (\SMALLPIN FILE)) (* Size of the type, in points) + (SETQ SUPER (\SMALLPIN FILE)) (* Superscripting distance) + (SETQ SUB (\SMALLPIN FILE)) (* former Subscripting distance) + (OR (ZEROP SUB) + (SETQ SUPER (IMINUS SUB))) + + (* If this is an old file, it'll have a subscript value not zero. + Let those past and do the right thing.) + + (COND + ((NOT (ZEROP (\BIN FILE))) (* This text is NEW. + Mark it so.) + (replace (PIECE PNEW) of PC with T))) + [COND + ((NOT (ZEROP (\BIN FILE))) (* There is style or user + information to be read) + (replace (CHARLOOKS CLSTYLE) of LOOKS with (OR (\ARBIN FILE) + 0)) + (replace (CHARLOOKS CLUSERINFO) of LOOKS with (\ARBIN FILE] + (SETQ PROPS (\SMALLPIN FILE)) + (with CHARLOOKS LOOKS [SETQ CLBOLD (NOT (ZEROP (LOGAND 512 PROPS] + [SETQ CLITAL (NOT (ZEROP (LOGAND 256 PROPS] + [SETQ CLULINE (NOT (ZEROP (LOGAND 128 PROPS] + [SETQ CLOLINE (NOT (ZEROP (LOGAND 64 PROPS] + [SETQ CLSTRIKE (NOT (ZEROP (LOGAND 32 PROPS] + [SETQ CLSMALLCAP (NOT (ZEROP (LOGAND 16 PROPS] + [SETQ CLPROTECTED (NOT (ZEROP (LOGAND 8 PROPS] + [SETQ CLINVISIBLE (NOT (ZEROP (LOGAND 4 PROPS] + [SETQ CLSELHERE (NOT (ZEROP (LOGAND 2 PROPS] + [SETQ CLCANCOPY (NOT (ZEROP (LOGAND 1 PROPS] + (SETQ CLSIZE SIZE) + (SETQ CLOFFSET SUPER)) + (replace (CHARLOOKS CLFONT) of LOOKS + with (COND + ((LISTP NAME) (* This was a font class. + Restore it.) + (FONTCLASS (pop NAME) + NAME)) + ((AND NAME (NOT (ZEROP SIZE))) + (FONTCREATE NAME SIZE (COND + ((AND (fetch (CHARLOOKS CLBOLD) of LOOKS) + (fetch (CHARLOOKS CLITAL) of LOOKS)) + 'BOLDITALIC) + ((fetch (CHARLOOKS CLBOLD) of LOOKS) + 'BOLD) + ((fetch (CHARLOOKS CLITAL) of LOOKS) + 'ITALIC]) (\TEDIT.GET.PARALOOKS1 + [LAMBDA (FILE) (* ; "Edited 30-May-91 20:34 by jds") + (* Read a paragraph format spec from + the FILE, and return it for later + use.) + (PROG ((LOOKS (create FMTSPEC)) + TABFLG DEFAULTTAB TABCOUNT TABS TABSPEC) + (replace (FMTSPEC 1STLEFTMAR) of LOOKS with (\SMALLPIN FILE)) + (* Left margin for the first line of + the paragraph) + (replace (FMTSPEC LEFTMAR) of LOOKS with (\SMALLPIN FILE)) + (* Left margin for the rest of the + paragraph) + (replace (FMTSPEC RIGHTMAR) of LOOKS with (\SMALLPIN FILE)) + (* Right margin for the paragraph) + (replace (FMTSPEC LEADBEFORE) of LOOKS with (\SMALLPIN FILE)) + (* Leading before the paragraph) + (replace (FMTSPEC LEADAFTER) of LOOKS with (\SMALLPIN FILE)) + (* Lead after the paragraph) + (replace (FMTSPEC LINELEAD) of LOOKS with (\SMALLPIN FILE)) + (* inter-line leading) + (replace (FMTSPEC TABSPEC) of LOOKS with (SETQ TABSPEC (CONS NIL NIL))) + (* Will be tab specs) + (SETQ TABFLG (\BIN FILE)) + (replace (FMTSPEC QUAD) of LOOKS with (SELECTC (\BIN FILE) + (1 'LEFT) + (2 'RIGHT) + (3 'CENTERED) + (4 'JUSTIFIED) + (SHOULDNT))) + (COND + ((NOT (ZEROP (LOGAND TABFLG 1))) (* There are tabs to read) + (SETQ DEFAULTTAB (\SMALLPIN FILE)) + (SETQ TABCOUNT (\BIN FILE)) + [SETQ TABS (for TAB# from 1 to TABCOUNT + collect (create TAB + TABX _ (\SMALLPIN FILE) + TABKIND _ (SELECTQ (\BIN FILE) + (0 'LEFT) + (1 'RIGHT) + (2 'CENTERED) + (3 'DECIMAL) + (SHOULDNT] + (OR (ZEROP DEFAULTTAB) + (RPLACA TABSPEC DEFAULTTAB)) + (RPLACD TABSPEC TABS))) + [COND + ((NOT (ZEROP (LOGAND TABFLG 2))) (* There are other paragraph + parameters to be read.) + (replace (FMTSPEC FMTSPECIALX) of LOOKS with (\SMALLPIN FILE)) + (* Special X location on page for + this paragraph) + (replace (FMTSPEC FMTSPECIALY) of LOOKS with (\SMALLPIN FILE)) + (replace (FMTSPEC FMTUSERINFO) of LOOKS with (\ARBIN FILE)) + (replace (FMTSPEC FMTPARATYPE) of LOOKS with (\ATMIN FILE)) + (replace (FMTSPEC FMTPARASUBTYPE) of LOOKS with (\ATMIN FILE)) + (replace (FMTSPEC FMTSTYLE) of LOOKS with (\ARBIN FILE)) + (replace (FMTSPEC FMTCHARSTYLES) of LOOKS with (\ARBIN FILE)) + (replace (FMTSPEC FMTNEWPAGEBEFORE) of LOOKS with (\ARBIN FILE)) + (replace (FMTSPEC FMTNEWPAGEAFTER) of LOOKS with (\ARBIN FILE] + (RETURN LOOKS]) (TEDIT.GET.OBJECT1 + [LAMBDA (STREAM PIECE FILE CURCH#) (* ; "Edited 12-Jun-90 18:17 by mitani") + (* Get an object from the file) + + (* CURCH# = fileptr within the text section of the file where the object's text + starts.) + + (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) + FILEPTRSAVE NAMELEN GETFN OBJ) + (SETQ GETFN (\ATMIN FILE)) (* The GETFN for this kind of + IMAGEOBJ) + (SETQ FILEPTRSAVE (GETFILEPTR FILE)) (* Save our file location thru the + building of the object) + (SETFILEPTR FILE CURCH#) + (SETQ OBJ (READIMAGEOBJ FILE GETFN)) + (SETFILEPTR FILE FILEPTRSAVE) + (replace (PIECE POBJ) of PIECE with OBJ) + (replace (PIECE PFILE) of PIECE with NIL) + (replace (PIECE PSTR) of PIECE with NIL) + [replace (PIECE PLOOKS) of PIECE with (COND + ((fetch (PIECE PREVPIECE) + of PIECE) + (fetch (PIECE PLOOKS) + of (fetch (PIECE PREVPIECE + ) + of PIECE))) + (T (OR (fetch (TEXTOBJ + DEFAULTCHARLOOKS + ) + of TEXTOBJ) + (\TEDIT.UNIQUIFY.CHARLOOKS + (CHARLOOKS.FROM.FONT + DEFAULTFONT) + TEXTOBJ] + (RETURN (fetch (PIECE POBJ) of PIECE]) ) (* ;; "VERSION 0 Compatibility reading functions") (DEFINEQ (TEDIT.BUILD.PCTB0 + [LAMBDA (TEXT TEXTOBJ PCCOUNT START END) (* ; "Edited 22-May-92 18:01 by jds") + +(* ;;; "READ OBSOLETE FORMATS OF TEDIT FILE") + + (PROG [SEL LINES PCTB PC OLDPC TYPECODE PCLEN CHLOOKSSEEN NEWPC PARALOOKSSEEN PIECEINFOCH# CACHE + TTEXTOBJ USER.CMFILE TSTREAM USERFILEFORMAT USERTEMP (CURFILECH# (OR START 0)) + (CURCH# 1) + (TEXTSTREAM (AND TEXTOBJ (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ] + (* ; + "Get the number of pieces needed (if AN formatted file), otherwise PCCOUNT will be NIL") + [SETQ DEFAULTPARALOOKS (OR DEFAULTPARALOOKS (COND + (TEXTOBJ (fetch (TEXTOBJ FMTSPEC) + of TEXTOBJ)) + (T (create FMTSPEC using + TEDIT.DEFAULT.FMTSPEC + ] + (SETQ PCTB (\MAKEPCTB NIL PCCOUNT)) + (SETFILEPTR TEXT (IDIFFERENCE (OR END (GETEOFPTR TEXT)) + 8)) + (SETQ PIECEINFOCH# (\DWIN TEXT)) + (SETFILEPTR TEXT PIECEINFOCH#) + (bind (OLDPC _ NIL) for I from 1 to PCCOUNT as PCN from + \FirstPieceOffset + by \EltsPerPiece do (SETQ PC (create PIECE + PFILE _ TEXT + PFPOS _ CURFILECH# + PLEN _ (SETQ PCLEN (\DWIN TEXT)) + PREVPIECE _ OLDPC + PPARALOOKS _ DEFAULTPARALOOKS)) + [COND + (OLDPC (replace (PIECE NEXTPIECE) of OLDPC + with PC) + (replace (PIECE PPARALOOKS) of PC + with (fetch (PIECE PPARALOOKS) + of OLDPC] + (SETQ TYPECODE (\SMALLPIN TEXT)) + (SELECTC TYPECODE + (\PieceDescriptorLOOKS + (TEDIT.GET.CHARLOOKS0 PC TEXT) + (add CURFILECH# (fetch (PIECE PLEN) + of PC))) + (\PieceDescriptorOBJECT + (TEDIT.GET.OBJECT0 TEXTSTREAM PC TEXT CURFILECH# + ) + (add CURFILECH# (fetch (PIECE PLEN) + of PC)) + (replace (PIECE PLEN) of PC with 1) + (* ; + "Only object--can't be followed by either ot the others.") + ) + (\PieceDescriptorPARA + (AND OLDPC (replace (PIECE PPARALAST) + of OLDPC with T)) + (TEDIT.GET.PARALOOKS0 PC TEXT) + (replace (PIECE PLEN) of PC + with (\DWIN TEXT)) + (* ; + "Set this piece's length from the character looks.") + (\SMALLPIN TEXT) + (* ; + "Skip the piece-type code, since we know what's next") + (TEDIT.GET.CHARLOOKS0 PC TEXT) + (* ; "This document is 'formatted' .") + (add CURFILECH# (fetch (PIECE PLEN) + of PC)) + (AND TEXTOBJ (replace (TEXTOBJ FORMATTEDP) + of TEXTOBJ with T))) + (SHOULDNT "Impossible piece-type code in BUILD.PCTB")) + (SETQ OLDPC PC) + (INSERT-BRT (CREATEPCNODE CURCH# PC) + PCTB) + (add CURCH# (fetch (PIECE PLEN) of PC)) + finally (INSERT-BRT (CREATEPCNODE CURCH# 'LASTPIECE) + PCTB)) + (RETURN PCTB]) (TEDIT.GET.CHARLOOKS0 + [LAMBDA (PC FILE) (* ; "Edited 30-May-91 20:26 by jds") + (* Put a description of LOOKS into + FILE. LOOKS apply to characters CH1 + thru CHLIM-1) + (PROG (FONT STR NAME NAMELEN SIZE SUPER SUB PROPS STYLESTR USERSTR (LOOKS (create CHARLOOKS)) + ) + (replace (PIECE PLOOKS) of PC with LOOKS) + (SETQ NAMELEN (\SMALLPIN FILE)) (* The length of the description + which follows) + [SETQ NAME (PACK (for I from 1 to NAMELEN collect (CHARACTER (\BIN FILE] + (* The font name) + (SETQ SIZE (\SMALLPIN FILE)) (* Size of the type, in points) + (SETQ SUPER (\SMALLPIN FILE)) (* Superscripting distance) + (SETQ SUB (\SMALLPIN FILE)) (* former Subscripting distance) + (OR (ZEROP SUB) + (SETQ SUPER (IMINUS SUB))) + + (* If this is an old file, it'll have a subscript value not zero. + Let those past and do the right thing.) + + (COND + ((NOT (ZEROP (\BIN FILE))) (* This text is NEW. + Mark it so.) + (replace (PIECE PNEW) of PC with T))) + [COND + ((NOT (ZEROP (\BIN FILE))) (* There is style or user + information to be read) + (SETQ STYLESTR (\STRINGIN FILE)) + (SETQ USERSTR (\STRINGIN FILE)) + (COND + ((NOT (ZEROP (NCHARS STYLESTR))) (* There IS style info) + (replace (CHARLOOKS CLSTYLE) of LOOKS with (READ STYLESTR))) + (T (replace (CHARLOOKS CLSTYLE) of LOOKS with 0))) + (COND + ((NOT (ZEROP (NCHARS USERSTR))) (* There IS user info) + (replace (CHARLOOKS CLUSERINFO) of LOOKS with (READ USERSTR] + (SETQ PROPS (\SMALLPIN FILE)) + (with CHARLOOKS LOOKS [SETQ CLBOLD (NOT (ZEROP (LOGAND 512 PROPS] + [SETQ CLITAL (NOT (ZEROP (LOGAND 256 PROPS] + [SETQ CLULINE (NOT (ZEROP (LOGAND 128 PROPS] + [SETQ CLOLINE (NOT (ZEROP (LOGAND 64 PROPS] + [SETQ CLSTRIKE (NOT (ZEROP (LOGAND 32 PROPS] + [SETQ CLSMALLCAP (NOT (ZEROP (LOGAND 16 PROPS] + [SETQ CLPROTECTED (NOT (ZEROP (LOGAND 8 PROPS] + [SETQ CLINVISIBLE (NOT (ZEROP (LOGAND 4 PROPS] + [SETQ CLSELHERE (NOT (ZEROP (LOGAND 2 PROPS] + [SETQ CLCANCOPY (NOT (ZEROP (LOGAND 1 PROPS] + (SETQ CLSIZE SIZE) + (SETQ CLOFFSET SUPER)) + (replace (CHARLOOKS CLFONT) of LOOKS + with (AND NAME (NOT (ZEROP SIZE)) + (FONTCREATE NAME SIZE (COND + ((AND (fetch (CHARLOOKS CLBOLD) of LOOKS) + (fetch (CHARLOOKS CLITAL) of LOOKS) + ) + 'BOLDITALIC) + ((fetch (CHARLOOKS CLBOLD) of LOOKS) + 'BOLD) + ((fetch (CHARLOOKS CLITAL) of LOOKS) + 'ITALIC]) (TEDIT.GET.OBJECT0 + [LAMBDA (STREAM PIECE FILE CURCH#) (* ; "Edited 12-Jun-90 18:17 by mitani") + (* Get an object from the file) + + (* CURCH# = fileptr within the text section of the file where the object's text + starts.) + + (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) + FILEPTRSAVE NAMELEN GETFN OBJ) + (SETQ GETFN (\ATMIN FILE)) (* The GETFN for this kind of + IMAGEOBJ) + (SETQ FILEPTRSAVE (GETFILEPTR FILE)) (* Save our file location thru the + building of the object) + (SETFILEPTR FILE CURCH#) + (SETQ OBJ (READIMAGEOBJ FILE GETFN)) + (SETFILEPTR FILE FILEPTRSAVE) + (replace (PIECE POBJ) of PIECE with OBJ) + (replace (PIECE PFILE) of PIECE with NIL) + (replace (PIECE PSTR) of PIECE with NIL) + [replace (PIECE PLOOKS) of PIECE with (COND + ((fetch (PIECE PREVPIECE) + of PIECE) + (fetch (PIECE PLOOKS) + of (fetch (PIECE PREVPIECE + ) + of PIECE))) + (T (OR (fetch (TEXTOBJ + DEFAULTCHARLOOKS + ) + of TEXTOBJ) + (\TEDIT.UNIQUIFY.CHARLOOKS + (CHARLOOKS.FROM.FONT + DEFAULTFONT) + TEXTOBJ] + (RETURN (fetch (PIECE POBJ) of PIECE]) (TEDIT.GET.PARALOOKS0 + [LAMBDA (PC FILE) (* ; "Edited 30-May-91 20:34 by jds") + (* Put a description of LOOKS into + FILE. LOOKS apply to characters CH1 + thru CHLIM-1) + (PROG ((LOOKS (create FMTSPEC)) + TABFLG DEFAULTTAB TABCOUNT TABS TABSPEC) + (replace (PIECE PPARALOOKS) of PC with LOOKS) + (replace (FMTSPEC 1STLEFTMAR) of LOOKS with (\SMALLPIN FILE)) + (* Left margin for the first line of + the paragraph) + (replace (FMTSPEC LEFTMAR) of LOOKS with (\SMALLPIN FILE)) + (* Left margin for the rest of the + paragraph) + (replace (FMTSPEC RIGHTMAR) of LOOKS with (\SMALLPIN FILE)) + (* Right margin for the paragraph) + (replace (FMTSPEC LEADBEFORE) of LOOKS with (\SMALLPIN FILE)) + (* Leading before the paragraph) + (replace (FMTSPEC LEADAFTER) of LOOKS with (\SMALLPIN FILE)) + (* Lead after the paragraph) + (replace (FMTSPEC LINELEAD) of LOOKS with (\SMALLPIN FILE)) + (* inter-line leading) + (replace (FMTSPEC TABSPEC) of LOOKS with (SETQ TABSPEC (CONS NIL NIL))) + (* Will be tab specs) + (SETQ TABFLG (\BIN FILE)) + (replace (FMTSPEC QUAD) of LOOKS with (SELECTC (\BIN FILE) + (1 'LEFT) + (2 'RIGHT) + (3 'CENTERED) + (4 'JUSTIFIED) + (SHOULDNT))) + (COND + ((NOT (ZEROP TABFLG)) (* There are tabs to read) + (SETQ DEFAULTTAB (\SMALLPIN FILE)) + (SETQ TABCOUNT (\BIN FILE)) + [SETQ TABS (for TAB# from 1 to TABCOUNT + collect (create TAB + TABX _ (\SMALLPIN FILE) + TABKIND _ (SELECTQ (\BIN FILE) + (0 'LEFT) + (1 'RIGHT) + (2 'CENTERED) + (3 'DECIMAL) + (SHOULDNT] + (OR (ZEROP DEFAULTTAB) + (RPLACA TABSPEC DEFAULTTAB)) + (RPLACD TABSPEC TABS]) ) (PUTPROPS TEDITFILE COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1999 2000 2001)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3099 57926 (TEDIT.BUILD.PCTB 3109 . 37483) (\TEDIT.CONVERT.FOREIGN.FORMAT 37485 . 38926 ) (TEDIT.FORMATTEDFILEP 38928 . 42792) (TEDIT.GET 42794 . 51610) (TEDIT.PARSE.PAGEFRAMES1 51612 . 53318) (\ARBIN 53320 . 53941) (\ATMIN 53943 . 54272) (\DWIN 54274 . 54552) (\STRINGIN 54554 . 55151) ( \TEDIT.FORMATTEDP1 55153 . 57417) (\TEDIT.SET.WINDOW 57419 . 57924)) (57962 78490 (TEDIT.INCLUDE 57972 . 69359) (TEDIT.RAW.INCLUDE 69361 . 78488)) (78524 122097 (TEDIT.PUT 78534 . 88907) (TEDIT.PUT.PCTB 88909 . 115833) (\TEDIT.PUTRESET 115835 . 116081) (TEDIT.PUT.PIECE.DESCRIPTOR 116083 . 118546) ( \ARBOUT 118548 . 119748) (\ATMOUT 119750 . 120265) (\DWOUT 120267 . 120550) (\STRINGOUT 120552 . 121004) (\TEDIT-OPEN-FONT-FILE 121006 . 122095)) (122098 132610 (\TEDIT.GET.CHARLOOKS.LIST 122108 . 122513) (\TEDIT.GET.SINGLE.CHARLOOKS 122515 . 125560) (\TEDIT.PUT.CHARLOOKS.LIST 125562 . 127357) ( \TEDIT.PUT.SINGLE.CHARLOOKS 127359 . 132608)) (132611 146890 (\TEDIT.GET.PARALOOKS.LIST 132621 . 133034) (\TEDIT.GET.SINGLE.PARALOOKS 133036 . 139430) (\TEDIT.PUT.PARALOOKS.LIST 139432 . 140426) ( \TEDIT.PUT.SINGLE.PARALOOKS 140428 . 146888)) (147198 208459 (TEDIT.BUILD.PCTB2 147208 . 160564) ( \TEDIT.GET.CHARLOOKS.LIST2 160566 . 160973) (\TEDIT.GET.SINGLE.CHARLOOKS2 160975 . 163887) ( \TEDIT.PUT.SINGLE.PARALOOKS2 163889 . 168603) (\TEDIT.PUT.SINGLE.CHARLOOKS2 168605 . 173101) ( \TEDIT.GET.PARALOOKS.LIST2 173103 . 173510) (\TEDIT.GET.SINGLE.PARALOOKS2 173512 . 178100) ( TEDIT.PUT.PCTB2 178102 . 205763) (\TEDIT.PUT.CHARLOOKS.LIST2 205765 . 207562) ( \TEDIT.PUT.PARALOOKS.LIST2 207564 . 208457)) (208536 229660 (TEDIT.BUILD.PCTB1 208546 . 218736) ( TEDIT.GET.PAGEFRAMES1 218738 . 218993) (\TEDIT.GET.CHARLOOKS1 218995 . 222545) (\TEDIT.GET.PARALOOKS1 222547 . 227128) (TEDIT.GET.OBJECT1 227130 . 229658)) (229720 245426 (TEDIT.BUILD.PCTB0 229730 . 235437) (TEDIT.GET.CHARLOOKS0 235439 . 239458) (TEDIT.GET.OBJECT0 239460 . 241988) ( TEDIT.GET.PARALOOKS0 241990 . 245424))))) STOP \ No newline at end of file diff --git a/library/TEDITFIND b/library/TEDITFIND new file mode 100644 index 00000000..e69d9fdf --- /dev/null +++ b/library/TEDITFIND @@ -0,0 +1,493 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 6-May-2018 17:34:44"  {DSK}kaplan>Local>medley3.5>lispcore>library>TEDITFIND.;2 40100 changes to%: (FNS TEDIT.FIND) previous date%: "25-Aug-94 10:53:52" {DSK}kaplan>Local>medley3.5>lispcore>library>TEDITFIND.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1994, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDITFINDCOMS) (RPAQQ TEDITFINDCOMS ((FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) [DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (TEDIT.SEARCH.CODETABLE (\TEDIT.SEARCH.CODETABLE] (COMS (* Read-table Utilities) (FNS \TEDIT.SEARCH.CODETABLE) (GLOBALVARS TEDIT.SEARCH.CODETABLE)) (FNS \TEDIT.BASICFIND TEDIT.FIND TEDIT.NEW.FIND TEDIT.NEXT \TEDIT.FIND.WC \TEDIT.FIND.WC1 \TEDIT.PACK.TARGETLIST \TEDIT.PARSE.SEARCHSTRING \TEDIT.SUBST.FN1 \TEDIT.SUBST.FN2 TEDIT.SUBSTITUTE))) (FILESLOAD TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SCRATCHLEN 64) (CONSTANTS (\SCRATCHLEN 64)) ) (FILESLOAD (LOADCOMP) TEDITDCL) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ TEDIT.SEARCH.CODETABLE (\TEDIT.SEARCH.CODETABLE)) ) (* Read-table Utilities) (DEFINEQ (\TEDIT.SEARCH.CODETABLE + (LAMBDA NIL (* jds "23-OCT-83 00:58") + (* Build the 16-bit-item "syntax class" + table for searching) + (PROG ((CODETBL (ARRAY 256 'SMALLP 0 0))) + (for I from 0 to 255 do (SETA CODETBL I I)) + + (* Default is that a char maps to itself, and is punctuation.) + + (for CH + in (CHARCODE (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 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)) + do (SETA CODETBL CH (IPLUS \AlphaNumericFlag \AlphaFlag CH))) + (for CH in (CHARCODE (0 1 2 3 4 5 6 7 8 9)) do (SETA CODETBL CH (IPLUS \AlphaNumericFlag CH + ))) + (for CH in (CHARCODE (%# * @ ! & ~ { })) as CODE + in (LIST \OneCharPattern \AnyStringPattern \OneAlphaPattern \OneNonAlphaPattern + \AnyAlphaPattern \AnyNonAlphaPattern \LeftBracketPattern \RightBracketPattern) + do (SETA CODETBL CH CODE)) + (RETURN CODETBL)))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.SEARCH.CODETABLE) ) (DEFINEQ (\TEDIT.BASICFIND + [LAMBDA (TEXTOBJ STRING CH# CHLIM) (* ; "Edited 30-May-91 20:56 by jds") + + (* ;; "Search thru TEXTOBJ, starting where the caret is, for the string STRING, exact match only for now. (Optionally, start the search at character ch#.)") + + (PROG ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + [TEXTLIM (OR CHLIM (ADD1 (IDIFFERENCE (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) + (NCHARS STRING] + (TEXTSTREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) + (FOUND NIL) + (CH#1 (NTHCHARCODE STRING 1)) + CH1 ANCHOR PCH# OANCHOR CH) + (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) + (* ; + "2/12/85 JDS: I don't understand WHY this is here, but I'll assume it's right for now.") + (* ; + "Prohibit future insertions in the current piece.") + (COND + ((OR CH# (fetch (SELECTION SET) of SEL))(* ; + "There must be a well-defined starting point.") + (RETURN (PROG NIL + (SETQ CH1 (OR CH# (SELECTQ (fetch (SELECTION POINT) of SEL) + (LEFT (fetch (SELECTION CH#) of SEL)) + (RIGHT (fetch (SELECTION CHLIM) of SEL)) + NIL))) (* ; + "Find the starting point for the search") + (* ; "DO THE SEARCH") + (COND + ((IGREATERP CH1 TEXTLIM) (* ; + "Starting the search past the last possible starting point. Just punt.") + (RETURN NIL))) + (SETQ ANCHOR (SUB1 CH1)) + RETRY + (\SETUPGETCH (ADD1 ANCHOR) + TEXTOBJ) + [for old ANCHOR from (ADD1 ANCHOR) to TEXTLIM + do (SETQ CH (\BIN TEXTSTREAM)) + (COND + ((EQ CH CH#1) + (RETURN] + (COND + ((IGREATERP ANCHOR TEXTLIM) + (RETURN NIL))) (* ; + "No starting character found before end of string") + (SETQ OANCHOR ANCHOR) + (SETQ FOUND T) + [for old CH1 from (ADD1 ANCHOR) to TEXTLIM as PCH# + from 2 to (NCHARS STRING) + do (SETQ CH (\BIN TEXTSTREAM)) + (COND + ((NEQ CH (NTHCHARCODE STRING PCH#)) + (SETQ FOUND NIL) + (RETURN] + (COND + (FOUND (RETURN ANCHOR)) + (T (GO RETRY]) (TEDIT.FIND [LAMBDA (TEXTOBJ TARGETSTRING START# END# WILDCARDS?) (* ; "Edited 6-May-2018 17:34 by rmk:") (* ; "Edited 30-May-91 20:56 by jds") (* ;; "If WILDCARDS? is NIL then TEDIT.FIND is the old TEDIT.FIND. Else, it returns a list of (SEL.START# SEL.END#) which is the start and end char positions of the selection") (LET* [(TEXTOBJ (TEXTOBJ TEXTOBJ)) (TEDIT.WILDCARD.CHARACTERS '("#" "*")) (REAL-END# (OR END# (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ] (AND TARGETSTRING (NOT (STRINGP TARGETSTRING)) (SETQ TARGETSTRING (MKSTRING TARGETSTRING))) (* ;; "RMK: FIND isn't undoable, FIND-AGAIN is armed on meta-g. No point in hiding a previous actual edit by adding the find event (given that the history is not a list, just a single event (TEDITHISTORY)") (AND NIL (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT THACTION _ 'Find THAUXINFO _ TARGETSTRING))) (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (* ;  "Any FIND invalidates the type-in cache.") (COND [WILDCARDS? (* ;  "will return a list of start and end of selection or nil if not found") (PROG (TARGETLIST SEL RESULT RESULT1) (RETURN (COND ((OR START# (AND (fetch (SELECTION SET) of (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))) (LEQ (SETQ START# (SELECTQ (fetch (SELECTION POINT) of SEL) (LEFT (fetch (SELECTION CH#) of SEL)) (RIGHT (fetch (SELECTION CHLIM) of SEL)) NIL)) REAL-END#))) (* ; "START# better be >= to END#") (COND ((AND (for X in [SETQ TARGETLIST (\TEDIT.PARSE.SEARCHSTRING (for X in (CHCON TARGETSTRING) collect (MKSTRING (CHARACTER X] collect X when (LITATOM X)) (SETQ RESULT1 (\TEDIT.SUBST.FN1 TEXTOBJ TARGETLIST START# REAL-END#))) (* ;  "If there are atoms, they are tedit wildcard chars") (\TEDIT.FIND.WC TEXTOBJ TARGETLIST RESULT1 REAL-END#)) (T (* ; "no wildcards but bounded search") (COND ((SETQ RESULT (TEDIT.FIND TEXTOBJ (CAR TARGETLIST) START# REAL-END# NIL)) (LIST RESULT (SUB1 (IPLUS RESULT (NCHARS (CAR TARGETLIST] (T (* ;  "will return just the number of the start char or nil if not found") (LET ((RESULT (\TEDIT.BASICFIND TEXTOBJ TARGETSTRING START# REAL-END#))) (COND ((NULL REAL-END#) RESULT) ((OR (NULL RESULT) (GREATERP (IPLUS RESULT (SUB1 (NCHARS TARGETSTRING))) REAL-END#)) NIL) (T RESULT]) (TEDIT.NEW.FIND + [LAMBDA (TEXTOBJ TARGETSTRING START# END# WILDCARDS?) (* ; "Edited 23-Feb-88 11:13 by jds") + + (* ;; "If WILDCARDS? is NIL then TEDIT.NEW.FIND is the old TEDIT.FIND. Else, it returns a list of (SEL.START# SEL.END#) which is the start and end char positions of the selection") + + (* ;; "(PROG ((TEXTSTREAM (fetch STREAMHINT of TEXTOBJ)) PATTERN FIRSTPAT PATTERNSTACK POSNSTACK FIRSTCHAR1 FIRSTCHAR2 FIRSTPATNORMAL PATTERNLEN FOUND PATTERNPOS TEXTPOS) (AND TARGETSTRING (NOT (STRINGP TARGETSTRING)) (SETQ TARGETSTRING (MKSTRING TARGETSTRING))) (SETQ PATTERN (\TEDIT.NEW.PARSE.SEARCHSTRING TARGETSTRING)) (OR PATTERN (RETURN)) (SETQ PATTERNLEN (FLENGTH PATTERN)) (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT THACTION _ (QUOTE Find) THAUXINFO _ TARGETSTRING)) (COND ((ZEROP (LOGAND \SpecialPattern (SETQ FIRSTPAT (CAR PATTERN)))) (* The pattern starts with an easy first character) (SETQ FIRSTPATNORMAL T) (SETQ FIRSTCHAR1 (LOGAND \CHARMASK FIRSTPAT)) (COND ((ZEROP (LOGAND \AlphaFlag FIRSTPAT)) (* Not alphabetic) (SETQ FIRSTCHAR2 FIRSTCHAR1)) (T (* Is alphabetic) (SETQ FIRSTCHAR2 (LOGAND FIRSTCHAR1 223)))))) (bind (CH# _ START#) while (ILEQ CH# END#) first (\SETUPGETCH START# TEXTOBJ) do (COND (FIRSTPATNORMAL (* The pattern starts with an easy first character) (COND ((AND (NEQ (SETQ CH (\BIN TEXTSTREAM)) FIRSTCHAR1) (NEW CH FIRSTCHAR2)) (GO $$ITERATE))) (SETQ PATTERNPOS 1) (SETQ CH (\BIN TEXTSTREAM))) (T (SETQ PATTERNPOS 0))) (SETQ TEXTPOS (\TEXTMARK TEXTOBJ)) (COND ((IGEQ PATTERNPOS PATTERNLEN) (SETQ FOUND T) (RETURN)))))") + + (HELP]) (TEDIT.NEXT + [LAMBDA (STREAM) (* ; "Edited 30-May-91 20:57 by jds") + (PROG ((TEXTOBJ (TEXTOBJ STREAM)) + TARGET SEL OPTION FIELDSEL) + (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (SETQ TARGET (TEDIT.FIND TEXTOBJ ">>*<<" NIL NIL T)) + (* find the first >>delimited<< + field) + (SETQ FIELDSEL (MBUTTON.FIND.NEXT.FIELD TEXTOBJ (fetch (SELECTION CH#) of SEL))) + (* find the first menu-type + insertion field, usually delimited + with {}) + [SETQ OPTION (COND + [(AND TARGET FIELDSEL) (* take the first one) + (COND + ((IGREATERP (CAR TARGET) + (fetch (SELECTION CH#) of FIELDSEL)) + (* use the {} selection) + 'FIELD) + (T 'TARGET] + (TARGET 'TARGET) + (FIELDSEL 'FIELD) + (T 'NEITHER] + (SELECTQ OPTION + (TARGET (* Found another fill-in) + (\SHOWSEL SEL NIL NIL) + (replace (SELECTION CH#) of SEL with (CAR TARGET)) + (* Set up SELECTION to be the found + text) + (replace (SELECTION CHLIM) of SEL with (ADD1 (CADR TARGET))) + (replace (SELECTION DCH) of SEL with (IDIFFERENCE + (ADD1 (CADR TARGET)) + (CAR TARGET))) + (replace (SELECTION POINT) of SEL with 'RIGHT) + (\TEDIT.SET.SEL.LOOKS SEL 'PENDINGDEL) (* Always selected normally) + (replace (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ with T) + (* And never pending a deletion.) + (\FIXSEL SEL TEXTOBJ) + (TEDIT.NORMALIZECARET TEXTOBJ) + (\SHOWSEL SEL NIL T) (* And get it into the window) + ) + (FIELD (* Replace the selection for this + textobj with the scratch sel + returned from + MBUTTON.FIND.NEXT.FIELD) + (\SHOWSEL SEL NIL NIL) + (replace (SELECTION CH#) of SEL with (fetch (SELECTION CH#) + of FIELDSEL)) + (* Set up SELECTION to be the found + text) + (replace (SELECTION CHLIM) of SEL with (fetch (SELECTION CHLIM) + of FIELDSEL)) + (replace (SELECTION DCH) of SEL with (fetch (SELECTION DCH) + of FIELDSEL)) + (replace (SELECTION POINT) of SEL with 'LEFT) + (\TEDIT.SET.SEL.LOOKS SEL 'PENDINGDEL) + (replace (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ with T) + (\FIXSEL SEL TEXTOBJ) + (TEDIT.NORMALIZECARET TEXTOBJ) + (\SHOWSEL SEL NIL T) (* And get it into the window) + ) + (NEITHER (TEDIT.PROMPTPRINT TEXTOBJ "No more blanks to fill in." T) + (SETQ SEL NIL)) + (SHOULDNT "No legal value found in selectq in TEDIT.NEXT")) + (COND + (SEL + + (* There really IS a selection made here, so set up the charlooks for it + properly.) + + (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with ( + \TEDIT.GET.INSERT.CHARLOOKS + TEXTOBJ SEL]) (\TEDIT.FIND.WC + [LAMBDA (TEXTOBJ TARGETLIST START# END#) (* ; "Edited 9-Dec-88 09:56 by jds") + (* ; + "\TEDIT.FIND.WC returns the end char # of the TARGETLIST which may contain wildcards") + (PROG (RESULT RESULT1) + (RETURN (COND + ((SETQ RESULT (\TEDIT.FIND.WC1 TEXTOBJ TARGETLIST START# END#)) + + (* ;; "SUB1 because NEWFIND.WC2 takes that arg as the Lastchar of the selection so far and so will start on the next char after this") + (* ; "DONE!") + (LIST START# (IMAX START# RESULT))) + (T (AND (SETQ RESULT1 (\TEDIT.SUBST.FN1 TEXTOBJ TARGETLIST (ADD1 START#) + END#)) + (\TEDIT.FIND.WC TEXTOBJ TARGETLIST RESULT1 END#]) (\TEDIT.FIND.WC1 + [LAMBDA (TEXTOBJ TARGETLIST TRIALEND# END#) (* ; "Edited 9-Dec-88 09:52 by jds") + (* ; + "TRIALEND# is where the next char string should go") + (* ; + "\TEDIT.FIND.WC1 should return the lastchar# of selection") + (PROG (RESULT RESULT1) + (RETURN (COND + ((NULL TARGETLIST) (* ; "DONE!") + (SUB1 TRIALEND#)) + [(STRINGP (CAR TARGETLIST)) + (COND + ((SETQ RESULT (TEDIT.FIND TEXTOBJ (CAR TARGETLIST) + TRIALEND# END# NIL)) + (* ; "NOT null") + (\TEDIT.FIND.WC1 TEXTOBJ (CDR TARGETLIST) + (IPLUS RESULT (NCHARS (CAR TARGETLIST))) + END#] + ((LITATOM (CAR TARGETLIST)) + (COND + [(MEMBER (CAR TARGETLIST) + '(%#)) (* ; "fixed width wildcard") + (COND + ((OR (NULL (CDR TARGETLIST)) + (EQUAL (CAR (TEDIT.FIND TEXTOBJ (CONCATLIST ( + \TEDIT.PACK.TARGETLIST + (CDR TARGETLIST))) + (ADD1 TRIALEND#) + END# T)) + (ADD1 TRIALEND#))) (* ; + "If the next start after a fixed char is the char after it, OK. else return nil") + (\TEDIT.FIND.WC1 TEXTOBJ (CDR TARGETLIST) + (ADD1 TRIALEND#) + END#] + (T (* ; "variable width wildcard") + (COND + ((CDR TARGETLIST) + (SETQ RESULT1 (TEDIT.FIND TEXTOBJ (CONCATLIST ( + \TEDIT.PACK.TARGETLIST + (CDR TARGETLIST))) + TRIALEND# END# T)) + (AND RESULT1 (CADR RESULT1))) + (T (* ; "last element of search") + (SUB1 TRIALEND#]) (\TEDIT.PACK.TARGETLIST + [LAMBDA (TARGETLIST) (* ; "Edited 24-Sep-87 09:54 by jds") + + (COND + ((NULL TARGETLIST) + NIL) + [(MEMBER (CAR TARGETLIST) + '("#" "*")) + (CONS (CONCAT (CAR TARGETLIST) + (CAR TARGETLIST)) + (\TEDIT.PACK.TARGETLIST (CDR TARGETLIST] + [(STRINGP (CAR TARGETLIST)) + (CONS (CAR TARGETLIST) + (\TEDIT.PACK.TARGETLIST (CDR TARGETLIST] + (T (* ; "wildcard") + + (CONS (MKSTRING (CAR TARGETLIST)) + (\TEDIT.PACK.TARGETLIST (CDR TARGETLIST]) (\TEDIT.PARSE.SEARCHSTRING + (LAMBDA (LST RESULT) (* jds "31-Jan-84 13:26") + (PROG ((TEDIT.WILDCARD.CHARACTERS '("#" "*"))) + (RETURN (COND + ((NULL LST) + (COND + (RESULT (LIST RESULT)))) + ((MEMBER (CAR LST) + TEDIT.WILDCARD.CHARACTERS) + (COND + ((NULL RESULT) + (CONS (MKATOM (CAR LST)) + (\TEDIT.PARSE.SEARCHSTRING (CDR LST)))) + (T (APPEND (LIST RESULT (MKATOM (CAR LST))) + (\TEDIT.PARSE.SEARCHSTRING (CDR LST)))))) + ((AND (EQUAL (CAR LST) + "'") + (LISTP (CDR LST)) + (MEMBER (CADR LST) + TEDIT.WILDCARD.CHARACTERS))(* quoting something a wildcard char) + (\TEDIT.PARSE.SEARCHSTRING (CDDR LST) + (COND + ((NULL RESULT) + (MKSTRING (CADR LST))) + (T (CONCAT RESULT (MKSTRING (CADR LST))))))) + (T (\TEDIT.PARSE.SEARCHSTRING (CDR LST) + (COND + ((NULL RESULT) + (CAR LST)) + (T (CONCAT RESULT (CAR LST))))))))))) (\TEDIT.SUBST.FN1 + [LAMBDA (TEXTOBJ TARGETLIST START# END#) (* ; "Edited 3-Sep-87 11:38 by jds") + (* ; + "returns the char location that would match the beginning element of a targetlist") + + (PROG (RESULT) + (SETQ RESULT (\TEDIT.SUBST.FN2 TEXTOBJ TARGETLIST START# END#)) + (RETURN (AND RESULT (IGEQ RESULT START#) + RESULT]) (\TEDIT.SUBST.FN2 + [LAMBDA (TEXTOBJ TARGETLIST TRIALSTART# END#) (* ; "Edited 9-Dec-88 09:54 by jds") + + (* ;; + "will return the start char of a wildcarded selection. returns NIL if selection is beyond bounds") + + (* ;; "TARGETLIST is (what)?") + + (LET (SUB-FIND-RESULT) + (COND + ((NULL TARGETLIST) + TRIALSTART#) + ((IGREATERP TRIALSTART# END#) + NIL) + [(LITATOM (CAR TARGETLIST)) + (COND + ((EQ (CAR TARGETLIST) + '%#) (* ; "fixed width wildcard") + (AND (SETQ SUB-FIND-RESULT (\TEDIT.SUBST.FN1 TEXTOBJ (CDR TARGETLIST) + (ADD1 TRIALSTART#) + END#)) + (SUB1 SUB-FIND-RESULT))) + (T (* ; + "variable width wildcard, so forget them") + (\TEDIT.SUBST.FN2 TEXTOBJ (CDR TARGETLIST) + TRIALSTART# END#] + (T (* ; "it's a string") + (TEDIT.FIND TEXTOBJ (CAR TARGETLIST) + TRIALSTART# END# NIL]) (TEDIT.SUBSTITUTE + [LAMBDA (TEXTSTREAM PATTERN REPLACEMENT CONFIRM?) (* ; "Edited 30-Mar-94 16:04 by jds") + + (* ;; "Replace all instances of PATTERN with REPLACEMENT. If CONFIRM? is non-NIL, ask before each replacement.") + + (PROG ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) + (REPLACEDFLG 0) + (YESLIST '("Y" "y" "yes" "YES" "T" "Yes")) + SEARCHSTRING REPLACESTRING ABORTFLG OUTOFRANGEFLG BEGINCHAR# ENDCHAR# STARTCHAR# RANGE + CONFIRMFLG SEL PC# SELCH# SELCHLIM SELPOINT CRSEEN REPLACE-LEN) + (COND + ([NULL (SETQ SEARCHSTRING (OR PATTERN (TEDIT.GETINPUT TEXTOBJ "Search string:" + (TEXTPROP TEXTOBJ + 'TEDIT.LAST.SUBSTITUTE.STRING) + (CHARCODE (EOL LF ESC] + (* ; + "If the search pattern is empty, bail out.") + (TEDIT.PROMPTPRINT TEXTOBJ "[Aborted]") + (RETURN))) + [SETQ REPLACESTRING (OR REPLACEMENT (TEDIT.GETINPUT TEXTOBJ "Replace string:" + (TEXTPROP TEXTOBJ + 'TEDIT.LAST.REPLACEMENT.STRING) + (CHARCODE (EOL LF ESC] + [COND + ((STRINGP REPLACESTRING) + (SETQ REPLACE-LEN (NCHARS REPLACESTRING))) + ((LISTP REPLACESTRING) (* ; + "It's a list of pieces, meaning insert these pieces as the replacement.") + (SETQ REPLACE-LEN (for PC in REPLACESTRING sum (fetch (PIECE PLEN) + of PC] + (SETQ CRSEEN (AND REPLACESTRING (STRINGP REPLACESTRING) + (STRPOS (CHARACTER (CHARCODE CR)) + 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 (MEMBER (TEDIT.GETINPUT TEXTOBJ "Ask before each replace?" "No" + (CHARCODE (EOL SPACE ESCAPE LF TAB))) + YESLIST] + (TEDIT.PROMPTPRINT TEXTOBJ "Substituting..." T) + (SETQ SEL (fetch (TEXTOBJ 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 BEGINCHAR# (SETQ STARTCHAR# (fetch (SELECTION CH#) of SEL))) + [SETQ ENDCHAR# (IPLUS STARTCHAR# (SUB1 (fetch (SELECTION DCH) of SEL] + (while (AND (SETQ RANGE (TEDIT.FIND TEXTOBJ SEARCHSTRING STARTCHAR# ENDCHAR# T)) + (NOT ABORTFLG)) + do [PROG (PENDING.SEL CHOICE) + (COND + [CONFIRMFLG (SETQ PENDING.SEL (TEDIT.SETSEL TEXTSTREAM (CAR RANGE) + (IDIFFERENCE (CADR RANGE) + (SUB1 (CAR RANGE))) + 'RIGHT T)) + (\SHOWSEL PENDING.SEL NIL NIL) + (TEDIT.NORMALIZECARET TEXTOBJ PENDING.SEL) + (\SHOWSEL PENDING.SEL NIL T) + [SETQ CHOICE (TEDIT.GETINPUT TEXTOBJ "OK to replace? ['q' quits]" + "Yes" (CHARCODE (EOL SPACE ESCAPE LF TAB] + (COND + ((MEMBER CHOICE '("Q" "q")) + (SETQ ABORTFLG T) + (GO L1)) + ((NOT (MEMBER CHOICE YESLIST)) + (* ; "turn off selection") + (TEDIT.SHOWSEL TEXTSTREAM NIL PENDING.SEL) + (GO L1)) + (T (* ; "OK to replace") + (TEDIT.DELETE TEXTSTREAM PENDING.SEL) + (* ; "make the replacement") + +(* ;;;; "This is just wrong in this clause: (COND ((AND REPLACESTRING (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)))") + + [AND REPLACESTRING + (OR (IEQP REPLACE-LEN 0) + (COND + ((LISTP REPLACESTRING) + (* ; "INSERT A RUN OF PIECES") + (\TEDIT.INSERT.PIECES + TEXTOBJ + (CAR RANGE) + (for PC in REPLACESTRING + collect (\TEDIT.COPY.PIECEMAPFN PC + TEXTOBJ TEXTOBJ TEXTOBJ + )) + REPLACE-LEN NIL NIL T NIL T) + (add (fetch (TEXTOBJ TEXTLEN) + of TEXTOBJ) + REPLACE-LEN)) + (T (TEDIT.INSERT TEXTSTREAM REPLACESTRING + (CAR RANGE] + [SETQ ENDCHAR# (IPLUS ENDCHAR# + (IDIFFERENCE + (OR (AND REPLACESTRING REPLACE-LEN) + 0) + (IDIFFERENCE (CADR RANGE) + (SUB1 (CAR RANGE] + (add REPLACEDFLG 1] + (T (* ; + "No confirmation required. Do the substitutions without showing intermediate work") + [replace (TEXTOBJ CARETLOOKS) of TEXTOBJ + with (fetch (PIECE PLOOKS) + of (\CHTOPC (CAR RANGE) + (fetch (TEXTOBJ PCTB) of TEXTOBJ + ] + (SETQ PC# (\DELETECH (CAR RANGE) + (ADD1 (CADR RANGE)) + (ADD1 (IDIFFERENCE (CADR RANGE) + (CAR RANGE))) + TEXTOBJ)) + (\FIXDLINES (fetch (TEXTOBJ LINES) of TEXTOBJ) + SEL + (CAR RANGE) + (ADD1 (CADR RANGE)) + TEXTOBJ) + [SETQ ENDCHAR# (IDIFFERENCE ENDCHAR# (IDIFFERENCE (CADR RANGE) + (SUB1 (CAR RANGE] + (* ; + "Take the length of what we're removing off the end-location, so we don't search too far.") + (COND + ((AND REPLACESTRING (NOT (EQUAL REPLACESTRING ""))) + (* ; + "If the replacestring is nothing, why bother to add nothing") + (\FIXILINES TEXTOBJ SEL (CAR RANGE) + REPLACE-LEN + (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (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] + ((LISTP REPLACESTRING)(* ; "INSERT A RUN OF PIECES") + (\TEDIT.INSERT.PIECES TEXTOBJ (CAR RANGE) + (for PC in REPLACESTRING + collect (\TEDIT.COPY.PIECEMAPFN PC TEXTOBJ + TEXTOBJ TEXTOBJ)) + REPLACE-LEN NIL NIL T NIL T) + (add (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) + REPLACE-LEN)) + (T (\INSERTCH REPLACESTRING (CAR RANGE) + TEXTOBJ))) + (SETQ ENDCHAR# (IPLUS ENDCHAR# REPLACE-LEN)) + (* ; + "Now add the length of the replacement string into the ending position, so we go far enough.") + )) + (add REPLACEDFLG 1))) + [SETQ STARTCHAR# (COND + (REPLACESTRING (IPLUS (CAR RANGE) + REPLACE-LEN)) + (T (CAR RANGE] + (RETURN) + L1 + + (* ;; + "12/12/88 Should only look at REPLACESTRING when there has been a replacement.") + + (SETQ STARTCHAR# (ADD1 (CAR RANGE] (* ; + "start looking where you left off")) + + (* ;; "Save the search & replacement strings to offer for next time:") + + (TEXTPROP TEXTOBJ 'TEDIT.LAST.SUBSTITUTE.STRING SEARCHSTRING) + (TEXTPROP TEXTOBJ 'TEDIT.LAST.REPLACEMENT.STRING REPLACESTRING) + + (* ;; "Print the message that says how many substitutions got made:") + + (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))) + + (* ;; "Update the current selection:") + + (COND + ((AND (NOT CONFIRMFLG) + (NOT (ZEROP REPLACEDFLG))) (* ; + "There WERE replacements, and they were not confirmed.") + (replace (SELECTION CHLIM) of SEL with (ADD1 ENDCHAR#)) + (* ; + "account for the changes in selection length due to replacements") + (replace (SELECTION CH#) of SEL with BEGINCHAR#) + (* ; "And remember where it started") + (replace (SELECTION DCH) of SEL with (IDIFFERENCE (fetch (SELECTION + CHLIM) + of SEL) + (fetch (SELECTION CH#) + of SEL))) + (\TEDIT.MARK.LINES.DIRTY TEXTOBJ (fetch (SELECTION CH#) of SEL) + (fetch (SELECTION CHLIM) of SEL)) + (TEDIT.UPDATE.SCREEN TEXTOBJ) + (\FIXSEL SEL TEXTOBJ) + (\SHOWSEL SEL NIL T))) + (RETURN REPLACEDFLG]) ) (PUTPROPS TEDITFIND COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1994 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1472 2819 (\TEDIT.SEARCH.CODETABLE 1482 . 2817)) (2894 39960 (\TEDIT.BASICFIND 2904 . 6485) (TEDIT.FIND 6487 . 11084) (TEDIT.NEW.FIND 11086 . 12716) (TEDIT.NEXT 12718 . 17715) ( \TEDIT.FIND.WC 17717 . 18692) (\TEDIT.FIND.WC1 18694 . 21673) (\TEDIT.PACK.TARGETLIST 21675 . 22370) ( \TEDIT.PARSE.SEARCHSTRING 22372 . 23949) (\TEDIT.SUBST.FN1 23951 . 24438) (\TEDIT.SUBST.FN2 24440 . 25816) (TEDIT.SUBSTITUTE 25818 . 39958))))) STOP \ No newline at end of file diff --git a/library/TEDITFNKEYS b/library/TEDITFNKEYS new file mode 100644 index 00000000..c33ddbb5 --- /dev/null +++ b/library/TEDITFNKEYS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 6-May-2018 17:15:13"  {DSK}kaplan>Local>medley3.5>lispcore>library>TEDITFNKEYS.;10 30302 changes to%: (VARS TEDITFNKEYSCOMS) (FNS \TEDIT.FIND \TEDIT.FINDAGAIN) previous date%: " 6-May-2018 17:07:57" {DSK}kaplan>Local>medley3.5>lispcore>library>TEDITFNKEYS.;9) (* ; " Copyright (c) 1985, 1986, 1987, 1990, 1991, 1994, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDITFNKEYSCOMS) (RPAQQ TEDITFNKEYSCOMS ((FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (COMS (* ;; "Functions that actually implement the commands for the function keys:") (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.FINDAGAIN \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.SELECT.ALL)) (COMS (* ;; "Auxiliary functions used in the above main functions:") (FNS \TEDIT.BOLD.CARET.OFF \TEDIT.BOLD.CARET.ON \TEDIT.ITALIC.CARET.OFF \TEDIT.ITALIC.CARET.ON \TEDIT.LARGER.CARET \TEDIT.SMALLER.CARET \TEDIT.SUBSCRIPT.CARET \TEDIT.SUPERSCRIPT.CARET \TEDIT.UNDERLINE.CARET.OFF \TEDIT.UNDERLINE.CARET.ON \TEDIT.STRIKEOUT.CARET.OFF \TEDIT.STRIKEOUT.CARET.ON)) (COMS (* ;  "little selection utilities etc., for building hacks") (FNS \SEL.LIMIT \SEL.LINEDESC \TK.DESCRIBEFONT \PARAS.IN.SEL)) [VARS (TEDIT.FNKEY.VERBOSE T) (\TEDIT.KEYS '(("2,4" UNDO) ("2,44" UNDO) ("2,3" FN \TEDIT.FIND) ("2,43" FN \TEDIT.FIND) ("2,10" REDO) ("2,50" REDO) ("2,22" NEXT) ("2,62" NEXT) (ESC EXPAND) ("2,24" EXPAND) ("2,101" FN \TEDIT.CENTER.SEL) ("2,141" FN \TEDIT.CENTER.SEL.REV) ("2,102" FN \TEDIT.BOLD.SEL.ON) ("2,142" FN \TEDIT.BOLD.SEL.OFF) ("2,103" FN \TEDIT.ITALIC.SEL.ON) ("2,143" FN \TEDIT.ITALIC.SEL.OFF) ("2,104" FN \TEDIT.UCASE.SEL) ("2,144" FN \TEDIT.LCASE.SEL) ("2,105" FN \TEDIT.STRIKEOUT.SEL.ON) ("2,145" FN \TEDIT.STRIKEOUT.SEL.OFF) ("2,106" FN \TEDIT.UNDERLINE.SEL.ON) ("2,146" FN \TEDIT.UNDERLINE.SEL.OFF) ("2,107" FN \TEDIT.SUBSCRIPTSEL) ("2,147" FN \TEDIT.SUPERSCRIPTSEL) ("2,110" FN \TEDIT.SMALLERSEL) ("2,150" FN \TEDIT.LARGERSEL) ("2,113" FN \TEDIT.SUPERSCRIPTSEL) ("2,153" FN \TEDIT.SUBSCRIPTSEL) ("2,114" FN \TEDIT.SUBSCRIPTSEL) ("2,154" FN \TEDIT.SUPERSCRIPTSEL) ("2,115" FN \TEDIT.DEFAULTSSEL) ("2,155" FN \TEDIT.SETDEFAULT.FROM.SEL) ("2,1" FN \TEDIT.SHOWCARETLOOKS) ("1,U" UNDO) ("1,u" UNDO) ("1,z" UNDO) ("1,Z" UNDO) ("1,F" FN \TEDIT.FIND) ("1,f" FN \TEDIT.FIND) ("1,a" FN \TEDIT.SELECT.ALL) ("1,A" FN \TEDIT.SELECT.ALL) ("1,g" FN \TEDIT.FINDAGAIN] [P (MAPC \TEDIT.KEYS (FUNCTION (LAMBDA (ENTRY) (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY] (* ; "Original was %"(FOR ENTRY IN \TEDIT.KEYS DO (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY))))%".") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") )) (FILESLOAD TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SCRATCHLEN 64) (CONSTANTS (\SCRATCHLEN 64)) ) (FILESLOAD (LOADCOMP) TEDITDCL) ) (* ;; "Functions that actually implement the commands for the function keys:") (DEFINEQ (\TEDIT.BOLD.SEL.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE) (* ; "Edited 6-Nov-87 11:00 by jds") (* ;; "Turn boldness off for the selected characters, and for future type-in.") (\TEDIT.BOLD.CARET.OFF TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT MEDIUM) SEL]) (\TEDIT.BOLD.SEL.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 6-Nov-87 11:00 by jds") (* ;; "Turn boldness on for selected characters and for future type-in.") (\TEDIT.BOLD.CARET.ON TEXTSTREAM TEXTOBJ SEL) (TEDIT.LOOKS TEXTSTREAM '(WEIGHT BOLD) SEL]) (\TEDIT.CENTER.SEL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 30-May-91 21:05 by jds") (* ;; "makes the current paragraph centered") (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS PARASEL (SAVECH# (fetch (SELECTION CH#) of SEL)) (SAVEDCH (fetch (SELECTION 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 30-May-91 21:05 by jds") (* ;; "acts like center.sel but cycles in the opposite direction") (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS PARASEL (SAVECH# (fetch (SELECTION CH#) of SEL)) (SAVEDCH (fetch (SELECTION 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 AGAIN) (* ; "Edited 6-May-2018 17:14 by rmk:") (* ; "Edited 30-May-91 21:05 by jds") (* 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 (MKLIST (fetch (TEXTOBJ \WINDOW) of TEXTOBJ] (CL:WHEN AGAIN (SETQ TARGET (WINDOWPROP W 'TEDIT.LAST.FIND.STRING))) (CL:UNLESS TARGET [SETQ TARGET (TEDIT.GETINPUT TEXTOBJ "Text to find: " (WINDOWPROP W 'TEDIT.LAST.FIND.STRING) (CHARCODE (EOL LF ESC]) [COND (TARGET (SETQ SEL (fetch (TEXTOBJ 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 (SELECTION CH#) of SEL with (CAR CH)) (* Set up SELECTION to be the found  text) (replace (SELECTION CHLIM) of SEL with (ADD1 (CADR CH))) [replace (SELECTION DCH) of SEL with (ADD1 (IDIFFERENCE (CADR CH) (CAR CH] (replace (SELECTION POINT) of SEL with 'RIGHT) (replace (TEXTOBJ 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 (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with -1]) (\TEDIT.FINDAGAIN [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 6-May-2018 17:12 by rmk:") (\TEDIT.FIND TEXTSTREAM TEXTOBJ SEL T]) (\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 30-May-91 21:05 by jds") (* ;; "LOWER-CASEs 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 (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) (* ; "Edited 30-May-91 21:09 by jds") (* * comment) (PROG ((LOOKS (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ))) (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT (\TK.DESCRIBEFONT (fetch (CHARLOOKS CLFONT) of LOOKS)) (COND ((AND (fetch (CHARLOOKS CLOFFSET) of LOOKS) (NEQ (fetch (CHARLOOKS CLOFFSET) of LOOKS) 0)) (CONCAT " offset " (fetch (CHARLOOKS CLOFFSET) of LOOKS))) (T "")) (COND ((fetch (CHARLOOKS CLOLINE) of LOOKS) " overlined") (T "")) (COND ((fetch (CHARLOOKS 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 30-May-91 21:05 by jds") (* ; "uppercasifies 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 (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]) (\TEDIT.SELECT.ALL [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 6-May-2018 12:41 by rmk:") (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of TEXTOBJ)) 'LEFT]) ) (* ;; "Auxiliary functions used in the above main functions:") (DEFINEQ (\TEDIT.BOLD.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(WEIGHT MEDIUM) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) (\TEDIT.BOLD.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(WEIGHT BOLD) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) (\TEDIT.ITALIC.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(SLOPE REGULAR) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) (\TEDIT.ITALIC.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(SLOPE ITALIC) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) (\TEDIT.LARGER.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(SIZEINCREMENT 2) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) (\TEDIT.SMALLER.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(SIZEINCREMENT -2) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) (\TEDIT.SUBSCRIPT.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(OFFSETINCREMENT -2) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) (\TEDIT.SUPERSCRIPT.CARET [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(OFFSETINCREMENT 2) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) (\TEDIT.UNDERLINE.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(UNDERLINE OFF) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) (\TEDIT.UNDERLINE.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(UNDERLINE ON) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) (\TEDIT.STRIKEOUT.CARET.OFF [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(STRIKEOUT OFF) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) (\TEDIT.STRIKEOUT.CARET.ON [LAMBDA (TEXTSTREAM TEXTOBJ SEL) (* ; "Edited 12-Jun-90 18:32 by mitani") (PROG ((LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST '(STRIKEOUT ON) (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) TEXTOBJ))) (COND (LOOKS (TEDIT.CARETLOOKS TEXTSTREAM LOOKS) (\TEDIT.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]) ) (* ; "little selection utilities etc., for building hacks") (DEFINEQ (\SEL.LIMIT [LAMBDA (SEL) (* ; "Edited 30-May-91 21:06 by jds") (* returns the character that delimits this selection.  The first char if the point is left else the last) (COND ((EQ (fetch (SELECTION POINT) of SEL) 'LEFT) (fetch (SELECTION CH#) of SEL)) (T (SUB1 (fetch (SELECTION CHLIM) of SEL]) (\SEL.LINEDESC [LAMBDA (SEL) (* ; "Edited 30-May-91 21:06 by jds") (* returns the first line descriptor  if the point is left, otherwise the  last) (COND [(EQ (fetch (SELECTION POINT) of SEL) 'LEFT) (CAR (MKLIST (fetch (SELECTION L1) of SEL] (T (CAR (MKLIST (fetch (SELECTION LN) of SEL]) (\TK.DESCRIBEFONT (LAMBDA (FONT) (* gbn "15-Dec-84 17:54") (* * returns a string which describes a font  (in short. If it's not italic then no mention is made of slope, etc.)) (CONCAT (L-CASE (FONTPROP FONT 'FAMILY)) " " (FONTPROP FONT 'SIZE) (COND ((NEQ (FONTPROP FONT 'WEIGHT) 'MEDIUM) (CONCAT " " (L-CASE (FONTPROP FONT 'WEIGHT)))) (T "")) (COND ((NEQ (FONTPROP FONT 'SLOPE) 'REGULAR) (CONCAT " " (L-CASE (FONTPROP FONT 'SLOPE)))) (T ""))))) (\PARAS.IN.SEL [LAMBDA (SEL TEXTOBJ) (* ; "Edited 30-May-91 21:06 by jds") (* returns a list which contains one character number for each paragraph  included in the selection) (PROG ((PARAS) PARAENDED PCS (POS (fetch (SELECTION CH#) of SEL))) (COND ((ZEROP (fetch (SELECTION DCH) of SEL)) (* there are not really any pieces in this selection, however, effect the  change to the para containing this selection by starting the selection one  character earlier. This is not the right soln, but TEdit has no looks on the  empty last para as yet.) (replace (SELECTION CH#) of SEL with (IDIFFERENCE (fetch (SELECTION CH#) of SEL) 1)) (replace (SELECTION DCH) of SEL with 1) (\FIXSEL SEL TEXTOBJ))) (SETQ PCS (TEDIT.SELECTED.PIECES TEXTOBJ SEL)) (* to include the first char) (SETQ PARAENDED T) (for PC in PCS do (COND (PARAENDED (* the last piece ended a paragraph,  so include this character in the  list) (SETQ PARAENDED NIL) (push PARAS POS))) (SETQ PARAENDED (fetch (PIECE PPARALAST) of PC)) (add POS (fetch (PIECE PLEN) of PC))) (RETURN (DREVERSE PARAS]) ) (RPAQQ TEDIT.FNKEY.VERBOSE T) (RPAQQ \TEDIT.KEYS (("2,4" UNDO) ("2,44" UNDO) ("2,3" FN \TEDIT.FIND) ("2,43" FN \TEDIT.FIND) ("2,10" REDO) ("2,50" REDO) ("2,22" NEXT) ("2,62" NEXT) (ESC EXPAND) ("2,24" EXPAND) ("2,101" FN \TEDIT.CENTER.SEL) ("2,141" FN \TEDIT.CENTER.SEL.REV) ("2,102" FN \TEDIT.BOLD.SEL.ON) ("2,142" FN \TEDIT.BOLD.SEL.OFF) ("2,103" FN \TEDIT.ITALIC.SEL.ON) ("2,143" FN \TEDIT.ITALIC.SEL.OFF) ("2,104" FN \TEDIT.UCASE.SEL) ("2,144" FN \TEDIT.LCASE.SEL) ("2,105" FN \TEDIT.STRIKEOUT.SEL.ON) ("2,145" FN \TEDIT.STRIKEOUT.SEL.OFF) ("2,106" FN \TEDIT.UNDERLINE.SEL.ON) ("2,146" FN \TEDIT.UNDERLINE.SEL.OFF) ("2,107" FN \TEDIT.SUBSCRIPTSEL) ("2,147" FN \TEDIT.SUPERSCRIPTSEL) ("2,110" FN \TEDIT.SMALLERSEL) ("2,150" FN \TEDIT.LARGERSEL) ("2,113" FN \TEDIT.SUPERSCRIPTSEL) ("2,153" FN \TEDIT.SUBSCRIPTSEL) ("2,114" FN \TEDIT.SUBSCRIPTSEL) ("2,154" FN \TEDIT.SUPERSCRIPTSEL) ("2,115" FN \TEDIT.DEFAULTSSEL) ("2,155" FN \TEDIT.SETDEFAULT.FROM.SEL) ("2,1" FN \TEDIT.SHOWCARETLOOKS) ("1,U" UNDO) ("1,u" UNDO) ("1,z" UNDO) ("1,Z" UNDO) ("1,F" FN \TEDIT.FIND) ("1,f" FN \TEDIT.FIND) ("1,a" FN \TEDIT.SELECT.ALL) ("1,A" FN \TEDIT.SELECT.ALL) ("1,g" FN \TEDIT.FINDAGAIN))) [MAPC \TEDIT.KEYS (FUNCTION (LAMBDA (ENTRY) (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY] (* ; "Original was %"(FOR ENTRY IN \TEDIT.KEYS DO (SELECTQ (CADR ENTRY) (FN (TEDIT.SETFUNCTION (CAR ENTRY) (CADDR ENTRY))) (TEDIT.SETSYNTAX (CAR ENTRY) (CADR ENTRY))))%"." ) (* ; "Changed by yabu.fx, for SUNLOADUP without DWIM.") (PUTPROPS TEDITFNKEYS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1991 1994 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5707 18741 (\TEDIT.BOLD.SEL.OFF 5717 . 6056) (\TEDIT.BOLD.SEL.ON 6058 . 6387) ( \TEDIT.CENTER.SEL 6389 . 7444) (\TEDIT.CENTER.SEL.REV 7446 . 8526) (\TEDIT.DEFAULTS.CARET 8528 . 8812) (\TEDIT.DEFAULTSSEL 8814 . 9137) (\TEDIT.SETDEFAULT.FROM.SEL 9139 . 9578) (\TEDIT.FIND 9580 . 12943) (\TEDIT.FINDAGAIN 12945 . 13119) (\TEDIT.ITALIC.SEL.OFF 13121 . 13363) (\TEDIT.ITALIC.SEL.ON 13365 . 13548) (\TEDIT.LARGERSEL 13550 . 13845) (\TEDIT.LCASE.SEL 13847 . 14598) (\TEDIT.SHOWCARETLOOKS 14600 . 16240) (\TEDIT.SMALLERSEL 16242 . 16540) (\TEDIT.SUBSCRIPTSEL 16542 . 16746) (\TEDIT.SUPERSCRIPTSEL 16748 . 16953) (\TEDIT.UCASE.SEL 16955 . 17762) (\TEDIT.UNDERLINE.SEL.OFF 17764 . 17952) ( \TEDIT.UNDERLINE.SEL.ON 17954 . 18140) (\TEDIT.STRIKEOUT.SEL.ON 18142 . 18328) ( \TEDIT.STRIKEOUT.SEL.OFF 18330 . 18518) (\TEDIT.SELECT.ALL 18520 . 18739)) (18813 24253 ( \TEDIT.BOLD.CARET.OFF 18823 . 19271) (\TEDIT.BOLD.CARET.ON 19273 . 19718) (\TEDIT.ITALIC.CARET.OFF 19720 . 20170) (\TEDIT.ITALIC.CARET.ON 20172 . 20620) (\TEDIT.LARGER.CARET 20622 . 21070) ( \TEDIT.SMALLER.CARET 21072 . 21522) (\TEDIT.SUBSCRIPT.CARET 21524 . 21978) (\TEDIT.SUPERSCRIPT.CARET 21980 . 22435) (\TEDIT.UNDERLINE.CARET.OFF 22437 . 22890) (\TEDIT.UNDERLINE.CARET.ON 22892 . 23343) ( \TEDIT.STRIKEOUT.CARET.OFF 23345 . 23798) (\TEDIT.STRIKEOUT.CARET.ON 23800 . 24251)) (24322 28070 ( \SEL.LIMIT 24332 . 24770) (\SEL.LINEDESC 24772 . 25368) (\TK.DESCRIBEFONT 25370 . 26085) ( \PARAS.IN.SEL 26087 . 28068))))) STOP \ No newline at end of file diff --git a/library/TEDITHCPY b/library/TEDITHCPY new file mode 100644 index 00000000..ad78e750 --- /dev/null +++ b/library/TEDITHCPY @@ -0,0 +1,1569 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "25-Aug-94 10:54:07" {DSK}export>lispcore>library>TEDITHCPY.;4 104820 + + changes to%: (VARS TEDITHCPYCOMS) (FILES TEDITDCL) + + previous date%: "29-Mar-94 17:25:49" {DSK}export>lispcore>library>TEDITHCPY.;3) + + +(* ; " +Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT TEDITHCPYCOMS) + +(RPAQQ TEDITHCPYCOMS ((FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (COMS (* ;; "Generic interface functions and common code") (FNS TEDIT.HARDCOPY TEDIT.HCPYFILE \TEDIT.HARDCOPY.DISPLAYLINE \TEDIT.HARDCOPY.FORMATLINE \DOFORMATTING.HARDCOPY \TEDIT.HARDCOPY.MODIFYLOOKS \TEDIT.HCPYLOOKS.UPDATE \TEDIT.HCPYFMTSPEC \TEDIT.INTEGER.IMAGEBOX)) (COMS (* ;; "Functions for scaling distances and regions as needed during hardcopy.") (FNS \TEDIT.SCALE \TEDIT.SCALEREGION)) (COMS (* ;; "PRESS-specific code") (VARS (TEDIT.DEFAULTPAGEREGION (CREATEREGION 2794 1905 16256 23495))) (* ; "0.75 inches from bottom, 1 from top")) (COMS (* ;; "Support for the window-menu's HARDCOPY button, LISTFILES, etc.") (FNS TEDIT.HARDCOPYFN \TEDIT.HARDCOPY \TEDIT.PRESS.HARDCOPY) (P (LISTPUT (ASSOC (QUOTE CONVERSION) (ASSOC (QUOTE INTERPRESS) PRINTFILETYPES)) (QUOTE TEDIT) (FUNCTION \TEDIT.HARDCOPY))) (P (LET ((PRESSVALUES (ASSOC (QUOTE CONVERSION) (ASSOC (QUOTE PRESS) PRINTFILETYPES)))) (COND (PRESSVALUES (* ; "Only install PRESS printing if PRESS is loaded.") (LISTPUT PRESSVALUES (QUOTE TEDIT) (FUNCTION \TEDIT.PRESS.HARDCOPY))))))) (COMS (* ;; "vars for Japanese Line Break") (VARS (TEDIT.DONT.BREAK.CHARS (QUOTE (8482 8483 8491 8492 8508 8525 8539 8537 8535 9249 9251 9253 9255 9257 9283 9315 9317 9319 9326 9505 9507 9509 9511 9513 9539 9571 9573 9575 9582))) (TEDIT.DONT.LAST.CHARS (QUOTE (8524 8538 8536 8534)))) (GLOBALVARS TEDIT.DONT.BREAK.CHARS TEDIT.DONT.LAST.CHARS)) (COMS (* ;; "Support for hardcopying several files as one document") (FNS TEDIT-BOOK))) +) + +(FILESLOAD TEDITDCL) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ \SCRATCHLEN 64) + + +(CONSTANTS (\SCRATCHLEN 64)) +) + + +(FILESLOAD (LOADCOMP) TEDITDCL) +) + + + +(* ;; "Generic interface functions and common code") + +(DEFINEQ + +(TEDIT.HARDCOPY + [LAMBDA (STREAM FILE DONTSEND BREAKPAGETITLE SERVER PRINTOPTIONS) + (* ; "Edited 5-Jan-88 16:09 by jds") + + (* ;; "Send the text to the printer.") + + (COND + [(OR SERVER DEFAULTPRINTINGHOST) + + (* ;; "We can only hardcopy if there is a server specified, or the system will give us a reasonable default one.") + + (for IMAGETYPE in (PRINTERPROP (PRINTERTYPE SERVER) + 'CANPRINT) + do (RETURN (TEDIT.FORMAT.HARDCOPY STREAM FILE DONTSEND BREAKPAGETITLE SERVER + PRINTOPTIONS IMAGETYPE)) finally (ERROR (CONCAT + "Can't print TEDIT documents on a " + (PRINTERTYPE + SERVER) + " printer."] + (T (TEDIT.PROMPTPRINT (TEXTOBJ STREAM) + "Can't HARDCOPY: No print server specified." T]) + +(TEDIT.HCPYFILE + [LAMBDA (STREAM FILE BREAKPAGETITLE) (* ; "Edited 12-Jun-90 18:36 by mitani") + + (* Create a hardcopy-format FILE from the text on STREAM, with the file type + depending on what the default printer is.) + + (LET ([IMAGETYPE (CAR (PRINTERPROP (PRINTERTYPE) + 'CANPRINT] + TEXTOBJ FILENM TXTFILE) + (COND + ([SETQ FILENM (OR FILE (\TEDIT.MAKEFILENAME (TEDIT.GETINPUT + (SETQ TEXTOBJ (TEXTOBJ STREAM)) + (CONCAT IMAGETYPE " file name: ") + (COND + ((type? STREAM (SETQ TXTFILE + (fetch + (TEXTOBJ TXTFILE) + of TEXTOBJ))) + (* There was a file, so supply + default) + (PACKFILENAME 'VERSION NIL 'EXTENSION + (SELECTQ IMAGETYPE + (PRESS 'PRESS) + (INTERPRESS 'IP) + NIL) + 'BODY + (fetch (STREAM FULLFILENAME) + of TXTFILE] + (TEDIT.FORMAT.HARDCOPY STREAM FILENM T BREAKPAGETITLE NIL NIL IMAGETYPE]) + +(\TEDIT.HARDCOPY.DISPLAYLINE + [LAMBDA (TEXTOBJ LINE THISLINE REGION PRSTREAM) (* ; "Edited 29-Mar-94 13:44 by jds") + + (* ;; "Display LINE on the HARDCOPY file under way.") + + (* ;; "If possible, use the information cached in THISLINE") + + (PROG ((CH 0) + (CHLIST (fetch CHARS of (OR (fetch (LINEDESCRIPTOR CACHE) of LINE) + THISLINE))) + (WLIST (fetch (THISLINE WIDTHS) of (OR (fetch (LINEDESCRIPTOR CACHE) + of LINE) + THISLINE))) + (LOOKS (fetch LOOKS of (OR (fetch (LINEDESCRIPTOR CACHE) of LINE) + THISLINE))) + (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (LEFTMARGIN (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE)) + (STREAMSCALE (DSPSCALE NIL PRSTREAM)) + (LINELEN (fetch LEN of (OR (fetch (LINEDESCRIPTOR CACHE) of LINE) + THISLINE))) + OLOOKS LOOKSTARTX FONT OFONT CURRENTY FIRST-SCALED-CHAR KERN) + (COND + ((ILEQ (fetch (LINEDESCRIPTOR CHAR1) of LINE) + TEXTLEN) (* ; + "Only display the line if it appears before the end of the text!") + (COND + ((fetch (LINEDESCRIPTOR CACHE) of LINE) + (* ; + "This line was cached. Don';t need to re-compute the breaks &c") + ) + ((NEQ (fetch DESC of THISLINE) + LINE) (* ; "Format the line to our specs") + (\TEDIT.HARDCOPY.FORMATLINE TEXTOBJ (fetch (REGION WIDTH) of REGION) + (fetch (LINEDESCRIPTOR CHAR1) of LINE) + THISLINE LINE NIL PRSTREAM))) (* ; + "Use the characters cached in THISLINE.") + (SETQ OLOOKS (\EDITELT LOOKS 0)) + (COND + ((ZEROP (SETQ FIRST-SCALED-CHAR (fetch (THISLINE TLFIRSTSPACE) of THISLINE)) + ) (* ; + "For expanding spaces to justify a line") + (DSPSPACEFACTOR (fetch (THISLINE TLSPACEFACTOR) of THISLINE) + PRSTREAM) + (SETQ FIRST-SCALED-CHAR -1))) + (MOVETO LEFTMARGIN [SETQ CURRENTY (COND + [(AND (fetch (CHARLOOKS CLOFFSET) of + OLOOKS) + (NEQ 0 (fetch (CHARLOOKS CLOFFSET) + of OLOOKS))) + (IPLUS (fetch (LINEDESCRIPTOR YBASE) + of LINE) + (FIXR (FTIMES STREAMSCALE + (fetch (CHARLOOKS + CLOFFSET) + of OLOOKS] + (T (fetch (LINEDESCRIPTOR YBASE) of LINE] + PRSTREAM) + (DSPFONT (SETQ OFONT (fetch (CHARLOOKS CLFONT) of OLOOKS)) + PRSTREAM) + [COND + ((SETQ KERN (LISTGET (fetch (CHARLOOKS CLUSERINFO) of OLOOKS) + 'KERN)) + (SETQ KERN (FIXR (FTIMES STREAMSCALE KERN] + (STREAMPROP PRSTREAM 'KERN KERN) + (SETQ LOOKSTARTX LEFTMARGIN) + (while (EQ (CHARCODE SPACE) + (\EDITELT CHLIST LINELEN)) do + (* ; + "Trim any trailing blanks off the line, to avoid the INTERPRESS CORRECT bug that they cause.") + (add LINELEN -1)) + (bind (LOOKNO _ 1) + (TX _ LEFTMARGIN) + DX for I from 0 to LINELEN + do (SETQ CH (\EDITELT CHLIST I)) + (SETQ DX (\EDITELT WLIST I)) + [COND + ((EQ I FIRST-SCALED-CHAR) (* ; "Time to turn on space scaling.") + (DSPSPACEFACTOR (fetch (THISLINE TLSPACEFACTOR) of THISLINE) + PRSTREAM) + (LET ((X (DSPXPOSITION NIL PRSTREAM)) + (Y (DSPYPOSITION NIL PRSTREAM))) + (MOVETO 0 0 PRSTREAM) + (MOVETO X Y PRSTREAM] + [SELECTC CH + (LMInvisibleRun + (* ;; + "An INVISIBLE run -- skip it, and skip over the char count:") + + (add LOOKNO 1)) + (LMLooksChange + + (* ;; "Change in character looks. Do any cleanup (like underlining) for the prior characters, and set up the new looks, like font:") + + (\TEDIT.HARDCOPY.MODIFYLOOKS LINE LOOKSTARTX TX + (fetch (LINEDESCRIPTOR YBASE) of LINE) + OLOOKS PRSTREAM) + (DSPFONT (fetch (CHARLOOKS CLFONT) + of (SETQ OLOOKS (\EDITELT LOOKS LOOKNO))) + PRSTREAM) + (add LOOKNO 1) + (DSPYPOSITION + [SETQ CURRENTY + (COND + [(AND (fetch (CHARLOOKS CLOFFSET) of OLOOKS) + (NEQ 0 (fetch (CHARLOOKS CLOFFSET) + of OLOOKS))) + (IPLUS (fetch (LINEDESCRIPTOR YBASE) of + LINE) + (FIXR (FTIMES STREAMSCALE (fetch + (CHARLOOKS CLOFFSET + ) + of OLOOKS] + (T (fetch (LINEDESCRIPTOR YBASE) of LINE] + PRSTREAM) + [COND + ((SETQ KERN (LISTGET (fetch (CHARLOOKS CLUSERINFO) + of OLOOKS) + 'KERN)) + (SETQ KERN (FIXR (FTIMES STREAMSCALE KERN] + (STREAMPROP PRSTREAM 'KERN KERN) + (SETQ LOOKSTARTX TX)) + ((CHARCODE SPACE) + (* ;; + "Space: Just print it, because we set up the space adjustment to do justification.") + + (* ; + "(DSPXPOSITION (IPLUS TX DX) PRSTREAM)") + (\OUTCHAR PRSTREAM CH)) + ((CHARCODE (TAB %#^I)) + (* ;; + "TAB: use the width from the cache to decide the right formatting:") + + [COND + ((OR (IEQP CH (CHARCODE %#^I)) + (fetch (CHARLOOKS CLLEADER) of OLOOKS) + (EQ (fetch (CHARLOOKS CLUSERINFO) of OLOOKS) + 'DOTTEDLEADER)) + + (* ;; + "Dotted leaders are meta-TAB, or have the DOTTEDLEADER looks.") + + (LET* [(DOTWIDTH (CHARWIDTH (CHARCODE %.) + (FONTCOPY (fetch (CHARLOOKS CLFONT) + of OLOOKS) + 'DEVICE PRSTREAM))) + (TTX (IPLUS TX DOTWIDTH (IDIFFERENCE DOTWIDTH + (IREMAINDER TX DOTWIDTH] + (DSPXPOSITION (IDIFFERENCE TTX DOTWIDTH) + PRSTREAM) (* ; + "Move over to the next even multiple of a dot's width.") + (while (ILEQ TTX (IPLUS TX DX)) + do (* ; + "Print enough dots to fill the TAB's gap.") + (\OUTCHAR PRSTREAM (CHARCODE %.)) + (add TTX DOTWIDTH] + (DSPXPOSITION (IPLUS TX DX) + PRSTREAM)) + ((CHARCODE CR) + (* ;; + "Do nothing for carriage return, since it ends the line.") + + NIL) + (NIL + (* ;; "Do nothing if it's NIL, which signals a character we deleted during line formatting (e.g., an unused discretionary hyphen)") + + NIL) + (COND + [(SMALLP CH) (* ; + "CH is a char code, just print it") + (COND + ((AND (IGEQ CH 192) + (ILEQ CH 207)) (* ; "This is an NS accent character. Readjust our position with MOVETO, so that the accent overprints the next character.") + (MOVETO (+ TX (RSH (- (\EDITELT WLIST (ADD1 I)) + DX) + 1)) + CURRENTY PRSTREAM) + (\OUTCHAR PRSTREAM CH) + (MOVETO TX CURRENTY PRSTREAM) + (SETQ DX 0)) + (T (\OUTCHAR PRSTREAM CH] + (T (* ; "CH is an object.") + + (* ;; "Add SETXY command to PRSTREAM,to avoid the XP-9's BUG") + + (DSPXPOSITION (IPLUS TX 1) + PRSTREAM) + (APPLY* (IMAGEOBJPROP CH 'DISPLAYFN) + CH PRSTREAM (IMAGESTREAMTYPE PRSTREAM) + TEXTOBJ) + (MOVETO (IPLUS TX DX) + CURRENTY PRSTREAM] + (add TX DX) finally + + (* ;; "Do any last-minute underlining or similar looks fix-ups, and print a revision mark, if one is needed:") + + (\TEDIT.HARDCOPY.MODIFYLOOKS LINE LOOKSTARTX TX + (fetch (LINEDESCRIPTOR YBASE) of LINE) + OLOOKS PRSTREAM) + (COND + ((fetch (FMTSPEC FMTREVISED) + of (fetch (LINEDESCRIPTOR LFMTSPEC) + of LINE)) + (* ; + "This paragraph has been revised, so mark it.") + (\TEDIT.MARK.REVISION TEXTOBJ (fetch + (LINEDESCRIPTOR + LFMTSPEC) + of LINE) + PRSTREAM LINE]) + +(\TEDIT.HARDCOPY.FORMATLINE + [LAMBDA (TEXTOBJ WIDTH CH#1 THISLINE LINE IMAGESTREAM DOINGHEADING? PAGEINFO) + (* ; "Edited 29-Mar-94 17:15 by jds") + +(* ;;; "Given a starting place, format the next line of text. Return T if a control-L was seen on the line.") + + (DECLARE (SPECVARS LOOKS ASCENT DESCENT FONTWIDTHS FONT INVISIBLERUNS CHNO TLEN LOOKNO CHLIST + WLIST DEVICE NEWASCENT NEWDESCENT IMAGESTREAM)) + (PROG ((TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (CH#B CH#1) + (CHNO CH#1) + (LOOKNO 0) + (GATHERBLANK T) + (TLEN 0) + (INVISIBLERUNS 0) + (DESCENT 0) + (ASCENT 0) + (PREVSP 0) + (%#BLANKS 0) + (DEVICE IMAGESTREAM) + (KERN NIL) + TX DX TXB CH FORCEEND T1SPACE TXB1 DXB LOOK#B FONT FONTWIDTHS TERMSA CLOOKS TEXTSTREAM + CHLIST WLIST LOOKS ASCENTB DESCENTB INVISIBLERUNSB TABPENDING BOX PC PCNO CTRL\L\SEEN + 1STLN FMTSPEC NEWASCENT NEWDESCENT PREVHYPH PREVDHYPH ORIGCHLIST ORIGWLIST) + + (* ;; "Variables:") + + (* ;; "(TLEN = Current character count on the line)") + + (* ;; "(CHNO = Current character # in the Text)") + + (* ;; "(DX = width of current char/object)") + + (* ;; "(TX = current right margin) ") + + (* ;; "(TXB1 = right margin of the first space/tab/CR in a row of space/tab/CR) ") + + (* ;; "(CH#B = The CHNO of most recent space/tab)") + + (* ;; "(TXB = right margin of most recent space/tab)") + + (* ;; "(DXB = width of most recent space/tab)") + + (* ;; "(PREVSP = location on the line of the previous space/tab to this space/tab + 1)") + + (* ;; "(T1SPACE = a space/CR/TAB has been seen)") + + (* ;; "(#BLANKS = # of spaces/tabs seen) ") + + (* ;; "(LOOKNO = Current index into the LOOKS array. Updated by \TEDIT.LOOKS.UPDATE as characters are read in)") + + (* ;; "(LOOK#B = The LOOKNO of the most recent space/tab)") + + (* ;; "(ASCENTB = Ascent at most recent potential line break point) (DESCENTB = Descent at most recent potential line break point)") + + [SETQ ORIGCHLIST (SETQ CHLIST (fetch (ARRAYP BASE) of (fetch CHARS of + THISLINE] + (* ; + "Place to put character codes/objects") + [SETQ ORIGWLIST (SETQ WLIST (fetch (ARRAYP BASE) of (fetch (THISLINE WIDTHS) + of THISLINE] + (* ; "Place to put width of each item") + (SETQ LOOKS (fetch LOOKS of THISLINE)) + (SETQ TEXTSTREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) + (SETQ TERMSA (fetch (TEXTOBJ TXTTERMSA) of TEXTOBJ)) + (replace LOOKSUPDATEFN of TEXTSTREAM with (FUNCTION \TEDIT.HCPYLOOKS.UPDATE)) + (* ; + "This gets called every time we cross a piece boundary, to check for changes in looks.") + (freplace (LINEDESCRIPTOR CHARLIM) of LINE with TEXTLEN) + (* ; + "Force each new line to find its true CHARLIM.") + (freplace (LINEDESCRIPTOR CHAR1) of LINE with CH#1) + (freplace (LINEDESCRIPTOR CR\END) of LINE with NIL) + (* ; "Assume we won't see a CR.") + (replace (LINEDESCRIPTOR LHASTABS) of LINE with NIL) + (* ; "And has no TABs.") + (replace (LINEDESCRIPTOR LSTLN) of LINE with NIL) + (* ; + "And assume it isn't the last line in a paragraph until we find otherwise.") + (replace (THISLINE TLFIRSTSPACE) of THISLINE with 0) + (* ; + "Start out assuming that all spaces on the line will be scaled.") + (COND + [(COND + ((AND (ILEQ CH#1 TEXTLEN) + (NOT (ZEROP TEXTLEN))) (* ; + "Only continue if there's really text we can format.") + (\SETUPGETCH CH#1 TEXTOBJ) (* ; "Starting place") + (* ; "And starting character looks") + (SETQ CLOOKS (fetch (TEXTSTREAM CURRENTLOOKS) of TEXTSTREAM)) + [COND + ((fetch (CHARLOOKS CLINVISIBLE) of CLOOKS) + (* ; + "We've hit a run of invisible characters. Skip them, and insert a marker in the line cache") + (add LOOKNO 1) (* ; + "Fix the counter of charlooks changes") + (SETQ PC (fetch (TEXTSTREAM PIECE) of TEXTSTREAM)) + (\EDITSETA LOOKS LOOKNO (SETQ INVISIBLERUNS (fetch (PIECE PLEN) + of PC))) + (\RPLPTR CHLIST 0 401) + (\RPLPTR WLIST 0 0) + (add TLEN 1) + (SETQ CHLIST (\ADDBASE CHLIST 2)) + (SETQ WLIST (\ADDBASE WLIST 2)) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) + (AND PC (SETQ CLOOKS (\TEDIT.APPLY.STYLES (ffetch (PIECE PLOOKS) + of PC) + PC TEXTOBJ))) + [while (AND PC (fetch (CHARLOOKS CLINVISIBLE) of CLOOKS)) + do (\EDITSETA LOOKS LOOKNO (add INVISIBLERUNS (fetch + (PIECE PLEN) + of PC))) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) + (AND PC (SETQ CLOOKS (\TEDIT.APPLY.STYLES (ffetch (PIECE PLOOKS) + of PC) + PC TEXTOBJ] + (add CHNO (\EDITELT LOOKS LOOKNO)) + (COND + (PC (* ; + "Move us to the right place in the stream") + (\SETUPGETCH (create EDITMARK + PC _ PC + PCOFF _ 0 + PCNO _ NIL) + TEXTOBJ)) + (T (* ; + "We've walked off the end of the document. Just note that we're not at any piece now.") + (replace (TEXTSTREAM PIECE) of TEXTSTREAM with NIL] + (ILEQ CHNO TEXTLEN))) + (\TEDIT.HCPYLOOKS.UPDATE TEXTSTREAM (fetch (TEXTSTREAM PIECE) of TEXTSTREAM + ) + CLOOKS) + (SETQ ASCENTB ASCENT) + (SETQ DESCENTB DESCENT) + (\EDITSETA LOOKS 0 CLOOKS) (* ; "Save looks in the line cache") + (SETQ FONT (fetch (CHARLOOKS CLFONT) of CLOOKS)) + [SETQ FONT (COND + ((AND (type? FONTCLASS FONT) + (FONTCLASSCOMPONENT FONT DEVICE))) + (T (FONTCOPY FONT 'DEVICE DEVICE](* ; + "Keep the font around for char widths.") + (SETQ FMTSPEC (\TEDIT.HCPYFMTSPEC (\TEDIT.APPLY.PARASTYLES + (OR (fetch (TEXTSTREAM CURRENTPARALOOKS) + of TEXTSTREAM) + (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ) + ) + PC TEXTOBJ) + IMAGESTREAM)) (* ; "Paragraph formatting info") + (COND + ((AND (NEQ FMTSPEC *TEDIT-CACHED-FMTSPEC*) + (fetch (FMTSPEC FMTCHARSTYLES) of FMTSPEC)) + + (* ;; "The cache of character styles for the current paragrpah is invalid; flush it, and note the new paragraph to cache for.") + + (SETQ *TEDIT-CURRENTPARA-CACHE* NIL) + (SETQ *TEDIT-CACHED-FMTSPEC* FMTSPEC))) + [SETQ 1STLN (OR (IEQP CH#1 1) + (AND (fetch (TEXTSTREAM PIECE) of TEXTSTREAM) + (fetch (PIECE PREVPIECE) of (fetch (TEXTSTREAM PIECE) + of TEXTSTREAM)) + (fetch (PIECE PPARALAST) of (fetch (PIECE PREVPIECE) + of (fetch + (TEXTSTREAM PIECE) + of TEXTSTREAM + ))) + (IEQP (fetch (TEXTSTREAM PCSTARTCH) of TEXTSTREAM) + (fetch (STREAM COFFSET) of TEXTSTREAM)) + (IEQP (fetch (TEXTSTREAM PCSTARTPG) of TEXTSTREAM) + (fetch (STREAM CPAGE) of TEXTSTREAM] + (* ; + "Are we on the first line of a paragraph?") + (replace (LINEDESCRIPTOR 1STLN) of LINE with 1STLN) + (COND + ((AND 1STLN (NOT DOINGHEADING?)) (* ; + "This is a new paragraph. Check for special paragraph types, and handle them accordingly.") + (SELECTQ (fetch (FMTSPEC FMTPARATYPE) of FMTSPEC) + (PAGEHEADING (* ; "This paragraph is the content for a page heading. Handle it, then don't bother formatting further.") + (TEDIT.HARDCOPY.PAGEHEADING TEXTOBJ TEXTSTREAM LINE FMTSPEC CHNO + IMAGESTREAM) + + (* ;; "This will capture the text, and set LINE:CHARLIM to the LAST char# in the page heading. That lets formatting continue apace.") + + (RETURN NIL)) + (EVEN (* ; "This paragraph may or may not belong here. If this is an odd page, we don't want to format this paragraph.") + (COND + ((ODDP (fetch (PAGEFORMATTINGSTATE PAGE#) of FORMATTINGSTATE)) + (TEDIT.SKIP.SPECIALCOND TEXTOBJ TEXTSTREAM LINE FMTSPEC CHNO + IMAGESTREAM) + (RETURN NIL)))) + (ODD (* ; "This paragraph may or may not belong here. If this is an even page, we don't want to format this paragraph.") + (COND + ((EVENP (fetch (PAGEFORMATTINGSTATE PAGE#) of FORMATTINGSTATE)) + (TEDIT.SKIP.SPECIALCOND TEXTOBJ TEXTSTREAM LINE FMTSPEC CHNO + IMAGESTREAM) + (RETURN NIL)))) + NIL))) + [SETQ TX (replace (LINEDESCRIPTOR LEFTMARGIN) of LINE + with (COND + (1STLN (fetch (FMTSPEC 1STLEFTMAR) of FMTSPEC)) + (T (fetch (FMTSPEC LEFTMAR) of FMTSPEC] + (* ; "Set the left margin accordingly") + [replace (LINEDESCRIPTOR RIGHTMARGIN) of LINE + with (SETQ WIDTH (COND + ((NOT (ZEROP (fetch (FMTSPEC RIGHTMAR) of FMTSPEC))) + (fetch (FMTSPEC RIGHTMAR) of FMTSPEC)) + (T WIDTH] (* ; + "RIGHTMAR = 0 => follow the window's width.") + (SETQ TXB1 WIDTH) + (for old TLEN from TLEN to 511 as old CHNO from CHNO + while (ILEQ CHNO TEXTLEN) when (SETQ CH (\BIN TEXTSTREAM)) + do (* ; "(The WHILE is there because we may reset TEXTLEN within the loop, and TO TEXTLEN only evaluates it once.)") + + (* ;; "The character loop") + + (* ;; "Get the next character for the line.") + + [SETQ DX (COND + ((SMALLP CH) (* ; "CH is really a character") + (\FGETCHARWIDTH FONT CH)) + (T (* ; "CH is an object") + (SETQ BOX (\TEDIT.INTEGER.IMAGEBOX (APPLY* (IMAGEOBJPROP + CH + 'IMAGEBOXFN) + CH IMAGESTREAM TX WIDTH + ))) + (* ; "Get its size") + [SETQ ASCENT (IMAX ASCENT (IDIFFERENCE (fetch YSIZE of BOX) + (fetch YDESC of BOX] + (SETQ DESCENT (IMAX DESCENT (fetch YDESC of BOX))) + (IMAGEOBJPROP CH 'BOUNDBOX BOX) + (fetch XSIZE of BOX] + (AND KERN (SETQ DX (IPLUS DX KERN))) (* ; "Get CH's X width.") + [SELCHARQ CH + (SPACE (* ; + "CH is a . Remember it, in case we need to break the line.") + (COND + (GATHERBLANK (SETQ TXB1 TX) + (SETQ GATHERBLANK NIL))) + (SETQ CH#B CHNO) (* ; + "put the location # of the previous space/tab in the character array instead of the space itself") + (COND + (NEWASCENT + + (* ;; "The ascent/descent changed. Update the real values, now that we have a character to actually take effect on it") + + (SETQ ASCENT (IMAX ASCENT NEWASCENT)) + (SETQ DESCENT (IMAX DESCENT NEWDESCENT)) + (SETQ NEWASCENT NIL))) + (\RPLPTR CHLIST 0 PREVSP) + (\RPLPTR WLIST 0 DX) + (SETQ PREVSP (ADD1 TLEN)) + (SETQ PREVHYPH NIL) + (SETQ PREVDHYPH NIL) (* ; + "We're now past needing any hyphens for line breaking, so forget the last hyphen spot.") + (SETQ T1SPACE T) + (add TX DX) + (SETQ TXB TX) + (SETQ DXB DX) + (SETQ LOOK#B LOOKNO) + (SETQ ASCENTB ASCENT) + (SETQ DESCENTB DESCENT) + (SETQ INVISIBLERUNSB INVISIBLERUNS) + (add %#BLANKS 1)) + (CR (* ; + "Ch is a . Force an end to the line.") + (freplace (LINEDESCRIPTOR CHARLIM) of LINE with CHNO) + (COND + ((AND NEWASCENT (ZEROP ASCENT) + (ZEROP DESCENT)) (* ; + "The ascent has changed; catch it") + (SETQ ASCENT NEWASCENT) + (SETQ DESCENT NEWDESCENT))) + (SETQ FORCEEND T) + (\RPLPTR CHLIST 0 (CHARCODE CR)) + (\RPLPTR WLIST 0 (SETQ DX 0)) + (COND + (GATHERBLANK (SETQ TXB1 TX) + (SETQ GATHERBLANK NIL))) + (SETQ T1SPACE T) + (freplace (LINEDESCRIPTOR CR\END) of LINE with T) + (SETQ TX (IPLUS TX DX)) + (replace (LINEDESCRIPTOR LSTLN) of LINE + with (fetch (PIECE PPARALAST) of (fetch PIECE + of TEXTSTREAM))) + (SETQ PREVDHYPH NIL) + (SETQ PREVHYPH NIL) (* ; + "We're now past needing any hyphens for line breaking, so forget the last hyphen spot.") + (RETURN)) + (^L (* ; + "Ch is a
Force an end to the line. Immediately--just like a CR.") + (SETQ CTRL\L\SEEN T) + (freplace (LINEDESCRIPTOR CHARLIM) of LINE with CHNO) + (SETQ FORCEEND T) + (\RPLPTR CHLIST 0 (CHARCODE CR)) + (\RPLPTR WLIST 0 (SETQ DX (IMAX DX 6))) + (COND + (GATHERBLANK (SETQ TXB1 TX) + (SETQ GATHERBLANK NIL))) + (SETQ T1SPACE T) + (freplace (LINEDESCRIPTOR CR\END) of LINE with T) + (SETQ TX (IPLUS TX DX)) + (replace (LINEDESCRIPTOR LSTLN) of LINE with T) + (SETQ PREVDHYPH NIL) + (SETQ PREVHYPH NIL) (* ; + "We're now past needing any hyphens for line breaking, so forget the last hyphen spot.") + (RETURN)) + (TAB + (* ;; "Try to be reasonable with tabs. This will create trouble when doing fast-case insert/delete, but Pah! for now.") + + (\RPLPTR CHLIST 0 CH) (* ; "TABs are 0 wide to start with.") + (replace (THISLINE TLFIRSTSPACE) of THISLINE with TLEN) + (COND + (NEWASCENT + + (* ;; "The ascent/descent changed. Update the real values, now that we have a character to actually take effect on it") + + (SETQ ASCENT (IMAX ASCENT NEWASCENT)) + (SETQ DESCENT (IMAX DESCENT NEWDESCENT)) + (SETQ NEWASCENT NIL))) + (SETQ TABPENDING (\TEDIT.FORMATTABS TEXTOBJ (fetch (FMTSPEC TABSPEC) + of FMTSPEC) + THISLINE CHLIST WLIST TX + (FIXR (FTIMES 36.0 (DSPSCALE NIL IMAGESTREAM))) + 0 TABPENDING (LRSH (FIXR (DSPSCALE NIL IMAGESTREAM + )) + 1) + NIL)) (* ; + "Figure out which tab stop to use, and what we need to do to get there.") + [COND + ((FIXP TABPENDING) (* ; + "If it returns a number, that is the new TX, adjusted for any prior tabs") + (SETQ TX TABPENDING) + (SETQ TABPENDING NIL)) + (TABPENDING (* ; + "Otherwise, look in the PENDINGTAB for the new TX") + (SETQ TX (fetch PTNEWTX of TABPENDING] + (COND + (GATHERBLANK (SETQ TXB1 TX) + (SETQ GATHERBLANK NIL))) + (SETQ CH#B CHNO) + (SETQ DX (\GETBASEPTR WLIST 0)) + (\TEDIT.PURGE.SPACES (fetch CHARS of THISLINE) + PREVSP) (* ; + "All the spaces before a tab don't take part in justification from here on.") + (SETQ %#BLANKS 0) (* ; + "So we can allocate extra space among the right number of blanks to justify things after the tab.") + (SETQ PREVSP 0) + (SETQ PREVDHYPH NIL) + (SETQ PREVHYPH NIL) (* ; + "We're now past needing any hyphens for line breaking, so forget the last hyphen spot.") + (SETQ T1SPACE T) + (SETQ TX (IPLUS TX DX)) + (SETQ TXB TX) (* ; + "Remember the world in case this is the 'space' before the line breaks") + (SETQ DXB DX) + (SETQ LOOK#B LOOKNO) + (SETQ ASCENTB ASCENT) + (SETQ DESCENTB DESCENT) + (SETQ INVISIBLERUNSB INVISIBLERUNS)) + (PROGN (COND + ((AND (EQ CH (CHARCODE "0,377")) + (NOT (ffetch (TEXTOBJ TXTNONSCHARS) of TEXTOBJ))) + + (* ;; + "Character-set change character. This suggests undetected NS characters.") + + (\TEDIT.NSCHAR.RUN CHNO TEXTOBJ TEXTSTREAM) + (* ; + "Leaves us ready to BIN again at the same place.") + + (* ;; "Back up the cache pointers and counters so that when we go to the top of the loop we're where we are now.") + + (SETQ CHLIST (\ADDBASE CHLIST -2)) + (SETQ WLIST (\ADDBASE WLIST -2)) + (add CHNO -1) + (add TLEN -1) + (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (* ; + "Because moving to NS characters changes the TEXTLEN for the shorter.") + ) + (T + (* ;; "This character isn't special. Just space over for it.") + + (SETQ GATHERBLANK T) + (COND + ((IGREATERP (SETQ TX (IPLUS TX DX)) + WIDTH) (* ; + "We're past the right margin; stop formatting at the last blank.") + (SETQ FORCEEND T) + (COND + (PREVDHYPH (* ; + "There's a hyphen we can break at. Go back there and break the line.") + (freplace (LINEDESCRIPTOR CHARLIM) of LINE + with CH#B) + (\RPLPTR ORIGCHLIST (LLSH (SUB1 PREVDHYPH) + 1) + (CHARCODE "-")) + (\RPLPTR ORIGWLIST (LLSH (SUB1 PREVDHYPH) + 1) + (\FGETCHARWIDTH FONT (CHARCODE "-"))) + (SETQ TX TXB) + (SETQ DX DXB) + (SETQ ASCENT ASCENTB) + (SETQ DESCENT DESCENTB) + (SETQ LOOKNO LOOK#B) + (SETQ INVISIBLERUNS INVISIBLERUNSB)) + (PREVHYPH (* ; + "There's a hyphen we can break at. Go back there and break the line.") + (freplace (LINEDESCRIPTOR CHARLIM) of LINE + with CH#B) + (SETQ TX TXB) + (SETQ DX DXB) + (SETQ ASCENT ASCENTB) + (SETQ DESCENT DESCENTB) + (SETQ LOOKNO LOOK#B) + (SETQ INVISIBLERUNS INVISIBLERUNSB)) + (T1SPACE (* ; + "There's a breaking point on this line. Go back there and break the line.") + (freplace (LINEDESCRIPTOR CHARLIM) of LINE + with CH#B) + (SETQ TX TXB) + (SETQ DX DXB) + (SETQ ASCENT ASCENTB) + (SETQ DESCENT DESCENTB) + (SETQ LOOKNO LOOK#B) + (SETQ INVISIBLERUNS INVISIBLERUNSB)) + ((IGREATERP TLEN 0) + (freplace (LINEDESCRIPTOR CHARLIM) of LINE + with (IMAX CH#1 (SUB1 CHNO))) + (SETQ TX (IDIFFERENCE TX DX)) + (* ; + "No spaces on this line; break it before this character.") + + (* ;; "Check line break character.") + + (while (OR (MEMBER (\GETBASEPTR CHLIST -2) + TEDIT.DONT.LAST.CHARS) + (MEMBER CH TEDIT.DONT.BREAK.CHARS)) + do + + (* ;; + "This character ch doesn't appear at first of lines. or") + + (* ;; + "Previous character doesn't appear at the end of lines.") + + (* ;; + "So,move previous character to next line.") + + (SETQ CHLIST (\ADDBASE CHLIST -2)) + (SETQ WLIST (\ADDBASE WLIST -2)) + (add TLEN -1) + (add CHNO -1) + (SETQ CH (\GETBASEPTR CHLIST 0))) + (freplace (LINEDESCRIPTOR CHARLIM) of LINE + with (IMAX (SUB1 CHNO) + CH#1))) + (T (* ; + "Can't split BEFORE the first thing on the line!") + (freplace (LINEDESCRIPTOR CHARLIM) of LINE + with CHNO) + (\RPLPTR CHLIST 0 CH) + (\RPLPTR WLIST 0 DX))) + (RETURN)) + (T (* ; "Not past the rightmargin yet...") + (COND + ((AND NEWASCENT (SMALLP CH)) + + (* ;; "The ascent/descent changed. Update the real values, now that we have a character to actually take effect on it") + + (SETQ ASCENT (IMAX ASCENT NEWASCENT)) + (SETQ DESCENT (IMAX DESCENT NEWDESCENT)) + (SETQ NEWASCENT NIL))) + (\RPLPTR CHLIST 0 CH) + (\RPLPTR WLIST 0 DX)(* ; "Check for decimal tabs") + (SELCHARQ CH + (%. (COND + ((AND TABPENDING (NOT (FIXP TABPENDING)) + (EQ (fetch PTTYPE of TABPENDING) + 'DECIMAL)) + (add (fetch (PENDINGTAB PTTABX) + of TABPENDING) + DX) + (* ; + "Adjust the pending tab so that the LEFT side of the decimal point goes at the tab stop.") + (SETQ TABPENDING + (\TEDIT.FORMATTABS TEXTOBJ (fetch + (FMTSPEC TABSPEC) + of FMTSPEC) + THISLINE CHLIST WLIST TX + (FIXR (FTIMES 36.0 (DSPSCALE NIL + IMAGESTREAM)) + ) + 0 TABPENDING + (LRSH (FIXR (DSPSCALE NIL IMAGESTREAM)) + 1) + T)) + (* ; + "Figure out which tab stop to use, and what we need to do to get there.") + [COND + ((FIXP TABPENDING) + (* ; + "If it returns a number, that is the new TX, adjusted for any prior tabs") + (SETQ TX TABPENDING) + (SETQ TABPENDING NIL)) + (TABPENDING + (* ; + "Otherwise, look in the PENDINGTAB for the new TX") + (SETQ TX (fetch PTNEWTX + of TABPENDING] + (COND + (GATHERBLANK (SETQ TXB1 TX) + (SETQ GATHERBLANK NIL))) + (SETQ CH#B CHNO) + (* ; "SETQ DX (\GETBASE WLIST 0)") + (\TEDIT.PURGE.SPACES (fetch CHARS + of THISLINE) + PREVSP) + (* ; + "All the spaces before a tab don't take part in justification from here on.") + (SETQ %#BLANKS 0) + (* ; + "So we can allocate extra space among the right number of blanks to justify things after the tab.") + (SETQ PREVSP 0) + (SETQ T1SPACE T) + (SETQ TXB TX) + (* ; + "Remember the world in case this is the 'space' before the line breaks") + (SETQ DXB DX) + (SETQ LOOK#B LOOKNO) + (SETQ ASCENTB ASCENT) + (SETQ DESCENTB DESCENT) + (SETQ INVISIBLERUNSB INVISIBLERUNS)))) + ((- "357,045") (* ; "Hyphen, M-dash") + (SETQ PREVHYPH (ADD1 TLEN)) + (SETQ PREVDHYPH NIL) + (SETQ TXB1 (SETQ TXB TX)) + (SETQ DXB DX) + (SETQ LOOK#B LOOKNO) + (SETQ CH#B CHNO) + (SETQ ASCENTB ASCENT) + (SETQ DESCENTB DESCENT) + (SETQ INVISIBLERUNSB INVISIBLERUNS)) + ("357,042" (* ; "non-breaking hyphen") + (\RPLPTR CHLIST 0 (CHARCODE "-"))) + ("357,043" (* ; "Discretionary hyphen") + (* ; "And isn't actually displayed.") + (SETQ PREVDHYPH (ADD1 TLEN)) + (SETQ PREVHYPH NIL) + (SETQ LOOK#B LOOKNO) + (SETQ CH#B CHNO) + (SETQ ASCENTB ASCENT) + (SETQ DESCENTB DESCENT) + (\RPLPTR WLIST 0 0) + (* ; + "Unless we use it, the prevhyph is 0 wide.") + (\RPLPTR CHLIST 0 NIL) + (SETQ TX (IDIFFERENCE TX DX)) + (SETQ DX (\FGETCHARWIDTH FONT (CHARCODE + "-"))) + (SETQ TXB1 (SETQ TXB (IPLUS TX DX))) + (SETQ DXB DX) + (SETQ INVISIBLERUNSB INVISIBLERUNS)) + ("357,041" (* ; "non-breaking space.") + (\RPLPTR CHLIST 0 (CHARCODE SPACE))) + (COND + ((AND (SMALLP CH) + (IGEQ CH 192) + (ILEQ CH 207)) + (* ; "This is an NS accent character. Space it 0.0 -- SO back TX down by the width of the accent, so it doesn't add to the line width.") + (SETQ TX (- TX DX] + (SETQ CHLIST (\ADDBASE CHLIST 2)) (* ; + "Move the pointers forward for the next character.") + (SETQ WLIST (\ADDBASE WLIST 2))) + +(* ;;; "Done processing characters; the line is now filled.") + + (COND + ((AND (IEQP TLEN 255) + (ILESSP CHNO TEXTLEN)) (* ; + "This line is too long for us to format??") + (TEDIT.PROMPTPRINT TEXTOBJ "Line too long to format." T))) + (COND + (TABPENDING (* ; + "There is a TAB outstanding. Go handle it.") + (add (fetch (PENDINGTAB PTTABX) of TABPENDING) + DX) (* ; + "Modify the pending tab so that the LEFT side of the CR is at the tab stop.") + (SETQ TABPENDING (\TEDIT.FORMATTABS TEXTOBJ (fetch (FMTSPEC TABSPEC) + of FMTSPEC) + THISLINE CHLIST WLIST TX + (FIXR (FTIMES 36.0 (DSPSCALE NIL IMAGESTREAM))) + 0 TABPENDING (LRSH (FIXR (DSPSCALE NIL IMAGESTREAM)) + 1) + T)) + (SETQ TX TABPENDING) + (SETQ TABPENDING NIL) + (\TEDIT.PURGE.SPACES (fetch CHARS of THISLINE) + PREVSP) + (SETQ PREVSP 0] + (T (* ; + "No text to go in this line; set Ascent/Descent to the default font from the window.") + (SETQ FMTSPEC (\TEDIT.HCPYFMTSPEC (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ))) + (\EDITSETA LOOKS 0 CLOOKS) + [SETQ 1STLN (AND (fetch (STREAM F5) of TEXTSTREAM) + (fetch (PIECE PREVPIECE) of (fetch (STREAM F5) + of TEXTSTREAM)) + (fetch (PIECE PPARALAST) of (fetch (PIECE PREVPIECE) + of (fetch + (STREAM F5) + of TEXTSTREAM)) + ) + (IEQP (fetch (STREAM FW6) of TEXTSTREAM) + (fetch (STREAM CPAGE) of TEXTSTREAM)) + (IEQP (fetch (STREAM FW7) of TEXTSTREAM) + (fetch (STREAM COFFSET) of TEXTSTREAM] + (replace (LINEDESCRIPTOR 1STLN) of LINE with 1STLN) + [SETQ TX (SETQ TXB (replace (LINEDESCRIPTOR LEFTMARGIN) of LINE + with (COND + (1STLN (fetch (FMTSPEC 1STLEFTMAR) of + FMTSPEC)) + (T (fetch (FMTSPEC LEFTMAR) of FMTSPEC] + [replace (LINEDESCRIPTOR RIGHTMARGIN) of LINE + with (SETQ WIDTH (COND + ((NOT (ZEROP (fetch (FMTSPEC RIGHTMAR) of FMTSPEC) + )) + (fetch (FMTSPEC RIGHTMAR) of FMTSPEC)) + (T WIDTH] + (SETQ TXB1 WIDTH))) + [COND + ((ZEROP (freplace (LINEDESCRIPTOR LHEIGHT) of LINE with (IPLUS ASCENT + DESCENT))) + (replace (LINEDESCRIPTOR LHEIGHT) of LINE + with (FONTPROP (OR (AND (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) + (fetch (CHARLOOKS CLFONT) of (fetch + (TEXTOBJ + DEFAULTCHARLOOKS + ) + of TEXTOBJ)) + ) + DEFAULTFONT) + 'HEIGHT] (* ; + "Line's height (or 12 for an empty line)") + (replace (LINEDESCRIPTOR ASCENT) of LINE with ASCENT) + (replace (LINEDESCRIPTOR DESCENT) of LINE with DESCENT) + (freplace (LINEDESCRIPTOR CHARTOP) of LINE with CHNO) + (COND + (FORCEEND NIL) + (T (SETQ CHNO (SUB1 CHNO)) + (SETQ TLEN (SUB1 TLEN)) + (SETQ TXB1 TX))) (* ; + "If we ran off the end of the text, then keep true space left on the line.") + (freplace (LINEDESCRIPTOR LXLIM) of LINE with TX) + (freplace DESC of THISLINE with LINE) + [freplace (THISLINE LEN) of THISLINE + with (IMIN 254 (COND + ((ILESSP TEXTLEN CH#1) + -1) + (T (IPLUS LOOKNO (IDIFFERENCE (IMIN (fetch (LINEDESCRIPTOR + CHARLIM) + of LINE) + TEXTLEN) + (IPLUS INVISIBLERUNS (fetch + (LINEDESCRIPTOR + CHAR1) of + LINE] + (freplace (LINEDESCRIPTOR SPACELEFT) of LINE with (IDIFFERENCE WIDTH TXB1)) + (\DOFORMATTING.HARDCOPY TEXTOBJ LINE FMTSPEC THISLINE %#BLANKS PREVSP 1STLN) + (replace (LINEDESCRIPTOR LFMTSPEC) of LINE with FMTSPEC) + (replace LOOKSUPDATEFN of TEXTSTREAM with NIL) + (RETURN CTRL\L\SEEN]) + +(\DOFORMATTING.HARDCOPY + [LAMBDA (TEXTOBJ LINE FMTSPEC THISLINE %#BLANKS PREVSP 1STLN) + (* ; "Edited 29-Mar-94 16:30 by jds") + (* ; + "Do the formatting work for justified, centered, etc. lines") + (PROG ((QUAD (fetch QUAD of FMTSPEC)) + (SPACELEFT (fetch (LINEDESCRIPTOR SPACELEFT) of LINE)) + (EXISTINGSPACE 0) + (CHLIST (fetch (THISLINE CHARS) of THISLINE)) + (WLIST (fetch (THISLINE WIDTHS) of THISLINE)) + (SPACEOFLOW 0) + EXTRASP OPREVSP LINELEAD) (* ; + "NB that SPACELEFT, OFLOW, etc. are kept in 32 x value form, for rounding ease.") + (replace (LINEDESCRIPTOR LTRUEDESCENT) of LINE with (fetch (LINEDESCRIPTOR + DESCENT) + of LINE)) + (replace (LINEDESCRIPTOR LTRUEASCENT) of LINE with (fetch (LINEDESCRIPTOR + ASCENT) + of LINE)) + (* ; + "Save the true ascent value for display purposes") + (replace (THISLINE TLSPACEFACTOR) of THISLINE with 1) + (* ; + "Start by assuming that we want a space factor of 1.0") + [COND + ((SETQ LINELEAD (fetch LINELEAD of FMTSPEC)) + (* ; + "If line leading was specified, set it") + (COND + (T (add (fetch (LINEDESCRIPTOR LHEIGHT) of LINE) + (fetch LINELEAD of FMTSPEC)) + (* ; + "And adjust the line's descent accordingly") + (add (fetch (LINEDESCRIPTOR DESCENT) of LINE) + (fetch LINELEAD of FMTSPEC] + [COND + ((AND 1STLN (fetch LEADBEFORE of FMTSPEC)) + (* ; + "If paragraph pre-leading was specified, set it") + (add (fetch (LINEDESCRIPTOR LHEIGHT) of LINE) + (fetch LEADBEFORE of FMTSPEC)) (* ; + "And adjust the line's ascent accordingly.") + (add (fetch (LINEDESCRIPTOR ASCENT) of LINE) + (fetch LEADBEFORE of FMTSPEC] + [COND + ((AND (fetch (LINEDESCRIPTOR LSTLN) of LINE) + (fetch LEADAFTER of FMTSPEC)) (* ; + "If paragraph pre-leading was specified, set it") + (add (fetch (LINEDESCRIPTOR LHEIGHT) of LINE) + (fetch LEADAFTER of FMTSPEC)) (* ; + "And adjust the line's ascent accordingly.") + (add (fetch (LINEDESCRIPTOR DESCENT) of LINE) + (fetch LEADAFTER of FMTSPEC] + (SELECTQ QUAD + (LEFT (* ; + "Do nothing for left-justified lines except replace the character codes")) + (RIGHT (* ; "Just move the right margin over") + (replace (LINEDESCRIPTOR LEFTMARGIN) of LINE + with (IPLUS (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE) + (fetch (LINEDESCRIPTOR SPACELEFT) of LINE))) + (replace (LINEDESCRIPTOR LXLIM) of LINE with (fetch ( + LINEDESCRIPTOR + RIGHTMARGIN + ) + of LINE)) + (COND + ((OR (ILESSP (fetch (THISLINE LEN) of THISLINE) + 0) + (ZEROP %#BLANKS) + (ZEROP PREVSP)) (* ; + "For empty lines, and lines with no spaces, don't bother fixing blank widths.") + (RETURN)))) + (CENTERED (* ; + "Split the difference for centering") + (add (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE) + (LRSH SPACELEFT 1)) + (add (fetch (LINEDESCRIPTOR LXLIM) of LINE) + (LRSH SPACELEFT 1)) + (COND + ((OR (ILESSP (fetch (THISLINE LEN) of THISLINE) + 0) + (ZEROP %#BLANKS) + (ZEROP PREVSP)) (* ; + "For empty lines, and lines with no spaces, don't bother fixing blank widths.") + (RETURN)))) + (JUSTIFIED (* ; + "For justified lines, stretch each space so line reaches the right margin") + (COND + ((OR (ILESSP (fetch (THISLINE LEN) of THISLINE) + 0) + (ZEROP %#BLANKS) + (ZEROP PREVSP)) (* ; + "For empty lines, and lines with no spaces, don't bother fixing blank widths.") + (RETURN))) + (COND + ((OR (fetch (LINEDESCRIPTOR CR\END) of LINE) + (IGEQ (fetch (LINEDESCRIPTOR CHARLIM) of LINE) + (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) + (* ; + "This is the last line in the paragraph; don't stretch it out.") + (SETQ EXTRASP 0)) + ((IEQP PREVSP (ADD1 (fetch (THISLINE LEN) of THISLINE))) + (* ; + "Only if the last character on the line is a space should we remove trailing spaces from the list") + (bind (OPREVSP _ (SUB1 PREVSP)) while (AND (IGREATERP PREVSP 0) + (ILEQ OPREVSP PREVSP) + ) + do + + (* ;; "Back up over all trailing white space on the line. So that those blanks don't get counted when computing the space to be added to each REAL space on the line, when it is justified.") + + (SETQ OPREVSP (SUB1 PREVSP)) + (SETQ PREVSP (\EDITELT CHLIST OPREVSP)) + (\EDITSETA CHLIST OPREVSP (CONSTANT (CHARCODE SPACE))) + (add %#BLANKS -1)) + (COND + ((ZEROP %#BLANKS) (* ; + "If there aren't any blanks except at end-of-line, don't bother going further.") + (RETURN))) + (replace (LINEDESCRIPTOR LXLIM) of LINE + with (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE)) + (* ; + "Fix the right margin for showing selections &c") + (SETQ EXTRASP (IQUOTIENT SPACELEFT %#BLANKS)) + (* ; + "Now apportion the extra space evenly among blanks.") + ) + (T + (* ;; + "NO SPACE AT END OF LINE -- LINE ENDS IN HYPHEN, ETC, OR MAYBE IS TOO LONG WITH NO SPACES.") + + (COND + ((ZEROP %#BLANKS) (* ; + "If there aren't any blanks except at end-of-line, don't bother going further.") + (RETURN))) + (replace (LINEDESCRIPTOR LXLIM) of LINE + with (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE)) + (* ; + "Fix the right margin for showing selections &c") + (SETQ EXTRASP (IQUOTIENT SPACELEFT %#BLANKS)) + (* ; + "Now apportion the extra space evenly among blanks.") + )) + (bind (SP _ PREVSP) while (IGREATERP SP 0) + do (* ; + "Fix up the widths of spaces in the line") + (SETQ OPREVSP (SUB1 SP)) + (SETQ SP (\EDITELT CHLIST OPREVSP)) + (add EXISTINGSPACE (\EDITELT WLIST OPREVSP))) + [while (IGREATERP PREVSP 0) + do (* ; + "Fix up the widths of spaces in the line") + (SETQ OPREVSP (SUB1 PREVSP)) + (SETQ PREVSP (\EDITELT CHLIST OPREVSP)) + (\EDITSETA CHLIST OPREVSP (CONSTANT (CHARCODE SPACE))) + (OR (fetch (LINEDESCRIPTOR CR\END) of LINE) + (\EDITSETA WLIST OPREVSP (FIXR (FTIMES (\EDITELT WLIST OPREVSP) + (FPLUS 1.0 + (FQUOTIENT + SPACELEFT + EXISTINGSPACE + ] + (COND + ((AND (NOT (ZEROP EXISTINGSPACE)) + (NOT (ZEROP EXTRASP))) (* ; "Only if we really expanded the line -- and there are spaces to expand (or else EXISTINGSPACE is 0).") + (replace (THISLINE TLSPACEFACTOR) of THISLINE + with (FQUOTIENT (IPLUS EXISTINGSPACE (fetch (LINEDESCRIPTOR + SPACELEFT) + of LINE)) + EXISTINGSPACE)) + (* ; + "And set the space factor for display") + ) + (T (* ; "Pathological cases ") + (replace (THISLINE TLSPACEFACTOR) of THISLINE with 1))) + (RETURN)) + NIL) + (\TEDIT.PURGE.SPACES CHLIST PREVSP) (* ; +"Change all the spaces--chained for justification--back into regular spaces, for the display code.") + ]) + +(\TEDIT.HARDCOPY.MODIFYLOOKS + [LAMBDA (LINE STARTX CURX CURY LOOKS PRSTREAM) (* ; "Edited 30-May-91 21:17 by jds") + + (* ;; "Do underlining, overlining, etc. for hardcopy files") + + [PROG ((STREAMSCALE (DSPSCALE NIL PRSTREAM)) + [RULEWIDTH (FIXR (FTIMES 0.75 (DSPSCALE NIL PRSTREAM] + (ONEPOINT (FIXR (DSPSCALE NIL PRSTREAM))) + YOFFSET) + (COND + ((fetch (CHARLOOKS CLULINE) of LOOKS) (* ; "It's underlined.") + (DRAWLINE STARTX (IDIFFERENCE (fetch (LINEDESCRIPTOR YBASE) of LINE) + (fetch (LINEDESCRIPTOR LTRUEDESCENT) of LINE)) + CURX + (IDIFFERENCE (fetch (LINEDESCRIPTOR YBASE) of LINE) + (fetch (LINEDESCRIPTOR LTRUEDESCENT) of LINE)) + RULEWIDTH + 'PAINT PRSTREAM) (* ; "A 1/2-pt underline") + )) + (COND + ((fetch (CHARLOOKS CLOLINE) of LOOKS) (* ; "Over-line") + (DRAWLINE STARTX (IPLUS (fetch (LINEDESCRIPTOR YBASE) of LINE) + (fetch (LINEDESCRIPTOR LTRUEASCENT) of LINE)) + CURX + (IPLUS (fetch (LINEDESCRIPTOR YBASE) of LINE) + (fetch (LINEDESCRIPTOR LTRUEASCENT) of LINE)) + RULEWIDTH + 'PAINT PRSTREAM))) + (COND + ((fetch (CHARLOOKS CLSTRIKE) of LOOKS) (* ; "Struch-thru") + (DRAWLINE STARTX (SETQ YOFFSET (IPLUS (fetch (LINEDESCRIPTOR YBASE) of LINE) + (IQUOTIENT + [FIXR (FTIMES STREAMSCALE + (FONTPROP (fetch (CHARLOOKS + CLFONT) + of LOOKS) + 'ASCENT] + 3))) + CURX YOFFSET RULEWIDTH 'PAINT PRSTREAM] + (MOVETO CURX CURY PRSTREAM]) + +(\TEDIT.HCPYLOOKS.UPDATE + [LAMBDA (STREAM PC NLOOKS) (* ; + "Edited 3-Jul-93 20:12 by sybalskY:MV:ENVOS") + + (* ;; "At a piece boundary, update the line formatting fields ASCENT, DESCENT, and FONTWIDTHS") + + (* ;; "Also, KERN, if USERPROPS has a KERN entry.") + + (DECLARE (USEDFREE LOOKS ASCENT DESCENT FONTWIDTHS FONT INVISIBLERUNS CHNO TLEN LOOKNO CHLIST + WLIST DEVICE NEWASCENT NEWDESCENT KERN IMAGESTREAM)) + (COND + (PC (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) + TLOOKS TEMP NEWPC OFFSET PARALOOKS PREVPC NEWKERN) + [COND + ([OR (NOT (fetch (PIECE PREVPIECE) of PC)) + (NEQ (fetch (PIECE PPARALOOKS) of PC) + (fetch (PIECE PPARALOOKS) of (fetch (PIECE PREVPIECE) + of PC] + (* ; +"The paragraph looks have changed between the last piece and this one. Take account of the change") + (SETQ PARALOOKS (\TEDIT.APPLY.PARASTYLES (fetch (PIECE PPARALOOKS) + of PC) + PC TEXTOBJ)) + (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with PARALOOKS)) + (T (SETQ PARALOOKS (fetch (TEXTSTREAM CURRENTPARALOOKS) of STREAM] + (SETQ TLOOKS (OR NLOOKS (\TEDIT.APPLY.STYLES (ffetch (PIECE PLOOKS) of + PC) + PC TEXTOBJ))) + (COND + ((fetch (CHARLOOKS CLINVISIBLE) of TLOOKS) + (* ; + "We've hit a run of invisible characters. Skip them, and insert a marker in the line cache") + (add LOOKNO 1) (* ; + "Fix the counter of charlooks changes") + (\EDITSETA LOOKS LOOKNO (fetch (PIECE PLEN) of PC)) + (\RPLPTR CHLIST 0 LMInvisibleRun) + (\RPLPTR WLIST 0 0) + (add TLEN 1) + (SETQ CHLIST (\ADDBASE CHLIST 2)) + (SETQ WLIST (\ADDBASE WLIST 2)) + (SETQ PREVPC PC) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) + (COND + ((NEQ (fetch (PIECE PPARALOOKS) of PC) + (fetch (PIECE PPARALOOKS) of PREVPC)) + (SETQ PARALOOKS (\TEDIT.APPLY.PARASTYLES (fetch (PIECE PPARALOOKS) + of PC) + PC TEXTOBJ)) + (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with PARALOOKS) + )) + (SETQ TLOOKS (AND PC (\TEDIT.APPLY.STYLES (ffetch (PIECE PLOOKS) + of PC) + PC TEXTOBJ))) + [while (AND PC (OR (ZEROP (fetch (PIECE PLEN) of PC)) + (fetch (CHARLOOKS CLINVISIBLE) of TLOOKS))) + do (\EDITSETA LOOKS LOOKNO (IPLUS (fetch (PIECE PLEN) of PC) + (\EDITELT LOOKS LOOKNO))) + (SETQ PREVPC PC) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) + (COND + ((AND PC (NEQ (fetch (PIECE PPARALOOKS) of PC) + (fetch (PIECE PPARALOOKS) of PREVPC))) + (* ; + "If there IS new text, and the paragraph looks have changed, update the streams notion of them.") + (SETQ PARALOOKS (\TEDIT.APPLY.PARASTYLES (fetch (PIECE + PPARALOOKS + ) + of PC) + PC TEXTOBJ)) + (* ; + "And take care of style sheets on the way.") + (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM + with PARALOOKS))) + (SETQ TLOOKS (AND PC (\TEDIT.APPLY.STYLES (ffetch (PIECE PLOOKS) + of PC) + PC TEXTOBJ] + (add CHNO (\EDITELT LOOKS LOOKNO)) + (add INVISIBLERUNS (\EDITELT LOOKS LOOKNO)) + (SETQ NEWPC PC))) + (COND + ([AND PC (OR NLOOKS (NOT (EQCLOOKS TLOOKS (fetch (TEXTSTREAM CURRENTLOOKS) + of STREAM] + (replace (TEXTSTREAM CURRENTLOOKS) of STREAM with TLOOKS) + (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with PARALOOKS) + (SETQ FONT (fetch (CHARLOOKS CLFONT) of TLOOKS)) + [SETQ FONT (COND + ((AND (type? FONTCLASS FONT) + (FONTCLASSCOMPONENT FONT DEVICE))) + (T (FONTCOPY FONT 'DEVICE DEVICE] + (SETQ OFFSET (OR [AND (fetch (CHARLOOKS CLOFFSET) of TLOOKS) + (FIXR (FTIMES (DSPSCALE NIL DEVICE) + (fetch (CHARLOOKS CLOFFSET) of TLOOKS + ] + 0)) + (SETQ NEWASCENT (IMAX ASCENT (IPLUS (fetch \SFAscent of FONT) + OFFSET))) + (SETQ NEWDESCENT (IMAX DESCENT (IDIFFERENCE (fetch \SFDescent of FONT) + OFFSET))) + (SETQ NEWKERN (LISTGET (fetch (CHARLOOKS CLUSERINFO) of TLOOKS) + 'KERN)) + (COND + [NEWKERN (SETQ KERN (FIXR (FTIMES (DSPSCALE NIL DEVICE) + NEWKERN] + (T (SETQ KERN NIL))) + (COND + ((NOT NLOOKS) + + (* ;; "If we're calling this to initialize values, don't go and update the running cache. However, since NLOOKS is NIL, we're not initializing, so go to it!") + + (add LOOKNO 1) (* ; + "Fix the counter of charlooks changes") + (\EDITSETA LOOKS LOOKNO TLOOKS) (* ; + "Save the new looks for selection/display") + (\RPLPTR CHLIST 0 LMLooksChange) (* ; + "Put a marker in the character list to denote a looks change") + (\RPLPTR WLIST 0 0) (* ; "Font changes have no width") + (add TLEN 1) + (SETQ CHLIST (\ADDBASE CHLIST 2)) + (SETQ WLIST (\ADDBASE WLIST 2)) (* ; + "Account for the dummy marker/looks in TLEN") + )) + (SETQ NEWPC PC)) + ((NOT (OR PC NLOOKS)) (* ; +"We have run off the end of the document. Bail out so that \TEDIT.HARDCOPY.FORMATLINE doesn't die") + (RETFROM '\BIN NIL))) + (OR NEWPC (SETQ NEWPC PC)) + [COND + ((AND (fetch (PIECE POBJ) of NEWPC) + (NEQ (fetch (PIECE PLEN) of NEWPC) + 1)) (* ; + "If this piece is for an object, check for a length mismatch") + (COND + ((IMAGEOBJPROP (fetch (PIECE POBJ) of NEWPC) + 'SUBSTREAM)) + (T + (* ;; "The object is several chars wide, but doesn't have a subsidiary stream to pull those chars from. Build an invisible run to fill the space.") + + (add LOOKNO 1) (* ; + "Fix the counter of charlooks changes") + (\EDITSETA LOOKS LOOKNO (SUB1 (fetch (PIECE PLEN) of PC))) + (\RPLPTR CHLIST 0 LMInvisibleRun) (* ; + "Note the existence of an invisible run of characters here.") + (\RPLPTR WLIST 0 0) + (add TLEN 1) + (SETQ CHLIST (\ADDBASE CHLIST 2)) + (SETQ WLIST (\ADDBASE WLIST 2)) + (add CHNO (\EDITELT LOOKS LOOKNO)) + (add INVISIBLERUNS (\EDITELT LOOKS LOOKNO)) + (* ; + "Keep track of how much invisible text we cross over") + ] + (RETURN NEWPC]) + +(\TEDIT.HCPYFMTSPEC + [LAMBDA (SPEC IMAGESTREAM) (* ; "Edited 30-May-91 21:18 by jds") + + (* ;; "Given a display-type FMTSPEC, create a hardcopy equivalent. (Special positions are made paper-relative first.)") + + (PROG ((SCALEFACTOR (DSPSCALE NIL IMAGESTREAM))) + (RETURN (create FMTSPEC using + SPEC 1STLEFTMAR _ (FIXR (FTIMES (fetch (FMTSPEC 1STLEFTMAR) + of SPEC) + SCALEFACTOR)) + LEFTMAR _ (FIXR (FTIMES (fetch (FMTSPEC LEFTMAR) + of SPEC) + SCALEFACTOR)) + RIGHTMAR _ (FIXR (FTIMES (fetch (FMTSPEC RIGHTMAR) + of SPEC) + SCALEFACTOR)) + LEADBEFORE _ (FIXR (FTIMES (fetch (FMTSPEC LEADBEFORE) + of SPEC) + SCALEFACTOR)) + LEADAFTER _ (FIXR (FTIMES (fetch (FMTSPEC LEADAFTER) + of SPEC) + SCALEFACTOR)) + LINELEAD _ (FIXR (FTIMES (fetch (FMTSPEC LINELEAD) + of SPEC) + SCALEFACTOR)) + FMTBASETOBASE _ (AND (fetch (FMTSPEC FMTBASETOBASE) + of SPEC) + (FIXR (FTIMES (fetch (FMTSPEC + FMTBASETOBASE + ) + of SPEC) + SCALEFACTOR))) + QUAD _ (fetch (FMTSPEC QUAD) of SPEC) + TABSPEC _ + [CONS (AND (CAR (fetch (FMTSPEC TABSPEC) of SPEC)) + (FIXR (FTIMES (CAR (fetch (FMTSPEC TABSPEC) + of SPEC)) + SCALEFACTOR))) + (for TAB in (CDR (fetch (FMTSPEC TABSPEC) + of SPEC)) + collect (CONS (FIXR (FTIMES SCALEFACTOR + (CAR TAB))) + (CDR TAB] + FMTSPECIALX _ (AND (fetch (FMTSPEC FMTSPECIALX) + of SPEC) + (FIXR (FTIMES (SCALEPAGEUNITS + (fetch (FMTSPEC + FMTSPECIALX + ) + of SPEC) + 1.0 NIL) + SCALEFACTOR))) + FMTSPECIALY _ (AND (fetch (FMTSPEC FMTSPECIALY) + of SPEC) + (FIXR (FTIMES (SCALEPAGEUNITS + (fetch (FMTSPEC + FMTSPECIALY + ) + of SPEC) + 1.0 NIL) + SCALEFACTOR]) + +(\TEDIT.INTEGER.IMAGEBOX + (LAMBDA (OLDBOX) (* jds "23-Oct-84 13:52") + + (* Take an IMAGEBOX, and assure that its contents are integers) + + (replace XKERN of OLDBOX with (FIXR (fetch XKERN of OLDBOX))) + (replace YDESC of OLDBOX with (FIXR (fetch YDESC of OLDBOX))) + (replace YSIZE of OLDBOX with (FIXR (fetch YSIZE of OLDBOX))) + (replace XSIZE of OLDBOX with (FIXR (fetch XSIZE of OLDBOX))) + OLDBOX)) +) + + + +(* ;; "Functions for scaling distances and regions as needed during hardcopy.") + +(DEFINEQ + +(\TEDIT.SCALE + [LAMBDA (VALUE SCALEFACTOR) (* ; "Edited 2-Jan-87 12:11 by jds") + +(* ;;; "Scale VALUE by SCALEFACTOR, and round it to the nearest integer. Used for scaling distances, etc. during hardcopy.") + + (FIXR (FTIMES VALUE SCALEFACTOR]) + +(\TEDIT.SCALEREGION + [LAMBDA (REGION SCALEFACTOR) (* ; "Edited 2-Jan-87 12:13 by jds") + +(* ;;; "Scale the region REGION by SCALEFACTOR, rounding all the dimensions to integers. Used to scale page-boundary regions during hardcopy.") + + (create REGION + LEFT _ (\TEDIT.SCALE (fetch (REGION LEFT) of REGION) + SCALEFACTOR) + BOTTOM _ (\TEDIT.SCALE (fetch (REGION BOTTOM) of REGION) + SCALEFACTOR) + WIDTH _ (\TEDIT.SCALE (fetch (REGION WIDTH) of REGION) + SCALEFACTOR) + HEIGHT _ (\TEDIT.SCALE (fetch (REGION HEIGHT) of REGION) + SCALEFACTOR]) +) + + + +(* ;; "PRESS-specific code") + + +(RPAQ TEDIT.DEFAULTPAGEREGION (CREATEREGION 2794 1905 16256 23495)) + + + +(* ; "0.75 inches from bottom, 1 from top") + + + + +(* ;; "Support for the window-menu's HARDCOPY button, LISTFILES, etc.") + +(DEFINEQ + +(TEDIT.HARDCOPYFN + [LAMBDA (WINDOW IMAGESTREAM) (* ; "Edited 12-Jun-90 18:35 by mitani") + + (* ;; + "This is the TEdit HARDCOPYFN, hooking into the system's standard Hardcopy window-menu operation.") + + (PROG ((TEXTOBJ (TEXTOBJ WINDOW)) + (TEXTSTREAM (TEXTSTREAM WINDOW))) + + (* ;; "TEXTSTREAM is bound here so we don't drop the steam on the floor if the window goes away, since the TEXTOBJ only has an XPOINTER to the stream in it. Please don't remove this binding!") + + (RESETLST + [RESETSAVE (\TEDIT.MARKACTIVE TEXTOBJ) + '(AND (\TEDIT.MARKINACTIVE OLDVALUE] + (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with 'Hardcopy) + (TEDIT.FORMAT.HARDCOPY TEXTOBJ IMAGESTREAM))) (* ; "Build the hardcopy") + ]) + +(\TEDIT.HARDCOPY + [LAMBDA (FILE PFILE) (* ; "Edited 12-Jun-90 18:35 by mitani") + + (* ;; "Send the document FILE to the printer (or to a print file, as determined by PFILE).") + + (CL:WITH-OPEN-STREAM [TEXT-STREAM (OPENTEXTSTREAM (COND + ((STRINGP FILE) + (MKATOM FILE)) + (T FILE] + (RESETLST + [RESETSAVE (\TEDIT.MARKACTIVE (TEXTOBJ TEXT-STREAM)) + '(AND (\TEDIT.MARKINACTIVE OLDVALUE] + [RESETSAVE NIL `(AND (CLOSEF? ',PFILE] + (replace (TEXTOBJ EDITOPACTIVE) of (TEXTOBJ TEXT-STREAM) with 'Hardcopy) + (TEDIT.FORMAT.HARDCOPY TEXT-STREAM PFILE T NIL NIL NIL 'INTERPRESS) + PFILE)]) + +(\TEDIT.PRESS.HARDCOPY + [LAMBDA (FILE PFILE) (* ; "Edited 12-Jun-90 18:36 by mitani") + (* Send the text to the printer.) + [SETQ FILE (OPENTEXTSTREAM (COND + ((STRINGP FILE) + (MKATOM FILE)) + (T FILE] + (RESETLST + [RESETSAVE (\TEDIT.MARKACTIVE (TEXTOBJ FILE)) + '(AND (\TEDIT.MARKINACTIVE OLDVALUE] + (replace (TEXTOBJ EDITOPACTIVE) of (TEXTOBJ FILE) with 'Hardcopy) + (TEDIT.FORMAT.HARDCOPY FILE PFILE T NIL NIL NIL 'PRESS) + (CLOSEF? PFILE) + PFILE)]) +) + +(LISTPUT (ASSOC (QUOTE CONVERSION) (ASSOC (QUOTE INTERPRESS) PRINTFILETYPES)) (QUOTE TEDIT) (FUNCTION \TEDIT.HARDCOPY)) + +(LET ((PRESSVALUES (ASSOC (QUOTE CONVERSION) (ASSOC (QUOTE PRESS) PRINTFILETYPES)))) (COND (PRESSVALUES (* ; "Only install PRESS printing if PRESS is loaded.") (LISTPUT PRESSVALUES (QUOTE TEDIT) (FUNCTION \TEDIT.PRESS.HARDCOPY))))) + + + +(* ;; "vars for Japanese Line Break") + + +(RPAQQ TEDIT.DONT.BREAK.CHARS (8482 8483 8491 8492 8508 8525 8539 8537 8535 9249 9251 9253 9255 9257 9283 9315 9317 9319 9326 9505 9507 9509 9511 9513 9539 9571 9573 9575 9582) +) + +(RPAQQ TEDIT.DONT.LAST.CHARS (8524 8538 8536 8534)) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS TEDIT.DONT.BREAK.CHARS TEDIT.DONT.LAST.CHARS) +) + + + +(* ;; "Support for hardcopying several files as one document") + +(DEFINEQ + +(TEDIT-BOOK + [LAMBDA (FILES DIRECTORY PRINT-FILE DONT-SEND) (* ; "Edited 22-Mar-93 23:55 by jds") + (LET ((DOC (OPENTEXTSTREAM (MKATOM (CAR FILES)) + NIL))) + + (* ;; "Gather all the files into one document:") + + (for FILE in (CDR FILES) do (TEDIT.SETSEL DOC 1 (fetch (TEXTOBJ TEXTLEN) + of (TEXTOBJ DOC)) + 'RIGHT NIL NIL) + (TEDIT.INCLUDE DOC (PACK* (OR DIRECTORY "") + FILE))) + (* ; "Set page layout") + (TEDIT.FORMAT.HARDCOPY DOC PRINT-FILE DONT-SEND NIL NIL NIL NIL NIL) + (CLOSEF DOC]) +) +(PUTPROPS TEDITHCPY COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 +1991 1992 1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (2353 99050 (TEDIT.HARDCOPY 2363 . 3614) (TEDIT.HCPYFILE 3616 . 5690) ( +\TEDIT.HARDCOPY.DISPLAYLINE 5692 . 19837) (\TEDIT.HARDCOPY.FORMATLINE 19839 . 67140) ( +\DOFORMATTING.HARDCOPY 67142 . 80435) (\TEDIT.HARDCOPY.MODIFYLOOKS 80437 . 82844) ( +\TEDIT.HCPYLOOKS.UPDATE 82846 . 93454) (\TEDIT.HCPYFMTSPEC 93456 . 98476) (\TEDIT.INTEGER.IMAGEBOX +98478 . 99048)) (99139 100223 (\TEDIT.SCALE 99149 . 99443) (\TEDIT.SCALEREGION 99445 . 100221)) ( +100466 102963 (TEDIT.HARDCOPYFN 100476 . 101327) (\TEDIT.HARDCOPY 101329 . 102238) ( +\TEDIT.PRESS.HARDCOPY 102240 . 102961)) (103772 104675 (TEDIT-BOOK 103782 . 104673))))) +STOP diff --git a/library/TEDITHISTORY b/library/TEDITHISTORY new file mode 100644 index 00000000..895f1763 --- /dev/null +++ b/library/TEDITHISTORY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "29-Jan-99 17:34:39" {DSK}sybalsky>lispcore3.0>library>TEDITHISTORY.;2 38471 changes to%: (FNS TEDIT.UNDO.INSERTION TEDIT.REDO.INSERTION TEDIT.UNDO.DELETION) previous date%: "25-Aug-94 10:54:22" {DSK}sybalsky>lispcore3.0>library>TEDITHISTORY.;1 ) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1990, 1991, 1993, 1994, 1999 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDITHISTORYCOMS) (RPAQQ TEDITHISTORYCOMS ((FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (GLOBALVARS TEDIT.HISTORY.TYPELST TEDIT.HISTORYLST) (INITVARS (TEDIT.HISTORY.TYPELST NIL) (TEDIT.HISTORYLST NIL)) (COMS (* ;; "History-list maintenance functions") (FNS \TEDIT.HISTORYADD \TEDIT.CUMULATE.EVENTS)) (COMS (* ;; "Specialized UNDO & REDO functions.") (FNS TEDIT.UNDO TEDIT.UNDO.INSERTION TEDIT.UNDO.DELETION TEDIT.REDO TEDIT.REDO.INSERTION TEDIT.UNDO.MOVE TEDIT.UNDO.REPLACE TEDIT.REDO.REPLACE TEDIT.REDO.MOVE)))) (FILESLOAD TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SCRATCHLEN 64) (CONSTANTS (\SCRATCHLEN 64)) ) (FILESLOAD (LOADCOMP) TEDITDCL) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.HISTORY.TYPELST TEDIT.HISTORYLST) ) (RPAQ? TEDIT.HISTORY.TYPELST NIL) (RPAQ? TEDIT.HISTORYLST NIL) (* ;; "History-list maintenance functions") (DEFINEQ (\TEDIT.HISTORYADD [LAMBDA (TEXTOBJ EVENT) (* ; "Edited 3-Sep-87 10:36 by jds") (* ;; "Add a new event to the history list. For now, this just re-sets the whole list to be the one event...") (* ;;  "This function also takes care of cumulating cumulative events, like successive deletions.") (LET* ((OLDEVENT (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)) (ETYPE (fetch (TEDITHISTORYEVENT THACTION) of EVENT)) (OETYPE (fetch (TEDITHISTORYEVENT THACTION) of OLDEVENT)) (REALEVENT EVENT)) [COND ((AND OLDEVENT (EQ OETYPE ETYPE) (EQ ETYPE 'Delete)) (* ;  "Repeated successive deletions. See if we can combine them.") (LET* [(OSTART (fetch (TEDITHISTORYEVENT THCH#) of OLDEVENT)) (NSTART (fetch (TEDITHISTORYEVENT THCH#) of EVENT)) (OLDEND (+ OSTART (fetch (TEDITHISTORYEVENT THLEN) of OLDEVENT))) (NEWEND (+ NSTART (fetch (TEDITHISTORYEVENT THLEN) of EVENT] (COND ((IEQP OLDEND NSTART) (* ;  "The old deletion was just in front of the current one; cumulate them.") (SETQ REALEVENT (\TEDIT.CUMULATE.EVENTS OLDEVENT EVENT T))) ((IEQP NEWEND OSTART) (* ;  "The new deletion was just in front of the old one; cumulate them.") (SETQ REALEVENT (\TEDIT.CUMULATE.EVENTS EVENT OLDEVENT T] (replace (TEXTOBJ TXTHISTORY) of TEXTOBJ with REALEVENT]) (\TEDIT.CUMULATE.EVENTS [LAMBDA (EVENT1 EVENT2 PIECES-TO-SAVE?) (* ; "Edited 3-Sep-87 10:42 by jds") (* ;; "Accumulate history events that should really be combined into a single event.") (* ;; "For now, this assumes they're events of the same type. Actually, this should be able to cumulate a delete/insert pair into a replacement, etc.") (LET* [(OLDLEN (fetch (TEDITHISTORYEVENT THLEN) of EVENT1)) (NEWPC1 (fetch (TEDITHISTORYEVENT THFIRSTPIECE) of EVENT2)) (REALEVENT (create TEDITHISTORYEVENT using EVENT1 THLEN _ (+ OLDLEN (fetch ( TEDITHISTORYEVENT THLEN) of EVENT2] (bind (PC _ (fetch (TEDITHISTORYEVENT THFIRSTPIECE) of EVENT1)) (CHCOUNT _ 0) while (< (SETQ CHCOUNT (+ CHCOUNT (fetch (PIECE PLEN) of PC))) OLDLEN) do (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) finally (replace (PIECE NEXTPIECE) of PC with NEWPC1) (replace (PIECE PREVPIECE) of NEWPC1 with PC) (RETURN)) REALEVENT]) ) (* ;; "Specialized UNDO & REDO functions.") (DEFINEQ (TEDIT.UNDO [LAMBDA (TEXTOBJ) (* ; "Edited 12-Jun-90 18:41 by mitani") (* ;; "Undo the last thing this guy did.") (COND ((NOT (FETCH (TEXTOBJ TXTREADONLY) OF TEXTOBJ)) (* ;; "Only undo things if the document is allowed to change.") (PROG ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) EVENT CH# LEN FIRSTPIECE) (COND ((SETQ EVENT (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)) (* ;  "There really is something to UNDO. Decide what, & fix it.") (SETQ LEN (fetch THLEN of EVENT)) (* ;  "Length of the text that was inserted/deleted/changed") (SETQ CH# (fetch THCH# of EVENT)) (* ; "Starting CH# of the change") (SETQ FIRSTPIECE (fetch THFIRSTPIECE of EVENT)) (* ;  "First piece affected by the change") (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) (\SHOWSEL SEL NIL NIL) [SELECTQ (fetch THACTION of EVENT) ((Insert Copy Include) (* ; "It was an insertion") (TEDIT.UNDO.INSERTION TEXTOBJ EVENT LEN CH# FIRSTPIECE)) (Delete (* ; "It was a deletion") (TEDIT.UNDO.DELETION TEXTOBJ EVENT LEN CH# FIRSTPIECE)) (Looks (* ; "It was a character-looks change") (TEDIT.UNDO.LOOKS TEXTOBJ EVENT LEN CH# FIRSTPIECE)) (ParaLooks (* ; "It was a PARA looks change") (TEDIT.UNDO.PARALOOKS TEXTOBJ EVENT LEN CH# FIRSTPIECE)) (Move (TEDIT.UNDO.MOVE TEXTOBJ EVENT LEN CH# FIRSTPIECE) (* ; "He moved some text") ) ((Replace LowerCase UpperCase) (* ;; "He replaced one piece of text with another ; Lower-casing and upper-casing have the same undo event.") (TEDIT.UNDO.REPLACE TEXTOBJ EVENT LEN CH# FIRSTPIECE)) (Get (* ; "He did a GET -- not undoable.") (TEDIT.PROMPTPRINT TEXTOBJ "You can't UNDO a GET." T)) (Put (* ; "He did a PUT -- not undoable.") (TEDIT.PROMPTPRINT TEXTOBJ "You can't UNDO a Put." T)) (COND ((AND (SETQ UNDOFN (ASSOC (fetch THACTION of EVENT) TEDIT.HISTORY.TYPELST)) (SETQ UNDOFN (CADDR UNDOFN))) (* ;  "TEDIT.HISTORY.TYPELST is an ALST of form (type redofn undofn)") (APPLY* UNDOFN TEXTOBJ EVENT LEN CH# FIRSTPIECE)) (T (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "UNDO not implemented for " (fetch THACTION of EVENT)) T] (\SHOWSEL SEL NIL T))) (T (TEDIT.PROMPTPRINT TEXTOBJ "Nothing to UNDO." T]) (TEDIT.UNDO.INSERTION [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE) (* ; "Edited 21-Apr-93 01:33 by jds") (* ;; "UNDO a prior Insert, Copy, or Include.") (PROG (OBJ DELETEFN) (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (* ;  "Keep TEdit from reusing the current cache piece in the future -- it is probably invalid") (\DELETECH CH# (IPLUS CH# LEN) LEN TEXTOBJ) (\FIXDLINES (fetch (TEXTOBJ LINES) of TEXTOBJ) (fetch (TEXTOBJ SEL) of TEXTOBJ) CH# (IPLUS CH# LEN) TEXTOBJ) (* ;  "Fix the line descriptors & selection") (TEDIT.UPDATE.SCREEN TEXTOBJ) (* ;  "Fix up the display for all this foofaraw") (replace (SELECTION POINT) of (fetch (TEXTOBJ SEL) of TEXTOBJ) with 'LEFT) (\FIXSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) TEXTOBJ) (* ; "Really fix the selection") (replace THACTION of EVENT with 'Delete) (* ;  "Make the UNDO be UNDOable, by changing the event to a deletion.") ]) (TEDIT.UNDO.DELETION [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE) (* ; "Edited 21-Apr-93 12:01 by jds") (* ;; "UNDO a prior Deletion of text.") (PROG ((NPC (fetch (PIECE NEXTPIECE) of FIRSTPIECE)) (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) (OTEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) NEWPIECE INSPC OBJECT INSERTFN START-OF-PIECE) (SETQ INSPC (\CHTOPC CH# PCTB T)) (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (* ;  "Keep future people from stepping on the current cache piece, which is probably no longer valid.") (COND ((fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ) (* ;  "Don't change read-only documents.") (RETURN))) [COND ((IGREATERP CH# START-OF-PIECE) (SETQ INSPC (\SPLITPIECE INSPC (- CH# START-OF-PIECE) TEXTOBJ INSPC#] (SETQ NEWPIECE (create PIECE using FIRSTPIECE)) (replace THFIRSTPIECE of EVENT with NEWPIECE) (bind (TL _ 0) while (ILESSP TL LEN) do (\INSERTPIECE NEWPIECE INSPC TEXTOBJ) (* ; "Insert the piece back in") [COND ([AND (SETQ OBJECT (fetch (PIECE POBJ) of NEWPIECE)) (SETQ INSERTFN (IMAGEOBJPROP OBJECT 'WHENINSERTEDFN] (* ;  "If this is an imageobject, and it has an insertfn, call it.") (APPLY* INSERTFN OBJECT ( \TEDIT.PRIMARYW TEXTOBJ) NIL (TEXTSTREAM TEXTOBJ] (SETQ TL (IPLUS TL (fetch (PIECE PLEN) of FIRSTPIECE) )) (* ;  "Keep track of how much we've re-inserted") (SETQ FIRSTPIECE NPC) (* ;  "Move to the next piece to insert") (AND NPC (SETQ NPC (fetch (PIECE NEXTPIECE) of NPC))) (SETQ NEWPIECE (create PIECE using FIRSTPIECE)) ) (* ;  "Done here because \INSERTPIECE creams the NEXTPIECE field.") (replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (IPLUS (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) LEN)) (* ;  "Reset the text length and EOF ptr of the text stream.") (\FIXILINES TEXTOBJ SEL CH# LEN OTEXTLEN) (* ;  "Fix the line descriptors & selection") (TEDIT.UPDATE.SCREEN TEXTOBJ) (* ;  "Fix up the display for all this foofaraw") (replace (SELECTION CH#) of SEL with CH#) (* ;  "Make the selection point at the re-inserted text") (replace (SELECTION CHLIM) of SEL with (IPLUS CH# LEN)) (replace (SELECTION DCH) of SEL with LEN) (replace (SELECTION POINT) of SEL with (fetch THPOINT of EVENT)) (\TEDIT.SET.SEL.LOOKS SEL 'NORMAL) (\FIXSEL SEL TEXTOBJ) (* ; "Really fix the selection") (replace THACTION of EVENT with 'Insert) (* ;  "Make the UNDO be UNDOable, by changing the event to a insertion.") ]) (TEDIT.REDO [LAMBDA (TEXTOBJ) (* ; "Edited 30-May-91 21:27 by jds") (* ;; "REDO the last thing this guy did.") (PROG ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) EVENT CH) (COND ((FETCH (TEXTOBJ TXTREADONLY) OF TEXTOBJ) (* ;; "The document is read-only; don't make any changes.") NIL) ((SETQ EVENT (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)) (* ;  "There really is something to REDO Decide what, & do it.") (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) (\SHOWSEL SEL NIL NIL) (SELECTQ (fetch THACTION of EVENT) ((Insert Copy Include) (* ; "It was an insertion") (TEDIT.REDO.INSERTION TEXTOBJ EVENT (IMAX 1 (SELECTQ (fetch (SELECTION POINT) of SEL) (LEFT (fetch (SELECTION CH#) of SEL)) (RIGHT (fetch (SELECTION CHLIM) of SEL)) NIL)))) (Delete (* ; "It was a deletion") (\TEDIT.DELETE SEL TEXTOBJ)) (Replace (* ;  "It was a replacement (a del/insert combo)") (TEDIT.REDO.REPLACE TEXTOBJ EVENT)) (LowerCase (* ; "He lower-cased something") (\TEDIT.LCASE.SEL TEXTOBJ TEXTOBJ SEL)) (UpperCase (* ; "He upper-cased something") (\TEDIT.LCASE.SEL TEXTOBJ TEXTOBJ SEL)) (Looks (* ; "It was a looks change") (TEDIT.REDO.LOOKS TEXTOBJ EVENT (IMAX 1 (SELECTQ (fetch (SELECTION POINT) of SEL) (LEFT (fetch (SELECTION CH#) of SEL)) (RIGHT (fetch (SELECTION CHLIM) of SEL)) NIL)))) (ParaLooks (* ; "It was a Paragraph looks change") (TEDIT.REDO.PARALOOKS TEXTOBJ EVENT (IMAX 1 (SELECTQ (fetch (SELECTION POINT) of SEL) (LEFT (fetch (SELECTION CH#) of SEL)) (RIGHT (fetch (SELECTION CHLIM) of SEL)) NIL)))) (Find (* ; "EXACT-MATCH SEARCH COMMAND") (RESETLST (RESETSAVE (CURSOR WAITINGCURSOR)) (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) (\SHOWSEL SEL NIL NIL) (SETQ CH (TEDIT.FIND TEXTOBJ (fetch THAUXINFO of EVENT))) (COND (CH (TEDIT.PROMPTPRINT TEXTOBJ "done.") (replace (SELECTION CH#) of SEL with CH) [replace (SELECTION CHLIM) of SEL with (IPLUS CH (NCHARS (fetch THAUXINFO of EVENT] (replace (SELECTION DCH) of SEL with (NCHARS (fetch THAUXINFO of EVENT))) (replace (SELECTION POINT) of SEL with 'RIGHT) (\FIXSEL SEL TEXTOBJ) (TEDIT.NORMALIZECARET TEXTOBJ) (\SHOWSEL SEL NIL T)) (T (TEDIT.PROMPTPRINT TEXTOBJ "[Not found]")))) (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (* ; "Drop the cached piece. WHY??") ) ((Move ReplaceMove) (* ; "He moved some text") (TEDIT.REDO.MOVE TEXTOBJ EVENT (fetch THLEN of EVENT) (IMAX 1 (SELECTQ (fetch (SELECTION POINT) of SEL) (LEFT (fetch (SELECTION CH#) of SEL)) (RIGHT (fetch (SELECTION CHLIM) of SEL)) NIL)) (fetch THFIRSTPIECE of EVENT))) (Get (* ; "He did a GET -- not undoable.") (TEDIT.PROMPTPRINT TEXTOBJ "You can't REDO a GET." T)) (Put (* ; "He did a PUT -- not undoable.") (TEDIT.PROMPTPRINT TEXTOBJ "You can't REDO a PUT." T)) (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "REDO of the action " (fetch THACTION of EVENT) " isn't implemented.") T)) (\SHOWSEL SEL NIL T))) (T (TEDIT.PROMPTPRINT TEXTOBJ "Nothing to REDO." T]) (TEDIT.REDO.INSERTION [LAMBDA (TEXTOBJ EVENT CH#) (* ; "Edited 21-Apr-93 01:06 by jds") (* ;  "REDO a prior Insert/Copy/Include of text.") (PROG (INSPC INSPC# NPC (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (LEN (fetch THLEN of EVENT)) (FIRSTPIECE (create PIECE using (fetch THFIRSTPIECE of EVENT) PNEW _ T)) (OTEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) OBJ COPYFN ORIGFIRSTPC) (SETQ ORIGFIRSTPC FIRSTPIECE) (replace THFIRSTPIECE of EVENT with FIRSTPIECE) (* ;  "So we can UNDO this, and remove the right set of pieces.") (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (* ;  "Force any further insertions to make new pieces.") (SETQ NPC (fetch (PIECE NEXTPIECE) of FIRSTPIECE)) (SETQ INSPC (\CHTOPC CH# PCTB T)) [SETQ INSPC (COND ((IEQP CH# START-OF-PIECE) (* ;  "We're inserting just before an existing piece") INSPC) (T (* ;  "We must split this piece, and insert before the second part.") (\SPLITPIECE INSPC (- CH# START-OF-PIECE) TEXTOBJ] (bind (TL _ 0) while (ILESSP TL LEN) do (* ;; "Loop thru the pieces of the prior insertion, inserting copies of enough of them to cover the length of the insertion.") [COND ((SETQ OBJ (fetch (PIECE POBJ) of FIRSTPIECE)) (* ; "This piece describes an object") [COND [(SETQ COPYFN (IMAGEOBJPROP OBJ 'COPYFN)) (SETQ OBJ (APPLY* COPYFN OBJ (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ ) (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ))) (COND ((EQ OBJ 'DON'T) (TEDIT.PROMPTPRINT TEXTOBJ "COPY of this object not allowed." T) (RETFROM 'TEDIT.COPY)) (T (replace (PIECE POBJ) of FIRSTPIECE with OBJ] (OBJ (replace (PIECE POBJ) of FIRSTPIECE with (COPY OBJ] (COND ((SETQ COPYFN (IMAGEOBJPROP OBJ 'WHENCOPIEDFN)) (* ;  "If there's an eventfn for copying, use it.") (APPLY* COPYFN OBJ (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) 'DSP) (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ] (\INSERTPIECE FIRSTPIECE INSPC TEXTOBJ) (* ; "Insert the piece back in") (SETQ TL (IPLUS TL (fetch (PIECE PLEN) of FIRSTPIECE))) (* ;  "Keep track of how much we've re-inserted") (SETQ FIRSTPIECE (create PIECE using NPC PNEW _ T)) (* ;  "Move to the next piece to insert") (AND NPC (SETQ NPC (fetch (PIECE NEXTPIECE) of NPC))) (* ;  "Done here because \INSERTPIECE creams the NEXTPIECE field.") ) (\TEDIT.DIFFUSE.PARALOOKS (fetch (PIECE PREVPIECE) of ORIGFIRSTPC) INSPC) (* ;  "propagate paragraph formatting into the new insertion") (replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (IPLUS (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) LEN)) (* ;  "Reset the text length and EOF ptr of the text stream.") (\FIXILINES TEXTOBJ SEL CH# LEN OTEXTLEN) (* ;  "Fix the line descriptors & selection") (TEDIT.UPDATE.SCREEN TEXTOBJ) (* ;  "Fix up the display for all this foofaraw") (replace (SELECTION CH#) of SEL with CH#) (* ;  "Make the selection point at the re-inserted text") (replace (SELECTION CHLIM) of SEL with (IPLUS CH# LEN)) (replace (SELECTION DCH) of SEL with LEN) (\TEDIT.SET.SEL.LOOKS SEL 'NORMAL) (\FIXSEL SEL TEXTOBJ) (* ; "Really fix the selection") (replace THACTION of EVENT with 'Insert) (* ;  "Make the UNDO be UNDOable, by changing the event to a insertion.") ]) (TEDIT.UNDO.MOVE [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE) (* ; "Edited 30-May-91 21:27 by jds") (* ; "UNDO a MOVE command") (PROG ((TOOBJ (fetch THAUXINFO of EVENT)) (FROMOBJ (fetch THTEXTOBJ of EVENT)) (SOURCECH# (fetch THOLDINFO of EVENT)) (CH# (fetch THCH# of EVENT)) TOSEL TOTEXTLEN) (\SHOWSEL (fetch (TEXTOBJ SEL) of TOOBJ) NIL NIL) (* ;  "Turn off the selections in the old source and target documents") (\SHOWSEL (fetch (TEXTOBJ SEL) of FROMOBJ) NIL NIL) (\DELETECH CH# (IPLUS CH# LEN) LEN FROMOBJ) (* ;  "Delete the characters we moved, from the place we moved them to") (\FIXDLINES (fetch (TEXTOBJ LINES) of FROMOBJ) (fetch (TEXTOBJ SEL) of FROMOBJ) CH# (IPLUS CH# LEN) FROMOBJ) (replace (SELECTION CH#) of (fetch (TEXTOBJ SEL) of FROMOBJ) with (replace (SELECTION CHLIM) of (fetch (TEXTOBJ SEL) of FROMOBJ) with CH#)) (* ;  "Make this document's selection be a point sel at the place the text used to be.") (replace (SELECTION DCH) of (fetch (TEXTOBJ SEL) of FROMOBJ) with 0) (replace (SELECTION POINT) of (fetch (TEXTOBJ SEL) of FROMOBJ) with 'LEFT) (* ;  "Mark lines for update, and fix the selection") (SETQ TOTEXTLEN (fetch (TEXTOBJ TEXTLEN) of TOOBJ)) (* ;  "The pre-insertion len of the place the text is returning to, for the line udpater below") (\TEDIT.INSERT.PIECES TOOBJ SOURCECH# (fetch THFIRSTPIECE of EVENT) LEN) (* ;; "Put the pieces we moved back where they came from (no need to copy them, since we did that on the original move.)") (\FIXILINES TOOBJ (fetch (TEXTOBJ SEL) of TOOBJ) SOURCECH# LEN TOTEXTLEN) (* ;  "Mark lines that need updating, and fix up the selection") (add (fetch (TEXTOBJ TEXTLEN) of TOOBJ) LEN) (* ;  "Update the text length of the erstwhile move source") (TEDIT.UPDATE.SCREEN FROMOBJ) (* ;  "Update the erstwhile text location's image.") (COND ((NEQ FROMOBJ TOOBJ) (* ;  "If they aren't the same document, we need to update the other document image as well.") (TEDIT.UPDATE.SCREEN TOOBJ))) (\FIXSEL (fetch (TEXTOBJ SEL) of TOOBJ) TOOBJ) (* ;  "Fix up the selections so their images will be OK") (\FIXSEL (fetch (TEXTOBJ SEL) of FROMOBJ) FROMOBJ) (\COPYSEL (fetch (TEXTOBJ SEL) of FROMOBJ) TEDIT.SELECTION) (* ;  "It's handy to think of this as the last selection made, also.") (replace THACTION of EVENT with 'Move) (replace THTEXTOBJ of EVENT with TOOBJ) (replace THAUXINFO of EVENT with FROMOBJ) (replace THOLDINFO of EVENT with CH#) (replace THCH# of EVENT with SOURCECH#) (\SHOWSEL (fetch (TEXTOBJ SEL) of TOOBJ) NIL T) (\SHOWSEL (fetch (TEXTOBJ SEL) of FROMOBJ) NIL T]) (TEDIT.UNDO.REPLACE [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE) (* ; "Edited 30-May-91 21:27 by jds") (PROG ((OLDEVENT (fetch THOLDINFO of EVENT)) (CH# (fetch THCH# of EVENT)) (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))) (\SHOWSEL SEL NIL NIL) (TEDIT.UNDO.INSERTION TEXTOBJ EVENT LEN CH# FIRSTPIECE) (\SHOWSEL SEL NIL NIL) (TEDIT.UNDO.DELETION TEXTOBJ OLDEVENT (fetch THLEN of OLDEVENT) CH# (fetch THFIRSTPIECE of OLDEVENT)) (replace THOLDINFO of OLDEVENT with EVENT) (replace THACTION of OLDEVENT with 'Replace) (replace THOLDINFO of EVENT with NIL) (\TEDIT.HISTORYADD TEXTOBJ OLDEVENT) (replace (SELECTION CH#) of SEL with CH#) (replace (SELECTION CHLIM) of SEL with (IPLUS CH# (fetch THLEN of OLDEVENT))) (replace (SELECTION DCH) of SEL with (fetch THLEN of OLDEVENT)) (replace (SELECTION POINT) of SEL with (fetch THPOINT of EVENT)) (replace THPOINT of OLDEVENT with (fetch THPOINT of EVENT)) (\FIXSEL SEL TEXTOBJ) (\SHOWSEL SEL NIL T]) (TEDIT.REDO.REPLACE [LAMBDA (TEXTOBJ EVENT) (* ; "Edited 30-May-91 21:28 by jds") (PROG ((OLDEVENT (fetch THOLDINFO of EVENT)) (CH# (fetch (SELECTION CH#) of (fetch (TEXTOBJ SEL) of TEXTOBJ))) (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))) (\SHOWSEL SEL NIL NIL) (\DELETECH (fetch (SELECTION CH#) of SEL) (fetch (SELECTION CHLIM) of SEL) (IDIFFERENCE (fetch (SELECTION CHLIM) of SEL) (fetch (SELECTION CH#) of SEL)) TEXTOBJ) (\FIXDLINES (fetch (TEXTOBJ LINES) of TEXTOBJ) SEL (fetch (SELECTION CH#) of SEL) (fetch (SELECTION CHLIM) of SEL) TEXTOBJ) (replace (SELECTION POINT) of SEL with 'LEFT) (TEDIT.REDO.INSERTION TEXTOBJ EVENT CH#) (replace THOLDINFO of EVENT with (SETQ OLDEVENT (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ))) (replace THACTION of OLDEVENT with 'Replace) (replace THACTION of EVENT with 'Replace) (replace THCH# of EVENT with CH#) (\TEDIT.HISTORYADD TEXTOBJ EVENT]) (TEDIT.REDO.MOVE [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE) (* ; "Edited 30-May-91 21:28 by jds") (PROG ((FROMOBJ TEXTOBJ) (SOURCECH# (fetch THOLDINFO of EVENT)) (OLDCH# (fetch THCH# of EVENT)) (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) (MOVESEL (fetch (TEXTOBJ MOVESEL) of TEXTOBJ)) OLDCHLIM) (replace (SELECTION CH#) of MOVESEL with OLDCH#) (replace (SELECTION CHLIM) of MOVESEL with (IPLUS OLDCH# LEN)) (replace (SELECTION DCH) of MOVESEL with LEN) (replace (SELECTION SET) of MOVESEL with T) (\FIXSEL MOVESEL TEXTOBJ) (\TEDIT.SET.SEL.LOOKS MOVESEL 'MOVE) (TEDIT.MOVE MOVESEL SEL]) ) (PUTPROPS TEDITHISTORY COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1990 1991 1993 1994 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1711 5083 (\TEDIT.HISTORYADD 1721 . 3606) (\TEDIT.CUMULATE.EVENTS 3608 . 5081)) (5136 38333 (TEDIT.UNDO 5146 . 9098) (TEDIT.UNDO.INSERTION 9100 . 10686) (TEDIT.UNDO.DELETION 10688 . 16623) (TEDIT.REDO 16625 . 23562) (TEDIT.REDO.INSERTION 23564 . 30211) (TEDIT.UNDO.MOVE 30213 . 34646) ( TEDIT.UNDO.REPLACE 34648 . 36087) (TEDIT.REDO.REPLACE 36089 . 37514) (TEDIT.REDO.MOVE 37516 . 38331))) )) STOP \ No newline at end of file diff --git a/library/TEDITLOOKS b/library/TEDITLOOKS new file mode 100644 index 00000000..0d4e372d --- /dev/null +++ b/library/TEDITLOOKS @@ -0,0 +1,2014 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "29-Jan-99 17:33:35" {DSK}sybalsky>lispcore3.0>library>TEDITLOOKS.;2 173603 changes to%: (FNS TEDIT.LOOKS \TEDIT.CHANGE.LOOKS) previous date%: "25-Aug-94 10:54:30" {DSK}sybalsky>lispcore3.0>library>TEDITLOOKS.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1999 by John Sybalsky & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDITLOOKSCOMS) (RPAQQ TEDITLOOKSCOMS [ (* ;; "Support for Character looks (font, italic/bold, sub/superscripting, etc) and paragraph looks (margins, centered/justified, tabs, etc.)") (FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) [DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (TEDIT.TERMSA.FONTS NIL) (TEDIT.DEFAULT.CHARLOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT)) (TEDIT.DEFAULT.FMTSPEC (\CREATE.TEDIT.DEFAULT.FMTSPEC)) (* ; "Original was (create FMTSPEC QUAD _ 'LEFT 1STLEFTMAR _ 0 LEFTMAR _ 0 RIGHTMAR _ 0 LEADBEFORE _ 0 LEADAFTER _ 0 LINELEAD _ 0 TABSPEC _ (CONS NIL NIL)).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (TEDIT.TERMSA.FONTS NIL) (TEDIT.KNOWN.FONTS '((Classic 'CLASSIC) (Modern 'MODERN) (Terminal 'TERMINAL) (Titan 'TITAN) (Gacha 'GACHA) (Helvetica 'HELVETICA) (Times% Roman 'TIMESROMAN] (VARS (TEDIT.CHARLOOKS.FEATURES '(SUPERSCRIPT INVISIBLE SELECTPOINT PROTECTED SIZE FAMILY OVERLINE STRIKEOUT UNDERLINE EXPANSION SLOPE WEIGHT)) (TEDIT.FACE.MENU (\CREATE.TEDIT.FACE.MENU)) (* ; "Original was (create MENU ITEMS _ '(Bold Italic Bold%% Italic Regular) CENTERFLG _ T TITLE _ %"Face:%").") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (TEDIT.SIZE.MENU (\CREATE.TEDIT.SIZE.MENU)) (* ; "Original was (create MENU ITEMS _ '(6 7 8 9 10 11 12 14 18 24 30 36) CENTERFLG _ T MENUROWS _ 4 TITLE _ %"Type Size:%").") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") ) (GLOBALVARS TEDIT.CURRENT.FONT TEDIT.CURRENT.CHARLOOKS TEDIT.CURRENT.PARALOOKS TEDIT.KNOWN.FONTS TEDIT.FACE.MENU TEDIT.SIZE.MENU TEDIT.DEFAULT.FONT TEDIT.DEFAULT.CHARLOOKS TEDIT.DEFAULT.FMTSPEC TEDIT.TERMSA.FONTS) (ADDVARS (FONTVARS (TEDIT.PROMPT.FONT DEFAULTFONT) (TEDIT.ICON.FONT MENUFONT))) (COMS (* ; "Character looks functions") (FNS CHARLOOKS.FROM.FONT EQCLOOKS SAMECLOOKS \TEDIT.UNIQUIFY.CHARLOOKS TEDIT.CARETLOOKS TEDIT.COPY.LOOKS \TEDIT.GET.CHARLOOKS \TEDIT.UNPARSE.CHARLOOKS.LIST TEDIT.MODIFYLOOKS TEDIT.NEW.FONT \TEDIT.PUT.CHARLOOKS \TEDIT.CARETLOOKS.VERIFY \TEDIT.GET.INSERT.CHARLOOKS \TEDIT.GET.TERMSA.WIDTHS \TEDIT.LOOKS.UPDATE \TEDIT.PARSE.CHARLOOKS.LIST \TEDIT.FLUSH.UNUSED.LOOKS) (* ;; "For making font substitutions") (FNS TEDIT.SUBLOOKS) (FNS \TEDIT.CHANGE.LOOKS TEDIT.LOOKS \TEDIT.LOOKS \TEDIT.FONTCOPY TEDIT.GET.LOOKS)) (COMS (* ; "Paragraph looks functions") (FNS \TEDIT.GET.PARALOOKS EQFMTSPEC \TEDIT.UNIQUIFY.PARALOOKS TEDIT.GET.PARALOOKS \TEDIT.UNPARSE.PARALOOKS.LIST \TEDIT.PARSE.PARALOOKS.LIST TEDIT.PARALOOKS TEDIT.COPY.PARALOOKS \TEDIT.PUT.PARALOOKS \TEDIT.CONVERT.TO.FORMATTED \TEDIT.PARABOUNDS \TEDIT.FORMATTABS) (* ;; "For making paragraph-looks substitutions.") (FNS TEDIT.SUBPARALOOKS SAMEPARALOOKS)) (COMS (* ; "UNDO & History List stuff") (FNS TEDIT.REDO.LOOKS TEDIT.REDO.PARALOOKS TEDIT.UNDO.LOOKS TEDIT.UNDO.PARALOOKS)) (COMS (* ; "Revision-mark support") (FNS \TEDIT.MARK.REVISION)) (COMS (* ;  "Added by yabu.fx, for SUNLOADUP without DWIM") (FNS \CREATE.TEDIT.DEFAULT.FMTSPEC \CREATE.TEDIT.FACE.MENU \CREATE.TEDIT.SIZE.MENU)) (COMS (* ; "Style-sheet support") (FNS \TEDIT.APPLY.STYLES \TEDIT.APPLY.PARASTYLES TEDIT.STYLESHEET TEDIT.POP.STYLESHEET TEDIT.PUSH.STYLESHEET TEDIT.ADD.STYLESHEET) (* ;; "*TEDIT-PARASTYLE-CACHE* is an ALIST of original char/para looks to styled char/para looks. It is used to cache stylings, and is reset when the main stylesheet changes, and when we change paragraph looks, given paras that have private char styles.") (* ;; "*TEDIT-CURRENTPARA-CACHE* is NIL if we're not in a para that has private char styles, or is the FMTSPEC (styled!) for that para, if we are. Used to decide when we have to flush *TEDIT-PARASTYLE-CACHE* at paragraph boundaries. Mostly, this'll be NIL and not interesting.") (* ;; "*TEDIT-STYLESHEET-SAVE-LIST* is a list of points inside TEDIT.STYLES, so we can %"push%" new style sheets on the front, and %"pop%" them off sensibly. This is the push-stack, in effect. Used by TEDIT.ADD.STYLESHEET, TEDIT.PUSH.STYLESHEET, and TEDIT.POP.STYLESHEET") (INITVARS (*TEDIT-PARASTYLE-CACHE*) (*TEDIT-CURRENTPARA-CACHE*) (*TEDIT-STYLESHEET-SAVE-LIST*]) (* ;; "Support for Character looks (font, italic/bold, sub/superscripting, etc) and paragraph looks (margins, centered/justified, tabs, etc.)" ) (FILESLOAD TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SCRATCHLEN 64) (CONSTANTS (\SCRATCHLEN 64)) ) (FILESLOAD (LOADCOMP) TEDITDCL) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQQ TEDIT.TERMSA.FONTS NIL) (RPAQ TEDIT.DEFAULT.CHARLOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT)) (RPAQ TEDIT.DEFAULT.FMTSPEC (\CREATE.TEDIT.DEFAULT.FMTSPEC)) (RPAQQ TEDIT.TERMSA.FONTS NIL) (RPAQQ TEDIT.KNOWN.FONTS ((Classic 'CLASSIC) (Modern 'MODERN) (Terminal 'TERMINAL) (Titan 'TITAN) (Gacha 'GACHA) (Helvetica 'HELVETICA) (Times% Roman 'TIMESROMAN))) ) (RPAQQ TEDIT.CHARLOOKS.FEATURES (SUPERSCRIPT INVISIBLE SELECTPOINT PROTECTED SIZE FAMILY OVERLINE STRIKEOUT UNDERLINE EXPANSION SLOPE WEIGHT)) (RPAQ TEDIT.FACE.MENU (\CREATE.TEDIT.FACE.MENU)) (RPAQ TEDIT.SIZE.MENU (\CREATE.TEDIT.SIZE.MENU)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.CURRENT.FONT TEDIT.CURRENT.CHARLOOKS TEDIT.CURRENT.PARALOOKS TEDIT.KNOWN.FONTS TEDIT.FACE.MENU TEDIT.SIZE.MENU TEDIT.DEFAULT.FONT TEDIT.DEFAULT.CHARLOOKS TEDIT.DEFAULT.FMTSPEC TEDIT.TERMSA.FONTS) ) (ADDTOVAR FONTVARS (TEDIT.PROMPT.FONT DEFAULTFONT) (TEDIT.ICON.FONT MENUFONT)) (* ; "Character looks functions") (DEFINEQ (CHARLOOKS.FROM.FONT + [LAMBDA (FONT) (* ; "Edited 30-May-91 21:45 by jds") + + (* Create a CHARLOOKS from a font, filling in such fields as can be inferred + from the font descriptor.) + + (PROG ((LOOKS (create CHARLOOKS + CLFONT _ FONT))) + (OR (FONTP FONT) + (\ILLEGAL.ARG FONT)) (* It HAS to be a font, first off.) + (SELECTQ (CAR (FONTPROP FONT 'FACE)) + (BOLD (replace (CHARLOOKS CLBOLD) of LOOKS with T) + (replace (CHARLOOKS CLITAL) of LOOKS with NIL)) + (replace (CHARLOOKS CLBOLD) of LOOKS with NIL)) + (* Set the boldness bit, if it's a + bold font.) + (SELECTQ (CADR (FONTPROP FONT 'FACE)) + (ITALIC (replace (CHARLOOKS CLITAL) of LOOKS with T)) + (replace (CHARLOOKS CLITAL) of LOOKS with NIL)) + (* Set the italic bit, if it's + italic) + (with CHARLOOKS LOOKS (SETQ CLSIZE (FONTPROP FONT 'SIZE)) + (* Grab the size from the font) + (SETQ CLOFFSET 0) (* And let it be neither super- + nor subscripted.) + ) + (RETURN LOOKS]) (EQCLOOKS + [LAMBDA (CLOOK1 CLOOK2) (* ; + "Edited 1-Jun-93 11:49 by sybalsky:mv:envos") + + (* ;; "Given two sets of CHARLOOKS, are they effectively the same?") + + (OR (EQ CLOOK1 CLOOK2) + (AND [OR (EQ (fetch (CHARLOOKS CLFONT) of CLOOK1) + (fetch (CHARLOOKS CLFONT) of CLOOK2)) + (AND (type? FONTCLASS (ffetch (CHARLOOKS CLFONT) of CLOOK1)) + (type? FONTCLASS (ffetch (CHARLOOKS CLFONT) of CLOOK2)) + (EQ (ffetch FONTCLASSNAME of (ffetch (CHARLOOKS CLFONT) + of CLOOK1)) + (ffetch FONTCLASSNAME of (ffetch (CHARLOOKS CLFONT) + of CLOOK2] + (EQ (ffetch (CHARLOOKS CLPROTECTED) of CLOOK1) + (ffetch (CHARLOOKS CLPROTECTED) of CLOOK2)) + (EQ (ffetch (CHARLOOKS CLINVISIBLE) of CLOOK1) + (ffetch (CHARLOOKS CLINVISIBLE) of CLOOK2)) + (EQ (ffetch (CHARLOOKS CLSELHERE) of CLOOK1) + (ffetch (CHARLOOKS CLSELHERE) of CLOOK2)) + (EQ (ffetch (CHARLOOKS CLCANCOPY) of CLOOK1) + (ffetch (CHARLOOKS CLCANCOPY) of CLOOK2)) + (EQ (ffetch (CHARLOOKS CLULINE) of CLOOK1) + (ffetch (CHARLOOKS CLULINE) of CLOOK2)) + (EQ (ffetch (CHARLOOKS CLOLINE) of CLOOK1) + (ffetch (CHARLOOKS CLOLINE) of CLOOK2)) + (EQ (ffetch (CHARLOOKS CLINVERTED) of CLOOK1) + (ffetch (CHARLOOKS CLINVERTED) of CLOOK2)) + (EQ (ffetch (CHARLOOKS CLSTRIKE) of CLOOK1) + (ffetch (CHARLOOKS CLSTRIKE) of CLOOK2)) + (EQ (ffetch (CHARLOOKS CLOFFSET) of CLOOK1) + (ffetch (CHARLOOKS CLOFFSET) of CLOOK2)) + (EQ (ffetch (CHARLOOKS CLSMALLCAP) of CLOOK1) + (ffetch (CHARLOOKS CLSMALLCAP) of CLOOK2)) + (EQ (ffetch (CHARLOOKS CLSTYLE) of CLOOK1) + (ffetch (CHARLOOKS CLSTYLE) of CLOOK2)) + (EQ (ffetch (CHARLOOKS CLUSERINFO) of CLOOK1) + (ffetch (CHARLOOKS CLUSERINFO) of CLOOK2]) (SAMECLOOKS + [LAMBDA (CLOOK1 CLOOK2 FEATURES) (* ; "Edited 30-May-91 21:45 by jds") + + (* ;; "Predicate to determine if CLOOK1 and CLOOK2 are the same in all the characteristics listed in FEATURES") + + (for F in FEATURES always (SELECTQ F + (FAMILY (EQ (FONTPROP (fetch (CHARLOOKS CLFONT) + of CLOOK1) + 'FAMILY) + (FONTPROP (fetch (CHARLOOKS CLFONT) + of CLOOK2) + 'FAMILY))) + (SIZE (EQ (FONTPROP (fetch (CHARLOOKS CLFONT) + of CLOOK1) + 'SIZE) + (FONTPROP (fetch (CHARLOOKS CLFONT) + of CLOOK2) + 'SIZE))) + (EXPANSION (EQ (FONTPROP (fetch (CHARLOOKS CLFONT) + of CLOOK1) + 'EXPANSION) + (FONTPROP (fetch (CHARLOOKS CLFONT) + of CLOOK2) + 'EXPANSION))) + (SLOPE (EQ (FONTPROP (fetch (CHARLOOKS CLFONT) + of CLOOK1) + 'SLOPE) + (FONTPROP (fetch (CHARLOOKS CLFONT) + of CLOOK2) + 'SLOPE))) + (WEIGHT (EQ (FONTPROP (fetch (CHARLOOKS CLFONT) + of CLOOK1) + 'WEIGHT) + (FONTPROP (fetch (CHARLOOKS CLFONT) + of CLOOK2) + 'WEIGHT))) + (SUPERSCRIPT (EQ (fetch (CHARLOOKS CLOFFSET) + of CLOOK1) + (fetch (CHARLOOKS CLOFFSET) + of CLOOK2))) + (INVISIBLE (EQ (fetch (CHARLOOKS CLINVISIBLE) + of CLOOK1) + (fetch (CHARLOOKS CLINVISIBLE) + of CLOOK2))) + (SELECTPOINT (EQ (fetch (CHARLOOKS CLSELHERE) + of CLOOK1) + (fetch (CHARLOOKS CLSELHERE) + of CLOOK2))) + (PROTECTED (EQ (fetch (CHARLOOKS CLPROTECTED) + of CLOOK1) + (fetch (CHARLOOKS CLPROTECTED) + of CLOOK2))) + (OVERLINE (EQ (fetch (CHARLOOKS CLOLINE) + of CLOOK1) + (fetch (CHARLOOKS CLOLINE) + of CLOOK2))) + (STRIKEOUT (EQ (fetch (CHARLOOKS CLSTRIKE) + of CLOOK1) + (fetch (CHARLOOKS CLSTRIKE) + of CLOOK2))) + (UNDERLINE (EQ (fetch (CHARLOOKS CLULINE) + of CLOOK1) + (fetch (CHARLOOKS CLULINE) + of CLOOK2))) + (FACE (EQUAL (FONTPROP (fetch (CHARLOOKS CLFONT) + of CLOOK1) + 'FACE) + (FONTPROP (fetch (CHARLOOKS CLFONT) + of CLOOK2) + 'FACE))) + (ERROR (CONCAT F + " is an unknown feature of character looks. Detected in SAMECLOOKS" + ]) (\TEDIT.UNIQUIFY.CHARLOOKS + [LAMBDA (NEWLOOKS TEXTOBJ) (* ; "Edited 30-May-91 21:40 by jds") + + (* Assure that there is only ONE of a given CHARLOOKS in the document--so that + all instances of that set of looks share structure.) + + (COND + ((for LOOK in (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ) + thereis (EQCLOOKS NEWLOOKS LOOK))) + (T (push (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ) + NEWLOOKS) + NEWLOOKS]) (TEDIT.CARETLOOKS + [LAMBDA (STREAM LOOKS) (* ; "Edited 30-May-91 21:40 by jds") + + (* ;; "Set the 'Caret looks' for a TEdit document, i.e., the looks that will be applied to newly-typed characters from here on.") + + (PROG ((TEXTOBJ (TEXTOBJ STREAM)) + CHARLOOKS) + (SETQ CHARLOOKS (\TEDIT.UNIQUIFY.CHARLOOKS (\TEDIT.CARETLOOKS.VERIFY + TEXTOBJ + (\TEDIT.PARSE.CHARLOOKS.LIST + LOOKS + (fetch (TEXTOBJ CARETLOOKS) + of TEXTOBJ) + TEXTOBJ)) + TEXTOBJ)) (* ; + "Parse up the looks he gave us, to make sure they're a valid CHARLOOKS") + (COND + ((NEQ CHARLOOKS (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ)) + (* ; + "Only change the caret looks if they really changed") + (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) + (* ; "Changing the caret's looks means we can't type into the same piece any more. Force the next insert to create a new one.") + (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with CHARLOOKS]) (TEDIT.COPY.LOOKS + [LAMBDA (STREAM SOURCE DEST) (* ; "Edited 30-May-91 21:43 by jds") + + (* ;; "Copy the CHARACTER LOOKS of one piece of text (actually, the first selected character) to another piece of text") + + (PROG ((TEXTOBJ (TEXTOBJ STREAM)) + LOOKS LEN) (* ; + "get the character looks of the first character of SOURCE") + [SETQ LOOKS (fetch (PIECE PLOOKS) + of (CL:TYPECASE SOURCE + ((SMALLP FIXP) (\CHTOPC SOURCE (fetch (TEXTOBJ PCTB) + of TEXTOBJ))) + (SELECTION + (\SHOWSEL SOURCE NIL NIL) + (* ; + "Turn off the source selection, so it doesn't hang around after the copy.") + (\CHTOPC (fetch (SELECTION CH#) of SOURCE) + (fetch (TEXTOBJ PCTB) of (fetch + (SELECTION \TEXTOBJ) + of SOURCE)))) + (T (\ILLEGAL.ARG SOURCE)))] + (COND + [(type? SELECTION DEST) (* ; + "make sure that the destination selection is in this document") + (COND + ((NEQ TEXTOBJ (fetch (SELECTION \TEXTOBJ) of DEST)) + (\LISPERROR "Destination selection is not in stream " STREAM] + (T (* ; + "set the LEN arg for TEDIT.LOOKS to be 1 since we just have a char pos.") + (SETQ LEN 1))) + (TEDIT.LOOKS TEXTOBJ LOOKS DEST LEN]) (\TEDIT.GET.CHARLOOKS + [LAMBDA (PC FILE LOOKSARRAY PREVPC) (* ; "Edited 30-May-91 21:43 by jds") + +(* ;;; "Set the PLOOKS for the current piece, PC, according to what the file says") + +(* ;;; "The PLEN field of this piece is the number of FILE BYTES taken to describe the piece. This may need to be adjusted for fat pieces, and at fat/thin boundaries. PREVPC is the previous piece, if any, so we can detect such boundaries.") + + (PROG ((FLAGS (\BIN FILE))) + (COND + ((NOT (ZEROP (LOGAND FLAGS 1))) (* ; "This text is NEW. Mark it so.") + (replace (PIECE PNEW) of PC with T))) + (COND + ((NOT (ZEROP (LOGAND FLAGS 2))) (* ; + "This text is FAT--16 bit characters.") + (replace (PIECE PFATP) of PC with T))) + (replace (PIECE PLOOKS) of PC with (ELT LOOKSARRAY (\SMALLPIN FILE))) + (* ; + "Look the looks up in the array we built according to specs earlier") + (COND + [(fetch (PIECE PFATP) of PC) (* ; + "For a fat piece, convert bytes to characters") + (COND + ((AND PREVPC (fetch (PIECE PFATP) of PREVPC)) + (replace (PIECE PLEN) of PC with (FOLDHI (FETCH (PIECE PLEN) + OF PC) + 2))) + (T (* ; + "The prior piece wasn't fat and this one is. Take account of the 255-255-0 in the length") + (replace (PIECE PLEN) of PC with (FOLDHI (IDIFFERENCE + (fetch (PIECE PLEN) + of PC) + 3) + 2)) + (add (fetch (PIECE PFPOS) of PC) + 3] + ((AND PREVPC (fetch (PIECE PFATP) of PREVPC)) + + (* ;; "The prior piece was fat and this one isn't. Take account of the 255-0 on the front of this piece's chars.") + + (replace (PIECE PLEN) of PC with (IDIFFERENCE (fetch (PIECE PLEN) + of PC) + 2)) + (add (fetch (PIECE PFPOS) of PC) + 2]) (\TEDIT.UNPARSE.CHARLOOKS.LIST + [LAMBDA (LOOKS) (* ; "Edited 30-May-91 21:45 by jds") + (* Convert a CHARLOOKS into an + equivalent PList-form for external + consumption) + (PROG ((NEWLOOKS NIL) + OFFSET) + (for PROP in (LIST (fetch (CHARLOOKS CLSTYLE) of LOOKS) + (fetch (CHARLOOKS CLUSERINFO) of LOOKS) + (ONOFF (fetch (CHARLOOKS CLINVERTED) of LOOKS)) + (FONTPROP (fetch (CHARLOOKS CLFONT) of LOOKS) + 'WEIGHT) + (FONTPROP (fetch (CHARLOOKS CLFONT) of LOOKS) + 'SLOPE) + (FONTPROP (fetch (CHARLOOKS CLFONT) of LOOKS) + 'EXPANSION) + (ONOFF (fetch (CHARLOOKS CLULINE) of LOOKS)) + (ONOFF (fetch (CHARLOOKS CLSTRIKE) of LOOKS)) + (ONOFF (fetch (CHARLOOKS CLOLINE) of LOOKS)) + (FONTPROP (fetch (CHARLOOKS CLFONT) of LOOKS) + 'FAMILY) + (FONTPROP (fetch (CHARLOOKS CLFONT) of LOOKS) + 'SIZE) + (ONOFF (fetch (CHARLOOKS CLPROTECTED) of LOOKS)) + (ONOFF (fetch (CHARLOOKS CLSELHERE) of LOOKS)) + (ONOFF (fetch (CHARLOOKS CLINVISIBLE) of LOOKS))) + as PROPNAME + in '(STYLE USERINFO INVERTED WEIGHT SLOPE EXPANSION UNDERLINE STRIKEOUT OVERLINE + FAMILY SIZE PROTECTED SELECTPOINT INVISIBLE) + do (push NEWLOOKS PROP) + (push NEWLOOKS PROPNAME)) + (push NEWLOOKS (IABS (OR (fetch (CHARLOOKS CLOFFSET) of LOOKS) + 0))) + [push NEWLOOKS (COND + ((IGREATERP (fetch (CHARLOOKS CLOFFSET) of LOOKS) + 0) + 'SUPERSCRIPT) + ((ILESSP (fetch (CHARLOOKS CLOFFSET) of LOOKS) + 0) + 'SUBSCRIPT) + (T 'SUPERSCRIPT] + (RETURN NEWLOOKS]) (TEDIT.MODIFYLOOKS + [LAMBDA (LINE STARTX DS LOOKS LINEBASEY) (* ; "Edited 30-May-91 21:45 by jds") + + (* Modify the screen to allow for underlining, etc. + Also, restore the vertical offset to the baseline.) + + (PROG ((CURX (DSPXPOSITION NIL DS)) + (CURY (DSPYPOSITION NIL DS)) + (FONT (fetch (CHARLOOKS CLFONT) of LOOKS))) + (COND + ((fetch (CHARLOOKS CLULINE) of LOOKS) (* It's underlined.) + (MOVETO STARTX (ADD1 (IDIFFERENCE (IPLUS CURY) + (fetch (LINEDESCRIPTOR LTRUEDESCENT) of LINE))) + DS) + (RELDRAWTO (IDIFFERENCE CURX STARTX) + 0 1 'PAINT DS))) + (COND + ((fetch (CHARLOOKS CLOLINE) of LOOKS) (* Over-line) + (MOVETO STARTX [IPLUS CURY (SUB1 (FONTPROP FONT 'ASCENT] + DS) + (RELDRAWTO (IDIFFERENCE CURX STARTX) + 0 1 'PAINT DS))) + (COND + ((fetch (CHARLOOKS CLSTRIKE) of LOOKS) (* Struck-thru) + (MOVETO STARTX (IPLUS CURY (IQUOTIENT (FONTPROP FONT 'ASCENT) + 3)) + DS) + (RELDRAWTO (IDIFFERENCE CURX STARTX) + 0 1 'PAINT DS))) + (COND + ((fetch (CHARLOOKS CLINVERTED) of LOOKS)(* Inverse video) + (BITBLT NIL NIL NIL DS STARTX (IDIFFERENCE CURY (FONTPROP FONT 'DESCENT)) + (IDIFFERENCE CURX STARTX) + (FONTPROP FONT 'HEIGHT) + 'TEXTURE + 'INVERT BLACKSHADE))) + (MOVETO CURX LINEBASEY DS]) (TEDIT.NEW.FONT + (LAMBDA (TEXTOBJ) (* jds " 8-Feb-85 11:27") + (PROG ((NAME (\TEDIT.MAKEFILENAME (TEDIT.GETINPUT TEXTOBJ "Name of font: ")))) + (AND NAME (SETQ TEDIT.KNOWN.FONTS (NCONC1 TEDIT.KNOWN.FONTS (LIST NAME (KWOTE (U-CASE + NAME))))) + (RETURN (U-CASE NAME)))))) (\TEDIT.PUT.CHARLOOKS + [LAMBDA (FILE CH1 CHLIM LOOKS OLDPC EDITSTENTATIVE LOOKSHARRAY PREVFATP) + (* ; "Edited 30-May-91 21:45 by jds") + + (* ;; "Put a description of LOOKS into FILE. LOOKS apply to characters CH1 thru CHLIM-1") + + (PROG ((FONT (fetch (CHARLOOKS CLFONT) of LOOKS)) + STR) + (\DWOUT FILE (IDIFFERENCE CHLIM CH1)) (* ; "The length of this run of looks") + (\SMALLPOUT FILE \PieceDescriptorLOOKS) (* ; + "Mark this as setting the piece's looks") + [\BOUT FILE (LOGOR (COND + ((AND EDITSTENTATIVE OLDPC (fetch (PIECE PNEW) of OLDPC)) + (* ; + "If this is a tentative edit, save the newness flag") + 1) + (T (* ; "Otherwise, don't bother") + 0)) + (COND + ((AND OLDPC (fetch (PIECE PFATP) of OLDPC)) + (* ; + "If this piece contains fat characters, remember that fact.") + 2) + (T (* ; "Otherwise, don't bother") + 0] + (\SMALLPOUT FILE (GETHASH LOOKS LOOKSHARRAY)) (* ; + "The index into the list of fonts") + ]) (\TEDIT.CARETLOOKS.VERIFY + [LAMBDA (TEXTOBJ NEWLOOKS) (* ; "Edited 30-May-91 21:41 by jds") + (* Check with the user's + CARETLOOKSFN to see if he wants to + make changes) + (PROG ((CARETFN (TEXTPROP TEXTOBJ 'CARETLOOKSFN)) + LOOKS) + (SETQ LOOKS (AND CARETFN (APPLY* CARETFN NEWLOOKS TEXTOBJ))) + (RETURN (COND + ((EQ LOOKS 'DON'T) (* He said not to change the looks.) + (OR (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) + (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ))) + (LOOKS (\TEDIT.UNIQUIFY.CHARLOOKS LOOKS TEXTOBJ)) + (T (* He didn't give us any guidance, + so return the looks unmodified.) + NEWLOOKS]) (\TEDIT.GET.INSERT.CHARLOOKS + [LAMBDA (TEXTOBJ SEL) (* ; "Edited 30-May-91 21:45 by jds") + + (* Given a default source of charlooks, set us up some good ones. + IN particular, reset CLPROTECTED if need be.) + + (PROG ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + [CH# (IMAX 1 (IMIN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) + (SELECTQ (fetch (SELECTION POINT) of SEL) + (LEFT (fetch (SELECTION CH#) of SEL)) + (RIGHT (SUB1 (fetch (SELECTION CHLIM) of SEL))) + (SHOULDNT] + PCNO PIECE LOOKS) + (SETQ PIECE (\CHTOPC CH# PCTB)) + [COND + [(NULL PIECE) (* No piece to take looks from; + use the default) + (SETQ LOOKS (OR (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) + (\TEDIT.UNIQUIFY.CHARLOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT) + TEXTOBJ] + ((ATOM PIECE) (* Trying to take from the + pseudo-piece at the end.) + (COND + [(ZEROP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (* No characters to steal from. + Use the defaults) + (SETQ LOOKS (OR (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) + (\TEDIT.UNIQUIFY.CHARLOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT + ) + TEXTOBJ] + (T (* Otherwise, steal the looks of the + last character) + (SETQ PIECE (fetch (PCTNODE PCE) + of (FINDNODE-INDEX PCTB (SUB1 (INDEX (fetch (PCTNODE + CHNUM) + of (\LASTNODE + PCTB)) + PCTB] + [COND + (LOOKS) + ((fetch (CHARLOOKS CLPROTECTED) of (fetch (PIECE PLOOKS) of PIECE)) + (* His looks are protected; + we have to copy to a new CHARLOOKS.) + (SETQ LOOKS (\TEDIT.UNIQUIFY.CHARLOOKS (create CHARLOOKS + using (fetch (PIECE PLOOKS) + of PIECE) + CLPROTECTED _ NIL CLSELHERE _ NIL) + TEXTOBJ))) + (T (* No protection, just reuse his + looks) + (SETQ LOOKS (fetch (PIECE PLOOKS) of PIECE] + (RETURN (\TEDIT.UNIQUIFY.CHARLOOKS (\TEDIT.CARETLOOKS.VERIFY TEXTOBJ LOOKS) + TEXTOBJ]) (\TEDIT.GET.TERMSA.WIDTHS + (LAMBDA (TERMSA FONT) (* jds "22-OCT-83 21:36") + + (* If the guy is using a terminal table, get an updated set of widths to + reflect that.) + + (PROG ((NWIDTHS (ARRAY 256 'SMALLP 0 0))) + (for I from 0 to 255 do (\WORDSETA NWIDTHS I (TEDIT.CHARWIDTH I FONT TERMSA))) + (RETURN NWIDTHS)))) (\TEDIT.LOOKS.UPDATE + [LAMBDA (STREAM PC) (* ; "Edited 30-May-91 21:47 by jds") + +(* ;;; "Called under \FORMATLINE, on which it depends. At a piece boundary, update the line formatting fields such as ASCENT, DESCENT, etc. Also, skip over invisible characters") + + (DECLARE (USEDFREE LOOKS CHLIST WLIST FONTWIDTHS CHNO ASCENT DESCENT LOOKNO LINE FONT + INVISIBLERUNS NEWASCENT NEWDESCENT)) + (COND + (PC (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) + (ORIGPC PC) + TLOOKS TEMP NEWPC PARALOOKS PREVPC) + [COND + ([OR (NOT (fetch (PIECE PREVPIECE) of ORIGPC)) + (NEQ (fetch (PIECE PPARALOOKS) of ORIGPC) + (fetch (PIECE PPARALOOKS) of (fetch (PIECE PREVPIECE) + of ORIGPC] + (SETQ PARALOOKS (\TEDIT.APPLY.PARASTYLES (fetch (PIECE PPARALOOKS) + of ORIGPC) + ORIGPC TEXTOBJ)) + (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with PARALOOKS)) + (T (SETQ PARALOOKS (fetch (TEXTSTREAM CURRENTPARALOOKS) of STREAM] + (SETQ TLOOKS (\TEDIT.APPLY.STYLES (ffetch (PIECE PLOOKS) of ORIGPC) + ORIGPC TEXTOBJ)) + (COND + ((fetch (CHARLOOKS CLINVISIBLE) of TLOOKS) + (* ; + "We've hit a run of invisible characters. Skip them, and insert a marker in the line cache") + (add LOOKNO 1) (* ; + "Fix the counter of charlooks changes") + (\EDITSETA LOOKS LOOKNO (fetch (PIECE PLEN) of ORIGPC)) + (\RPLPTR CHLIST 0 LMInvisibleRun) (* ; + "Note the existence of an invisible run of characters here.") + (\RPLPTR WLIST 0 0) + (add TLEN 1) + (SETQ CHLIST (\ADDBASE CHLIST 2)) + (SETQ WLIST (\ADDBASE WLIST 2)) + (SETQ PREVPC ORIGPC) + (SETQ ORIGPC (fetch (PIECE NEXTPIECE) of ORIGPC)) + (COND + ((AND ORIGPC (NEQ (fetch (PIECE PPARALOOKS) of ORIGPC) + (fetch (PIECE PPARALOOKS) of PREVPC))) + (SETQ PARALOOKS (\TEDIT.APPLY.PARASTYLES (fetch (PIECE PPARALOOKS) + of ORIGPC) + ORIGPC TEXTOBJ)) + (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with PARALOOKS) + )) + (SETQ TLOOKS (AND ORIGPC (\TEDIT.APPLY.STYLES (ffetch (PIECE PLOOKS) + of ORIGPC) + ORIGPC TEXTOBJ))) + [while (AND ORIGPC (OR (ZEROP (fetch (PIECE PLEN) of ORIGPC)) + (fetch (CHARLOOKS CLINVISIBLE) of TLOOKS))) + do (* ; + "Skip over this run of invisible characters --and any trailing run of empty pieces") + (\EDITSETA LOOKS LOOKNO (IPLUS (fetch (PIECE PLEN) of ORIGPC) + (\EDITELT LOOKS LOOKNO))) + (* ; + "Note the invisible run length for the line displayer") + (SETQ PREVPC ORIGPC) + (SETQ ORIGPC (fetch (PIECE NEXTPIECE) of ORIGPC)) + (COND + ((NOT ORIGPC) (* ; + "We ran off the end of the document. Don't try to update paragraph looks.") + ) + ((NEQ (fetch (PIECE PPARALOOKS) of ORIGPC) + (fetch (PIECE PPARALOOKS) of PREVPC)) + (* ; + "Paragraph looks changed in the course of the invisible section.") + (SETQ PARALOOKS (\TEDIT.APPLY.PARASTYLES (fetch + (PIECE PPARALOOKS) + of ORIGPC) + ORIGPC TEXTOBJ)) + (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM + with PARALOOKS))) + (SETQ TLOOKS (AND ORIGPC (\TEDIT.APPLY.STYLES (ffetch + (PIECE PLOOKS) + of ORIGPC) + ORIGPC TEXTOBJ] + (while (AND ORIGPC (ZEROP (fetch (PIECE PLEN) of ORIGPC))) + do (* ; + "Skip over any trailing pieces that are zero long") + (SETQ PREVPC ORIGPC) + (SETQ ORIGPC (fetch (PIECE NEXTPIECE) of ORIGPC))) + (add CHNO (\EDITELT LOOKS LOOKNO)) + (add INVISIBLERUNS (\EDITELT LOOKS LOOKNO)) + (* ; + "Keep track of how much invisible text we cross over") + (SETQ NEWPC ORIGPC))) + (COND + ([AND ORIGPC (NOT (EQCLOOKS TLOOKS (fetch (TEXTSTREAM CURRENTLOOKS) + of STREAM] + + (* ;; "Only update looks if there's really a new piece to update them from, and the looks have really changed") + + (replace (TEXTSTREAM CURRENTLOOKS) of STREAM with TLOOKS) + (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with PARALOOKS) + [COND + [(type? FONTCLASS (fetch (CHARLOOKS CLFONT) of TLOOKS)) + (* ; + "For FONTCLASSes, we have to get the real font") + (SETQ FONT (FONTCOPY (fetch (CHARLOOKS CLFONT) of TLOOKS) + 'DEVICE + 'DISPLAY] + (T (* ; + "It's a font already, so no work is needed") + (SETQ FONT (fetch (CHARLOOKS CLFONT) of TLOOKS] + [SETQ NEWASCENT (IMAX ASCENT (IPLUS (FONTPROP FONT 'ASCENT) + (OR (ffetch (CHARLOOKS CLOFFSET) + of TLOOKS) + 0] + [SETQ NEWDESCENT (IMAX DESCENT (IDIFFERENCE (FONTPROP FONT 'DESCENT) + (OR (ffetch (CHARLOOKS CLOFFSET) + of TLOOKS) + 0] + [COND + ((fetch (FMTSPEC FMTHARDCOPY) of PARALOOKS) + (* ; + "If it's a hardcopy-format line, grab the hardcopy widths.") + (SETQ FONT (FONTCOPY (fetch (CHARLOOKS CLFONT) of TLOOKS) + 'DEVICE DEVICE] + (add LOOKNO 1) (* ; + "Fix the counter of charlooks changes") + (\EDITSETA LOOKS LOOKNO TLOOKS) (* ; + "Save the new looks for selection/display") + (\RPLPTR CHLIST 0 LMLooksChange) (* ; + "Put a marker in the character list to denote a looks change") + (\RPLPTR WLIST 0 0) (* ; "Font changes have no width") + (add TLEN 1) + (SETQ CHLIST (\ADDBASE CHLIST 2)) + (SETQ WLIST (\ADDBASE WLIST 2)) (* ; + "Account for the dummy marker/looks in TLEN") + (COND + ((ffetch (CHARLOOKS CLPROTECTED) of TLOOKS) + (* ; + "If this line contains protected text, mark the linedescriptor accordingly") + (freplace (LINEDESCRIPTOR LHASPROT) of LINE with T))) + (SETQ NEWPC ORIGPC)) + [(AND ORIGPC (fetch (PIECE PREVPIECE) of ORIGPC) + (fetch (PIECE POBJ) of (fetch (PIECE PREVPIECE) of ORIGPC)) + ) + + (* ;; "After passing over an image object, always update the ascent and descent. This avoids losing that info if an image object is first on the line; we used to forget the starting font's data, which left following characters at the mercy of the imageobj.") + + [SETQ NEWASCENT (IMAX ASCENT (IPLUS (FONTPROP FONT 'ASCENT) + (OR (ffetch (CHARLOOKS CLOFFSET) + of TLOOKS) + 0] + (SETQ NEWDESCENT (IMAX DESCENT (IDIFFERENCE (FONTPROP FONT 'DESCENT) + (OR (ffetch (CHARLOOKS CLOFFSET) + of TLOOKS) + 0] + ((NOT ORIGPC) + + (* ;; "No more pieces in this document (we ran off the end skipping invisible text!) Return a NIL from the BIN, so that \FORMATLINE will not die.") + + (RETFROM '\BIN NIL))) + (RETURN NEWPC]) (\TEDIT.PARSE.CHARLOOKS.LIST + [LAMBDA (NLOOKS OLOOKS TEXTOBJ) (* ; "Edited 30-May-91 21:46 by jds") + + (* ;; "Takes a CHARLOOKS, a FONTDESCRIPTOR, or an ALST-format looks spec and parses it into a new CHARLOOKS. If OLOOKS is given, it will be used as the base for modifications; otherwise, TEDIT.DEFAULT.CHARLOOKS will be.") + + (PROG ((FAMILY NIL) + (FONT NIL) + (FACE NIL) + (SIZE NIL) + (SIZEINC NIL) + (PROT NIL) + (SELHERE NIL) + (ULINE NIL) + (OLINE NIL) + (STRIKE NIL) + (SUPER NIL) + (OFFSETINC NIL) + (WEIGHT NIL) + (SLOPE NIL) + (EXPANSION NIL) + (SUB NIL) + (INVISIBLE NIL) + STYLE STYLESET UISET USERINFO NEWLOOKS NEWFONT NEWPCLOOKS INVERSEVIDEO) + (* ; + "Construct the set of new looks to apply:") + (COND + ((type? CHARLOOKS NLOOKS) (* ; + "We've already got a made-up set of looks; we'll just use it.") + (RETURN NLOOKS)) + ((FONTP NLOOKS) (* ; + "It was a font spec. Make the looks be that font, otherwise unmodified.") + (RETURN (CHARLOOKS.FROM.FONT NLOOKS))) + (T (* ; + "We got an AList -- prepare looks changes in that form") + (SETQ FONT (LISTGET NLOOKS 'FONT)) + (SETQ FAMILY (LISTGET NLOOKS 'FAMILY)) + (SETQ FACE (LISTGET NLOOKS 'FACE)) + (SETQ SIZE (LISTGET NLOOKS 'SIZE)) + (SETQ PROT (LISTGET NLOOKS 'PROTECTED)) + (SETQ SELHERE (LISTGET NLOOKS 'SELECTPOINT)) + (SETQ ULINE (LISTGET NLOOKS 'UNDERLINE)) + (SETQ OLINE (LISTGET NLOOKS 'OVERLINE)) + (SETQ INVERSEVIDEO (LISTGET NEWLOOKS 'INVERTED)) + (SETQ STRIKE (LISTGET NLOOKS 'STRIKEOUT)) + (SETQ INVISIBLE (LISTGET NLOOKS 'INVISIBLE)) + (SETQ SUPER (LISTGET NLOOKS 'SUPERSCRIPT)) + (SETQ SUB (LISTGET NLOOKS 'SUBSCRIPT)) + (SETQ WEIGHT (LISTGET NLOOKS 'WEIGHT)) + (SETQ SLOPE (LISTGET NLOOKS 'SLOPE)) + (SETQ EXPANSION (LISTGET NLOOKS 'EXPANSION)) + (SETQ OFFSETINC (LISTGET NLOOKS 'OFFSETINCREMENT)) + (SETQ SIZEINC (LISTGET NLOOKS 'SIZEINCREMENT)) + (SETQ STYLE (LISTGET NLOOKS 'STYLE)) + (SETQ STYLESET (FMEMB 'STYLE NLOOKS)) + (SETQ USERINFO (LISTGET NLOOKS 'USERINFO)) + (SETQ UISET (FMEMB 'USERINFO NLOOKS)) + (SETQ NLOOKS NIL) (* ; + "Tell later code to use NEWLOOKS.") + (SETQ NEWLOOKS NIL) + [COND + (FAMILY (SETQ NEWLOOKS (CONS 'FAMILY (CONS FAMILY NEWLOOKS] + [COND + (FONT (SETQ FONT (CAR (NLSETQ (\DTEST FONT 'FONTDESCRIPTOR] + [COND + [(OR WEIGHT SLOPE EXPANSION) (* ; + "Setting one of these inhibits the FACE parameter") + [AND WEIGHT (SETQ NEWLOOKS (CONS 'WEIGHT (CONS WEIGHT NEWLOOKS] + [AND SLOPE (SETQ NEWLOOKS (CONS 'SLOPE (CONS SLOPE NEWLOOKS] + (AND EXPANSION (SETQ NEWLOOKS (CONS 'EXPANSION (CONS EXPANSION NEWLOOKS] + (FACE (SETQ NEWLOOKS (CONS 'FACE (CONS FACE NEWLOOKS] + [COND + (SIZE (SETQ NEWLOOKS (CONS 'SIZE (CONS SIZE NEWLOOKS] + [SETQ NEWPCLOOKS + (COND + [OLOOKS (create CHARLOOKS using OLOOKS CLFONT _ + (SETQ NEWFONT + (OR FONT (\TEDIT.FONTCOPY + (fetch (CHARLOOKS CLFONT) + of OLOOKS) + NEWLOOKS TEXTOBJ] + (T (create CHARLOOKS + using TEDIT.DEFAULT.CHARLOOKS CLFONT _ + (SETQ NEWFONT + (OR FONT (\TEDIT.FONTCOPY + (fetch (CHARLOOKS CLFONT) of + TEDIT.DEFAULT.CHARLOOKS + ) + (COND + (SIZEINC (* ; + "There's a size change requested. Fix up the size of the font.") + (LISTPUT NEWLOOKS 'SIZE + (IPLUS (FONTPROP (fetch (CHARLOOKS + CLFONT) + of + TEDIT.DEFAULT.CHARLOOKS + ) + 'SIZE) + SIZEINC)) + NEWLOOKS) + (T NEWLOOKS)) + TEXTOBJ] (* ; "Give this piece its new looks") + [replace (CHARLOOKS CLBOLD) of NEWPCLOOKS with (EQ 'BOLD + (FONTPROP NEWFONT + 'WEIGHT] + [replace (CHARLOOKS CLITAL) of NEWPCLOOKS with (EQ 'ITALIC + (FONTPROP NEWFONT + 'SLOPE] + [AND PROT (replace (CHARLOOKS CLPROTECTED) of NEWPCLOOKS + with (EQ PROT 'ON] + [AND SELHERE (replace (CHARLOOKS CLSELHERE) of NEWPCLOOKS + with (EQ SELHERE 'ON] + [AND ULINE (replace (CHARLOOKS CLULINE) of NEWPCLOOKS + with (EQ ULINE 'ON] + [AND OLINE (replace (CHARLOOKS CLOLINE) of NEWPCLOOKS + with (EQ OLINE 'ON] + [AND STRIKE (replace (CHARLOOKS CLSTRIKE) of NEWPCLOOKS + with (EQ STRIKE 'ON] + [AND INVISIBLE (replace (CHARLOOKS CLINVISIBLE) of NEWPCLOOKS + with (EQ INVISIBLE 'ON] + [AND INVERSEVIDEO (replace (CHARLOOKS CLINVERTED) of NEWPCLOOKS + with (EQ INVERSEVIDEO 'ON] + (AND SUPER (replace (CHARLOOKS CLOFFSET) of NEWPCLOOKS with SUPER)) + (AND SUB (replace (CHARLOOKS CLOFFSET) of NEWPCLOOKS with (IMINUS SUB))) + (AND STYLESET (replace (CHARLOOKS CLSTYLE) of NEWPCLOOKS with STYLE)) + (AND UISET (replace (CHARLOOKS CLUSERINFO) of NEWPCLOOKS with USERINFO)) + (AND OFFSETINC (replace (CHARLOOKS CLOFFSET) of NEWPCLOOKS + with (IPLUS (OR (fetch (CHARLOOKS CLOFFSET) of + NEWPCLOOKS + ) + 0) + OFFSETINC))) + (replace (CHARLOOKS CLSIZE) of NEWPCLOOKS with (FONTPROP NEWFONT + 'SIZE)) + (RETURN NEWPCLOOKS]) (\TEDIT.FLUSH.UNUSED.LOOKS + [LAMBDA (TEXTOBJ FIRSTPC) (* ; "Edited 30-May-91 21:47 by jds") + + (* ;; "Run thru the CHARLOOKS and PARALOOKS lists for this document, and flush any looks that aren't being used in the document itself.") + + (PROG ((CHARLOOKS (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ)) + (PARALOOKS (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ))) + (for LOOKS in CHARLOOKS do (* ; + "Reset the in-use mark in all CHARLOOKSs") + (replace (CHARLOOKS CLMARK) of LOOKS + with NIL)) + (for LOOKS in PARALOOKS do (* ; + "Reset the in-use mark in all FMTSPECs") + (replace (FMTSPEC FMTMARK) of LOOKS + with NIL)) + (while FIRSTPC do (* ; + "Now run thru the pieces in the document, marking the looks that are really in use.") + (replace (CHARLOOKS CLMARK) of (fetch (PIECE PLOOKS) + of FIRSTPC) + with T) + (replace (FMTSPEC FMTMARK) of (fetch (PIECE PPARALOOKS + ) + of FIRSTPC) + with T) + (SETQ FIRSTPC (fetch (PIECE NEXTPIECE) of FIRSTPC))) + (replace (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ + with (for LOOKS in CHARLOOKS when (fetch (CHARLOOKS CLMARK) + of LOOKS) collect LOOKS)) + (* ; + "Keep only those CHARLOOKSs that ARE being used.") + (replace (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ + with (for LOOKS in PARALOOKS when (fetch (FMTSPEC FMTMARK) + of LOOKS) collect LOOKS)) + (* ; + "And only those PARALOOKSs that ARE being used.") + ]) ) (* ;; "For making font substitutions") (DEFINEQ (TEDIT.SUBLOOKS + [LAMBDA (TEXTSTREAM OLDLOOKSLIST NEWLOOKSLIST) (* ; "Edited 26-Apr-93 14:53 by jds") + +(* ;;; "User entry to substitute one set of looks for another. Goes through the whole textstream and whenever the looks match the characteristics of OLDLOOKSLIST which are specified, the characteristics listed in NEWLOOKSLIST are substituted.") + + (LET* ((OLDLOOKS (\TEDIT.PARSE.CHARLOOKS.LIST OLDLOOKSLIST)) + (NEWLOOKS (\TEDIT.PARSE.CHARLOOKS.LIST NEWLOOKSLIST)) + (TEXTOBJ (TEXTOBJ TEXTSTREAM)) + (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + (FIRSTPC (\CHTOPC 1 PCTB)) + (FEATURELIST (for A on OLDLOOKSLIST by (CDDR A) collect (CAR A))) + CHANGEMADE) + (\SHOWSEL SEL NIL NIL) (* ; "Turn off the selection, first.") + [OR (ZEROP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (bind (CH# _ 1) for (PC _ FIRSTPC) while PC + by (fetch (PIECE NEXTPIECE) of PC) + do (COND + ((SAMECLOOKS OLDLOOKS (fetch (PIECE PLOOKS) of PC) + FEATURELIST) + (replace (TEXTOBJ \DIRTY) of (TEXTOBJ TEXTSTREAM) with T) + (freplace (PIECE PLOOKS) of PC + with (\TEDIT.UNIQUIFY.CHARLOOKS (\TEDIT.PARSE.CHARLOOKS.LIST + NEWLOOKSLIST + (fetch (PIECE PLOOKS) + of PC)) + (TEXTOBJ TEXTSTREAM))) + (\TEDIT.MARK.LINES.DIRTY TEXTOBJ CH# (+ CH# (fetch (PIECE PLEN) + of PC))) + (SETQ CHANGEMADE T))) + (add CH# (fetch (PIECE PLEN) of PC] + (COND + ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + (TEDIT.UPDATE.SCREEN TEXTOBJ) (* ; "Update the screen image") + (\FIXSEL SEL TEXTOBJ) + (\SHOWSEL SEL NIL T))) + (COND + (CHANGEMADE 'Done) + (T 'NoChangesMade]) ) (DEFINEQ (\TEDIT.CHANGE.LOOKS [LAMBDA (STREAM NEWLOOKS CH# LEN) (* ; "Edited 19-Apr-93 14:08 by jds") (* ;;; "Internal programmatic interface to changing character looks. DOES NOT CHANGE the current selection.") (* ;;; "THIS FUNCTION AND \TEDIT.PARSE.CHARLOOKS.LIST MUST TRACK ONE ANOTHER, FOR THE P-LIST FORMAT..") (PROG ((TEXTOBJ (TEXTOBJ STREAM)) PCTB PC1 PCNO1 PCNON PCN \INPC FAMILY FONT FACE SIZE PROT SELHERE ULINE OLINE STRIKE INVERSEVIDEO (SUPER NIL) (WEIGHT NIL) (SLOPE NIL) (SIZEINC NIL) (OFFSETINC NIL) (EXPANSION NIL) (NEWLOOKS NEWLOOKS) (NLOOKSAVE NEWLOOKS) (SUB NIL) (INVISIBLE NIL) FOOLOOKS NEWFONT DY CHLIM (OLDLOOKSLIST NIL) STYLE STYLESET UISET USERINFO START-OF-PIECE) (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (SETQ \INPC (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ)) (* ;  "Construct the set of new looks to apply:") (COND ((OR (IGREATERP CH# (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) (ZEROP LEN)) (* ;  "There won't be any text changed by this. Just punt out.") (TEDIT.CARETLOOKS STREAM NEWLOOKS) (* ; "After setting the caret looks.") (RETURN))) [COND ((type? CHARLOOKS NEWLOOKS) (* ;  "We've already got a made-up set of looks; we'll just use it.") ) ((FONTP NEWLOOKS) (* ;  "If it's a font descriptor, extract what we need from that.") (SETQ FONT NEWLOOKS) (SETQ NEWLOOKS NIL)) (T (* ;  "We got an AList -- prepare looks changes in that form") (SETQ FONT (LISTGET NEWLOOKS 'FONT)) (SETQ FAMILY (LISTGET NEWLOOKS 'FAMILY)) (SETQ FACE (LISTGET NEWLOOKS 'FACE)) (SETQ SIZE (LISTGET NEWLOOKS 'SIZE)) (SETQ PROT (LISTGET NEWLOOKS 'PROTECTED)) (SETQ SELHERE (LISTGET NEWLOOKS 'SELECTPOINT)) (SETQ ULINE (LISTGET NEWLOOKS 'UNDERLINE)) (SETQ OLINE (LISTGET NEWLOOKS 'OVERLINE)) (SETQ INVERSEVIDEO (LISTGET NEWLOOKS 'INVERTED)) (SETQ STRIKE (LISTGET NEWLOOKS 'STRIKEOUT)) (SETQ INVISIBLE (LISTGET NEWLOOKS 'INVISIBLE)) (SETQ SUPER (LISTGET NEWLOOKS 'SUPERSCRIPT)) (SETQ SUB (LISTGET NEWLOOKS 'SUBSCRIPT)) (SETQ WEIGHT (LISTGET NEWLOOKS 'WEIGHT)) (SETQ SLOPE (LISTGET NEWLOOKS 'SLOPE)) (SETQ EXPANSION (LISTGET NEWLOOKS 'EXPANSION)) (SETQ SIZEINC (LISTGET NEWLOOKS 'SIZEINCREMENT)) (SETQ OFFSETINC (LISTGET NEWLOOKS 'OFFSETINCREMENT)) (SETQ STYLE (LISTGET NEWLOOKS 'STYLE)) (SETQ STYLESET (FMEMB 'STYLE NEWLOOKS)) (SETQ USERINFO (LISTGET NEWLOOKS 'USERINFO)) (SETQ UISET (FMEMB 'USERINFO NEWLOOKS)) (SETQ NEWLOOKS NIL) (* ; "Tell later code to use FOOLOOKS") (SETQ FOOLOOKS NIL) [COND (FAMILY (SETQ FOOLOOKS (CONS 'FAMILY (CONS FAMILY FOOLOOKS] [COND (FONT (COND ((type? FONTCLASS FONT) (* ;  "Needn't do anything. It's a font class.") ) ([SETQ FONT (CAR (NLSETQ (\DTEST FONT 'FONTDESCRIPTOR] (* ;  "Try converting it to a font--it might be a list or some such.") ) (T (* ;  "Nothing doing--it isn't any of the reasonable forms, so punt.") (TEDIT.PROMPTPRINT (CONCAT FONT " isn't a valid font descriptor.") T) (RETURN] [COND [(OR WEIGHT SLOPE EXPANSION) (* ;  "Setting one of these inhibits the FACE parameter") [AND WEIGHT (SETQ FOOLOOKS (CONS 'WEIGHT (CONS WEIGHT FOOLOOKS] [AND SLOPE (SETQ FOOLOOKS (CONS 'SLOPE (CONS SLOPE FOOLOOKS] (AND EXPANSION (SETQ FOOLOOKS (CONS 'EXPANSION (CONS EXPANSION FOOLOOKS] (FACE (SETQ FOOLOOKS (CONS 'FACE (CONS FACE FOOLOOKS] (COND [SIZE (SETQ FOOLOOKS (CONS 'SIZE (CONS SIZE FOOLOOKS] (SIZEINC (SETQ FOOLOOKS (CONS 'SIZE (CONS 'BOGUSSIZE FOOLOOKS] (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T) (* ; "Mark the document changed.") (SETQ CHLIM (IMIN (ADD1 (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) (IPLUS CH# LEN))) (* ; "last ch to change") (SETQ PC1 (\CHTOPC CH# PCTB T)) (* ; "Piece the first ch is in") (COND ((IGREATERP CH# START-OF-PIECE) (* ;  "If CH# is not first ch in piece, split it.") (SETQ PC1 (\SPLITPIECE PC1 (- CH# START-OF-PIECE) TEXTOBJ PCNO1)) (* ;  "Take 2nd half of the split, which starts with CH#.") (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (* ;  "NB: \SplitPiece may make a new PCTB, so copy it here.") )) (SETQ PCN (\CHTOPC CHLIM PCTB T)) (COND ((IEQP CHLIM START-OF-PIECE) (* ;  "CHLIM+1 is the start of a new piece. just use prevpiece as pcn") (SETQ PCN (\CHTOPC (SUB1 CHLIM) PCTB T))) (T (* ;  "If the last char isn't the last char in the piece, then split it and take the first half.") (\SPLITPIECE PCN (- CHLIM START-OF-PIECE) TEXTOBJ PCNON))) [COND (NEWLOOKS (* ;; "For the case of a completely specified looks, do the following outside the loop: Make sure that this isn't a duplicate set of looks for this document.") (SETQ NEWLOOKS (\TEDIT.UNIQUIFY.CHARLOOKS NEWLOOKS TEXTOBJ] [bind (PC _ PC1) NEWPCLOOKS while (AND PC (NEQ PC PCN)) do (SETQ OLDLOOKSLIST (NCONC1 OLDLOOKSLIST (fetch (PIECE PLOOKS) of PC))) (* ; "Save old looks for the Undo.") (COND (NEWLOOKS (* ;  "We got a CHARLOOKS in. Just use it") (replace (PIECE PLOOKS) of PC with NEWLOOKS)) (T (* ;  "Otherwise, we have to override selectively") [replace (PIECE PLOOKS) of PC with (SETQ NEWPCLOOKS (create CHARLOOKS using (fetch (PIECE PLOOKS) of PC] (* ;; "If a size increment is specified, then add to the newspecs arg for fontcopy, the entry with the incremented size from the current font.") [replace (CHARLOOKS CLFONT) of NEWPCLOOKS with (SETQ NEWFONT (OR FONT (\TEDIT.FONTCOPY (fetch (CHARLOOKS CLFONT) of (fetch (PIECE PLOOKS) of PC)) (COND (SIZEINC (* ;  "There's a size change requested. Fix up the size of the font.") (LISTPUT FOOLOOKS 'SIZE (IPLUS (FONTPROP (fetch (CHARLOOKS CLFONT) of (fetch (PIECE PLOOKS ) of PC)) 'SIZE) SIZEINC)) FOOLOOKS) (T FOOLOOKS)) TEXTOBJ] (* ; "Give this piece its new looks") [replace (CHARLOOKS CLBOLD) of NEWPCLOOKS with (EQ 'BOLD (FONTPROP NEWFONT 'WEIGHT] [replace (CHARLOOKS CLITAL) of NEWPCLOOKS with (EQ 'ITALIC (FONTPROP NEWFONT 'SLOPE] [AND PROT (replace (CHARLOOKS CLPROTECTED) of NEWPCLOOKS with (EQ PROT 'ON] [AND SELHERE (replace (CHARLOOKS CLSELHERE) of NEWPCLOOKS with (EQ SELHERE 'ON] [AND ULINE (replace (CHARLOOKS CLULINE) of NEWPCLOOKS with (EQ ULINE 'ON] [AND OLINE (replace (CHARLOOKS CLOLINE) of NEWPCLOOKS with (EQ OLINE 'ON] [AND STRIKE (replace (CHARLOOKS CLSTRIKE) of NEWPCLOOKS with (EQ STRIKE 'ON] [AND INVISIBLE (replace (CHARLOOKS CLINVISIBLE) of NEWPCLOOKS with (EQ INVISIBLE 'ON] (AND SUPER (replace (CHARLOOKS CLOFFSET) of NEWPCLOOKS with SUPER)) (AND SUB (replace (CHARLOOKS CLOFFSET) of NEWPCLOOKS with (IMINUS SUB))) (AND STYLESET (replace (CHARLOOKS CLSTYLE) of NEWPCLOOKS with STYLE)) (AND UISET (replace (CHARLOOKS CLUSERINFO) of NEWPCLOOKS with USERINFO )) (AND OFFSETINC (replace (CHARLOOKS CLOFFSET) of NEWPCLOOKS with (IPLUS (OR (fetch (CHARLOOKS CLOFFSET) of NEWPCLOOKS) 0) OFFSETINC))) [AND INVERSEVIDEO (replace (CHARLOOKS CLINVERTED) of NEWPCLOOKS with (EQ INVERSEVIDEO 'ON] (replace (CHARLOOKS CLSIZE) of NEWPCLOOKS with (FONTPROP NEWFONT 'SIZE)) (replace (PIECE PLOOKS) of PC with (\TEDIT.UNIQUIFY.CHARLOOKS NEWPCLOOKS TEXTOBJ)) (* ;  "Assure that each set of looks appears only once in the world.") )) [COND ((EQ PC \INPC) (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (  \TEDIT.CARETLOOKS.VERIFY TEXTOBJ (fetch (PIECE PLOOKS) of PC] (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) finally (OR PC (RETURN)) (SETQ OLDLOOKSLIST (NCONC1 OLDLOOKSLIST (fetch (PIECE PLOOKS) of PC))) (COND (NEWLOOKS (* ;  "We got a CHARLOOKS in. Just use it") (replace (PIECE PLOOKS) of PC with NEWLOOKS)) (T (* ;  "Otherwise, we have to override selectively") [replace (PIECE PLOOKS) of PC with (SETQ NEWPCLOOKS (create CHARLOOKS using (fetch (PIECE PLOOKS) of PC] (* ;; "If a size increment is specified, then add to the newspecs arg for fontcopy, the entry with the incremented size from the current font.") [replace (CHARLOOKS CLFONT) of NEWPCLOOKS with (SETQ NEWFONT (OR FONT (\TEDIT.FONTCOPY (fetch (CHARLOOKS CLFONT) of (fetch (PIECE PLOOKS) of PC)) (COND (SIZEINC (PROGN (LISTPUT FOOLOOKS 'SIZE (IPLUS (FONTPROP (fetch (CHARLOOKS CLFONT) of (fetch (PIECE PLOOKS ) of PC)) 'SIZE) SIZEINC)) FOOLOOKS)) (T FOOLOOKS)) TEXTOBJ] (* ; "Give this piece its new looks") [replace (CHARLOOKS CLBOLD) of NEWPCLOOKS with (EQ 'BOLD (FONTPROP NEWFONT 'WEIGHT] [replace (CHARLOOKS CLITAL) of NEWPCLOOKS with (EQ 'ITALIC (FONTPROP NEWFONT 'SLOPE] [AND PROT (replace (CHARLOOKS CLPROTECTED) of NEWPCLOOKS with (EQ PROT 'ON] [AND SELHERE (replace (CHARLOOKS CLSELHERE) of NEWPCLOOKS with (EQ SELHERE 'ON] [AND ULINE (replace (CHARLOOKS CLULINE) of NEWPCLOOKS with (EQ ULINE 'ON] [AND OLINE (replace (CHARLOOKS CLOLINE) of NEWPCLOOKS with (EQ OLINE 'ON] [AND STRIKE (replace (CHARLOOKS CLSTRIKE) of NEWPCLOOKS with (EQ STRIKE 'ON] (AND SUPER (replace (CHARLOOKS CLOFFSET) of NEWPCLOOKS with SUPER)) (AND SUB (replace (CHARLOOKS CLOFFSET) of NEWPCLOOKS with (IMINUS SUB))) [AND INVISIBLE (replace (CHARLOOKS CLINVISIBLE) of NEWPCLOOKS with (EQ INVISIBLE 'ON] [AND INVERSEVIDEO (replace (CHARLOOKS CLINVERTED) of NEWPCLOOKS with (EQ INVERSEVIDEO 'ON] [AND OFFSETINC (replace (CHARLOOKS CLOFFSET) of NEWPCLOOKS with (IPLUS OFFSETINC (OR (fetch (CHARLOOKS CLOFFSET) of NEWPCLOOKS) 0] (AND STYLESET (replace (CHARLOOKS CLSTYLE) of NEWPCLOOKS with STYLE)) (AND UISET (replace (CHARLOOKS CLUSERINFO) of NEWPCLOOKS with USERINFO)) (replace (CHARLOOKS CLSIZE) of NEWPCLOOKS with (FONTPROP NEWFONT 'SIZE)) (replace (PIECE PLOOKS) of PC with (\TEDIT.UNIQUIFY.CHARLOOKS NEWPCLOOKS TEXTOBJ] (\TEDIT.MARK.LINES.DIRTY TEXTOBJ CH# CHLIM) (COND ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) NIL NIL) (TEDIT.RESET.EXTEND.PENDING.DELETE (fetch (TEXTOBJ SEL) of TEXTOBJ)) (TEDIT.UPDATE.SCREEN TEXTOBJ) (* ; "Update the screen image") (\FIXSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) TEXTOBJ) (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) NIL T))) (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (RETURN (LIST OLDLOOKSLIST NLOOKSAVE PC1]) (TEDIT.LOOKS [LAMBDA (STREAM NEWLOOKS SELORCH# LEN) (* ; "Edited 30-May-91 21:41 by jds") (* ;; "Programmatic interface for character looks in TEdit") (PROG ((TEXTOBJ (TEXTOBJ STREAM)) TSEL CHANGERESULT) [SETQ TSEL (COND ((type? SELECTION SELORCH#) SELORCH#) (SELORCH# (TEDIT.SETSEL TEXTOBJ SELORCH# LEN 'LEFT)) (T (fetch (TEXTOBJ SEL) of TEXTOBJ] (COND ((NOT (fetch (SELECTION SET) of TSEL)) (* ;  "No selection to change the looks of. Can't do anything!") (RETURN))) (COND ((SETQ CHANGERESULT (\TEDIT.CHANGE.LOOKS STREAM NEWLOOKS (fetch (SELECTION CH#) of TSEL) (fetch (SELECTION DCH) of TSEL))) (* ; "Go actually change the looks") (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT THACTION _ 'Looks THLEN _ (fetch (SELECTION DCH) of TSEL) THCH# _ (fetch (SELECTION CH#) of TSEL) THFIRSTPIECE _ (CADDR CHANGERESULT) THOLDINFO _ (CAR CHANGERESULT) THAUXINFO _ (CADR CHANGERESULT))) (* ; "Save this action for undo/redo") ]) (\TEDIT.LOOKS + [LAMBDA (TEXTOBJ) (* ; "Edited 30-May-91 21:41 by jds") + + (* ;; "Handler for the middle-button menu's LOOKS button. Brings up 3 menus, for font, face, and size. Then calls TEDIT.LOOKS to make the requested changes.") + + (LET* [(SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (FONT NIL) + (FACE NIL) + (SIZE NIL) + NEWLOOKS + (REGION (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) + 'REGION)) + (POS (create POSITION + XCOORD _ (fetch LEFT of REGION) + YCOORD _ (fetch TOP of REGION] + (COND + ((IGREATERP (fetch (SELECTION CH#) of SEL) + (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (* ; "Nothing to change, really") + ) + [(fetch (SELECTION SET) of SEL) (* ; "He's got something selected.") + (CURSORPOSITION (CREATEPOSITION 0 (fetch HEIGHT of REGION)) + (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ))) + (SETQ FONT (MENU (create MENU + TITLE _ "Font:" + ITEMS _ (NCONC1 (COPY TEDIT.KNOWN.FONTS) + (LIST 'Other (LIST (FUNCTION TEDIT.NEW.FONT) + TEXTOBJ))) + CENTERFLG _ T) + POS)) (* ; "Set the font for the new text.") + (SETQ FACE (SELECTQ (MENU TEDIT.FACE.MENU POS) + (Bold 'BOLD) + (Italic 'ITALIC) + (Bold% Italic 'BOLDITALIC) + (Regular 'STANDARD) + NIL)) (* ; "Set the face (bold, etc.)") + (SETQ SIZE (MENU TEDIT.SIZE.MENU POS)) (* ; "Set the type size") + (* ; + "Construct the set of new looks to apply:") + (COND + (FONT (SETQ NEWLOOKS (LIST 'FAMILY FONT))) + (T (SETQ NEWLOOKS NIL))) (* ; "The font") + [COND + (FACE (SETQ NEWLOOKS (CONS 'FACE (CONS FACE NEWLOOKS] + (* ; "The face") + [COND + (SIZE (SETQ NEWLOOKS (CONS 'SIZE (CONS SIZE NEWLOOKS] + (* ; "The size") + (COND + (NEWLOOKS (* ; + "If there's something to do, do it.") + (TEDIT.LOOKS TEXTOBJ NEWLOOKS SEL] + (T (TEDIT.PROMPTPRINT TEXTOBJ "Please select some text to modify first" T]) (\TEDIT.FONTCOPY + (LAMBDA (FONT NEWSPECS TEXTOBJ) (* jds "26-Dec-84 16:06") + + (* Cloak FONTCOPY in protection for the user from an unavailable font.) + + (COND + ((NULL NEWSPECS) (* No changes specified. + Punt it.) + FONT) + ((CAR (NLSETQ (FONTCOPY FONT NEWSPECS)))) + (T (PROG ((OLDFAMILY (FONTPROP FONT 'FAMILY)) + (OLDSIZE (FONTPROP FONT 'SIZE))) + (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "Can't find font " (OR (LISTGET NEWSPECS + 'FAMILY) + OLDFAMILY) + " " + (OR (LISTGET NEWSPECS 'SIZE) + OLDSIZE) + " " + (OR (LISTGET NEWSPECS 'FACE) + (FONTPROP FONT 'FACE))) + T)) + FONT)))) (TEDIT.GET.LOOKS + [LAMBDA (TEXTOBJ CH#ORCHARLOOKS) (* ; "Edited 30-May-91 21:44 by jds") + (* 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 (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (* There's no text in the document. + Use the extant caret looks.) + (SETQ LOOKS (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ))) + [(FIXP CH#ORCHARLOOKS) (* He gave us a CH# to geth the + looks of. Grab it.) + (SETQ LOOKS (fetch (PIECE PLOOKS) of (\CHTOPC (IMIN (fetch (TEXTOBJ TEXTLEN + ) + of TEXTOBJ) + CH#ORCHARLOOKS) + (fetch (TEXTOBJ PCTB) + of TEXTOBJ] + [(type? SELECTION CH#ORCHARLOOKS) (* Get the looks of the selected + text) + (SETQ LOOKS (fetch (PIECE PLOOKS) of (\CHTOPC (IMIN (fetch (TEXTOBJ TEXTLEN + ) + of TEXTOBJ) + (fetch (SELECTION + CH#) + of CH#ORCHARLOOKS)) + (fetch (TEXTOBJ PCTB) + of TEXTOBJ] + ((NULL CH#ORCHARLOOKS) (* Get the looks of the selected + text) + (SETQ LOOKS (fetch (PIECE PLOOKS) of (\CHTOPC (IMIN (fetch (TEXTOBJ TEXTLEN + ) + of TEXTOBJ) + (fetch (SELECTION + CH#) + of + (fetch (TEXTOBJ + SEL) + of TEXTOBJ))) + (fetch (TEXTOBJ PCTB) + of TEXTOBJ] + + (* * Now break the looks apart into a PROPLIST) + + (SETQ NLOOKS (\TEDIT.UNPARSE.CHARLOOKS.LIST LOOKS)) + (RETURN NLOOKS]) ) (* ; "Paragraph looks functions") (DEFINEQ (\TEDIT.GET.PARALOOKS + [LAMBDA (FILE PARAHASH) (* ; "Edited 18-Dec-88 17:47 by jds") + + (* ;; "Read a paragraph format spec from the FILE, and return it for later use.") + + (* ;; "Paragraph format # of 0 indicates an end-of-file dummy, used to preserve the paralooks of EOF para break.") + + (LET ((LOOKS# (\SMALLPIN FILE))) + (COND + ((ZEROP LOOKS#) + NIL) + (T (ELT PARAHASH LOOKS#]) (EQFMTSPEC + [LAMBDA (PARALOOK1 PARALOOK2) (* ; + "Edited 2-Jul-93 21:32 by sybalskY:MV:ENVOS") + + (* ;; "Given two sets of FMTSPECS, are they effectively the same?") + + (OR (EQ PARALOOK1 PARALOOK2) + (AND (EQ (fetch (FMTSPEC QUAD) of PARALOOK1) + (fetch (FMTSPEC QUAD) of PARALOOK2)) + (EQ (ffetch (FMTSPEC FMTNEWPAGEBEFORE) of PARALOOK1) + (ffetch (FMTSPEC FMTNEWPAGEBEFORE) of PARALOOK2)) + (EQ (ffetch (FMTSPEC FMTNEWPAGEAFTER) of PARALOOK1) + (ffetch (FMTSPEC FMTNEWPAGEAFTER) of PARALOOK2)) + (EQ (ffetch (FMTSPEC FMTSTYLE) of PARALOOK1) + (ffetch (FMTSPEC FMTSTYLE) of PARALOOK2)) + (EQ (ffetch (FMTSPEC FMTSPECIALX) of PARALOOK1) + (ffetch (FMTSPEC FMTSPECIALX) of PARALOOK2)) + (EQ (ffetch (FMTSPEC FMTSPECIALY) of PARALOOK1) + (ffetch (FMTSPEC FMTSPECIALY) of PARALOOK2)) + (EQ (ffetch (FMTSPEC FMTHEADINGKEEP) of PARALOOK1) + (ffetch (FMTSPEC FMTHEADINGKEEP) of PARALOOK2)) + (EQ (ffetch (FMTSPEC FMTKEEP) of PARALOOK1) + (ffetch (FMTSPEC FMTKEEP) of PARALOOK2)) + (EQ (ffetch (FMTSPEC FMTPARATYPE) of PARALOOK1) + (ffetch (FMTSPEC FMTPARATYPE) of PARALOOK2)) + (EQ (ffetch (FMTSPEC FMTPARASUBTYPE) of PARALOOK1) + (ffetch (FMTSPEC FMTPARASUBTYPE) of PARALOOK2)) + (EQ (ffetch (FMTSPEC FMTHARDCOPY) of PARALOOK1) + (ffetch (FMTSPEC FMTHARDCOPY) of PARALOOK2)) + (EQ (ffetch (FMTSPEC FMTREVISED) of PARALOOK1) + (ffetch (FMTSPEC FMTREVISED) of PARALOOK2)) + (EQ (ffetch (FMTSPEC FMTCOLUMN) of PARALOOK1) + (ffetch (FMTSPEC FMTCOLUMN) of PARALOOK2)) + (EQP (ffetch (FMTSPEC 1STLEFTMAR) of PARALOOK1) + (ffetch (FMTSPEC 1STLEFTMAR) of PARALOOK2)) + (EQP (ffetch (FMTSPEC LEFTMAR) of PARALOOK1) + (ffetch (FMTSPEC LEFTMAR) of PARALOOK2)) + (EQP (ffetch (FMTSPEC RIGHTMAR) of PARALOOK1) + (ffetch (FMTSPEC RIGHTMAR) of PARALOOK2)) + (EQP (ffetch (FMTSPEC LEADBEFORE) of PARALOOK1) + (ffetch (FMTSPEC LEADBEFORE) of PARALOOK2)) + (EQP (ffetch (FMTSPEC LEADAFTER) of PARALOOK1) + (ffetch (FMTSPEC LEADAFTER) of PARALOOK2)) + (EQP (ffetch (FMTSPEC LINELEAD) of PARALOOK1) + (ffetch (FMTSPEC LINELEAD) of PARALOOK2)) + (EQP (ffetch (FMTSPEC FMTBASETOBASE) of PARALOOK1) + (ffetch (FMTSPEC FMTBASETOBASE) of PARALOOK2)) + (EQUAL (ffetch (FMTSPEC FMTUSERINFO) of PARALOOK1) + (ffetch (FMTSPEC FMTUSERINFO) of PARALOOK2)) + (EQUAL (ffetch (FMTSPEC FMTCHARSTYLES) of PARALOOK1) + (ffetch (FMTSPEC FMTCHARSTYLES) of PARALOOK2)) + (EQUALALL (ffetch (FMTSPEC TABSPEC) of PARALOOK1) + (ffetch (FMTSPEC TABSPEC) of PARALOOK2]) (\TEDIT.UNIQUIFY.PARALOOKS + [LAMBDA (NEWLOOKS TEXTOBJ) (* ; "Edited 30-May-91 21:41 by jds") + + (* Assure that there is only ONE of a given PARALOOKS in the document--so that + all instances of that set of looks share structure.) + + (COND + ((for LOOK in (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ) + thereis (EQFMTSPEC NEWLOOKS LOOK))) + (T (push (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ) + NEWLOOKS) + NEWLOOKS]) (TEDIT.GET.PARALOOKS + [LAMBDA (TEXTSTREAM SELORCH#) (* ; "Edited 30-May-91 21:44 by jds") + (* ; + "Return a proplist of paragraph formatting information about the characters specified.") + (LET* [(TEXTOBJ (TEXTOBJ TEXTSTREAM)) + (SEL (OR SELORCH# (fetch (TEXTOBJ SEL) of TEXTOBJ] + (\TEDIT.UNPARSE.PARALOOKS.LIST (fetch (PIECE PPARALOOKS) + of + (\CHTOPC (CL:TYPECASE SEL + (SELECTION (fetch (SELECTION CH#) + of SEL)) + ((OR FIXP SMALLP) + (IMAX 1 (IMIN SEL (fetch + (TEXTOBJ TEXTLEN) + of TEXTOBJ)) + )) + (T (\ILLEGAL.ARG SEL))) + (fetch (TEXTOBJ PCTB) of TEXTOBJ]) (\TEDIT.UNPARSE.PARALOOKS.LIST + [LAMBDA (FMTSPEC) (* ; "Edited 30-May-91 21:48 by jds") + (* ; + "Convert a FMTSPEC into an equivalent PList-form for external consumption") + (PROG ((NEWLOOKS NIL)) + (for PROP in (LIST (fetch (FMTSPEC QUAD) of FMTSPEC) + (fetch (FMTSPEC 1STLEFTMAR) of FMTSPEC) + (fetch (FMTSPEC LEFTMAR) of FMTSPEC) + (fetch (FMTSPEC RIGHTMAR) of FMTSPEC) + (fetch (FMTSPEC LEADBEFORE) of FMTSPEC) + (fetch (FMTSPEC LEADAFTER) of FMTSPEC) + (fetch (FMTSPEC LINELEAD) of FMTSPEC) + (fetch (FMTSPEC FMTBASETOBASE) of FMTSPEC) + (fetch (FMTSPEC TABSPEC) of FMTSPEC) + (fetch (FMTSPEC FMTSTYLE) of FMTSPEC) + (fetch (FMTSPEC FMTCHARSTYLES) of FMTSPEC) + (fetch (FMTSPEC FMTUSERINFO) of FMTSPEC) + (fetch (FMTSPEC FMTSPECIALX) of FMTSPEC) + (fetch (FMTSPEC FMTSPECIALY) of FMTSPEC) + (fetch (FMTSPEC FMTPARATYPE) of FMTSPEC) + (fetch (FMTSPEC FMTPARASUBTYPE) of FMTSPEC) + (fetch (FMTSPEC FMTNEWPAGEBEFORE) of FMTSPEC) + (fetch (FMTSPEC FMTNEWPAGEAFTER) of FMTSPEC) + (fetch (FMTSPEC FMTHEADINGKEEP) of FMTSPEC) + (fetch (FMTSPEC FMTKEEP) of FMTSPEC) + (fetch (FMTSPEC FMTHARDCOPY) of FMTSPEC) + (fetch (FMTSPEC FMTREVISED) of FMTSPEC) + (fetch (FMTSPEC FMTCOLUMN) of FMTSPEC)) as PROPNAME + in '(QUAD 1STLEFTMARGIN LEFTMARGIN RIGHTMARGIN PARALEADING POSTPARALEADING + LINELEADING BASETOBASE TABS STYLE CHARSTYLES USERINFO SPECIALX SPECIALY + TYPE SUBTYPE NEWPAGEBEFORE NEWPAGEAFTER HEADINGKEEP KEEP HARDCOPY REVISED + COLUMN) as METHOD + in '(VALUE VALUE VALUE VALUE VALUE VALUE VALUE VALUE VALUE VALUE VALUE VALUE VALUE + VALUE VALUE VALUE VALUE VALUE ONOFF VALUE VALUE VALUE VALUE) + do (SELECTQ METHOD + (VALUE (* ; + "Give him the value straight from the looks") + (push NEWLOOKS PROP)) + (ONOFF (* ; "Translate T/NIL into ON/OFF") + (push NEWLOOKS (ONOFF PROP))) + (SHOULDNT)) + (push NEWLOOKS PROPNAME)) + (RETURN NEWLOOKS]) (\TEDIT.PARSE.PARALOOKS.LIST + [LAMBDA (NEWLOOKS OLDLOOKS) (* ; + "Edited 3-Jul-93 21:49 by sybalskY:MV:ENVOS") + (* ; + "Apply a given format spec to the paragraphs which are included in this guy.") + (PROG (D PC PCNO NPC NCHLIM PCTB LASTLOOKS 1STLEFT LEFT RIGHT LEADB LEADA LLEAD TABSPECC QUADD + NLOOKSAVE PC1 TYPE SUBTYPE TYPESET SUBTYPESET NEWBEFORESET NEWBEFORE NEWAFTERSET + NEWAFTER KEEP KEEPSET HEADINGKEEP BASETOBASE BASESET REVISED REVISEDSET COLUMN COLUMNSET + USERINFO USERINFOSET SPECIALX SPECXSET SPECIALY SPECYSET STYLE STYLESET CHARSTYLES + CHARSTYLESSET) + (COND + ((type? FMTSPEC NEWLOOKS) (* ; + "if we were given an FMTSPEC really replace the FMTSPEC of all pieces affected") + (RETURN NEWLOOKS)) + (T (* ; + "create an FMTSPEC from the Alist") + (SETQ 1STLEFT (LISTGET NEWLOOKS '1STLEFTMARGIN)) + (SETQ LEFT (LISTGET NEWLOOKS 'LEFTMARGIN)) + (SETQ RIGHT (LISTGET NEWLOOKS 'RIGHTMARGIN)) + (SETQ LEADB (LISTGET NEWLOOKS 'PARALEADING)) + (SETQ LEADA (LISTGET NEWLOOKS 'POSTPARALEADING)) + (SETQ LLEAD (LISTGET NEWLOOKS 'LINELEADING)) + (SETQ TYPESET (FMEMB 'TYPE NEWLOOKS)) + (SETQ TYPE (LISTGET NEWLOOKS 'TYPE)) + (SETQ SUBTYPESET (FMEMB 'SUBTYPE NEWLOOKS)) + (SETQ SUBTYPE (LISTGET NEWLOOKS 'SUBTYPE)) + (SETQ NEWBEFORESET (FMEMB 'NEWPAGEBEFORE NEWLOOKS)) + (SETQ NEWBEFORE (LISTGET NEWLOOKS 'NEWPAGEBEFORE)) + (SETQ NEWAFTERSET (FMEMB 'NEWPAGEAFTER NEWLOOKS)) + (SETQ NEWAFTER (LISTGET NEWLOOKS 'NEWPAGEAFTER)) + (SETQ HEADINGKEEP (LISTGET NEWLOOKS 'HEADINGKEEP)) + (* ; "Keep for headings") + (SETQ KEEP (LISTGET NEWLOOKS 'KEEP)) (* ; + "More general `Keep-together' spec -- undefined as of 5/22/85") + (SETQ KEEPSET (FMEMB 'KEEP NEWLOOKS)) + (SETQ BASETOBASE (LISTGET NEWLOOKS 'BASETOBASE)) + (SETQ BASESET (FMEMB 'BASETOBASE NEWLOOKS)) + (SETQ REVISED (LISTGET NEWLOOKS 'REVISED)) + (SETQ REVISEDSET (FMEMB 'REVISED NEWLOOKS)) + (SETQ QUADD (LISTGET NEWLOOKS 'QUAD)) + (SETQ COLUMN (LISTGET NEWLOOKS 'COLUMN)) + (SETQ COLUMNSET (FMEMB 'COLUMN NEWLOOKS)) + (SETQ USERINFO (LISTGET NEWLOOKS 'USERINFO)) + (SETQ USERINFOSET (FMEMB 'USERINFO NEWLOOKS)) + (SETQ SPECIALX (LISTGET NEWLOOKS 'SPECIALY)) + (SETQ SPECXSET (FMEMB 'SPECIALY NEWLOOKS)) + (SETQ SPECIALY (LISTGET NEWLOOKS 'SPECIALY)) + (SETQ SPECYSET (FMEMB 'SPECIALY NEWLOOKS)) + (SETQ STYLE (LISTGET NEWLOOKS 'STYLE)) + (SETQ STYLESET (FMEMB 'STYLE NEWLOOKS)) + (SETQ CHARSTYLES (LISTGET NEWLOOKS 'CHARSTYLES)) + (SETQ CHARSTYLESSET (FMEMB 'CHARSTYLES NEWLOOKS)) + [SELECTQ QUADD + ((LEFT RIGHT CENTERED JUSTIFIED NIL) (* ; + "Do nothing -- we got a valid justification spec") + ) + ((JUST J) + (SETQ QUADD 'JUSTIFIED)) + ((L) + (SETQQ QUADD LEFT)) + (R (SETQQ QUADD RIGHT)) + ((C CENTER) + (SETQQ QUADD CENTERED)) + (PROGN (* ; + "We got an illegal QUAD value. Use LEFT.") + (TEDIT.PROMPTPRINT (AND (BOUNDP 'TEXTOBJ) + TEXTOBJ) + (CONCAT "Illegal paragraph quad " QUADD ", replaced with LEFT.") + T) + (SETQ QUADD 'LEFT] + (SETQ TABSPECC (LISTGET NEWLOOKS 'TABS)) + + (* ;; "change from the users list to the real tabspec + +CONS pair of default width and LIST of TAB record instances") + + [COND + (TABSPECC (SETQ TABSPECC (CONS [OR (CAR TABSPECC) + (AND OLDLOOKS (CAR (fetch (FMTSPEC TABSPEC) + of OLDLOOKS] + (for SPEC in (CDR TABSPECC) + collect (create TAB + TABKIND _ (CDR SPEC) + TABX _ (CAR SPEC] + (SETQ NEWLOOKS (create FMTSPEC using (OR OLDLOOKS TEDIT.DEFAULT.FMTSPEC))) + (AND 1STLEFT (replace (FMTSPEC 1STLEFTMAR) of NEWLOOKS with 1STLEFT)) + (AND LEFT (replace (FMTSPEC LEFTMAR) of NEWLOOKS with LEFT)) + (AND RIGHT (replace (FMTSPEC RIGHTMAR) of NEWLOOKS with RIGHT)) + (AND LEADB (replace (FMTSPEC LEADBEFORE) of NEWLOOKS with LEADB)) + (AND LEADA (replace (FMTSPEC LEADAFTER) of NEWLOOKS with LEADA)) + (AND LLEAD (replace (FMTSPEC LINELEAD) of NEWLOOKS with LLEAD)) + (AND TABSPECC (replace (FMTSPEC TABSPEC) of NEWLOOKS with TABSPECC)) + (AND QUADD (replace (FMTSPEC QUAD) of NEWLOOKS with QUADD)) + (AND TYPESET (replace (FMTSPEC FMTPARATYPE) of NEWLOOKS with TYPE)) + (AND SUBTYPESET (replace (FMTSPEC FMTPARASUBTYPE) of NEWLOOKS with + SUBTYPE)) + (AND NEWBEFORESET (replace (FMTSPEC FMTNEWPAGEBEFORE) of NEWLOOKS + with NEWBEFORE)) + (AND NEWAFTERSET (replace (FMTSPEC FMTNEWPAGEAFTER) of NEWLOOKS with + NEWAFTER)) + [AND HEADINGKEEP (replace (FMTSPEC FMTHEADINGKEEP) of NEWLOOKS + with (EQ HEADINGKEEP 'ON] + (AND KEEPSET (replace (FMTSPEC FMTKEEP) of NEWLOOKS with KEEP)) + (AND BASESET (replace (FMTSPEC FMTBASETOBASE) of NEWLOOKS with BASETOBASE + )) + (AND REVISEDSET (replace (FMTSPEC FMTREVISED) of NEWLOOKS with REVISED)) + (AND COLUMNSET (replace (FMTSPEC FMTCOLUMN) of NEWLOOKS with COLUMN)) + (AND SPECXSET (replace (FMTSPEC FMTSPECIALX) of NEWLOOKS with SPECIALX)) + (AND SPECYSET (replace (FMTSPEC FMTSPECIALY) of NEWLOOKS with SPECIALY)) + (AND STYLESET (replace (FMTSPEC FMTSTYLE) of NEWLOOKS with STYLE)) + (AND CHARSTYLESSET (replace (FMTSPEC FMTCHARSTYLES) of NEWLOOKS with + CHARSTYLES)) + (AND USERINFOSET (replace (FMTSPEC FMTUSERINFO) of NEWLOOKS with USERINFO + )) + (RETURN NEWLOOKS]) (TEDIT.PARALOOKS + [LAMBDA (TEXTOBJ NEWLOOKS SEL LEN) (* ; "Edited 21-Apr-93 18:44 by jds") + + (* ;; "Apply a given format spec to the paragraphs which are included in this guy.") + + (SETQ TEXTOBJ (TEXTOBJ TEXTOBJ)) + (PROG ([SEL (COND + ((type? SELECTION SEL) + SEL) + ((FIXP SEL) + (TEDIT.SETSEL TEXTOBJ SEL LEN 'RIGHT)) + (T (fetch (TEXTOBJ SEL) of TEXTOBJ] + CH# CHLIM REPLACEALLFIELDS D PC PCNO NPC NCHLIM PCTB LASTLOOKS 1STLEFT LEFT RIGHT LEADB + LEADA BLEAD BLEADSET LLEAD TABSPECC QUADD NLOOKSAVE PC1 OLDLOOKSLIST TYPE SUBTYPE TYPESET + SUBTYPESET SPECIALX SPECIALY NEWBEFORESET NEWBEFORE NEWAFTERSET NEWAFTER KEEP KEEPSET + HEADINGKEEP BASETOBASE BASESET HCPYMODE HCPYSET USERINFO USERSET REVISED REVISEDSET STYLE + STYLESET CHARSTYLES CHARSTYLESSET COLUMN COLUMNSET STYLE STYLESET START-OF-PIECE OLDSTART) + (SETQ CH# (fetch (SELECTION CH#) of SEL)) (* ; "First affected character") + (SETQ CHLIM (IMIN (IMAX CH# (SUB1 (fetch (SELECTION CHLIM) of SEL))) + (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) + (* ; "Last affected character.") + (COND + ((IGREATERP CH# (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (* ; + "Can't change the para looks of something beyond end of text.") + (RETURN)) + ((NOT (fetch (SELECTION SET) of SEL)) (* ; + "Can't do anything if there is no selection set in the main document") + (RETURN))) + (COND + ((NOT (fetch (TEXTOBJ FORMATTEDP) of TEXTOBJ)) + (\TEDIT.CONVERT.TO.FORMATTED TEXTOBJ))) + (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + (* ; + "Because it may grow during the conversion to formatted.") + (SETQ PC (\CHTOPC CH# PCTB T)) + (SETQ OLDSTART START-OF-PIECE) + (SETQ PC1 PC) + (SETQ NLOOKSAVE NEWLOOKS) + [COND + ((type? FMTSPEC NEWLOOKS) (* ; + "if we were given an FMTSPEC really replace the FMTSPEC of all pieces affected") + (SETQ D (create FMTSPEC copying NEWLOOKS)) + (* ; + "Create the universal replacement looks") + (SETQ REPLACEALLFIELDS T) (* ; + "And set the replace-everything flag.") + ) + (T (* ; + "create an FMTSPEC from the Alist") + (SETQ 1STLEFT (LISTGET NEWLOOKS '1STLEFTMARGIN)) + (SETQ LEFT (LISTGET NEWLOOKS 'LEFTMARGIN)) + (SETQ RIGHT (LISTGET NEWLOOKS 'RIGHTMARGIN)) + (SETQ LEADB (LISTGET NEWLOOKS 'PARALEADING)) + (SETQ LEADA (LISTGET NEWLOOKS 'POSTPARALEADING)) + (SETQ LLEAD (LISTGET NEWLOOKS 'LINELEADING)) + (SETQ BLEAD (LISTGET NEWLOOKS 'BASETOBASE)) + (SETQ BLEADSET (FMEMB 'BASETOBASE NEWLOOKS)) + (SETQ QUADD (LISTGET NEWLOOKS 'QUAD)) + (SETQ TYPESET (FMEMB 'TYPE NEWLOOKS)) + (SETQ TYPE (LISTGET NEWLOOKS 'TYPE)) + (SETQ SUBTYPESET (FMEMB 'SUBTYPE NEWLOOKS)) + (SETQ SUBTYPE (LISTGET NEWLOOKS 'SUBTYPE)) + (SETQ SPECIALX (LISTGET NEWLOOKS 'SPECIALX)) + (SETQ SPECIALY (LISTGET NEWLOOKS 'SPECIALY)) + (SETQ NEWBEFORESET (FMEMB 'NEWPAGEBEFORE NEWLOOKS)) + (SETQ NEWBEFORE (LISTGET NEWLOOKS 'NEWPAGEBEFORE)) + (SETQ NEWAFTERSET (FMEMB 'NEWPAGEAFTER NEWLOOKS)) + (SETQ NEWAFTER (LISTGET NEWLOOKS 'NEWPAGEAFTER)) + (SETQ HEADINGKEEP (LISTGET NEWLOOKS 'HEADINGKEEP)) + (* ; "Keep for headings") + (SETQ KEEP (LISTGET NEWLOOKS 'KEEP)) (* ; + "More general 'Keep-together' spec -- undefined as of 5/22/85") + (SETQ KEEPSET (FMEMB 'KEEP NEWLOOKS)) + (SETQ BASETOBASE (LISTGET NEWLOOKS 'BASETOBASE)) + (SETQ BASESET (FMEMB 'BASETOBASE NEWLOOKS)) + (SETQ HCPYMODE (LISTGET NEWLOOKS 'HARDCOPY)) + (SETQ HCPYSET (FMEMB 'HARDCOPY NEWLOOKS)) + (SETQ USERINFO (LISTGET NEWLOOKS 'USERINFO)) + (SETQ USERSET (FMEMB 'USERINFO NEWLOOKS)) + (SETQ REVISED (LISTGET NEWLOOKS 'REVISED)) + (SETQ REVISEDSET (FMEMB 'REVISED NEWLOOKS)) + (SETQ TABSPECC (LISTGET NEWLOOKS 'TABS)) + (SETQ STYLE (LISTGET NEWLOOKS 'STYLE)) + (SETQ STYLESET (FMEMB 'STYLE NEWLOOKS)) + (SETQ CHARSTYLES (LISTGET NEWLOOKS 'CHARSTYLES)) + (SETQ CHARSTYLESSET (FMEMB 'CHARSTYLES NEWLOOKS)) + (SETQ COLUMN (LISTGET NEWLOOKS 'COLUMN)) + (SETQ COLUMNSET (FMEMB 'COLUMN NEWLOOKS)) + (SETQ STYLE (LISTGET NEWLOOKS 'STYLE)) + (SETQ STYLESET (FMEMB 'STYLE NEWLOOKS)) + + (* ;; "change from the users list to the real tabspec --- CONS pair of default width and LIST of TAB record instances") + + (COND + (TABSPECC (SETQ TABSPECC (CONS [OR (COND + ((AND (CAR TABSPECC) + (ZEROP (CAR TABSPECC))) + 1) + (T (CAR TABSPECC))) + (CAR (fetch (FMTSPEC TABSPEC) + of (fetch (PIECE PPARALOOKS) + of PC] + (for SPEC in (CDR TABSPECC) + collect (create TAB + TABKIND _ (CDR SPEC) + TABX _ (CAR SPEC] + [COND + (REPLACEALLFIELDS + + (* ;; "Given that we're replacing the FMTSPEC wholesale, let's uniquify it within this document OUTSIDE the loop.") + + (SETQ D (\TEDIT.UNIQUIFY.PARALOOKS D TEXTOBJ] + (bind (NPC _ PC) while NPC + do (SETQ OLDLOOKSLIST (NCONC1 OLDLOOKSLIST (fetch (PIECE PPARALOOKS) + of NPC))) + [COND + (REPLACEALLFIELDS + + (* ;; "We're replacing the whole paragraph format. Just smash the new one it; it has been uniquified (and recorded in the master list) already.") + + (replace (PIECE PPARALOOKS) of NPC with D)) + (T (* ; + "Only replacing part of the looks; create a new one, and smash it.") + (COND + [(NEQ (fetch (PIECE PPARALOOKS) of NPC) + LASTLOOKS) (* ; + "only build a new FMTSPEC when they are different") + (SETQ LASTLOOKS (ffetch (PIECE PPARALOOKS) of NPC)) + (SETQ NEWLOOKS (create FMTSPEC using LASTLOOKS)) + (AND 1STLEFT (freplace (FMTSPEC 1STLEFTMAR) of NEWLOOKS + with 1STLEFT)) + (AND LEFT (freplace (FMTSPEC LEFTMAR) of NEWLOOKS with + LEFT)) + (AND RIGHT (freplace (FMTSPEC RIGHTMAR) of NEWLOOKS with + RIGHT)) + (AND LEADB (freplace (FMTSPEC LEADBEFORE) of NEWLOOKS + with LEADB)) + (AND LEADA (freplace (FMTSPEC LEADAFTER) of NEWLOOKS + with LEADA)) + (AND BLEADSET (freplace (FMTSPEC FMTBASETOBASE) of NEWLOOKS + with BLEAD)) + (AND LLEAD (freplace (FMTSPEC LINELEAD) of NEWLOOKS with + LLEAD)) + (AND TABSPECC (freplace (FMTSPEC TABSPEC) of NEWLOOKS + with TABSPECC)) + (AND QUADD (freplace (FMTSPEC QUAD) of NEWLOOKS with QUADD)) + (AND TYPESET (freplace (FMTSPEC FMTPARATYPE) of NEWLOOKS + with TYPE)) + (AND SUBTYPESET (freplace (FMTSPEC FMTPARASUBTYPE) of NEWLOOKS + with SUBTYPE)) + (AND SPECIALX (freplace (FMTSPEC FMTSPECIALX) of NEWLOOKS + with SPECIALX)) + (AND SPECIALY (freplace (FMTSPEC FMTSPECIALY) of NEWLOOKS + with SPECIALY)) + (AND NEWBEFORESET (freplace (FMTSPEC FMTNEWPAGEBEFORE) of + NEWLOOKS + with NEWBEFORE)) + (AND NEWAFTERSET (freplace (FMTSPEC FMTNEWPAGEAFTER) of NEWLOOKS + with NEWAFTER)) + [AND HEADINGKEEP (freplace (FMTSPEC FMTHEADINGKEEP) of NEWLOOKS + with (EQ HEADINGKEEP 'ON] + (AND KEEPSET (freplace (FMTSPEC FMTKEEP) of NEWLOOKS + with KEEP)) + (AND BASESET (freplace (FMTSPEC FMTBASETOBASE) of NEWLOOKS + with BASETOBASE)) + (AND HCPYSET (freplace (FMTSPEC FMTHARDCOPY) of NEWLOOKS + with HCPYMODE)) + (AND USERSET (freplace (FMTSPEC FMTUSERINFO) of NEWLOOKS + with USERINFO)) + (AND REVISEDSET (freplace (FMTSPEC FMTREVISED) of NEWLOOKS + with REVISED)) + (AND STYLESET (freplace (FMTSPEC FMTSTYLE) of NEWLOOKS + with STYLE)) + (AND CHARSTYLESSET (freplace (FMTSPEC FMTCHARSTYLES) of NEWLOOKS + with CHARSTYLES)) + (AND COLUMNSET (freplace (FMTSPEC FMTCOLUMN) of NEWLOOKS + with COLUMN)) + (AND STYLESET (replace (FMTSPEC FMTSTYLE) of NEWLOOKS + with STYLE)) + (freplace (PIECE PPARALOOKS) of NPC with (SETQ NEWLOOKS + ( + \TEDIT.UNIQUIFY.PARALOOKS + NEWLOOKS TEXTOBJ] + (T (* ; "Re-use the last set of looks; they're still what we want (this paragraph looks like the last one.)") + (freplace (PIECE PPARALOOKS) of NPC with NEWLOOKS] + [SETQ CHLIM (IMAX CHLIM (SETQ NCHLIM (SETQ START-OF-PIECE + (IPLUS START-OF-PIECE (fetch + (PIECE PLEN) + of NPC] + (COND + ((fetch (PIECE PPARALAST) of NPC) + (* ; + "We've found the end of a paragraph. Stop to see if we've run off the end yet.") + (COND + ((IGEQ NCHLIM (SUB1 (fetch (SELECTION CHLIM) of SEL))) + (RETURN))) (* ; "Make a new set of looks.") + )) + (SETQ NPC (fetch (PIECE NEXTPIECE) of NPC))) + (SETQ LASTLOOKS NIL) + [bind (NPC _ (fetch (PIECE PREVPIECE) of PC)) + while (AND NPC (NOT (fetch (PIECE PPARALAST) of NPC))) + do (SETQ OLDLOOKSLIST (CONS (fetch (PIECE PPARALOOKS) of NPC) + OLDLOOKSLIST)) + [COND + (REPLACEALLFIELDS + + (* ;; "We're replacing the whole paragraph format. Just smash the new one it; it has been uniquified (and recorded in the master list) already.") + + (replace (PIECE PPARALOOKS) of NPC with D)) + (T (* ; + "Only replacing part of the looks; create a new one, and smash it.") + (COND + [(NEQ (fetch (PIECE PPARALOOKS) of NPC) + LASTLOOKS) (* ; + "only build a new FMTSPEC when they are different") + (SETQ LASTLOOKS (fetch (PIECE PPARALOOKS) of NPC)) + (SETQ NEWLOOKS (create FMTSPEC using LASTLOOKS)) + (AND 1STLEFT (freplace (FMTSPEC 1STLEFTMAR) of NEWLOOKS + with 1STLEFT)) + (AND LEFT (freplace (FMTSPEC LEFTMAR) of NEWLOOKS with + LEFT)) + (AND RIGHT (freplace (FMTSPEC RIGHTMAR) of NEWLOOKS with + RIGHT)) + (AND LEADB (freplace (FMTSPEC LEADBEFORE) of NEWLOOKS + with LEADB)) + (AND LEADA (freplace (FMTSPEC LEADAFTER) of NEWLOOKS + with LEADA)) + (AND LLEAD (freplace (FMTSPEC LINELEAD) of NEWLOOKS with + LLEAD)) + (AND TABSPECC (freplace (FMTSPEC TABSPEC) of NEWLOOKS + with TABSPECC)) + (AND QUADD (freplace (FMTSPEC QUAD) of NEWLOOKS with QUADD)) + (AND TYPESET (freplace (FMTSPEC FMTPARATYPE) of NEWLOOKS + with TYPE)) + (AND SUBTYPESET (freplace (FMTSPEC FMTPARASUBTYPE) of NEWLOOKS + with SUBTYPE)) + (AND SPECIALX (freplace (FMTSPEC FMTSPECIALX) of NEWLOOKS + with SPECIALX)) + (AND SPECIALY (freplace (FMTSPEC FMTSPECIALY) of NEWLOOKS + with SPECIALY)) + (AND NEWBEFORESET (freplace (FMTSPEC FMTNEWPAGEBEFORE) of + NEWLOOKS + with NEWBEFORE)) + (AND NEWAFTERSET (freplace (FMTSPEC FMTNEWPAGEAFTER) of NEWLOOKS + with NEWAFTER)) + [AND HEADINGKEEP (freplace (FMTSPEC FMTHEADINGKEEP) of NEWLOOKS + with (EQ HEADINGKEEP 'ON] + (AND KEEPSET (freplace (FMTSPEC FMTKEEP) of NEWLOOKS + with KEEP)) + (AND BASESET (freplace (FMTSPEC FMTBASETOBASE) of NEWLOOKS + with BASETOBASE)) + (AND HCPYSET (freplace (FMTSPEC FMTHARDCOPY) of NEWLOOKS + with HCPYMODE)) + (AND USERSET (freplace (FMTSPEC FMTUSERINFO) of NEWLOOKS + with USERINFO)) + (AND REVISEDSET (freplace (FMTSPEC FMTREVISED) of NEWLOOKS + with REVISED)) + (AND STYLESET (freplace (FMTSPEC FMTSTYLE) of NEWLOOKS + with STYLE)) + (AND CHARSTYLESSET (freplace (FMTSPEC FMTCHARSTYLES) of NEWLOOKS + with CHARSTYLES)) + (AND COLUMNSET (freplace (FMTSPEC FMTCOLUMN) of NEWLOOKS + with COLUMN)) + (AND STYLESET (freplace (FMTSPEC FMTSTYLE) of NEWLOOKS + with STYLE)) + (freplace (PIECE PPARALOOKS) of NPC with (SETQ NEWLOOKS + ( + \TEDIT.UNIQUIFY.PARALOOKS + NEWLOOKS TEXTOBJ] + (T (* ; "Re-use the last set of looks; they're still what we want (this paragraph looks like the last one.)") + (freplace (PIECE PPARALOOKS) of NPC with NEWLOOKS] + (SETQ PC1 NPC) + (SETQ OLDSTART (IDIFFERENCE OLDSTART (fetch (PIECE PLEN) of PC1))) + (SETQ NPC (fetch (PIECE PREVPIECE) of NPC)) + finally (SETQ CH# (IMIN CH# (IMAX 1 OLDSTART] + (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) + NIL NIL) (* ; + "Turn off the sel before updating the screen") + (\TEDIT.MARK.LINES.DIRTY TEXTOBJ CH# (ADD1 CHLIM)) + (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T) + (* ; "Mark the document as changed.") + (\TEDIT.HISTORYADD TEXTOBJ + (create TEDITHISTORYEVENT + THACTION _ 'ParaLooks + THLEN _ (IDIFFERENCE CHLIM CH#) + THCH# _ CH# + THFIRSTPIECE _ PC1 + THOLDINFO _ OLDLOOKSLIST + THAUXINFO _ NLOOKSAVE)) (* ; "Save this action for undo/redo") + (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) + (COND + ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + (TEDIT.UPDATE.SCREEN TEXTOBJ) (* ; "Update the screen image") + (\FIXSEL SEL TEXTOBJ) + (\SHOWSEL SEL NIL T]) (TEDIT.COPY.PARALOOKS + [LAMBDA (STREAM SOURCE DEST) (* ; "Edited 30-May-91 21:44 by jds") + + (* ;; "Copy the PARAGRAPH LOOKS from one place to another") + + (PROG ((TEXTOBJ (TEXTOBJ STREAM)) + LOOKS LEN) (* ; + "get the paragraph looks of the first character of SOURCE") + [SETQ LOOKS (fetch (PIECE PPARALOOKS) + of (CL:TYPECASE SOURCE + ((SMALLP FIXP) (\CHTOPC SOURCE (fetch (TEXTOBJ PCTB) + of TEXTOBJ))) + (SELECTION + (\SHOWSEL SOURCE NIL NIL) + (* ; + "Turn off the looks-source selection") + (\CHTOPC (fetch (SELECTION CH#) of SOURCE) + (fetch (TEXTOBJ PCTB) of (fetch + (SELECTION \TEXTOBJ) + of SOURCE)))) + (T (\ILLEGAL.ARG SOURCE)))] + (COND + [(type? SELECTION DEST) (* ; + "make sure that the destination selection is in this document") + (COND + ((NEQ TEXTOBJ (fetch (SELECTION \TEXTOBJ) of DEST)) + (\LISPERROR "Destination selection is not in stream " STREAM] + (T (* ; + "set the LEN arg for TEDIT.PARALOOKS to be 1 since we just have a char pos.") + (SETQ LEN 1))) + (TEDIT.PARALOOKS TEXTOBJ LOOKS DEST LEN]) (\TEDIT.PUT.PARALOOKS + [LAMBDA (FILE PC PARAHASH) (* ; "Edited 30-May-91 21:44 by jds") + + (* ;; "Put a description of LOOKS into FILE. LOOKS apply to characters CH1 thru CHLIM-1") + + (* ;; "NB: ANY CHANGE TO THE FORMAT THIS PUTS OUT NEEDS TO BE MIRRORED IN TEDIT.PUT.PCTB WHERE IT PUTS OUT THE DUMMY FINAL PARAGRAPH PIECE.") + + (PROG ((LOOKS (fetch (PIECE PPARALOOKS) of PC)) + DEFAULTTAB TABSPECS OUTPUTFORMAT) + (\DWOUT FILE 0) (* ; + "Place holder for number of characters in the piece -- really taken from the charlooks.") + (\SMALLPOUT FILE \PieceDescriptorPARA) (* ; + "Identify this as a paragraph looks piece") + (\SMALLPOUT FILE (GETHASH LOOKS PARAHASH]) (\TEDIT.CONVERT.TO.FORMATTED + [LAMBDA (TEXTOBJ START END) (* ; "Edited 29-Apr-93 19:47 by jds") + (* ; + "Turn an unformatted TEdit file into a formatted TEdit file.") + (PROG ((NEXTCR (\TEDIT.BASICFIND TEXTOBJ (MKSTRING (CHARACTER (CHARCODE CR))) + (OR START 1))) + (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + [CRSTRING (MKSTRING (CHARACTER (CHARCODE CR] + (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + PCNO PC START-OF-PIECE) + [while (AND NEXTCR (ILEQ NEXTCR (OR END TEXTLEN))) + do (* ; + "Look at each CR in the range given (or whole file) and insert paragraph breaks accordingly.") + (SETQ PC (\CHTOPC NEXTCR (fetch (TEXTOBJ PCTB) of TEXTOBJ) + T)) + [COND + ((IEQP (ADD1 NEXTCR) + START-OF-PIECE) (* ; + "This para ends on a piece bound.") + ) + (T (* ; + "The CR is in mid-piece. Split just after it.") + (\SPLITPIECE PC (- (ADD1 NEXTCR) + START-OF-PIECE) + TEXTOBJ PCNO) + (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ] + (replace (PIECE PPARALAST) of PC with T) + (SETQ NEXTCR (\TEDIT.BASICFIND TEXTOBJ CRSTRING (ADD1 NEXTCR] + (replace (TEXTOBJ FORMATTEDP) of TEXTOBJ with T) + (\TEDIT.MARK.LINES.DIRTY TEXTOBJ (OR START 1) + (OR END TEXTLEN]) (\TEDIT.PARABOUNDS + [LAMBDA (TEXTOBJ CH#) (* ; "Edited 21-Apr-93 18:22 by jds") + + (* ;; "returns the first and last chars of the paragraph bracketed by CH#") + + (PROG ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + PCNO NPC PC OPC BEGIN END PIECE START-OF-PIECE OLDSTART) + [COND + ((ZEROP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (* ; + "An empty document has no paragraphs.") + (RETURN (CONS 1 1] + (SETQ PC (\CHTOPC CH# PCTB T)) + [COND + ((ATOM PC) (* ; + "OOPS, we found the end-of-doc piece. Back up to the last real piece in the document.") + (SETQ PC (\CHTOPC (FETCH (TEXTOBJ TEXTLEN) OF TEXTOBJ) + PCTB T] + (SETQ PIECE PC) + (SETQ OPC PIECE) + (SETQ OLDSTART (IPLUS START-OF-PIECE (fetch (PIECE PLEN) of PC))) + (repeatwhile (AND PIECE (NOT (fetch (PIECE PPARALAST) of OPC))) + do (* ; + "Find the piece that ends the paragraph") + (SETQ OPC PIECE) + (add START-OF-PIECE (fetch (PIECE PLEN) of PIECE)) + (SETQ PIECE (fetch (PIECE NEXTPIECE) of PIECE))) + [SETQ END (COND + (PIECE (* ; + "This is the piece that ends the para. Get the CH# of its final character") + (SUB1 START-OF-PIECE)) + (T (* ; + "If PIECE winds up NIL, we walked off the end of the document, so use the textlen.") + (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ] + (bind (PIECE _ PC) repeatwhile (AND PIECE (NOT (fetch (PIECE PPARALAST) + of PIECE))) + do (* ; + "Now find the piece that ends the previous paragraph") + (add OLDSTART (IMINUS (fetch (PIECE PLEN) of PIECE))) + (SETQ PIECE (fetch (PIECE PREVPIECE) of PIECE))) + (SETQ BEGIN OLDSTART) (* ; + "Actually, NPC is pointing at the piece that starts THIS para.") + (RETURN (CONS BEGIN END]) (\TEDIT.FORMATTABS + [LAMBDA (TEXTOBJ TABSPEC THISLINE CHBASE WBASE CURTX DFLTTABX MARGINXOFFSET PRIORTAB GRAIN + CLEANINGUP) (* ; "Edited 13-Nov-90 01:09 by jds") + (* ; + "Do the formatting work for a tab.") + + (* ;; "PRIORTAB is the outstanding tab, if any, that has to be resolved. This will be a centered or flush right tab. its format is a PENDINGTAB") + + (* ;; "If CLEANINGUP is non-NIL, then we're at the end of the line, and only need to resolve the outstanding tab.") + + (* ;; "GRAIN is the granularity of the tab spacing; anything within GRAIN will slop over to the next tab. This is to finesse rounding problems when going among various devices.") + + (PROG (NEXTTAB NEXTTABTYPE NEXTTABX DEFAULTTAB TABWIDTH) + [COND + (PRIORTAB + + (* ;; "If there is a prior tab to resolve, do that first--it affects the perceived current X value, which affects later tabs") + + (SELECTQ (fetch PTTYPE of PRIORTAB) + ((CENTERED DOTTEDCENTERED) (* ; "Centered around the tab X") + [SETQ TABWIDTH (IMAX 3 (IDIFFERENCE (IDIFFERENCE + (fetch PTTABX of PRIORTAB) + (LRSH (IDIFFERENCE CURTX + (fetch PTOLDTX + of PRIORTAB)) + 1)) + (fetch PTOLDTX of PRIORTAB] + (\RPLPTR (fetch PTWBASE of PRIORTAB) + 0 TABWIDTH) + (add CURTX TABWIDTH)) + ((RIGHT DOTTEDRIGHT DECIMAL DOTTEDDECIMAL) + (* ; "Snug up against the tab X") + [SETQ TABWIDTH (IMAX 3 (IDIFFERENCE (IDIFFERENCE (fetch PTTABX + of PRIORTAB) + (IDIFFERENCE CURTX + (fetch PTOLDTX + of PRIORTAB))) + (fetch PTOLDTX of PRIORTAB] + (\RPLPTR (fetch PTWBASE of PRIORTAB) + 0 TABWIDTH) (* ; + "Now we can fill in the real width") + (add CURTX TABWIDTH)) + (SHOULDNT] + (SETQ DEFAULTTAB (OR (CAR TABSPEC) + DFLTTABX)) (* ; + "Default Tab width, if there aren't any real tabs to use") + (SETQ NEXTTAB (for TAB in (CDR TABSPEC) when (IGREATERP (fetch TABX + of TAB) + (IDIFFERENCE CURTX + MARGINXOFFSET)) + do (RETURN TAB))) (* ; + "The next tab on this line, if any") + (SETQ NEXTTABTYPE (OR (AND NEXTTAB (fetch TABKIND of NEXTTAB)) + 'LEFT)) (* ; + "The type of the next tab (LEFT, if we use the default spacing)") + (SETQ NEXTTABX (IPLUS [COND + (NEXTTAB (* ; + "There is a real tab to go to; use its location.") + (fetch TABX of NEXTTAB)) + (T (* ; + "No real tab; use the next multiple of the default spacing.") + (ITIMES DEFAULTTAB (IPLUS 1 (IQUOTIENT (IPLUS GRAIN + (IDIFFERENCE + CURTX + MARGINXOFFSET)) + DEFAULTTAB] + MARGINXOFFSET)) (* ; "The next tab's X value") + (COND + (CLEANINGUP (* ; + "We're cleaning up at end of line, so this shouldn't have any effect.") + (RETURN CURTX)) + (T (SELECTQ NEXTTABTYPE + ((DOTTEDLEFT DOTTEDCENTERED DOTTEDRIGHT DOTTEDDECIMAL) + (* ; + "This is a dotted-leader tab. Change it to Meta-TAB, so the line displayer knows.") + (\RPLPTR CHBASE 0 (CHARCODE %#^I))) + NIL) + (SELECTQ NEXTTABTYPE + ((LEFT DOTTEDLEFT) (* ; "Flush LEFT TAB.") + (SETQ TABWIDTH (IMAX 1 (IDIFFERENCE NEXTTABX CURTX))) + (\RPLPTR WBASE 0 TABWIDTH) + (RETURN CURTX)) + ((CENTERED DOTTEDCENTERED) (* ; "Centered around the tab X") + (\RPLPTR WBASE 0 0) (* ; "For now, the TAB is 0 wide") + (RETURN (create PENDINGTAB + PTNEWTX _ CURTX + PTOLDTAB _ NEXTTAB + PTTYPE _ NEXTTABTYPE + PTTABX _ NEXTTABX + PTWBASE _ WBASE + PTOLDTX _ CURTX))) + ((RIGHT DOTTEDRIGHT DECIMAL DOTTEDDECIMAL) + (* ; "Snug up against the tab X") + (\RPLPTR WBASE 0 0) (* ; "For now, the TAB is 0 wide") + (RETURN (create PENDINGTAB + PTNEWTX _ CURTX + PTOLDTAB _ NEXTTAB + PTTYPE _ NEXTTABTYPE + PTTABX _ NEXTTABX + PTWBASE _ WBASE + PTOLDTX _ CURTX))) + (SHOULDNT]) ) (* ;; "For making paragraph-looks substitutions.") (DEFINEQ (TEDIT.SUBPARALOOKS + [LAMBDA (TEXTSTREAM OLDLOOKSLIST NEWLOOKSLIST) (* ; "Edited 26-Apr-93 15:13 by jds") + +(* ;;; "User entry to substitute one set of looks for another. Goes through the whole textstream and whenever the looks match the characteristics of OLDLOOKSLIST which are specified, the characteristics listed in NEWLOOKSLIST are substituted.") + + (LET* ((OLDLOOKS (\TEDIT.PARSE.PARALOOKS.LIST OLDLOOKSLIST)) + (NEWLOOKS (\TEDIT.PARSE.PARALOOKS.LIST NEWLOOKSLIST)) + (TEXTOBJ (TEXTOBJ TEXTSTREAM)) + (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + (FIRSTPC (\CHTOPC 1 PCTB)) + (FEATURELIST (for A on OLDLOOKSLIST by (CDDR A) collect (CAR A))) + CHANGEMADE) + (\SHOWSEL SEL NIL NIL) (* ; "Turn off the selection, first.") + [OR (ZEROP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (bind (CH# _ 1) for (PC _ FIRSTPC) while PC + by (fetch (PIECE NEXTPIECE) of PC) + do (COND + ((SAMEPARALOOKS OLDLOOKS (fetch (PIECE PPARALOOKS) of PC) + FEATURELIST) + (replace (TEXTOBJ \DIRTY) of (TEXTOBJ TEXTSTREAM) with T) + (freplace (PIECE PPARALOOKS) of PC + with (\TEDIT.UNIQUIFY.PARALOOKS (\TEDIT.PARSE.PARALOOKS.LIST + NEWLOOKSLIST + (fetch (PIECE PPARALOOKS) + of PC)) + (TEXTOBJ TEXTSTREAM))) + (\TEDIT.MARK.LINES.DIRTY TEXTOBJ CH# (+ CH# (fetch (PIECE PLEN) + of PC))) + (SETQ CHANGEMADE T))) + (add CH# (fetch (PIECE PLEN) of PC] + (COND + ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + (TEDIT.UPDATE.SCREEN TEXTOBJ) (* ; "Update the screen image") + (\FIXSEL SEL TEXTOBJ) + (\SHOWSEL SEL NIL T))) + (COND + (CHANGEMADE 'Done) + (T 'NoChangesMade]) (SAMEPARALOOKS + [LAMBDA (PARALOOK1 PARALOOK2 FEATURES) (* ; "Edited 8-Dec-92 00:44 by jds") + + (* ;; "Predicate to determine if CLOOK1 and CLOOK2 are the same in all the characteristics listed in FEATURES") + + (for F in FEATURES always (SELECTQ F + (STYLE (EQUAL (fetch (FMTSPEC FMTSTYLE) + of PARALOOK1) + (fetch (FMTSPEC FMTSTYLE) + of PARALOOK2))) + (LEFTMARGIN (IEQP (fetch (FMTSPEC LEFTMAR) + of PARALOOK1) + (fetch (FMTSPEC LEFTMAR) + of PARALOOK2))) + (1STLEFTMARGIN (IEQP (fetch (FMTSPEC 1STLEFTMAR) + of PARALOOK1) + (fetch (FMTSPEC 1STLEFTMAR) + of PARALOOK2))) + (RIGHTMARGIN (IEQP (fetch (FMTSPEC RIGHTMAR) + of PARALOOK1) + (fetch (FMTSPEC RIGHTMAR) + of PARALOOK2))) + (QUAD (EQ (fetch (FMTSPEC QUAD) of PARALOOK1) + (fetch (FMTSPEC QUAD) of PARALOOK2))) + (POSTPARALEADING + (IEQP (fetch (FMTSPEC LEADBEFORE) of + PARALOOK1) + (fetch (FMTSPEC LEADBEFORE) of + PARALOOK2))) + (PARALEADING (IEQP (fetch (FMTSPEC LEADBEFORE) + of PARALOOK1) + (fetch (FMTSPEC LEADBEFORE) + of PARALOOK2))) + (LINELEADING (IEQP (fetch (FMTSPEC LINELEAD) + of PARALOOK1) + (fetch (FMTSPEC LINELEAD) + of PARALOOK2))) + (TABS (EQUAL (fetch (FMTSPEC TABSPEC) of + PARALOOK1 + ) + (fetch (FMTSPEC TABSPEC) of + PARALOOK2 + ))) + (NEWPAGEBEFORE (EQ (fetch (FMTSPEC FMTNEWPAGEBEFORE + ) of PARALOOK1 + ) + (fetch (FMTSPEC FMTNEWPAGEBEFORE + ) of PARALOOK2 + ))) + (NEWPAGEAFTER (EQ (fetch (FMTSPEC FMTNEWPAGEAFTER) + of PARALOOK1) + (fetch (FMTSPEC FMTNEWPAGEAFTER) + of PARALOOK2))) + (SPECIALX (IEQP (fetch (FMTSPEC FMTSPECIALX) + of PARALOOK1) + (fetch (FMTSPEC FMTSPECIALX) + of PARALOOK2))) + (SPECIALY (IEQP (fetch (FMTSPEC FMTSPECIALY) + of PARALOOK1) + (fetch (FMTSPEC FMTSPECIALY) + of PARALOOK2))) + (HEADINGKEEP (EQ (fetch (FMTSPEC FMTHEADINGKEEP) + of PARALOOK1) + (fetch (FMTSPEC FMTHEADINGKEEP) + of PARALOOK2))) + (ERROR (CONCAT F + " is an unknown feature of paragraph looks. Detected in SAMEPARALOOKS" + ]) ) (* ; "UNDO & History List stuff") (DEFINEQ (TEDIT.REDO.LOOKS + [LAMBDA (TEXTOBJ EVENT CH#) (* ; "Edited 30-May-91 21:42 by jds") + (* Set looks on the current + selection from the + TEDIT.CHARLOOKS.WINDOW) + (PROG ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (NEWLOOKS (fetch THAUXINFO of EVENT))) + (COND + ((fetch (SELECTION SET) of SEL) (* He's got something selected.) + (TEDIT.LOOKS TEXTOBJ NEWLOOKS SEL) (* Go perform a similar action + again.) + ) + (T (TEDIT.PROMPTPRINT TEXTOBJ "Please select some text to modify first" T]) (TEDIT.REDO.PARALOOKS + [LAMBDA (TEXTOBJ EVENT CH#) (* ; "Edited 30-May-91 21:42 by jds") + (* Re-set the looks on selected + paragraphs) + (PROG ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (NEWLOOKS (fetch THAUXINFO of EVENT))) + (COND + ((fetch (SELECTION SET) of SEL) (* He's got something selected.) + (TEDIT.PARALOOKS TEXTOBJ NEWLOOKS SEL) (* Go perform a similar action + again.) + ) + (T (TEDIT.PROMPTPRINT TEXTOBJ "Please select some text to modify first" T]) (TEDIT.UNDO.LOOKS + [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE) (* ; "Edited 30-May-91 21:44 by jds") + (* Set looks on the current + selection from the + TEDIT.CHARLOOKS.WINDOW) + (PROG ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + CHLIM + (OLDLOOKSLIST (fetch THOLDINFO of EVENT)) + (NEWLOOKSLIST NIL) + (\INPC (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ))) + (bind (PC _ (fetch THFIRSTPIECE of EVENT)) for OLDLOOKS in OLDLOOKSLIST + do (SETQ NEWLOOKSLIST (NCONC1 NEWLOOKSLIST (fetch (PIECE PLOOKS) of PC))) + (* Remember this for the undo.) + (replace (PIECE PLOOKS) of PC with OLDLOOKS) + (* Give this piece its old looks) + [COND + ((EQ PC \INPC) + (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ + with (\TEDIT.CARETLOOKS.VERIFY TEXTOBJ (fetch (PIECE PLOOKS) + of PC] + (SETQ PC (fetch (PIECE NEXTPIECE) of PC))) + (replace THOLDINFO of EVENT with NEWLOOKSLIST) + (* Remember the other looks in case + we UNDO the UNDO.) + (\TEDIT.MARK.LINES.DIRTY TEXTOBJ CH# (IPLUS (fetch THCH# of EVENT) + (fetch THLEN of EVENT) + -1)) + (TEDIT.UPDATE.SCREEN TEXTOBJ) + (\TEDIT.SET.SEL.LOOKS SEL 'NORMAL) + (SETQ TEDIT.PENDINGDEL NIL) + (\FIXSEL SEL TEXTOBJ) + (\SHOWSEL SEL NIL T]) (TEDIT.UNDO.PARALOOKS + [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE) (* ; "Edited 30-May-91 21:44 by jds") + (* Set looks on the current + selection from the + TEDIT.CHARLOOKS.WINDOW) + (PROG ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + CHLIM + (OLDLOOKSLIST (fetch THOLDINFO of EVENT)) + (NEWLOOKSLIST NIL)) + (bind (PC _ (fetch THFIRSTPIECE of EVENT)) for OLDLOOKS in OLDLOOKSLIST + do (SETQ NEWLOOKSLIST (NCONC1 NEWLOOKSLIST (fetch (PIECE PPARALOOKS) + of PC))) + (* Remember this for the undo.) + (replace (PIECE PPARALOOKS) of PC with OLDLOOKS) + (* Give this piece its old looks) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC))) + (replace THOLDINFO of EVENT with NEWLOOKSLIST) + (* Remember the other looks in case + we UNDO the UNDO.) + (\TEDIT.MARK.LINES.DIRTY TEXTOBJ CH# (IPLUS (fetch THCH# of EVENT) + (fetch THLEN of EVENT) + -1)) + (TEDIT.UPDATE.SCREEN TEXTOBJ) + (\TEDIT.SET.SEL.LOOKS SEL 'NORMAL) + (SETQ TEDIT.PENDINGDEL NIL) + (\FIXSEL SEL TEXTOBJ) + (\SHOWSEL SEL NIL T]) ) (* ; "Revision-mark support") (DEFINEQ (\TEDIT.MARK.REVISION + [LAMBDA (TEXTOBJ FMTSPEC IMAGESTREAM LINE) (* ; "Edited 30-May-91 21:38 by jds") + (LET ((SCALE (DSPSCALE NIL IMAGESTREAM))) + (BLTSHADE BLACKSHADE IMAGESTREAM (+ (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE) + (FIXR (CL:* 12 SCALE))) + (fetch (LINEDESCRIPTOR YBOT) of LINE) + (FIXR SCALE) + (fetch (LINEDESCRIPTOR LHEIGHT) of LINE) + 'PAINT]) ) (* ; "Added by yabu.fx, for SUNLOADUP without DWIM") (DEFINEQ (\CREATE.TEDIT.DEFAULT.FMTSPEC + [LAMBDA NIL + (create FMTSPEC + QUAD _ 'LEFT + 1STLEFTMAR _ 0 + LEFTMAR _ 0 + RIGHTMAR _ 0 + LEADBEFORE _ 0 + LEADAFTER _ 0 + LINELEAD _ 0 + TABSPEC _ (CONS NIL NIL]) (\CREATE.TEDIT.FACE.MENU + [LAMBDA NIL + (create MENU + ITEMS _ '(Bold Italic Bold% Italic Regular) + CENTERFLG _ T + TITLE _ "Face:"]) (\CREATE.TEDIT.SIZE.MENU + [LAMBDA NIL + (create MENU + ITEMS _ '(6 7 8 9 10 11 12 14 18 24 30 36) + CENTERFLG _ T + MENUROWS _ 4 + TITLE _ "Type Size:"]) ) (* ; "Style-sheet support") (DEFINEQ (\TEDIT.APPLY.STYLES + [LAMBDA (LOOKS PC TEXTOBJ) (* ; + "Edited 4-Jul-93 01:02 by sybalskY:MV:ENVOS") + + (* ;; "Given a set of looks, return the looks with the proper styles expanded out.") + + (\TEDIT.CHECK (type? CHARLOOKS LOOKS)) (* ; + "Incoming thing has to be a LOOKS.") + (OR (CDR (ASSOC LOOKS *TEDIT-CURRENTPARA-CACHE*)) + (CDR (ASSOC LOOKS *TEDIT-PARASTYLE-CACHE*)) + (LET ((STYLE (fetch (CHARLOOKS CLSTYLE) of LOOKS)) + (STYLE-SHEET (OR (fetch (TEXTOBJ TXTSTYLESHEET) of TEXTOBJ) + TEDIT.STYLES)) + (NOSTYLE) + CHARSTYLES CHARSTYLE IN-PARA FMTSPEC) + (SETQ STYLE (COND + ((NULL STYLE) (* ; + "STYLE of NIL means don't bother. Just use the looks we got.") + (SETQ NOSTYLE T) + LOOKS) + ((AND [SETQ CHARSTYLES (AND (fetch (TEXTSTREAM CURRENTPARALOOKS) + of (fetch (TEXTOBJ STREAMHINT) + of TEXTOBJ)) + (fetch (FMTSPEC FMTCHARSTYLES) + of (fetch (TEXTSTREAM + CURRENTPARALOOKS) + of (fetch (TEXTOBJ + STREAMHINT) + of TEXTOBJ] + (SETQ CHARSTYLE (FASSOC STYLE CHARSTYLES))) + (* ; + "If the paragraph we're in has character styles, and this is one of them, use it.") + (SETQ IN-PARA T) + CHARSTYLE) + ((CDR (SASSOC STYLE STYLE-SHEET))) + ((AND (LITATOM STYLE) + (DEFINEDP STYLE)) (* ; + "Call the guy's function to find the new looks") + (APPLY* STYLE LOOKS PC TEXTOBJ)) + (T (* ; + "If all else fails, return the original set of looks") + (SETQ NOSTYLE T) + LOOKS))) + (SETQ STYLE (COND + ((LISTP STYLE) + (\TEDIT.PARSE.CHARLOOKS.LIST (APPEND STYLE '(STYLE NIL)) + LOOKS)) + (T STYLE))) + + (* ;; "Cache the looks->styled-looks mapping, either in the cache for this kind of paragraph (which gets wiped when we hit a new para type), or in the global cache.") + + [OR NOSTYLE (CL:IF IN-PARA + (push *TEDIT-CURRENTPARA-CACHE* (CONS LOOKS STYLE)) + (push *TEDIT-PARASTYLE-CACHE* (CONS LOOKS STYLE)))] + STYLE]) (\TEDIT.APPLY.PARASTYLES + [LAMBDA (PARALOOKS PC TEXTOBJ) (* ; + "Edited 3-Jul-93 23:15 by sybalskY:MV:ENVOS") + + (* ;; "Given a set of looks, return the looks with the proper styles expanded out.") + + (\TEDIT.CHECK (type? FMTSPEC PARALOOKS)) (* ; + "Incoming thing has to be a LOOKS.") + (OR (CDR (ASSOC PARALOOKS *TEDIT-PARASTYLE-CACHE*)) + (LET* [(NOSTYLE) + (STYLE-SHEET (OR (fetch (TEXTOBJ TXTSTYLESHEET) of TEXTOBJ) + TEDIT.STYLES)) + (STYLE (COND + ((NULL (fetch (FMTSPEC FMTSTYLE) of PARALOOKS)) + (SETQ NOSTYLE T) + PARALOOKS) + ((CDR (SASSOC (fetch (FMTSPEC FMTSTYLE) of PARALOOKS) + STYLE-SHEET))) + ((AND (LITATOM (fetch (FMTSPEC FMTSTYLE) of PARALOOKS)) + (DEFINEDP (fetch (FMTSPEC FMTSTYLE) of PARALOOKS))) + (* ; + "Call the guy's function to find the new looks") + (APPLY* (fetch (FMTSPEC FMTSTYLE) of PARALOOKS) + PARALOOKS PC TEXTOBJ)) + (T (SETQ NOSTYLE T) + PARALOOKS] + (SETQ STYLE (COND + ((LISTP STYLE) + (\TEDIT.PARSE.PARALOOKS.LIST (APPEND STYLE '(STYLE NIL)) + PARALOOKS)) + (T STYLE))) + (OR NOSTYLE (push *TEDIT-PARASTYLE-CACHE* (CONS PARALOOKS STYLE))) + STYLE]) (TEDIT.STYLESHEET + [LAMBDA (SHEET TEXTSTREAM) (* ; + "Edited 3-Jul-93 23:19 by sybalskY:MV:ENVOS") + + (* ;; "Put a new stylesheet into force. This REPLACES any existing style sheets, and forgets any pushed sheets.") + + (LET [(TEXTOBJ (AND TEXTSTREAM (TEXTOBJ TEXTSTREAM] + (COND + (TEXTOBJ (SETQ *TEDIT-PARASTYLE-CACHE* NIL) (* ; + "Clear the cache, to force reformatting") + (replace (TEXTOBJ TXTSTYLESHEET) of TEXTOBJ with SHEET)) + (T + (* ;; "No specific document given; change the global style sheet TEDIT.STYLES") + + (SETQ *TEDIT-PARASTYLE-CACHE* NIL) (* ; + "Clear the cache, to force reformatting") + (SETQ TEDIT.STYLES SHEET) + (SETQ *TEDIT-STYLESHEET-SAVE-LIST* (LIST TEDIT.STYLES]) (TEDIT.POP.STYLESHEET + [LAMBDA NIL (* ; + "Edited 3-Jul-93 17:42 by sybalskY:MV:ENVOS") + + (* ;; "Go back to an earlier stylesheet, by popping the stack of saved sheets. You can't pop back to no sheet -- you'll always bottom out at the original style sheet.") + + (SETQ *TEDIT-PARASTYLE-CACHE* NIL) (* ; + "Clear the cache, to force reformatting") + (SETQ TEDIT.STYLES (OR (CL:POP *TEDIT-STYLESHEET-SAVE-LIST*) + TEDIT.STYLES]) (TEDIT.PUSH.STYLESHEET + [LAMBDA (SHEET) (* ; + "Edited 3-Jul-93 17:40 by sybalskY:MV:ENVOS") + + (* ;; "Add more style definitions to the current style sheet, and remember how to get back to the old one. Think of this as PUSHING onto a stack of stylesheets, with the new sheet being a composition of SHEET and the existing styles. ") + + (SETQ *TEDIT-PARASTYLE-CACHE* NIL) (* ; + "Clear the cache, to force reformatting") + (SETQ TEDIT.STYLES (APPEND SHEET TEDIT.STYLES)) + (CL:PUSH TEDIT.STYLES *TEDIT-STYLESHEET-SAVE-LIST*]) (TEDIT.ADD.STYLESHEET + [LAMBDA (SHEET) (* ; + "Edited 3-Jul-93 17:38 by sybalskY:MV:ENVOS") + + (* ;; "Add more style definitions to the current style sheet. This ADDS entries, without remembering that there was an earlier sheet. ") + + (SETQ *TEDIT-PARASTYLE-CACHE* NIL) (* ; + "Clear the cache, to force reformatting") + (SETQ TEDIT.STYLES (APPEND SHEET TEDIT.STYLES)) + (SETQ *TEDIT-STYLESHEET-SAVE-LIST* (LIST TEDIT.STYLES]) ) (* ;; "*TEDIT-PARASTYLE-CACHE* is an ALIST of original char/para looks to styled char/para looks. It is used to cache stylings, and is reset when the main stylesheet changes, and when we change paragraph looks, given paras that have private char styles." ) (* ;; "*TEDIT-CURRENTPARA-CACHE* is NIL if we're not in a para that has private char styles, or is the FMTSPEC (styled!) for that para, if we are. Used to decide when we have to flush *TEDIT-PARASTYLE-CACHE* at paragraph boundaries. Mostly, this'll be NIL and not interesting." ) (* ;; "*TEDIT-STYLESHEET-SAVE-LIST* is a list of points inside TEDIT.STYLES, so we can %"push%" new style sheets on the front, and %"pop%" them off sensibly. This is the push-stack, in effect. Used by TEDIT.ADD.STYLESHEET, TEDIT.PUSH.STYLESHEET, and TEDIT.POP.STYLESHEET" ) (RPAQ? *TEDIT-PARASTYLE-CACHE* ) (RPAQ? *TEDIT-CURRENTPARA-CACHE* ) (RPAQ? *TEDIT-STYLESHEET-SAVE-LIST* ) (PUTPROPS TEDITLOOKS COPYRIGHT ("John Sybalsky & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (8534 61591 (CHARLOOKS.FROM.FONT 8544 . 10228) (EQCLOOKS 10230 . 12750) (SAMECLOOKS 12752 . 18828) (\TEDIT.UNIQUIFY.CHARLOOKS 18830 . 19391) (TEDIT.CARETLOOKS 19393 . 21069) ( TEDIT.COPY.LOOKS 21071 . 23183) (\TEDIT.GET.CHARLOOKS 23185 . 26163) (\TEDIT.UNPARSE.CHARLOOKS.LIST 26165 . 29043) (TEDIT.MODIFYLOOKS 29045 . 30827) (TEDIT.NEW.FONT 30829 . 31264) (\TEDIT.PUT.CHARLOOKS 31266 . 33059) (\TEDIT.CARETLOOKS.VERIFY 33061 . 34192) (\TEDIT.GET.INSERT.CHARLOOKS 34194 . 37958) ( \TEDIT.GET.TERMSA.WIDTHS 37960 . 38394) (\TEDIT.LOOKS.UPDATE 38396 . 50020) ( \TEDIT.PARSE.CHARLOOKS.LIST 50022 . 58755) (\TEDIT.FLUSH.UNUSED.LOOKS 58757 . 61589)) (61639 64190 ( TEDIT.SUBLOOKS 61649 . 64188)) (64191 94025 (\TEDIT.CHANGE.LOOKS 64201 . 83729) (TEDIT.LOOKS 83731 . 85641) (\TEDIT.LOOKS 85643 . 88868) (\TEDIT.FONTCOPY 88870 . 90144) (TEDIT.GET.LOOKS 90146 . 94023)) ( 94068 148145 (\TEDIT.GET.PARALOOKS 94078 . 94558) (EQFMTSPEC 94560 . 98042) (\TEDIT.UNIQUIFY.PARALOOKS 98044 . 98606) (TEDIT.GET.PARALOOKS 98608 . 100046) (\TEDIT.UNPARSE.PARALOOKS.LIST 100048 . 103449) ( \TEDIT.PARSE.PARALOOKS.LIST 103451 . 111477) (TEDIT.PARALOOKS 111479 . 132937) (TEDIT.COPY.PARALOOKS 132939 . 134999) (\TEDIT.PUT.PARALOOKS 135001 . 135891) (\TEDIT.CONVERT.TO.FORMATTED 135893 . 137906) (\TEDIT.PARABOUNDS 137908 . 140707) (\TEDIT.FORMATTABS 140709 . 148143)) (148205 156686 ( TEDIT.SUBPARALOOKS 148215 . 150773) (SAMEPARALOOKS 150775 . 156684)) (156729 162561 (TEDIT.REDO.LOOKS 156739 . 157630) (TEDIT.REDO.PARALOOKS 157632 . 158436) (TEDIT.UNDO.LOOKS 158438 . 160653) ( TEDIT.UNDO.PARALOOKS 160655 . 162559)) (162600 163134 (\TEDIT.MARK.REVISION 162610 . 163132)) (163196 163865 (\CREATE.TEDIT.DEFAULT.FMTSPEC 163206 . 163487) (\CREATE.TEDIT.FACE.MENU 163489 . 163661) ( \CREATE.TEDIT.SIZE.MENU 163663 . 163863)) (163902 172479 (\TEDIT.APPLY.STYLES 163912 . 167502) ( \TEDIT.APPLY.PARASTYLES 167504 . 169439) (TEDIT.STYLESHEET 169441 . 170485) (TEDIT.POP.STYLESHEET 170487 . 171134) (TEDIT.PUSH.STYLESHEET 171136 . 171855) (TEDIT.ADD.STYLESHEET 171857 . 172477))))) STOP \ No newline at end of file diff --git a/library/TEDITMENU b/library/TEDITMENU new file mode 100644 index 00000000..922a0c62 --- /dev/null +++ b/library/TEDITMENU @@ -0,0 +1,4539 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "24-Apr-95 12:05:29" {DSK}library>TEDITMENU.;5 275666 + + changes to%: (FNS \TEDIT.TABTYPE.SET) + + previous date%: "25-Aug-94 10:54:56" {DSK}library>TEDITMENU.;4) + + +(* ; " +Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT TEDITMENUCOMS) + +(RPAQQ TEDITMENUCOMS + [(FILES TEDITDCL) + (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) + (FILES (LOADCOMP) + TEDITDCL)) + [COMS (* ; "Simple Menu Button support") + (FNS MB.BUTTONEVENTINFN MB.DISPLAY MB.SETIMAGE MB.SELFN MB.SIZEFN MB.WHENOPERATEDFN + MB.COPYFN MB.GETFN MB.PUTFN MB.SHOWSELFN MBUTTON.CREATE MBUTTON.CHANGENAME + MBUTTON.FIND.BUTTON MBUTTON.FIND.NEXT.BUTTON MBUTTON.FIND.NEXT.FIELD MBUTTON.INIT + MBUTTON.NEXT.FIELD.AS.NUMBER MBUTTON.NEXT.FIELD.AS.PIECES + MBUTTON.NEXT.FIELD.AS.TEXT MBUTTON.NEXT.FIELD.AS.ATOM MBUTTON.SET.FIELD + MBUTTON.SET.NEXT.FIELD MBUTTON.SET.NEXT.BUTTON.STATE TEDITMENU.STREAM + \TEDITMENU.SELSCREENER) + (GLOBALVARS MBUTTONIMAGEFNS) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MBUTTON.INIT)) + (ADDVARS (IMAGEOBJTYPES (TEditMenuButton FILE TEDITMENU GETFN MB.GETFN] + [COMS + (* ;; + "Three-state (ON-OFF-NEUTRAL) menu buttons, for, e.g., character properties like BOLD") + + (FNS MB.CREATE.THREESTATEBUTTON MB.THREESTATE.DISPLAY MB.THREESTATE.SHOWSELFN + MB.THREESTATE.WHENOPERATEDFN MB.THREESTATEBUTTON.FN THREESTATE.INIT) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (THREESTATE.INIT] + [COMS (* ; "One-of-N Menu button sets") + (FNS MB.CREATE.NWAYBUTTON MB.NB.DISPLAYFN MB.NB.WHENOPERATEDFN MB.NB.SIZEFN + MB.NWAYBUTTON.SELFN MB.NWAYMENU.NEWBUTTON NWAYBUTTON.INIT MB.NB.PACKITEMS + MB.NWAYBUTTON.ADDITEM) + (GLOBALVARS NWAYBUTTONIMAGEFNS) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (NWAYBUTTON.INIT)) + (ADDVARS (IMAGEOBJTYPES (NWayButton FILE TEDITMENU GETFN MB.GETFN] + [COMS + (* ;; "Two-state, toggling menu buttons.") + + (FNS \TEXTMENU.TOGGLE.CREATE \TEXTMENU.TOGGLE.DISPLAY \TEXTMENU.TOGGLE.SHOWSELFN + \TEXTMENU.TOGGLE.WHENOPERATEDFN \TEXTMENU.TOGGLEFN \TEXTMENU.TOGGLE.INIT + \TEXTMENU.SET.TOGGLE) + (GLOBALVARS \TOGGLEIMAGEFNS) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEXTMENU.TOGGLE.INIT)) + (ADDVARS (IMAGEOBJTYPES (ToggleButton FILE TEDITMENU GETFN MB.GETFN] + [COMS + (* ;; "Margin Setting and display") + + (FNS DRAWMARGINSCALE MARGINBAR MARGINBAR.CREATE MB.MARGINBAR.SELFN MB.MARGINBAR.SIZEFN + MB.MARGINBAR.DISPLAYFN MDESCALE MSCALE MB.MARGINBAR.SHOWTAB MB.MARGINBAR.TABTRACK + \TEDIT.TABTYPE.SET MARGINBAR.INIT) + (BITMAPS \TEDIT.LEFTTAB \TEDIT.CENTERTAB \TEDIT.RIGHTTAB \TEDIT.DECIMALTAB + \TEDIT.DOTTED.LEFTTAB \TEDIT.DOTTED.CENTERTAB \TEDIT.DOTTED.RIGHTTAB + \TEDIT.DOTTED.DECIMALTAB TEDIT.EXTENDEDRIGHTMARK) + (GLOBALVARS MARGINBARIMAGEFNS) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MARGINBAR.INIT)) + (ADDVARS (IMAGEOBJTYPES (MarginRuler FILE TEDITMENU GETFN MB.GETFN] + (COMS + (* ;; "Text menu creation and support") + + (FNS \TEXTMENU.START \TEXTMENU.DOC.CREATE TEXTMENU.CLOSEFN) + (BITMAPS TEXTMENUICON TEXTMENUICONMASK)) + [COMS (* ; "TEdit-specific support") + (FNS \TEDITMENU.CREATE \TEDIT.EXPANDED.MENU MB.DEFAULTBUTTON.FN + \TEDITMENU.RECORD.UNFORMATTED MB.DEFAULTBUTTON.ACTIONFN) + (FNS \TEDIT.CHARLOOKSMENU.CREATE \TEDIT.EXPANDEDCHARLOOKS.MENU \TEDIT.APPLY.BOLDNESS + \TEDIT.APPLY.CHARLOOKS \TEDIT.APPLY.OLINE \TEDIT.SHOW.CHARLOOKS + \TEDIT.NEUTRALIZE.CHARLOOKS \TEDIT.FILL.IN.CHARLOOKS.MENU + \TEDIT.NEUTRALIZE.CHARLOOKS.MENU \TEDIT.PARSE.CHARLOOKS.MENU \TEDIT.APPLY.SLOPE + \TEDIT.APPLY.STRIKEOUT \TEDIT.APPLY.ULINE) + (FNS \TEDITPARAMENU.CREATE \TEDIT.EXPANDEDPARA.MENU \TEDIT.APPLY.PARALOOKS + \TEDIT.SHOW.PARALOOKS \TEDIT.NEUTRALIZE.PARALOOKS.MENU \TEDIT.RECORD.TABLEADERS) + (FNS \TEDIT.SHOW.PAGEFORMATTING \TEDITPAGEMENU.CREATE \TEDIT.APPLY.PAGEFORMATTING + TEDIT.UNPARSE.PAGEFORMAT) + (COMS (* ; "Initialization Code") + (GLOBALVARS TEDIT.EXPANDED.MENU TEDIT.EXPANDEDPARA.MENU TEDIT.CHARLOOKS.MENU + TEDIT.MENUDIVIDER.SPEC TEDIT.EXPANDEDMENU.SPEC TEDIT.CHARLOOKSMENU.SPEC + TEDIT.PARAMENU.SPEC TEDIT.PAGEMENU.SPEC TEDIT.EXPANDED.PAGEMENU) + (FNS \TEDIT.MENU.INIT) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEDIT.MENU.INIT) + (\TEDITMENU.CREATE) + (\TEDIT.CHARLOOKSMENU.CREATE) + (\TEDITPARAMENU.CREATE) + (\TEDITPAGEMENU.CREATE] + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA]) + +(FILESLOAD TEDITDCL) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ \SCRATCHLEN 64) + + +(CONSTANTS (\SCRATCHLEN 64)) +) + + +(FILESLOAD (LOADCOMP) + TEDITDCL) +) + + + +(* ; "Simple Menu Button support") + +(DEFINEQ + +(MB.BUTTONEVENTINFN + [LAMBDA (OBJ STREAM SEL RELX RELY SELWINDOW TEXTSTREAM)(* ; "Edited 30-May-91 22:15 by jds") + + (* There was a buttn event inside a menu button. + Make sure that the button gets turned OFF when the mouse moves outside it.) + + (PROG [(OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX] + (replace (SELECTION SELKIND) of SEL with 'VOLATILE) + (COND + ((IMAGEOBJPROP OBJ 'MENUBUTTON.SELECTED) + + (* This button is still active from an earlier hit. + Don't let it be selected again.) + + (RETURN 'DON'T)) + ((AND (IGEQ RELX 0) + (IGEQ RELY 0) + (ILEQ RELX (fetch XSIZE of OBJBOX)) + (ILEQ RELY (fetch YSIZE of OBJBOX))) + (* We're really inside the thing. + Return an indication that we're to + be left alone.) + (RETURN T)) + (T (* He's moved outside the button. + Don't permit the selection.) + (RETURN 'DON'T]) + +(MB.DISPLAY + [LAMBDA (OBJ STREAM MODE) (* ; "Edited 11-Jan-89 16:58 by jds") + + (* ;; "Display the innards of a menu button") + + (SELECTQ (IMAGESTREAMTYPE STREAM) + (DISPLAY + (* ;; "Going to the display. Use the cached bitmap version of the button") + + [PROG (BITMAP DS (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX)) + (X (DSPXPOSITION NIL STREAM)) + (Y (DSPYPOSITION NIL STREAM))) + [SETQ BITMAP (COND + ((IMAGEOBJPROP OBJ 'BITCACHE)) + (T (MB.SETIMAGE OBJ) + (IMAGEOBJPROP OBJ 'BITCACHE] + [BITBLT BITMAP 0 0 STREAM X (SETQ Y (IDIFFERENCE Y (fetch YDESC + of OBJBOX] + (* ; "Display the button's image") + (COND + ((EQ (IMAGEOBJPROP OBJ 'STATE) + 'ON) (* ; + "If the button is ON, mark it so.") + (BITBLT NIL 0 0 STREAM X Y (fetch XSIZE of OBJBOX) + (fetch YSIZE of OBJBOX) + 'TEXTURE + 'INVERT BLACKSHADE]) + (PROG (BITMAP DS (FONT (IMAGEOBJPROP OBJ 'MBFONT)) + (TEXT (IMAGEOBJPROP OBJ 'MBTEXT)) + OLOOKS) (* ; + "Going to some output image stream. Use the actual text.") + (SETQ OLOOKS (DSPFONT (FONTCOPY FONT 'DEVICE STREAM) + STREAM)) (* ; + "Change to the font for this menu button.") + (PRIN1 TEXT STREAM) (* ; "Print the button text") + (DSPFONT OLOOKS STREAM) (* ; + "And put the font back as it was.") + ]) + +(MB.SETIMAGE + [LAMBDA (OBJ) (* jds "23-Aug-84 13:22") + (PROG ((MBFONT (IMAGEOBJPROP OBJ 'MBFONT)) + (MBTEXT (IMAGEOBJPROP OBJ 'MBTEXT)) + BOX BITMAP DS) + (SETQ BOX (create IMAGEBOX + XSIZE _ (STRINGWIDTH MBTEXT MBFONT) + YSIZE _ (FONTPROP MBFONT 'HEIGHT) + YDESC _ (FONTPROP MBFONT 'DESCENT) + XKERN _ 0)) + (SETQ BITMAP (BITMAPCREATE (fetch XSIZE of BOX) + (fetch YSIZE of BOX))) + (IMAGEOBJPROP OBJ 'BITCACHE BITMAP) + (IMAGEOBJPROP OBJ 'BOUNDBOX BOX) + (SETQ DS (DSPCREATE BITMAP)) + (DSPXOFFSET 0 DS) + (DSPYOFFSET 0 DS) + (DSPFONT MBFONT DS) + (MOVETO 0 (FONTPROP MBFONT 'DESCENT) + DS) + (PRIN1 MBTEXT DS) + (RETURN OBJ]) + +(MB.SELFN + [LAMBDA (OBJ SEL W FN) (* ; "Edited 30-May-91 22:15 by jds") + (* Calls a menu-button's associated + function, then turns off the + highlighting of the menu button.) + (PROG [(TSEL (create SELECTION)) + (BUTTONFN (OR FN (IMAGEOBJPROP OBJ 'MBFN] + (\COPYSEL SEL TSEL) (* Save the selection that points to + the menu button.) + (replace (SELECTION SELKIND) of SEL with 'CHAR) + (replace (SELECTION SET) of SEL with NIL) + (replace (SELECTION ONFLG) of SEL with NIL) + (* Call the button's function) + (COND + ((NEQ (AND BUTTONFN (APPLY* BUTTONFN OBJ SEL W)) + 'DON'T) (* If the button fn left the + selection alone,) + (\FIXSEL TSEL (fetch (SELECTION \TEXTOBJ) of TSEL)) + (\SHOWSEL TSEL NIL NIL))) (* Turn off the button hilite) + ]) + +(MB.SIZEFN + [LAMBDA (OBJ STREAM CURX RIGHTMARGIN) (* jds "30-Aug-84 11:24") + (* Tell the size of a menu button) + (PROG ((FONT (IMAGEOBJPROP OBJ 'MBFONT)) + BOX) + [COND + ((DISPLAYSTREAMP STREAM) (* We're formatting for the DISPLAY) + ) + [(EQ 'INTERPRESS (IMAGESTREAMTYPE STREAM)) + (SETQ FONT (FONTCOPY FONT 'DEVICE 'INTERPRESS] + ((EQ 'PRESS (IMAGESTREAMTYPE STREAM)) + (SETQ FONT (FONTCOPY FONT 'DEVICE 'PRESS] + (SETQ BOX (create IMAGEBOX + XSIZE _ (STRINGWIDTH (IMAGEOBJPROP OBJ 'MBTEXT) + FONT) + YSIZE _ (FONTPROP FONT 'HEIGHT) + YDESC _ (FONTPROP FONT 'DESCENT) + XKERN _ 0)) + (IMAGEOBJPROP OBJ 'BOUNDBOX BOX) + (RETURN BOX]) + +(MB.WHENOPERATEDFN + [LAMBDA (OBJ DS OPERATION SEL) (* jds " 7-Feb-84 14:20") + (SELECTQ OPERATION + (HIGHLIGHTED (MB.SHOWSELFN OBJ SEL T DS)) + (UNHIGHLIGHTED (MB.SHOWSELFN OBJ SEL NIL DS)) + (SELECTED (MB.SELFN OBJ SEL DS)) + (DESELECTED) + NIL]) + +(MB.COPYFN + [LAMBDA (OBJ) (* jds "23-May-84 11:32") + (* Copy a menu button object.) + (create IMAGEOBJ + OBJECTDATUM _ (COPY (fetch (IMAGEOBJ OBJECTDATUM) of OBJ)) + IMAGEOBJPLIST _ (COPY (fetch (IMAGEOBJ IMAGEOBJPLIST) of OBJ)) + IMAGEOBJFNS _ (fetch (IMAGEOBJ IMAGEOBJFNS) of OBJ]) + +(MB.GETFN + [LAMBDA (OBJ FILE) (* ; "Edited 20-Aug-87 16:17 by jds") + (* READ a menu button from a file.) + (ERROR) + (PROG [(TEXT (IMAGEOBJPROP OBJ 'MBTEXT)) + (MBFN (IMAGEOBJPROP OBJ 'MBFN)) + (FONT (IMAGEOBJPROP OBJ 'MBFONT] + (\STRINGOUT FILE TEXT) + (\ATMOUT FILE MBFN) + (\ATMOUT FILE (FONTPROP FONT 'FAMILY)) + (\SMALLPOUT FILE (FONTPROP FONT 'SIZE)) + (for ATTR in (FONTPROP FONT 'FACE) do (\ATMOUT FILE ATTR]) + +(MB.PUTFN + [LAMBDA (OBJ FILE) (* ; "Edited 20-Aug-87 16:17 by jds") + + (* ;; + "Write a menu button from a file; suitable for re-reading using the image objects GETFN.") + + (PROG [(TEXT (IMAGEOBJPROP OBJ 'MBTEXT)) + (MBFN (IMAGEOBJPROP OBJ 'MBFN)) + (FONT (IMAGEOBJPROP OBJ 'MBFONT] + (HELP) + (\STRINGOUT FILE TEXT) (* ; "The button's image") + + (\ATMOUT FILE MBFN) (* ; "The FN called when hit") + + (\ATMOUT FILE (FONTPROP FONT 'FAMILY)) + (\SMALLPOUT FILE (FONTPROP FONT 'SIZE)) + (for ATTR in (FONTPROP FONT 'FACE) do (\ATMOUT FILE ATTR]) + +(MB.SHOWSELFN + [LAMBDA (OBJ SEL ON DS) (* ; "Edited 11-Jan-89 16:35 by jds") + (LET [(OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX] + (OR (IMAGEOBJPROP OBJ 'BITCACHE) + (MB.DISPLAY OBJ)) (* ; + "MAKE SURE THE DISPLAY FORM EXISTS") + (BITBLT (IMAGEOBJPROP OBJ 'BITCACHE) + 0 0 DS 0 0 (fetch (IMAGEBOX XSIZE) of OBJBOX) + (fetch (IMAGEBOX YSIZE) of OBJBOX) + 'INPUT + 'REPLACE) + (COND + ((OR ON (EQ (IMAGEOBJPROP OBJ 'STATE) + 'ON)) + (BITBLT NIL 0 (fetch (IMAGEBOX YDESC) of OBJBOX) + DS 0 0 (fetch (IMAGEBOX XSIZE) of OBJBOX) + (fetch (IMAGEBOX YSIZE) of OBJBOX) + 'TEXTURE + 'INVERT BLACKSHADE]) + +(MBUTTON.CREATE + [LAMBDA (MBTEXT MBFN MBFONT IMAGEFNS) (* ; "Edited 11-Jan-89 16:10 by jds") + + (* ;; "Create a MENU BUTTON image object, and fill in its image and function-hook fields") + + (LET* ([REAL-FONT (OR MBFONT (FONTCLASSCOMPONENT DEFAULTFONT 'DISPLAY] + (OBJ (IMAGEOBJCREATE NIL (OR IMAGEFNS MBUTTONIMAGEFNS))) + (BOX (create IMAGEBOX + XSIZE _ (STRINGWIDTH MBTEXT REAL-FONT) + YSIZE _ (FONTPROP REAL-FONT 'HEIGHT) + YDESC _ (FONTPROP REAL-FONT 'DESCENT) + XKERN _ 0)) + BITMAP DS) + (IMAGEOBJPROP OBJ 'MBFN MBFN) (* ; + "The function to be called when the button is pushed") + (IMAGEOBJPROP OBJ 'MBTEXT MBTEXT) (* ; + "The text displayed in the button") + (IMAGEOBJPROP OBJ 'MBFONT REAL-FONT) (* ; "The font that text appears in") + (MB.SETIMAGE OBJ) (* ; + "Set up the image for the button, so we don't create it repeatedly.") + OBJ]) + +(MBUTTON.CHANGENAME + [LAMBDA (TEXTOBJ OBJ NEWNAME) (* jds "23-Aug-84 13:26") + + (* Change the text that appears in a button, and redisplay the button if it's + visible) + + (PROG (BOX BITMAP DS) + (IMAGEOBJPROP OBJ 'MBTEXT NEWNAME) + (MB.SETIMAGE OBJ) + (TEDIT.OBJECT.CHANGED TEXTOBJ OBJ]) + +(MBUTTON.FIND.BUTTON + [LAMBDA (LABEL TEXTSTREAM CH#) (* ; "Edited 22-Apr-93 15:40 by jds") + (* "27-Sep-84 00:52" gbn) + + (* * returns the piece no containing the imageobj with MBTEXT prop LABEL) + + (PROG ((LABELATOM (MKATOM LABEL)) + OBJ STARTPCNO (PCTB (fetch (TEXTOBJ PCTB) of (TEXTOBJ TEXTSTREAM))) + START-OF-PIECE PC) + (RETURN (first (SETQ PC (\CHTOPC (OR CH# 1) + PCTB T)) while (AND PC (NOT (ATOM PC))) + do (SETQ OBJ (fetch (PIECE POBJ) of PC)) + (COND + ([AND OBJ (EQ LABELATOM (MKATOM (IMAGEOBJPROP OBJ 'MBTEXT] + (RETURN PCNO))) + (add START-OF-PIECE (fetch (PIECE PLEN) of PC)) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC]) + +(MBUTTON.FIND.NEXT.BUTTON + [LAMBDA (TEXTOBJ CH#) (* ; "Edited 22-Apr-93 16:39 by jds") + + (* ;; "Finds the next instance of an OBJECT which looks like a menu button, 3-state button, or menuobj. If none is found, return NIL") + + (PROG ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + START-OF-PIECE) + (RETURN (bind PC OBJ first (SETQ PC (\CHTOPC CH# PCTB T)) + while (AND PC (NOT (ATOM PC))) + do (* ; + "Loo thru the piece table, looking for pieces with objects in them") + (SETQ OBJ (fetch (PIECE POBJ) of PC)) + [COND + ((AND OBJ (OR (type? MBUTTON OBJ) + (type? MARGINBAR OBJ) + (type? NWAYBUTTON OBJ))) + (* ; + "Which are some kind of menu-buttonish object") + (RETURN (CONS OBJ START-OF-PIECE] + (add START-OF-PIECE (fetch (PIECE PLEN) of PC)) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC]) + +(MBUTTON.FIND.NEXT.FIELD + [LAMBDA (TEXTOBJ CH# DON'TFIX) (* ; "Edited 22-Apr-93 16:53 by jds") + + (* ;; "Starting from CH#, find the next fill-in area (usually surrounded by a {-} pair), and select any text it contains. Returns the TEXTOBJ's SCRATCHSEL with the text selected. (If no insert point is found, NIL.)") + + (PROG ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + (SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + CH1 PCNO PCNO1 PC CH LEN START-OF-PIECE (DEPTH 0)) + (COND + ((IGREATERP CH# (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (* ; + "Can't look past the end of the document") + (RETURN NIL))) + (SETQ PC (\CHTOPC CH# PCTB T)) + (while PC do (* ; + "Look thru the pieces for one which starts a user-fill-in area") + (COND + ((fetch (CHARLOOKS CLSELHERE) of (fetch (PIECE PLOOKS) + of PC)) + (* ; "Found it, so return") + (RETURN))) + (add START-OF-PIECE (fetch (PIECE PLEN) of PC)) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC))) + (COND + (PC (* ; + "We found a starting point for a type-in field") + (add START-OF-PIECE (fetch (PIECE PLEN) of PC)) + (SETQ CH1 START-OF-PIECE) (* ; + "Remember the starting character number") + (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) + (while PC do (COND + ((fetch (CHARLOOKS CLPROTECTED) + of (fetch (PIECE PLOOKS) of PC)) + (RETURN))) + (add START-OF-PIECE (fetch (PIECE PLEN) of PC)) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC))) + (SETQ LEN (IDIFFERENCE START-OF-PIECE CH1)) + (replace (SELECTION CH#) of SCRATCHSEL with CH1) + (replace (SELECTION CHLIM) of SCRATCHSEL with (IPLUS CH1 + (IMAX 0 LEN))) + (replace (SELECTION DCH) of SCRATCHSEL with LEN) + (replace (SELECTION SELOBJ) of SCRATCHSEL with NIL) + (replace (SELECTION POINT) of SCRATCHSEL with 'LEFT) + (* ; + "So if it's used, it'll be in the correct spot.") + (replace (SELECTION SELKIND) of SCRATCHSEL with 'CHAR)) + (T (* ; + "No fill-in blank found, so return an indication.") + (RETURN NIL))) + (COND + ((NOT DON'TFIX) + (\FIXSEL SCRATCHSEL TEXTOBJ))) + (RETURN SCRATCHSEL]) + +(MBUTTON.INIT + [LAMBDA NIL (* jds "12-Feb-85 14:32") + (SETQ MBUTTONIMAGEFNS (IMAGEFNSCREATE (FUNCTION MB.DISPLAY) + (FUNCTION MB.SIZEFN) + (FUNCTION MB.PUTFN) + (FUNCTION MB.GETFN) + 'MB.COPYFN + (FUNCTION MB.BUTTONEVENTINFN) + 'NILL + 'NILL + 'NILL + 'NILL + 'NILL + (FUNCTION MB.WHENOPERATEDFN) + 'NIL + 'TEditMenuButton]) + +(MBUTTON.NEXT.FIELD.AS.NUMBER + [LAMBDA (TEXTOBJ CH#) (* ; "Edited 12-Jun-90 19:00 by mitani") + (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH# T) + (NUMBERP (MKATOM (TEDIT.SEL.AS.STRING (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) + (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ]) + +(MBUTTON.NEXT.FIELD.AS.PIECES + [LAMBDA (TEXTOBJ CH#) (* ; "Edited 30-Mar-94 16:02 by jds") + + (* ;; + "Find the next fill-in field in the menu after CH#, and return its contents as A LIST OF PIECES.") + + (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH# T) + (TEDIT.SELECTED.PIECES TEXTOBJ (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ) + NIL + 'CL:IDENTITY]) + +(MBUTTON.NEXT.FIELD.AS.TEXT + [LAMBDA (TEXTOBJ CH#) (* ; "Edited 22-Apr-93 16:14 by jds") + + (* ;; "Find the next fill-in field in the menu after CH#, and return its contents as a string.") + + (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH# T) + (TEDIT.SEL.AS.STRING (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) + (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ]) + +(MBUTTON.NEXT.FIELD.AS.ATOM + [LAMBDA (TEXTOBJ CH#) (* ; "Edited 12-Jun-90 19:00 by mitani") + + (* Find the next fill-in field, and return its contents as an atom. + If the field is empty, return NIL.) + + (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH# T) (* Move to the next fill-in blank.) + (PROG [(STR (TEDIT.SEL.AS.STRING (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) + (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ] + (COND + ((ZEROP (NCHARS STR)) (* The field is empty.) + (RETURN NIL)) + (T (* It's non-empty. + Convert the string to an atom.) + (RETURN (MKATOM STR]) + +(MBUTTON.SET.FIELD + [LAMBDA (TEXTSTREAM FIELD VALUE) (* ; "Edited 22-Apr-93 10:56 by jds") + + (* ;; "Makes the contents of the field with name FIELD be VALUE.") + + (PROG ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) + PCTB OBJ SAVED.SEL FIELD.SEL PCNO NEW-STRING) + (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + (SETQ PCNO (MBUTTON.FIND.BUTTON FIELD TEXTSTREAM)) + (COND + (PCNO [SETQ FIELD.SEL (MBUTTON.FIND.NEXT.FIELD TEXTOBJ (fetch (PCTNODE CHNUM) + of (FINDNODE-INDEX + PCTB PCNO] + (* ; + "select the field following this button.") + (COND + (FIELD.SEL (* ; + "there are contents to set for this button") + (\FIXSEL FIELD.SEL TEXTOBJ) + (TEDIT.SETSEL TEXTSTREAM (fetch (SELECTION CH#) of FIELD.SEL) + (fetch (SELECTION DCH) of FIELD.SEL) + (fetch (SELECTION POINT) of FIELD.SEL) + T) + (SETQ NEW-STRING (MKSTRING VALUE)) + (COND + ((ZEROP (NCHARS NEW-STRING)) (* ; + "Nothing to replace, so just delete it.") + (TEDIT.DELETE TEXTSTREAM)) + (T (* ; + "there IS new info, so insert it.") + (TEDIT.INSERT TEXTSTREAM (MKSTRING VALUE]) + +(MBUTTON.SET.NEXT.FIELD + [LAMBDA (TEXTOBJ CH# NEWVALUE DONTUPDATESCREEN) (* ; "Edited 30-May-91 22:15 by jds") + + (* SET the text content of the next fill-in field in this document to be + NEWVALUE) + + (PROG ((SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ))) + (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH#) (* Find the next menu fill-in field) + (\FIXSEL SCRATCHSEL TEXTOBJ) + + (* Fix up the SELECTION that describes its contents, so we've got the right + screen coordinates &c) + + (OR (ZEROP (fetch (SELECTION DCH) of SCRATCHSEL)) + (\TEDIT.DELETE SCRATCHSEL TEXTOBJ T)) (* If there is text in that fill-in, + delete it to make room for ours) + (COND + (NEWVALUE (* Only insert something if there IS + something to insert.) + (TEDIT.\INSERT (MKSTRING NEWVALUE) + SCRATCHSEL TEXTOBJ))) (* Then fill it with out new value.) + ]) + +(MBUTTON.SET.NEXT.BUTTON.STATE + [LAMBDA (TEXTOBJ STARTINGCH NEWSTATE) (* jds "31-Jul-85 22:09") + + (* * Find the next menu button in the document, and set its state to NEWSTATE. + Return 1 + the CH# of the button, for further searchers) + + (PROG* ((NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ STARTINGCH)) + (BUTTON (CAR NEXTB))) + (IMAGEOBJPROP BUTTON 'STATE NEWSTATE) + (RETURN (ADD1 (CDR NEXTB]) + +(TEDITMENU.STREAM + [LAMBDA (TEXTSTREAM) (* jds "13-Aug-84 14:10") + + (* returns the textstream of the teditmenu attached to this stream if any) + + (PROG (MENUW (MAINWINDOW (\TEDIT.MAINW TEXTSTREAM))) + [SETQ MENUW (for W in (ATTACHEDWINDOWS MAINWINDOW) + thereis (AND (WINDOWPROP W 'TEDITMENU) + (EQUAL (WINDOWPROP W 'TITLE) + "TEdit Menu"] + (RETURN (COND + (MENUW (TEXTSTREAM MENUW]) + +(\TEDITMENU.SELSCREENER + [LAMBDA (TEXTOBJ SEL SELECTMODE FINAL?) (* ; "Edited 30-May-91 22:15 by jds") + + (* Called to screen potential selections in the TEdit menu window; + if an edit op is in progress, no selection will be permitted.-) + + (PROG ((MAINW (WINDOWPROP (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + 'MAINWINDOW)) + MAINTEXT) + (SETQ MAINTEXT (WINDOWPROP MAINW 'TEXTOBJ)) + (COND + ((AND (EQ (fetch (SELECTION CH#) of SEL) + (fetch (SELECTION CH#) of TEDIT.SCRATCHSELECTION)) + (EQ (fetch (SELECTION DCH) of SEL) + (fetch (SELECTION DCH) of TEDIT.SCRATCHSELECTION)) + (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT)) + (\COPYSEL SEL TEDIT.SCRATCHSELECTION) + (RETURN 'DON'T)) + ((EQ (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT) + T) + (TEDIT.PROMPTPRINT TEXTOBJ "Edit operation in progress; please wait." T) + (RETURN 'DON'T)) + ((fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT) + (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT) + " in progress; please wait.") + T) + (\COPYSEL SEL TEDIT.SCRATCHSELECTION) + (RETURN 'DON'T]) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS MBUTTONIMAGEFNS) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(MBUTTON.INIT) + + +(ADDTOVAR IMAGEOBJTYPES (TEditMenuButton FILE TEDITMENU GETFN MB.GETFN)) +) + + + +(* ;; "Three-state (ON-OFF-NEUTRAL) menu buttons, for, e.g., character properties like BOLD") + +(DEFINEQ + +(MB.CREATE.THREESTATEBUTTON + [LAMBDA (TEXT FONT STATECHANGEFN INITSTATE) (* jds "24-Sep-86 00:49") + (PROG ((OBJ (IMAGEOBJCREATE NIL THREESTATEIMAGEFNS)) + (BOX (create IMAGEBOX + XSIZE _ (STRINGWIDTH TEXT FONT) + YSIZE _ (FONTPROP FONT 'HEIGHT) + YDESC _ (FONTPROP FONT 'DESCENT) + XKERN _ 0)) + DS BITMAP X Y) + (SETQ X (fetch XSIZE of BOX)) + (SETQ Y (fetch YSIZE of BOX)) + (IMAGEOBJPROP OBJ 'MBTEXT TEXT) + (IMAGEOBJPROP OBJ 'MBFONT FONT) + (IMAGEOBJPROP OBJ 'MBFN 'MB.THREESTATEBUTTON.FN) + (IMAGEOBJPROP OBJ 'STATECHANGEFN STATECHANGEFN) + (IMAGEOBJPROP OBJ 'STATE (OR INITSTATE 'NEUTRAL)) + (SETQ BITMAP (BITMAPCREATE X Y)) + (IMAGEOBJPROP OBJ 'BITCACHE BITMAP) + (SETQ DS (DSPCREATE BITMAP)) + (DSPXOFFSET 0 DS) + (DSPYOFFSET 0 DS) + (DSPFONT FONT DS) + (MOVETO 0 (FONTPROP FONT 'DESCENT) + DS) + (PRIN1 (IMAGEOBJPROP OBJ 'MBTEXT) + DS) + (RETURN OBJ]) + +(MB.THREESTATE.DISPLAY + [LAMBDA (OBJ STREAM MODE) (* jds "30-Aug-84 13:53") + (* Display the innards of a menu + button) + (PROG (DS (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX)) + (FONT (IMAGEOBJPROP OBJ 'MBFONT)) + (CURX (DSPXPOSITION NIL STREAM)) + (CURY (DSPYPOSITION NIL STREAM)) + BITMAP X Y) + (OR OBJBOX (SETQ OBJBOX (MB.SIZEFN OBJ STREAM))) (* Make sure the size is set.) + (SETQ X (fetch XSIZE of OBJBOX)) + (SETQ Y (fetch YSIZE of OBJBOX)) + (COND + ((SETQ BITMAP (IMAGEOBJPROP OBJ 'BITCACHE)) (* The image bitmap exists already. + Use it.) + ) + (T (* Need to create an image for this + object.) + (SETQ BITMAP (BITMAPCREATE X Y)) + (IMAGEOBJPROP OBJ 'BITCACHE BITMAP) + (SETQ DS (DSPCREATE BITMAP)) + (DSPXOFFSET 0 DS) + (DSPYOFFSET 0 DS) + (DSPFONT FONT DS) + (MOVETO 0 (FONTPROP FONT 'DESCENT) + DS) + (PRIN1 (IMAGEOBJPROP OBJ 'MBTEXT) + DS))) + (BITBLT BITMAP 0 0 STREAM CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX)) + X Y 'INPUT 'PAINT) + (SELECTQ (IMAGEOBJPROP OBJ 'STATE) + (ON + + (* The button is ON. Display it as white text on black background) + + (BITBLT NIL 0 0 STREAM CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX)) + X Y 'TEXTURE 'INVERT BLACKSHADE)) + (OFF + + (* The button is OFF. Mark it with a diagonal line thru it.) + + (DRAWLINE CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX)) + (SUB1 (IPLUS CURX X)) + (SUB1 (IPLUS (IDIFFERENCE CURY (fetch YDESC of OBJBOX)) + Y)) + 1 + 'PAINT STREAM)) + (NEUTRAL (* The button is neutral. + Just display it regular.)) + NIL]) + +(MB.THREESTATE.SHOWSELFN + [LAMBDA (OBJ SEL ON DS) (* ; "Edited 30-May-91 22:16 by jds") + (PROG [(IMAGEBOX (OR (IMAGEOBJPROP OBJ 'BOUNDBOX) + (IMAGEBOX OBJ DS] + (COND + (ON (SELECTQ (IMAGEOBJPROP OBJ 'STATE) + (ON (* Switch from ON to NEUTRAL) + (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) + (fetch YSIZE of IMAGEBOX) + 'TEXTURE + 'INVERT BLACKSHADE)) + (OFF (* Switch from OFF to ON) + (BITBLT (IMAGEOBJPROP OBJ 'BITCACHE) + 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) + (fetch YSIZE of IMAGEBOX) + 'INPUT + 'REPLACE) + (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) + (fetch YSIZE of IMAGEBOX) + 'TEXTURE + 'INVERT BLACKSHADE)) + (NEUTRAL (* Switch from NEUTRAL to OFF) + (DRAWLINE 0 0 (SUB1 (fetch XSIZE of IMAGEBOX)) + (SUB1 (fetch YSIZE of IMAGEBOX)) + 1 + 'PAINT DS)) + NIL)) + ((fetch (SELECTION SET) of SEL) + (SELECTQ (IMAGEOBJPROP OBJ 'STATE) + (ON (* Switch from NEUTRAL to ON) + (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) + (fetch YSIZE of IMAGEBOX) + 'TEXTURE + 'INVERT BLACKSHADE)) + (OFF (* Switch from ON to OFF) + (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) + (fetch YSIZE of IMAGEBOX) + 'TEXTURE + 'INVERT BLACKSHADE) + (DRAWLINE 0 0 (SUB1 (fetch XSIZE of IMAGEBOX)) + (SUB1 (fetch YSIZE of IMAGEBOX)) + 1 + 'PAINT DS)) + (NEUTRAL (* Switch from OFF to NEUTRAL) + (BITBLT (IMAGEOBJPROP OBJ 'BITCACHE) + 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) + (fetch YSIZE of IMAGEBOX) + 'INPUT + 'REPLACE)) + NIL]) + +(MB.THREESTATE.WHENOPERATEDFN + [LAMBDA (OBJ DS OPERATION SEL) (* ; "Edited 30-May-91 22:16 by jds") + (* Handle operations on a + three-state button) + (SELECTQ OPERATION + (HIGHLIGHTED (* It is being hilighted) + (MB.THREESTATE.SHOWSELFN OBJ SEL T DS)) + (UNHIGHLIGHTED (* And being de-hilighted) + (MB.THREESTATE.SHOWSELFN OBJ SEL NIL DS)) + (SELECTED (* It's being selected) + (MB.THREESTATEBUTTON.FN OBJ SEL DS) (* Run the state-changing function) + (replace (SELECTION SET) of SEL with NIL) + (* And mar the selection turned off, + so others can use it without + trashing us) + (replace (SELECTION ONFLG) of SEL with NIL) + (replace (SELECTION SET) of TEDIT.SELECTION with NIL)) + (DESELECTED) + NIL]) + +(MB.THREESTATEBUTTON.FN + [LAMBDA (OBJ SEL W) (* ; "Edited 30-May-91 22:16 by jds") + (* MBFN for TEdit default menu item + buttons.) + (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) + (STATECHANGEFN (IMAGEOBJPROP OBJ 'STATECHANGEFN)) + OFILE CH NEWSTATE) + (SETQ NEWSTATE (SELECTQ (IMAGEOBJPROP OBJ 'STATE) + (OFF 'ON) + (ON 'NEUTRAL) + (NEUTRAL 'OFF) + 'ON)) + (if STATECHANGEFN + then (* apply the user supplied state + change fn if she supplied one) + (APPLY* STATECHANGEFN OBJ NEWSTATE (TEXTSTREAM TEXTOBJ))) + (IMAGEOBJPROP OBJ 'STATE NEWSTATE) + (replace (SELECTION ONFLG) of SEL with NIL]) + +(THREESTATE.INIT + [LAMBDA NIL (* jds " 9-Feb-86 15:17") + (* Initialize the IMAGEFNS for 3-state + menu button IMAGEOBJs) + (SETQ THREESTATEIMAGEFNS (IMAGEFNSCREATE (FUNCTION MB.THREESTATE.DISPLAY) + (FUNCTION MB.SIZEFN) + (FUNCTION MB.PUTFN) + (FUNCTION MB.GETFN) + (FUNCTION MB.COPYFN) + (FUNCTION MB.BUTTONEVENTINFN) + 'NILL + 'NILL + 'NILL + 'NILL + 'NILL + (FUNCTION MB.THREESTATE.WHENOPERATEDFN) + 'NILL + '3StateMenuButton]) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(THREESTATE.INIT) +) + + + +(* ; "One-of-N Menu button sets") + +(DEFINEQ + +(MB.CREATE.NWAYBUTTON + [LAMBDA (BUTTONS FONT CHANGESTATEFN INITSTATE MAXITEMS/LINE) + (* gbn "24-Sep-84 15:31") + (PROG ((OBJECT (IMAGEOBJCREATE NIL NWAYBUTTONIMAGEFNS)) + HEIGHT IMAGES IMAGE DS DESCENT SPACING SIDEEFFECTFNS WIDTHS TWIDTHS) + (SETQ FONT (OR FONT (FONTCREATE 'HELVETICA 10))) + (SETQ HEIGHT (FONTPROP FONT 'HEIGHT)) + (SETQ DESCENT (FONTPROP FONT 'DESCENT)) + (SETQ WIDTHS (for BUTTON in BUTTONS collect (STRINGWIDTH (COND + ((NLISTP BUTTON) + BUTTON) + (T (CAR BUTTON))) + FONT))) + (SETQ IMAGES (for WIDTH in WIDTHS as BUTTON in BUTTONS collect (BITMAPCREATE WIDTH HEIGHT)) + ) + (SETQ SPACING (STRINGWIDTH " " FONT)) + [SETQ SIDEEFFECTFNS (for BUTTON in BUTTONS collect (AND (LISTP BUTTON) + (CADR BUTTON] + (SETQ DS (DSPCREATE)) + (DSPXOFFSET 0 DS) + (DSPYOFFSET 0 DS) + (DSPFONT FONT DS) + (DSPRIGHTMARGIN 32000 DS) + (for IMAGE in IMAGES as BUTTON in BUTTONS do (DSPDESTINATION IMAGE DS) + (MOVETO 0 DESCENT DS) + (PRIN1 (COND + ((NLISTP BUTTON) + BUTTON) + (T (CAR BUTTON))) + DS)) + (IMAGEOBJPROP OBJECT 'MINWIDTH (for WIDTH in WIDTHS largest WIDTH)) + (* We always need at least one + button's width) + (IMAGEOBJPROP OBJECT 'MINHEIGHT (IPLUS HEIGHT 2)) (* And at least one button's height) + [IMAGEOBJPROP OBJECT 'MAXWIDTH (COND + [MAXITEMS/LINE (SETQ TWIDTHS (SORT (COPY WIDTHS))) + (IPLUS (CAR TWIDTHS) + (for WIDTH in (CDR TWIDTHS) as I + from 1 to (SUB1 MAXITEMS/LINE) + sum (IPLUS WIDTH SPACING] + (T (IPLUS (CAR WIDTHS) + (for WIDTH in (CDR WIDTHS) + sum (IPLUS WIDTH SPACING] + + (* At most, we're as wide as the N widest buttons put together) + + (IMAGEOBJPROP OBJECT 'MAXHEIGHT (ITIMES (IPLUS HEIGHT 2) + (LENGTH BUTTONS))) + (IMAGEOBJPROP OBJECT 'ITEMSPACE SPACING) + (IMAGEOBJPROP OBJECT 'BUTTONS BUTTONS) + (IMAGEOBJPROP OBJECT 'BUTTONIMAGES IMAGES) + (IMAGEOBJPROP OBJECT 'BUTTONHEIGHT (IPLUS HEIGHT 2)) + (IMAGEOBJPROP OBJECT 'BUTTONWIDTHS WIDTHS) + (IMAGEOBJPROP OBJECT 'NBUTTONS (LENGTH BUTTONS)) + (IMAGEOBJPROP OBJECT 'STATE INITSTATE) + (IMAGEOBJPROP OBJECT 'SELECTEDBUTTON NIL) + (IMAGEOBJPROP OBJECT 'SIDEEFFECTFNS SIDEEFFECTFNS) + (IMAGEOBJPROP OBJECT 'DESCENT DESCENT) + (IMAGEOBJPROP OBJECT 'MBFONT FONT) + (IMAGEOBJPROP OBJECT 'MAXITEMS/LINE MAXITEMS/LINE) + (RETURN OBJECT]) + +(MB.NB.DISPLAYFN + [LAMBDA (OBJ STREAM MODE) (* jds "28-Aug-84 15:07") + (* Display the innards of a menu + button) + (PROG (BITMAP DS (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX)) + (X (DSPXPOSITION NIL STREAM)) + (Y (DSPYPOSITION NIL STREAM)) + (BUTTONX (IMAGEOBJPROP OBJ 'BUTTONX)) + (BUTTONY (IMAGEOBJPROP OBJ 'BUTTONY)) + (BUTTONLIST (IMAGEOBJPROP OBJ 'BUTTONS)) + (BUTTONIMAGES (IMAGEOBJPROP OBJ 'BUTTONIMAGES)) + STATE) + [COND + ((SETQ BITMAP (IMAGEOBJPROP OBJ 'IMAGECACHE)) (* The button image exists already) + ) + (T (* Have to make one.) + (SETQ BITMAP (BITMAPCREATE (fetch XSIZE of OBJBOX) + (fetch YSIZE of OBJBOX))) + (IMAGEOBJPROP OBJ 'IMAGECACHE BITMAP) + (SETQ DS (DSPCREATE BITMAP)) + (DSPXOFFSET 0 DS) + (DSPYOFFSET 0 DS) + (DSPFONT (IMAGEOBJPROP OBJ 'MBFONT) + DS) + (for X in BUTTONX as Y in BUTTONY as IMAGE in BUTTONIMAGES + do (* Display the images) + (BITBLT IMAGE 0 0 DS X Y NIL NIL 'INPUT 'REPLACE] + [BITBLT BITMAP 0 0 STREAM X (SETQ Y (IDIFFERENCE Y (fetch YDESC of OBJBOX] + (* Display the button's image) + (COND + ((SETQ STATE (IMAGEOBJPROP OBJ 'STATE)) (* There's a selected button.) + (for BXVAL in BUTTONX as BYVAL in BUTTONY as IMAGE in BUTTONIMAGES as BUTTON + in BUTTONLIST when (EQ STATE BUTTON) do (BITBLT IMAGE 0 0 STREAM (IPLUS X BXVAL) + (IPLUS Y BYVAL) + NIL NIL 'INVERT 'REPLACE]) + +(MB.NB.WHENOPERATEDFN + [LAMBDA (OBJ DS OPERATION SEL) (* ; "Edited 30-May-91 22:16 by jds") + (SELECTQ OPERATION + (HIGHLIGHTED (* (MB.SHOWSELFN OBJ SEL T DS))) + (UNHIGHLIGHTED (* (MB.SHOWSELFN OBJ SEL NIL DS))) + (SELECTED (* There may be a side-effect to + occur upon selection.) + [PROG ((STATE (IMAGEOBJPROP OBJ 'STATE)) + FN) + (for BUTTON in (IMAGEOBJPROP OBJ 'BUTTONS) as SIDEFN + in (IMAGEOBJPROP OBJ 'SIDEEFFECTFNS) when (EQ STATE BUTTON) + do (COND + (SIDEFN (MB.SELFN OBJ SEL DS SIDEFN] + (replace (SELECTION SET) of SEL with NIL)) + (DESELECTED) + NIL]) + +(MB.NB.SIZEFN + [LAMBDA (OBJ STREAM CURX RIGHTMARGIN) (* jds " 6-Sep-84 14:19") + (* Tell the size of an n-way menu) + (PROG ((OLDBOX (IMAGEOBJPROP OBJ 'BOUNDBOX)) + BOX + (MAXITEMS/LINE (IMAGEOBJPROP OBJ 'MAXITEMS/LINE)) + (MAXWIDTH (IMAGEOBJPROP OBJ 'MAXWIDTH)) + (MINWIDTH (IMAGEOBJPROP OBJ 'MINWIDTH)) + (MAXHEIGHT (IMAGEOBJPROP OBJ 'MAXHEIGHT)) + (MINHEIGHT (IMAGEOBJPROP OBJ 'MINHEIGHT)) + (LINEHEIGHT (IMAGEOBJPROP OBJ 'LINEHEIGHT)) + (BUTTONHEIGHT (IMAGEOBJPROP OBJ 'BUTTONHEIGHT)) + (BUTTONWIDTHS (IMAGEOBJPROP OBJ 'BUTTONWIDTHS)) + (SPACING (IMAGEOBJPROP OBJ 'ITEMSPACE)) + (SLACK (IDIFFERENCE RIGHTMARGIN CURX)) + BUTTONX BUTTONY BUTTONINFO WIDTH HEIGHT) + [COND + ((AND (IGEQ SLACK MAXWIDTH) + (NOT MAXITEMS/LINE)) + + (* There's space for all the items on one line. + Use it) + + (SETQ WIDTH MAXWIDTH) + (SETQ HEIGHT MINHEIGHT) + [SETQ BUTTONX (bind (CURX _ 0) for ITEM in BUTTONWIDTHS + collect (PROG1 CURX (add CURX SPACING) + (add CURX ITEM] + (SETQ BUTTONY (for ITEM in BUTTONWIDTHS collect 0))) + [(ILEQ SLACK MINWIDTH) (* Have to stack it vertically.) + (SETQ WIDTH MINWIDTH) + (SETQ HEIGHT MAXHEIGHT) + (SETQ BUTTONX (for ITEM in BUTTONWIDTHS collect 0)) + (SETQ BUTTONY (bind (CURY _ (ITIMES BUTTONHEIGHT (LENGTH BUTTONWIDTHS))) for ITEM + in BUTTONWIDTHS collect (add CURY (IMINUS BUTTONHEIGHT] + (T (SETQ BUTTONINFO (MB.NB.PACKITEMS SLACK BUTTONWIDTHS SPACING MAXITEMS/LINE)) + [SETQ BUTTONX (for LINE in BUTTONINFO join (COPY (CDR LINE] + [SETQ BUTTONY (bind (CURY _ (ITIMES BUTTONHEIGHT (LENGTH BUTTONINFO))) for LINE + in BUTTONINFO join (PROGN (SETQ CURY (IDIFFERENCE CURY BUTTONHEIGHT) + ) + (for X in (CDR LINE) collect CURY] + [SETQ WIDTH (CAR (for LINE in BUTTONINFO largest (CAR LINE] + (SETQ HEIGHT (ITIMES BUTTONHEIGHT (LENGTH BUTTONINFO] + (COND + ((AND OLDBOX (IEQP WIDTH (fetch XSIZE of OLDBOX)) + (IEQP HEIGHT (fetch YSIZE of OLDBOX))) (* If nothing changed, don't bother + reformatting.) + (RETURN OLDBOX)) + (T (* Otherwise invalidate the image + cache) + (IMAGEOBJPROP OBJ 'IMAGECACHE NIL))) + (SETQ BOX (create IMAGEBOX + XSIZE _ WIDTH + YSIZE _ HEIGHT + YDESC _ (IMAGEOBJPROP OBJ 'DESCENT) + XKERN _ 0)) + (IMAGEOBJPROP OBJ 'BOUNDBOX BOX) + (IMAGEOBJPROP OBJ 'BUTTONX BUTTONX) + (IMAGEOBJPROP OBJ 'BUTTONY BUTTONY) + (RETURN BOX]) + +(MB.NWAYBUTTON.SELFN + [LAMBDA (OBJ W SEL MOUSEX MOUSEY) (* ; "Edited 30-May-91 22:16 by jds") + (* Selecting an NWAY button.) + (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) + (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX)) + (OLDSTATE (IMAGEOBJPROP OBJ 'STATE)) + (BUTTONLIST (IMAGEOBJPROP OBJ 'BUTTONS)) + (BUTTONX (IMAGEOBJPROP OBJ 'BUTTONX)) + (BUTTONIMAGES (IMAGEOBJPROP OBJ 'BUTTONIMAGES)) + (BUTTONY (IMAGEOBJPROP OBJ 'BUTTONY)) + (BUTTONWIDTHS (IMAGEOBJPROP OBJ 'BUTTONWIDTHS)) + (BUTTONLIST (IMAGEOBJPROP OBJ 'BUTTONLIST)) + (BUTTONHEIGHT (IMAGEOBJPROP OBJ 'BUTTONHEIGHT)) + CH STATE) + [for BUTTON in BUTTONLIST as X in BUTTONX as Y in BUTTONY + as WIDTH in BUTTONWIDTHS as IMAGE in BUTTONIMAGES + do (COND + ((INSIDE? (create REGION + LEFT _ X + BOTTOM _ Y + WIDTH _ WIDTH + HEIGHT _ BUTTONHEIGHT) + MOUSEX MOUSEY) (* The mouse is pointing here. + Select this.) + (SETQ STATE BUTTON) + (BITBLT IMAGE 0 0 W X Y NIL NIL 'INVERT 'REPLACE)) + ((EQ OLDSTATE BUTTON) (* This was the old selection + (and it's different, too)%. + Unselect it) + (BITBLT IMAGE 0 0 W X Y NIL NIL 'INPUT 'REPLACE] + (IMAGEOBJPROP OBJ 'STATE STATE) + (RETURN T]) + +(MB.NWAYMENU.NEWBUTTON + [LAMBDA (TEXTOBJ CH# OLDBUTTON NEWBUTTON) (* jds " 8-Feb-84 19:41") + + (* Given a hook on an existing button, and an insertion point, insert a new + button) + + (PROG ((ARBITRATOR (IMAGEOBJPROP OLDBUTTON 'ARBITRATOR)) + BUTTON) + (IMAGEOBJPROP BUTTON 'ARBITRATOR ARBITRATOR) + (TEDIT.INSERT.OBJECT BUTTON TEXTOBJ CH#) + (TEDIT.INSERT TEXTOBJ " " (ADD1 CH#)) + (TEDIT.LOOKS TEXTOBJ '(PROTECTED ON) (ADD1 CH#) + 2) + (RETURN BUTTON]) + +(NWAYBUTTON.INIT + [LAMBDA (BUTTONS FONT INITSTATE) (* jds " 9-Feb-86 15:17") + (SETQ NWAYBUTTONIMAGEFNS (IMAGEFNSCREATE (FUNCTION MB.NB.DISPLAYFN) + (FUNCTION MB.NB.SIZEFN) + (FUNCTION MB.PUTFN) + (FUNCTION MB.GETFN) + (FUNCTION MB.COPYFN) + (FUNCTION MB.NWAYBUTTON.SELFN) + 'NILL + 'NILL + 'NILL + 'NILL + 'NILL + (FUNCTION MB.NB.WHENOPERATEDFN) + 'NILL + 'NWayButton]) + +(MB.NB.PACKITEMS + [LAMBDA (WIDTH ITEMWIDTHS SPACING MAXITEMS/LINE) (* jds "24-Oct-84 17:42") + + (* * Pack items into lines WIDTH wide. Item widths are in ITEMWIDTHS, and each + pair of items on a line is separated by SPACING. + Returns a list of lists, one per line packed, of the relative X starts of the + items) + + (PROG ((CURX 0) + (LINES NIL) + (CURLINE NIL) + (CURLINEITEMS 0) + ITEM) + (while ITEMWIDTHS do (SETQ ITEM (pop ITEMWIDTHS)) + (COND + ((OR [ILESSP WIDTH (IPLUS CURX ITEM (COND + (CURLINE SPACING) + (T 0] + (AND MAXITEMS/LINE (IGEQ CURLINEITEMS MAXITEMS/LINE))) + (* Time for a new line) + (SETQ LINES (NCONC1 LINES (CONS CURX CURLINE))) + (* Add to our list of lines so far) + (SETQ CURLINE NIL) (* Empty the line accumulator) + (SETQ CURLINEITEMS 0) (* reset the line item count) + (SETQ CURX 0))) + (AND CURLINE (add CURX SPACING)) + (SETQ CURLINE (NCONC1 CURLINE CURX)) + (add CURX ITEM) + (add CURLINEITEMS 1)) + [AND CURLINE (SETQ LINES (NCONC1 LINES (CONS CURX CURLINE] + (* Capture the last partial line, if + there is one.) + (RETURN LINES]) + +(MB.NWAYBUTTON.ADDITEM + [LAMBDA (OBJECT NEWBUTTON) (* jds "11-Jul-85 12:44") + + (* Given an existing n-way choice menu button, add another choice to the list) + + (PROG ([BUTTONS (CONS NEWBUTTON (IMAGEOBJPROP OBJECT 'BUTTONS] + HEIGHT IMAGES IMAGE DS DESCENT SPACING SIDEEFFECTFNS WIDTHS FONT) + (SETQ FONT (IMAGEOBJPROP OBJECT 'MBFONT)) + (SETQ HEIGHT (FONTPROP FONT 'HEIGHT)) + (SETQ DESCENT (FONTPROP FONT 'DESCENT)) + (SETQ WIDTHS (for BUTTON in BUTTONS collect (STRINGWIDTH (COND + ((NLISTP BUTTON) + BUTTON) + (T (CAR BUTTON))) + FONT))) + (SETQ IMAGES (for WIDTH in WIDTHS as BUTTON in BUTTONS collect (BITMAPCREATE WIDTH HEIGHT)) + ) + (SETQ SPACING (STRINGWIDTH " " FONT)) + [SETQ SIDEEFFECTFNS (for BUTTON in BUTTONS collect (AND (LISTP BUTTON) + (CADR BUTTON] + (SETQ DS (DSPCREATE)) + (DSPXOFFSET 0 DS) + (DSPYOFFSET 0 DS) + (DSPFONT FONT DS) + (DSPRIGHTMARGIN 32000 DS) + (for IMAGE in IMAGES as BUTTON in BUTTONS do (DSPDESTINATION IMAGE DS) + (MOVETO 0 DESCENT DS) + (PRIN1 (COND + ((NLISTP BUTTON) + BUTTON) + (T (CAR BUTTON))) + DS)) + (IMAGEOBJPROP OBJECT 'MINWIDTH (for WIDTH in WIDTHS largest WIDTH)) + (IMAGEOBJPROP OBJECT 'MINHEIGHT (IPLUS HEIGHT 2)) + [IMAGEOBJPROP OBJECT 'MAXWIDTH (IPLUS (CAR WIDTHS) + (for WIDTH in (CDR WIDTHS) + sum (IPLUS WIDTH SPACING] + (IMAGEOBJPROP OBJECT 'MAXHEIGHT (ITIMES (IPLUS HEIGHT 2) + (LENGTH BUTTONS))) + (IMAGEOBJPROP OBJECT 'ITEMSPACE SPACING) + (IMAGEOBJPROP OBJECT 'BUTTONS BUTTONS) + (IMAGEOBJPROP OBJECT 'BUTTONIMAGES IMAGES) + (IMAGEOBJPROP OBJECT 'BUTTONHEIGHT (IPLUS HEIGHT 2)) + (IMAGEOBJPROP OBJECT 'BUTTONWIDTHS WIDTHS) + (IMAGEOBJPROP OBJECT 'NBUTTONS (LENGTH BUTTONS)) + (IMAGEOBJPROP OBJECT 'SELECTEDBUTTON NIL) + (IMAGEOBJPROP OBJECT 'SIDEEFFECTFNS SIDEEFFECTFNS) + (IMAGEOBJPROP OBJECT 'DESCENT DESCENT) + (RETURN OBJECT]) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS NWAYBUTTONIMAGEFNS) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(NWAYBUTTON.INIT) + + +(ADDTOVAR IMAGEOBJTYPES (NWayButton FILE TEDITMENU GETFN MB.GETFN)) +) + + + +(* ;; "Two-state, toggling menu buttons.") + +(DEFINEQ + +(\TEXTMENU.TOGGLE.CREATE + [LAMBDA (TEXT FONT STATECHANGEFN INITSTATE) (* gbn "24-Sep-84 14:45") + + (* Creates a TOGGLE menu button, that can turn off and on alternately.) + + (PROG ((OBJ (IMAGEOBJCREATE NIL \TOGGLEIMAGEFNS)) + (BOX (create IMAGEBOX + XSIZE _ (STRINGWIDTH TEXT FONT) + YSIZE _ (FONTPROP FONT 'HEIGHT) + YDESC _ (FONTPROP FONT 'DESCENT) + XKERN _ 0)) + DS BITMAP X Y) + (SETQ X (fetch XSIZE of BOX)) + (SETQ Y (fetch YSIZE of BOX)) + (IMAGEOBJPROP OBJ 'MBTEXT TEXT) + (IMAGEOBJPROP OBJ 'MBFONT FONT) + (IMAGEOBJPROP OBJ 'MBFN '\TEXTMENU.TOGGLEFN) + (IMAGEOBJPROP OBJ 'STATECHANGEFN STATECHANGEFN) + + (* a function to be called on finalization of selection of this button to + provide for user side-effects) + + (IMAGEOBJPROP OBJ 'STATE (OR INITSTATE 'OFF)) + (SETQ BITMAP (BITMAPCREATE X Y)) + (IMAGEOBJPROP OBJ 'BITCACHE BITMAP) + (SETQ DS (DSPCREATE BITMAP)) + (DSPXOFFSET 0 DS) + (DSPYOFFSET 0 DS) + (DSPFONT FONT DS) + (MOVETO 0 (FONTPROP FONT 'DESCENT) + DS) + (PRIN1 (IMAGEOBJPROP OBJ 'MBTEXT) + DS) + (RETURN OBJ]) + +(\TEXTMENU.TOGGLE.DISPLAY + [LAMBDA (OBJ STREAM MODE) (* gbn "27-Sep-84 01:23") + (* "27-Sep-84 01:11" gbn) + (* Display the innards of a menu + toggle) + (PROG (DS (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX)) + (FONT (IMAGEOBJPROP OBJ 'MBFONT)) + (CURX (DSPXPOSITION NIL STREAM)) + (CURY (DSPYPOSITION NIL STREAM)) + BITMAP X Y) + (OR OBJBOX (SETQ OBJBOX (MB.SIZEFN OBJ STREAM))) (* Make sure the size is set.) + (SETQ X (fetch XSIZE of OBJBOX)) + (SETQ Y (fetch YSIZE of OBJBOX)) + (COND + ([type? BITMAP (SETQ BITMAP (IMAGEOBJPROP OBJ 'BITCACHE] + (* The image bitmap exists already. + Use it.) + ) + (T (* Need to create an image for this + object.) + (SETQ BITMAP (BITMAPCREATE X Y)) + (IMAGEOBJPROP OBJ 'BITCACHE BITMAP) + (SETQ DS (DSPCREATE BITMAP)) + (DSPXOFFSET 0 DS) + (DSPYOFFSET 0 DS) + (DSPFONT FONT DS) + (MOVETO 0 (FONTPROP FONT 'DESCENT) + DS) + (PRIN1 (IMAGEOBJPROP OBJ 'MBTEXT) + DS))) + (BITBLT BITMAP 0 0 STREAM CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX)) + X Y 'INPUT 'PAINT) + (SELECTQ (IMAGEOBJPROP OBJ 'STATE) + (ON + + (* The button is ON. Display it as white text on black background) + + (BITBLT NIL 0 0 STREAM CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX)) + X Y 'TEXTURE 'INVERT BLACKSHADE)) + (OFF (* The button is OFF. + Just display it regular.)) + (ERROR "Invalid state in toggle button " OBJ]) + +(\TEXTMENU.TOGGLE.SHOWSELFN + [LAMBDA (OBJ SEL ON DS) (* ; "Edited 30-May-91 22:16 by jds") + (PROG [(IMAGEBOX (OR (IMAGEOBJPROP OBJ 'BOUNDBOX) + (IMAGEBOX OBJ DS] + (COND + (ON (SELECTQ (IMAGEOBJPROP OBJ 'STATE) + (ON (* Switch from ON to + (NEUTRAL (* Switch from OFF to + NEUTRAL) (BITBLT (IMAGEOBJPROP OBJ + (QUOTE BITCACHE)) 0 0 DS 0 0 + (fetch XSIZE of IMAGEBOX) + (fetch YSIZE of IMAGEBOX) + (QUOTE INPUT) (QUOTE REPLACE)))) + (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) + (fetch YSIZE of IMAGEBOX) + 'TEXTURE + 'INVERT BLACKSHADE)) + (OFF (* Switch from OFF to ON) + (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) + (fetch YSIZE of IMAGEBOX) + 'TEXTURE + 'INVERT BLACKSHADE)) + NIL)) + ((fetch (SELECTION SET) of SEL) + (SELECTQ (IMAGEOBJPROP OBJ 'STATE) + (ON (* Switch from OFF to ON) + (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) + (fetch YSIZE of IMAGEBOX) + 'TEXTURE + 'INVERT BLACKSHADE)) + (OFF (* Switch from ON to OFF) + (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) + (fetch YSIZE of IMAGEBOX) + 'TEXTURE + 'INVERT BLACKSHADE)) + NIL]) + +(\TEXTMENU.TOGGLE.WHENOPERATEDFN + [LAMBDA (OBJ DS OPERATION SEL) (* ; "Edited 30-May-91 22:16 by jds") + (* Handle operations on a + three-state button) + (SELECTQ OPERATION + (HIGHLIGHTED (* It is being hilighted) + (\TEXTMENU.TOGGLE.SHOWSELFN OBJ SEL T DS)) + (UNHIGHLIGHTED (* And being de-hilighted) + (\TEXTMENU.TOGGLE.SHOWSELFN OBJ SEL NIL DS)) + (SELECTED (* It's being selected) + (\TEXTMENU.TOGGLEFN OBJ SEL DS) (* Run the state-changing function) + (replace (SELECTION SET) of SEL with NIL) + (* And mar the selection turned off, + so others can use it without + trashing us) + (replace (SELECTION ONFLG) of SEL with NIL) + (replace (SELECTION SET) of TEDIT.SELECTION with NIL)) + (DESELECTED) + NIL]) + +(\TEXTMENU.TOGGLEFN + [LAMBDA (OBJ SEL W) (* ; "Edited 30-May-91 22:16 by jds") + (* MBFN for TOGGLE buttons--cycle + back and forthe betwen states.) + (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) + (STATECHANGEFN (IMAGEOBJPROP OBJ 'STATECHANGEFN)) + OFILE CH NEWSTATE) + (SETQ NEWSTATE (SELECTQ (IMAGEOBJPROP OBJ 'STATE) + (OFF 'ON) + (ON 'OFF) + 'ON)) + (COND + (STATECHANGEFN (* apply the user supplied state + change fn if he supplied one) + (APPLY* STATECHANGEFN OBJ NEWSTATE (TEXTSTREAM TEXTOBJ) + SEL))) + (IMAGEOBJPROP OBJ 'STATE NEWSTATE) + (replace (SELECTION ONFLG) of SEL with NIL]) + +(\TEXTMENU.TOGGLE.INIT + [LAMBDA NIL (* jds " 9-Feb-86 15:18") + (SETQ \TOGGLEIMAGEFNS (IMAGEFNSCREATE (FUNCTION \TEXTMENU.TOGGLE.DISPLAY) + (FUNCTION MB.SIZEFN) + (FUNCTION MB.PUTFN) + (FUNCTION MB.GETFN) + (FUNCTION MB.COPYFN) + (FUNCTION MB.BUTTONEVENTINFN) + 'NILL + 'NILL + 'NILL + 'NILL + 'NILL + (FUNCTION \TEXTMENU.TOGGLE.WHENOPERATEDFN) + 'NILL + 'ToggleButton]) + +(\TEXTMENU.SET.TOGGLE + [LAMBDA (TEXT VALUE TEXTSTREAM) (* ; "Edited 12-Jun-90 19:02 by mitani") + + (* * finds the button with MBTEXT field TEXT in TEXTSTREAM and sets its state + to VALUE) + + (PROG ((PCNO (MBUTTON.FIND.BUTTON TEXT TEXTSTREAM)) + OBJ PC) + (COND + ((NOT PCNO) + (ERROR TEXT " was not found as a button."))) + [SETQ OBJ (fetch (PIECE POBJ) of (SETQ PC (fetch (PCTNODE PCE) + of (FINDNODE-INDEX + (fetch (TEXTOBJ PCTB) + of (TEXTOBJ TEXTSTREAM) + ) + PCNO] + (IMAGEOBJPROP OBJ 'STATE VALUE) + (IMAGEOBJPROP OBJ 'BITCACHE 'JUNK) + (for WINDOW inside (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ TEXTSTREAM)) + do (\TEDIT.REPAINTFN WINDOW)) + (RETURN VALUE]) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \TOGGLEIMAGEFNS) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(\TEXTMENU.TOGGLE.INIT) + + +(ADDTOVAR IMAGEOBJTYPES (ToggleButton FILE TEDITMENU GETFN MB.GETFN)) +) + + + +(* ;; "Margin Setting and display") + +(DEFINEQ + +(DRAWMARGINSCALE + [LAMBDA (W UNIT) (* ; "Edited 12-Jun-90 18:59 by mitani") + + (* ;; " Draw the margin-bar scale -- the markings across the bottom of the margin bar that show you the margin values. Draws the scale in window W, according to UNIT = 1 for points, or 12 for picas.") + + (PROG ((WREG (DSPCLIPPINGREGION NIL W)) + (OLDOP (DSPOPERATION 'REPLACE W))) + (DSPFILL (create REGION + LEFT _ 0 + BOTTOM _ 0 + WIDTH _ (fetch (REGION WIDTH) of WREG) + HEIGHT _ 24) + WHITESHADE + 'REPLACE W) (* ; "CLEAR IT OUT FIRST.") + (SELECTQ UNIT + (1 (* ; "Straight Points") + [for X from 4 by 3 to (fetch (REGION WIDTH) of WREG) + do + + (* ;; "Put a tick every 3 points, with a number every inch.") + + (COND + ((ZEROP (IREMAINDER (IDIFFERENCE X 4) + 72)) + (BITBLT NIL 0 0 W X 8 1 16 'TEXTURE 'REPLACE BLACKSHADE) + (MOVETO (IDIFFERENCE X (LRSH (STRINGWIDTH (IDIFFERENCE X 4)) + 1)) + 10 W) + (PRIN1 (IDIFFERENCE X 4) + W)) + (T (BITBLT NIL 0 0 W X 20 1 4 'TEXTURE 'REPLACE BLACKSHADE]) + (12 (* ; "Picas") + (for X from 4 by 12 to (fetch (REGION WIDTH) of WREG) + as NOMX from 0 + do + + (* ;; "Put a tick every half-pica, with a number every inch.") + + (COND + ((ZEROP (IREMAINDER NOMX 6)) + (BITBLT NIL 0 0 W X 8 1 16 'TEXTURE 'REPLACE BLACKSHADE) + (MOVETO (IDIFFERENCE X (LRSH (STRINGWIDTH NOMX) + 1)) + 10 W) + (PRIN1 NOMX W)) + (T (BITBLT NIL 0 0 W X 20 1 4 'TEXTURE 'REPLACE BLACKSHADE))) + (BITBLT NIL 0 0 W (IPLUS X 6) + 22 1 2 'TEXTURE 'REPLACE BLACKSHADE))) + NIL) + (BITBLT NIL 0 0 W 4 23 (fetch (REGION WIDTH) of WREG) + 1 + 'TEXTURE + 'REPLACE BLACKSHADE) + (MOVETO 0 0 W) + (RELDRAWTO (IDIFFERENCE (fetch (REGION WIDTH) of WREG) + 2) + 0 1 'PAINT W) + (RELDRAWTO 0 (IDIFFERENCE (fetch (REGION HEIGHT) of WREG) + 2) + 1 + 'PAINT W) + (RELDRAWTO (IMINUS (IDIFFERENCE (fetch (REGION WIDTH) of WREG) + 2)) + 0 1 'PAINT W) + (RELDRAWTO 0 (IMINUS (IDIFFERENCE (fetch (REGION HEIGHT) of WREG) + 2)) + 1 + 'PAINT W) + (DSPOPERATION OLDOP W]) + +(MARGINBAR + [LAMBDA (W L1 LN R TABS UNIT UPDATE RIGHTLIM) (* ; "Edited 12-Jun-90 18:59 by mitani") + (* Given a set of margins and a + unit, show the margin bar properly) + (PROG ((OLDOP (DSPOPERATION 'ERASE W)) + (SCALEDL1 (MSCALE L1 UNIT)) + (SCALEDLN (MSCALE LN UNIT)) + (SCALEDR (MSCALE R UNIT)) + (FLOATINGRIGHT NIL) + (EXTENDEDRIGHT NIL) + UNSETL1 UNSETLN) + (OR UPDATE (DRAWMARGINSCALE W UNIT)) + (DSPFONT (FONTCREATE 'GACHA 10) + W) + (SETQ L1 (MKSTRING (ABS L1))) + (SETQ LN (MKSTRING (ABS LN))) + (SETQ R (MKSTRING (ABS R))) + [COND + [(ILESSP SCALEDR 4) (* Unset right margin. + Show specially, but at its usual + place.) + (SETQ FLOATINGRIGHT T) + (SETQ SCALEDR (IPLUS 4 (IDIFFERENCE 4 SCALEDR] + ((ILEQ SCALEDR 4) (* Floating right margin => marked + specially) + (SETQ FLOATINGRIGHT T) + (SETQ SCALEDR RIGHTLIM)) + ((IGREATERP SCALEDR RIGHTLIM) (* Not floating, so just limit it to + the rightmost that can be seen.) + (SETQ EXTENDEDRIGHT T) + (SETQ SCALEDR (IDIFFERENCE RIGHTLIM 8] + [COND + ((ILESSP SCALEDL1 4) (* Unset right FIRST LEFT margin. + Show specially, but at its usual + place.) + (SETQ UNSETL1 T) + (SETQ SCALEDL1 (IPLUS 4 (IDIFFERENCE 4 SCALEDL1] + [COND + ((ILESSP SCALEDLN 4) (* Unset LEFT margin. + Show specially, but at its usual + place.) + (SETQ UNSETLN T) + (SETQ SCALEDLN (IPLUS 4 (IDIFFERENCE 4 SCALEDLN] + (BITBLT NIL 0 0 W 1 26 (IDIFFERENCE (fetch (REGION WIDTH) of (DSPCLIPPINGREGION + NIL W)) + 3) + 32 + 'TEXTURE + 'REPLACE WHITESHADE) + (BITBLT NIL 0 0 W SCALEDL1 42 (IDIFFERENCE SCALEDR SCALEDL1) + 16 + 'TEXTURE + 'REPLACE BLACKSHADE) + (BITBLT NIL 0 0 W SCALEDLN 26 (IDIFFERENCE SCALEDR SCALEDLN) + 16 + 'TEXTURE + 'REPLACE BLACKSHADE) + (COND + (UNSETL1 (* 1st left margin isn't set, tho it + has a value. Mark it neutral) + (BITBLT NIL 0 0 W SCALEDL1 42 (IPLUS (STRINGWIDTH L1 W) + 2) + 16 + 'TEXTURE + 'REPLACE EDITGRAY) + (DSPOPERATION 'PAINT W) + (MOVETO (IPLUS SCALEDL1 2) + 44 W) + (PRIN1 L1 W) + (DSPOPERATION 'ERASE W)) + (T (MOVETO (IPLUS SCALEDL1 2) + 44 W) + (PRIN1 L1 W))) + (COND + (UNSETLN (* left margin isn't set, tho it has + a value. Mark it neutral) + (BITBLT NIL 0 0 W SCALEDLN 26 (IPLUS (STRINGWIDTH LN W) + 2) + 16 + 'TEXTURE + 'REPLACE EDITGRAY) + (DSPOPERATION 'PAINT W) + (MOVETO (IPLUS SCALEDLN 2) + 28 W) + (PRIN1 LN W) + (DSPOPERATION 'ERASE W)) + (T (MOVETO (IPLUS SCALEDLN 2) + 28 W) + (PRIN1 LN W))) + [COND + (FLOATINGRIGHT (* Floating right margin is marked + by a light gray marker) + (BITBLT NIL 0 0 W (IDIFFERENCE SCALEDR (IPLUS (STRINGWIDTH R W) + 2)) + 26 + (IPLUS (STRINGWIDTH R W) + 2) + 32 + 'TEXTURE + 'REPLACE EDITGRAY) + (DSPOPERATION 'PAINT W)) + (EXTENDEDRIGHT (* A non-visible right margin is + marked by two wavy lines indicating + a break) + (BITBLT TEDIT.EXTENDEDRIGHTMARK 0 0 W SCALEDR 26 8 32 'INPUT 'REPLACE] + (MOVETO (IDIFFERENCE SCALEDR (IPLUS (STRINGWIDTH R W) + 2)) + 36 W) + (PRIN1 R W) + (DSPOPERATION OLDOP W) + (COND + ((EQ TABS 'NEUTRAL) (* All tabs have been neutralized. + Just lay down a grey pattern over + them.) + (DSPFILL (create REGION + LEFT _ 2 + BOTTOM _ 1 + HEIGHT _ 8 + WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of ( + DSPCLIPPINGREGION + NIL W)) + 4)) + EDITGRAY + 'REPLACE W)) + (T (DSPFILL (create REGION + LEFT _ 2 + BOTTOM _ 1 + HEIGHT _ 8 + WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) + of (DSPCLIPPINGREGION NIL W)) + 4)) + WHITESHADE + 'REPLACE W) + (for TAB in TABS do (* Run thru the tabs, putting them + down in place.) + (MB.MARGINBAR.SHOWTAB W TAB UNIT 'PAINT]) + +(MARGINBAR.CREATE + [LAMBDA (MARL1 MARLN MARR MARTABS MARUNIT MARTABTYPE) (* ; "Edited 12-Jun-90 18:59 by mitani") + (* Create an instance of the + margin-setting ruler for TEdit's + use.) + (PROG ((BOX (create IMAGEBOX + XSIZE _ 1008 + YSIZE _ 62 + YDESC _ 0 + XKERN _ 4)) + OBJ OBJDATUM BITMAP DS) + (SETQ OBJ + (IMAGEOBJCREATE (SETQ OBJDATUM + (create MARGINBAR + MARL1 _ MARL1 + MARLN _ MARLN + MARR _ MARR + MARTABS _ MARTABS + MARUNIT _ MARUNIT + MARTABTYPE _ MARTABTYPE)) + MARGINBARIMAGEFNS)) + + (* Create an IMAGEOBJ, containing an instance of the record to hold margin and + tab info) + + (SETQ BITMAP (BITMAPCREATE (fetch XSIZE of BOX) + (fetch YSIZE of BOX))) (* A cache for the ruler's screen + image) + (IMAGEOBJPROP OBJ 'BITCACHE BITMAP) + (SETQ DS (DSPCREATE BITMAP)) (* And a displaystream for modifying + that image) + (IMAGEOBJPROP OBJ 'DSPCACHE DS) + (DSPXOFFSET 0 DS) + (DSPYOFFSET 0 DS) + (DSPCLIPPINGREGION (create REGION + LEFT _ 0 + BOTTOM _ 0 + WIDTH _ (fetch XSIZE of BOX) + HEIGHT _ (fetch YSIZE of BOX)) + DS) + (MARGINBAR DS (fetch (MARGINBAR MARL1) of OBJDATUM) + (fetch (MARGINBAR MARLN) of OBJDATUM) + (fetch (MARGINBAR MARR) of OBJDATUM) + (fetch (MARGINBAR MARTABS) of OBJDATUM) + (fetch (MARGINBAR MARUNIT) of OBJDATUM) + NIL + (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL DS))) + + (* Fill in the cache with the original value This does the time-consuming part + of drawing the ticks on the ruler and such, which would make drawing it on the + fly unbearable.) + + (IMAGEOBJPROP OBJ 'NEEDSUPDATE T) + + (* And tell the display function that it needs to be updated when first + displayed. Which is the faster part.) + + (RETURN OBJ]) + +(MB.MARGINBAR.SELFN + [LAMBDA (OBJ SELWINDOW SEL RELX RELY STREAM ORIGX ORIGY) + (* ; "Edited 12-Jun-90 18:59 by mitani") + (* ; + "Let the user adjust margins and tabs using the mouse.") + (PROG [(OBJDATUM (IMAGEOBJPROP OBJ 'OBJECTDATUM)) + (IMAGEBOX (OR (IMAGEOBJPROP OBJ 'BOUNDBOX) + (IMAGEBOX OBJ STREAM 'DISPLAY] + (PROG ((L1 (fetch MARL1 of OBJDATUM)) + (LN (fetch MARLN of OBJDATUM)) + (R (fetch MARR of OBJDATUM)) + (TABS (fetch MARTABS of OBJDATUM)) + [SCALEDTABS (COND + ((LISTP (fetch MARTABS of OBJDATUM)) + (* ; + "Only scale the tabs if there are any, and they're not neutralized.") + (for TAB in (fetch MARTABS of OBJDATUM) + collect (MSCALE (fetch TABX of TAB) + (fetch MARUNIT of OBJDATUM] + (UNIT (fetch MARUNIT of OBJDATUM)) + (CLIP (create REGION + LEFT _ 0 + BOTTOM _ 0 + WIDTH _ (fetch XSIZE of IMAGEBOX) + HEIGHT _ (fetch YSIZE of IMAGEBOX))) + (RIGHTLIM (IDIFFERENCE (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL + SELWINDOW)) + 4)) + TAB TABX OL1 OLN OR) + (SETQ OL1 L1) + (SETQ OLN LN) + (SETQ OR R) + [COND + [(INSIDE? (create REGION + LEFT _ (IDIFFERENCE (MSCALE (ABS L1) + UNIT) + 2) + BOTTOM _ 42 + WIDTH _ 16 + HEIGHT _ 16) + RELX RELY) (* ; "Move the 1st-line left margin.") + (while (AND (MOUSESTATE (OR LEFT MIDDLE RIGHT)) + (INSIDE? CLIP (LASTMOUSEX STREAM) + (LASTMOUSEY STREAM))) + do (SETQ L1 (MAX 0 (MDESCALE (LASTMOUSEX STREAM) + UNIT))) + [COND + ((\TEDIT.MOUSESTATE RIGHT) (* ; + "Right mouse button UNsets the margin.") + (SETQ L1 (MINUS L1] + (COND + ((NOT (EQUAL OL1 L1)) + (MARGINBAR STREAM L1 LN R TABS UNIT T RIGHTLIM) + (SETQ OL1 L1] + [(INSIDE? (create REGION + LEFT _ (IDIFFERENCE (MSCALE (ABS LN) + UNIT) + 2) + BOTTOM _ 26 + WIDTH _ 16 + HEIGHT _ 16) + RELX RELY) (* ; "Move the skirt's left margin") + (while (AND (MOUSESTATE (OR LEFT MIDDLE RIGHT)) + (INSIDE? CLIP (LASTMOUSEX STREAM) + (LASTMOUSEY STREAM))) + do (SETQ LN (MAX 0 (MDESCALE (LASTMOUSEX STREAM) + UNIT))) + [COND + ((\TEDIT.MOUSESTATE RIGHT) (* ; + "Right mouse button UNsets the margin.") + (SETQ LN (MINUS LN] + (COND + ((NOT (EQUAL OLN LN)) + (MARGINBAR STREAM L1 LN R TABS UNIT T RIGHTLIM) + (SETQ OLN LN] + [(OR (INSIDE? (create REGION + LEFT _ (IDIFFERENCE (IMIN (MSCALE (ABS R) + UNIT) + (fetch XSIZE of IMAGEBOX) + (fetch (REGION WIDTH) + of (DSPCLIPPINGREGION NIL + SELWINDOW))) + 16) + BOTTOM _ 26 + WIDTH _ 16 + HEIGHT _ 32) + RELX RELY) + (AND (ZEROP (IABS (FIXR R))) + (INSIDE? (create REGION + LEFT _ (IDIFFERENCE (IMIN (fetch XSIZE of + IMAGEBOX + ) + (fetch (REGION WIDTH) + of (DSPCLIPPINGREGION + NIL SELWINDOW))) + 16) + BOTTOM _ 26 + WIDTH _ 16 + HEIGHT _ 32) + RELX RELY))) (* ; "Move the right margin") + (while (AND (MOUSESTATE (OR LEFT MIDDLE RIGHT)) + (INSIDE? CLIP (LASTMOUSEX STREAM) + (LASTMOUSEY STREAM))) + do (SETQ R (MAX 0 (MDESCALE (LASTMOUSEX STREAM) + UNIT))) + [COND + ((\TEDIT.MOUSESTATE RIGHT) (* ; + "Right mouse button UNsets the margin.") + (SETQ R (MINUS R] + (COND + ((NOT (EQUAL OR R)) + (MARGINBAR STREAM L1 LN R TABS UNIT T RIGHTLIM) + (SETQ OR R] + ((INSIDE? (create REGION + LEFT _ 0 + BOTTOM _ 0 + WIDTH _ (fetch (REGION WIDTH) of CLIP) + HEIGHT _ 16) + RELX RELY) (* ; "We're in the tab ruler region") + (COND + ((MOUSESTATE LEFT) (* ; "MOVE a tab") + [SETQ TAB (for TABX in SCALEDTABS as TAB in TABS + smallest (ABS (IDIFFERENCE TABX (LASTMOUSEX STREAM] + (AND TAB (MB.MARGINBAR.TABTRACK STREAM OBJDATUM TAB))) + [(MOUSESTATE MIDDLE) (* ; "ADD/CHANGE a tab") + (COND + ((EQ (fetch MARTABS of OBJDATUM) + 'NEUTRAL) (* ; + "The tabs used to be NEUTRAL. Clear the tab region, and start afresh.") + (replace MARTABS of OBJDATUM with NIL) + (* ; + "So we don't come this way again.") + (DSPFILL (create REGION + LEFT _ 2 + BOTTOM _ 1 + HEIGHT _ 8 + WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) + of (DSPCLIPPINGREGION NIL + SELWINDOW)) + 4)) + WHITESHADE + 'REPLACE SELWINDOW) (* ; + "Make the tab region look non-neutral, too, so that tabs look OK on it.") + )) + (COND + ((AND [SETQ TAB (for TABX in SCALEDTABS as TAB in TABS + smallest (ABS (IDIFFERENCE TABX (LASTMOUSEX STREAM] + (SETQ TABX (MSCALE (CAR TAB) + UNIT)) + (IGEQ (LASTMOUSEX STREAM) + (IDIFFERENCE TABX 2)) + (ILEQ (LASTMOUSEX STREAM) + (IPLUS TABX 2))) + (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT 'ERASE) + (replace TABKIND of TAB with (OR (fetch MARTABTYPE + of OBJDATUM) + 'LEFT)) + (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT 'PAINT) + (MB.MARGINBAR.TABTRACK STREAM OBJDATUM TAB)) + ([OR (NOT TAB) + (NOT (EQP (fetch TABX of TAB) + (MDESCALE (LASTMOUSEX STREAM) + UNIT] (* ; "Really create a new tab") + [SETQ TAB (create TAB + TABX _ (MDESCALE (LASTMOUSEX STREAM) + UNIT) + TABKIND _ (OR (fetch MARTABTYPE of OBJDATUM) + 'LEFT] + (SETQ TABS (CONS TAB TABS)) + (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT 'PAINT) + (MB.MARGINBAR.TABTRACK STREAM OBJDATUM TAB] + ((MOUSESTATE RIGHT) (* ; "DELETE a tab.") + (COND + ((AND [SETQ TAB (for TABX in SCALEDTABS as TAB in TABS + smallest (ABS (IDIFFERENCE TABX (LASTMOUSEX STREAM] + (SETQ TABX (MSCALE (CAR TAB) + UNIT)) + (IGEQ (LASTMOUSEX STREAM) + (IDIFFERENCE TABX 2)) + (ILEQ (LASTMOUSEX STREAM) + (IPLUS TABX 2))) + (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT 'ERASE) + (SETQ TABS (LDIFFERENCE TABS (LIST TAB] + (replace MARL1 of OBJDATUM with L1) + (replace MARLN of OBJDATUM with LN) + (replace MARR of OBJDATUM with R) + (replace MARTABS of OBJDATUM with TABS))) + T]) + +(MB.MARGINBAR.SIZEFN + [LAMBDA (OBJ) (* jds " 5-Sep-84 14:10") + (PROG ((BOX (create IMAGEBOX + XSIZE _ 1008 + YSIZE _ 62 + YDESC _ 0 + XKERN _ 4))) + (IMAGEOBJPROP OBJ 'BOUNDBOX BOX) + (RETURN BOX]) + +(MB.MARGINBAR.DISPLAYFN + [LAMBDA (OBJ STREAM MODE) (* ; "Edited 12-Jun-90 18:59 by mitani") + (* Display the innards of a menu + button) + (PROG ((IMAGEBOX (OR (IMAGEOBJPROP OBJ 'BOUNDBOX) + (IMAGEBOX OBJ STREAM MODE))) + (OBJDATUM (IMAGEOBJPROP OBJ 'OBJECTDATUM)) + BITMAP + (DS (DSPCREATE)) + WASON) + (COND + [[SETQ WASON (SETQ BITMAP (IMAGEOBJPROP OBJ 'BITCACHE] + + (* The marginbar existed already as an image. + Don't bother re-creating it, and remember that we're allowed to MODIFY the old + image instead of creating a new one.) + + (SETQ DS (IMAGEOBJPROP OBJ 'DSPCACHE] + (T (* Have to create an image for the + margin bar) + (SETQ BITMAP (BITMAPCREATE (fetch XSIZE of IMAGEBOX) + (fetch YSIZE of IMAGEBOX))) + (* Create a cache bitmap) + (IMAGEOBJPROP OBJ 'BITCACHE BITMAP) + (SETQ DS (DSPCREATE BITMAP)) + (IMAGEOBJPROP OBJ 'DSPCACHE DS) + (DSPXOFFSET 0 DS) + (DSPYOFFSET 0 DS) + (DSPCLIPPINGREGION (create REGION + LEFT _ 0 + BOTTOM _ 0 + WIDTH _ (fetch XSIZE of IMAGEBOX) + HEIGHT _ (fetch YSIZE of IMAGEBOX)) + DS))) + (MARGINBAR DS (fetch (MARGINBAR MARL1) of OBJDATUM) + (fetch (MARGINBAR MARLN) of OBJDATUM) + (fetch (MARGINBAR MARR) of OBJDATUM) + (fetch (MARGINBAR MARTABS) of OBJDATUM) + (fetch (MARGINBAR MARUNIT) of OBJDATUM) + (OR WASON (IMAGEOBJPROP OBJ 'NEEDSUPDATE NIL)) + (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL STREAM))) + (* Update the image, if it needs it) + (BITBLT BITMAP 0 0 STREAM (IDIFFERENCE (DSPXPOSITION NIL STREAM) + 4) + (IDIFFERENCE (DSPYPOSITION NIL STREAM) + (fetch YDESC of IMAGEBOX]) + +(MDESCALE + [LAMBDA (VAL UNIT) (* jds " 4-NOV-83 17:29") + + (* Convert a value from screen offset units to marginbar units) + + (COND + ((IEQP UNIT 12) + (QUOTIENT (IQUOTIENT (LLSH (IDIFFERENCE VAL 4) + 1) + UNIT) + 2.0)) + (T (QUOTIENT (DIFFERENCE VAL 4) + UNIT]) + +(MSCALE + [LAMBDA (VAL UNIT) (* jds " 4-NOV-83 17:31") + (* Convert from marginbar units to a + screen X offset) + (IPLUS 4 (FIXR (TIMES VAL (OR UNIT 1]) + +(MB.MARGINBAR.SHOWTAB + [LAMBDA (W TAB UNIT MODE) (* jds "22-Mar-85 17:36") + + (* Paint/erase/otherwise display the sign for a TAB in window WINDOW, using + units UNIT) + + (PROG ((TABX (MSCALE (fetch TABX of TAB) + UNIT))) + (SELECTQ (fetch TABKIND of TAB) + (LEFT (* Flush-left tab.) + (BITBLT \TEDIT.LEFTTAB 0 0 W (IDIFFERENCE TABX 2) + 1 NIL NIL 'INPUT MODE)) + (CENTERED (* Centered Tab) + (BITBLT \TEDIT.CENTERTAB 0 0 W (IDIFFERENCE TABX 5) + 1 NIL NIL 'INPUT MODE)) + (RIGHT (* Flush-right Tab) + (BITBLT \TEDIT.RIGHTTAB 0 0 W (IDIFFERENCE TABX 7) + 1 NIL NIL 'INPUT MODE)) + (DECIMAL (* Decimal aligned tab) + (BITBLT \TEDIT.DECIMALTAB 0 0 W (IDIFFERENCE TABX 7) + 1 NIL NIL 'INPUT MODE)) + (DOTTEDLEFT (* Decimal aligned tab) + (BITBLT \TEDIT.DOTTED.LEFTTAB 0 0 W (IDIFFERENCE TABX 7) + 1 NIL NIL 'INPUT MODE)) + (DOTTEDCENTERED (* Decimal aligned tab) + (BITBLT \TEDIT.DOTTED.CENTERTAB 0 0 W (IDIFFERENCE TABX 7) + 1 NIL NIL 'INPUT MODE)) + (DOTTEDRIGHT (* Decimal aligned tab) + (BITBLT \TEDIT.DOTTED.RIGHTTAB 0 0 W (IDIFFERENCE TABX 7) + 1 NIL NIL 'INPUT MODE)) + (DOTTEDDECIMAL (* Decimal aligned tab) + (BITBLT \TEDIT.DOTTED.DECIMALTAB 0 0 W (IDIFFERENCE TABX 7) + 1 NIL NIL 'INPUT MODE)) + NIL]) + +(MB.MARGINBAR.TABTRACK + [LAMBDA (STREAM OBJ TAB) (* jds " 8-Feb-84 20:38") + + (* Given that the mouse is down over a tab, track the tab as the mouse moves.) + + (PROG ((UNIT (fetch MARUNIT of OBJ)) + (CLIP (DSPCLIPPINGREGION NIL STREAM)) + (OLDX (MSCALE (fetch TABX of TAB) + (fetch MARUNIT of OBJ))) + X) + (while (AND (MOUSESTATE (OR LEFT MIDDLE RIGHT)) + (INSIDE? CLIP (LASTMOUSEX STREAM) + (LASTMOUSEY STREAM))) do (COND + ([NOT (IEQP OLDX (SETQ X (LASTMOUSEX STREAM] + (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT + 'ERASE) + (replace TABX of TAB + with (MDESCALE X UNIT)) + (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT + 'PAINT) + (SETQ OLDX X]) + +(\TEDIT.TABTYPE.SET + [LAMBDA (OBJ SEL W) (* ; + "Edited 24-Apr-95 12:03 by sybalsky:mv:envos") + (* Change the kind of TAB that will + be set in the succeeding marginbar.) + (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) + (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) + STATE DOTTEDBUTTON) + (SETQ STATE (IMAGEOBJPROP OBJ 'STATE)) (* Find out roughly what kind of TAB + this is to be.) + [SETQ STATE (U-CASE (COND + ((LISTP STATE) + (CAR STATE)) + (T STATE] (* Make sure it's upper case, and an + atom.) + (SETQ DOTTEDBUTTON (CAR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))) + (* Find out if this is to be a tab + with a dotted leader.) + [COND + ((EQ (IMAGEOBJPROP DOTTEDBUTTON 'STATE) + 'ON) (* Yes. Make this a DOTTEDxxx tab.) + (SETQ STATE (PACK* 'DOTTED STATE] + (TEDIT.MAPPIECES TEXTOBJ [FUNCTION (LAMBDA (CH# PC PCNO FNARG) + + (* Now run thru the rest of the document until we find the margin bar. + Replace the tab type of that margin bar with the new type.) + + (COND + ((AND (IGREATERP CH# (CAR FNARG)) + (fetch (PIECE POBJ) of PC) + (type? MARGINBAR (fetch (PIECE POBJ) + of PC))) + (replace MARTABTYPE + of (IMAGEOBJPROP (fetch (PIECE POBJ) + of PC) + 'OBJECTDATUM) with + (CDR FNARG)) + 'STOP] + (CONS CH# STATE]) + +(MARGINBAR.INIT + [LAMBDA NIL (* jds " 9-Feb-86 15:18") + (SETQ MARGINBARIMAGEFNS (IMAGEFNSCREATE (FUNCTION MB.MARGINBAR.DISPLAYFN) + (FUNCTION MB.MARGINBAR.SIZEFN) + (FUNCTION MB.MARGINBAR.PUTFN) + (FUNCTION MB.MARGINBAR.GETFN) + (FUNCTION MB.COPYFN) + (FUNCTION MB.MARGINBAR.SELFN) + 'NILL + 'NILL + 'NILL + 'NILL + 'NILL + 'NILL + 'NILL + 'NILL + 'MarginRuler]) +) + +(RPAQQ \TEDIT.LEFTTAB #*(10 8)B@@@B@@@G@@@JH@@B@@@B@@@CN@@@@@@) + +(RPAQQ \TEDIT.CENTERTAB #*(10 8)@D@@@D@@@N@@AE@@@D@@@D@@AO@@@@@@) + +(RPAQQ \TEDIT.RIGHTTAB #*(10 8)@A@@@A@@@CH@@ED@@A@@@A@@AO@@@@@@) + +(RPAQQ \TEDIT.DECIMALTAB #*(10 8)@A@@@A@@@CH@@ED@@A@@@CH@@CH@@@@@) + +(RPAQQ \TEDIT.DOTTED.LEFTTAB #*(16 8)@@H@@@H@@AL@@BJ@@@H@CFH@CFOH@@@@) + +(RPAQQ \TEDIT.DOTTED.CENTERTAB #*(16 8)@@A@@@A@@@CH@@ED@@A@CFA@CFGL@@@@) + +(RPAQQ \TEDIT.DOTTED.RIGHTTAB #*(16 8)@@@D@@@D@@@N@@AE@@@DCF@DCFGL@@@@) + +(RPAQQ \TEDIT.DOTTED.DECIMALTAB #*(16 8)@@@D@@@D@@@N@@AE@@@D@MHN@MHN@@@@) + +(RPAQQ TEDIT.EXTENDEDRIGHTMARK #*(8 32)FF@@FF@@FF@@FF@@LL@@LL@@LL@@LL@@LL@@LL@@LL@@LL@@FF@@FF@@FF@@FF@@CC@@CC@@CC@@CC@@CC@@CC@@CC@@CC@@FF@@FF@@FF@@FF@@LL@@LL@@LL@@LL@@ +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS MARGINBARIMAGEFNS) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(MARGINBAR.INIT) + + +(ADDTOVAR IMAGEOBJTYPES (MarginRuler FILE TEDITMENU GETFN MB.GETFN)) +) + + + +(* ;; "Text menu creation and support") + +(DEFINEQ + +(\TEXTMENU.START + [LAMBDA (MENU MAINWINDOW TITLE HEIGHT) (* ; + "Edited 4-Jun-93 11:59 by sybalsky:mv:envos") + + (* ;; "Create a TEdit-based menu for a given main window.") + + (PROG ([WREG (COND + (MAINWINDOW (WINDOWPROP MAINWINDOW 'REGION)) + (T (GETREGION] + (CH#1 NIL) + MENUW MENUTEXT) + (COND + ((AND MAINWINDOW (WINDOWPROP MAINWINDOW 'TEDITMENU)) + (* ; + "This is a menu window. It can't have a menu, so bail out.") + (RETURN)) + ([AND MAINWINDOW (for WW in (ATTACHEDWINDOWS MAINWINDOW) + thereis (EQUAL (OR TITLE "TEdit Menu") + (WINDOWPROP WW 'TEDITMENU] + (* ; + "If this main window already has a menu, don't add another.") + (RETURN))) + (SETQ MENUW (CREATEW (SETQ WREG (COND + (MAINWINDOW (create REGION + LEFT _ (fetch (REGION LEFT) + of WREG) + BOTTOM _ (fetch (REGION TOP) + of WREG) + WIDTH _ (fetch (REGION WIDTH) + of WREG) + HEIGHT _ (OR HEIGHT 133))) + (T WREG))) + (OR TITLE "TEdit Menu"))) + (WINDOWADDPROP MENUW 'CLOSEFN 'TEXTMENU.CLOSEFN) + (WINDOWPROP MENUW 'TEDITMENU (OR TITLE "TEdit Menu")) + (* ; + "Mark this as a TEDIT MENU window") + (ATTACHWINDOW MENUW MAINWINDOW 'TOP 'JUSTIFY 'LOCALCLOSE) + (SETQ MENUTEXT MENU) + (replace (TEXTOBJ MENUFLG) of (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) + with T) + [AND MAINWINDOW (WINDOWPROP MENUW 'PROMPTWINDOW (WINDOWPROP MAINWINDOW 'PROMPTWINDOW] + [TEDIT MENUTEXT MENUW NIL (LIST 'TITLEMENUFN 'DON'T 'PROMPTWINDOW (fetch (TEXTOBJ + PROMPTWINDOW) + of (TEXTOBJ + MAINWINDOW + ] + (AND MAINWINDOW (TTY.PROCESS (WINDOWPROP MAINWINDOW 'PROCESS]) + +(\TEXTMENU.DOC.CREATE + [LAMBDA (MENUDESC MENUPROPS) (* ; "Edited 12-Jun-90 19:00 by mitani") + + (* Create the TEXTSTREAM for a menu, given a description. + That stream is passed to \TEXTMENU.START to get the menu up on screen) + + (PROG ((CH#1 NIL) + MENUW MENUTEXT) + [SETQ MENUTEXT (OPENTEXTSTREAM "" NIL NIL NIL (OR MENUPROPS '(FONT (MODERN 10] + (bind (CH# _ 1) + OBJ for DESC in MENUDESC + do (SELECTQ (CAR DESC) + (* (* This is a comment within a menu + description -- Ignore it.)) + (MB.BUTTON (* A menu button -- + hitting it calls a function) + (TEDIT.INSERT.OBJECT (MBUTTON.CREATE + (MKATOM (fetch (MB.BUTTON MBLABEL) + of DESC)) + (fetch (MB.BUTTON MBBUTTONEVENTFN) + of DESC) + (fetch (MB.BUTTON MBFONT) of DESC)) + MENUTEXT CH#) + (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) + '(PROTECTED OFF) + CH# 1) + (add CH# 1)) + (MB.3STATE (* 3-state button; + hitting it changes state among ON, + OFF, and NEUTRAL.) + (TEDIT.INSERT.OBJECT (MB.CREATE.THREESTATEBUTTON + (MKATOM (fetch (MB.3STATE MBLABEL) + of DESC)) + (fetch (MB.3STATE MBFONT) of DESC) + (fetch (MB.3STATE MBCHANGESTATEFN) + of DESC) + (fetch (MB.3STATE MBINITSTATE) + of DESC)) + MENUTEXT CH#) + (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) + '(PROTECTED OFF) + CH# 1) + (add CH# 1)) + (MB.TOGGLE (* TOGGLE button; hitting it + switches between ON and OFF.) + (TEDIT.INSERT.OBJECT (\TEXTMENU.TOGGLE.CREATE + (MKATOM (fetch (MB.TOGGLE MBTEXT) + of DESC)) + (fetch (MB.TOGGLE MBFONT) of DESC) + (fetch (MB.TOGGLE MBCHANGESTATEFN) + of DESC) + (fetch (MB.TOGGLE MBINITSTATE) + of DESC)) + MENUTEXT CH#) + (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) + '(PROTECTED OFF) + CH# 1) + (add CH# 1)) + (MB.NWAY (* N-way buttons; choosing one turns + the others off.) + (SETQ OBJ (MB.CREATE.NWAYBUTTON (fetch (MB.NWAY MBBUTTONS) + of DESC) + (fetch (MB.NWAY MBFONT) of DESC) + (fetch (MB.NWAY MBCHANGESTATEFN) of DESC) + (fetch (MB.NWAY MBINITSTATE) of DESC) + (fetch (MB.NWAY MBMAXITEMSPERLINE) of + DESC))) + (TEDIT.INSERT.OBJECT OBJ MENUTEXT CH#) + (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) + '(PROTECTED OFF) + CH# 1) + (add CH# 1)) + (MENU (* Real menu, except the selection + sticks) + (TEDIT.INSERT.OBJECT (MB.CREATE.FULLMENU (CADR DESC)) + MENUTEXT CH#) + (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) + '(PROTECTED OFF) + CH# 1) + (add CH# 1)) + (MB.MARGINBAR (* Margin ruler for TEdit formatting) + (TEDIT.INSERT.OBJECT (MARGINBAR.CREATE -0.5 -0.5 -39.5 NIL + 12) + MENUTEXT CH#) + (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) + '(PROTECTED OFF) + CH# 1) + (add CH# 1)) + (MB.TEXT (* Arbitrary text, which will be + protected from the user.) + (TEDIT.INSERT MENUTEXT (fetch (MB.TEXT MBSTRING) of DESC) + CH#) + [AND (fetch (MB.TEXT MBFONT) of DESC) + (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) + (LIST 'MBFONT (fetch (MB.TEXT MBFONT) of DESC)) + CH# + (NCHARS (fetch (MB.TEXT MBSTRING) of DESC] + (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) + '(PROTECTED ON) + CH# + (NCHARS (fetch (MB.TEXT MBSTRING) of DESC))) + (add CH# (NCHARS (fetch (MB.TEXT MBSTRING) of DESC)))) + (MB.INSERT (* An insertion point, with optional + text to put there) + (TEDIT.INSERT MENUTEXT " {}" CH#) + (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) + '(PROTECTED ON) + CH# 4) + (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) + '(PROTECTED ON SELECTPOINT ON) + (IPLUS CH# 2) + 1) + (OR CH#1 (SETQ CH#1 (IPLUS CH# 3))) + [COND + ((fetch (MB.INSERT MBINITENTRY) of DESC) + (* There is an initial entry to be + made. Make it) + [COND + ((IMAGEOBJP (fetch (MB.INSERT MBINITENTRY) of + DESC)) + (* It is an imageobj.) + (TEDIT.INSERT.OBJECT (fetch (MB.INSERT MBINITENTRY) + of DESC) + MENUTEXT + (IPLUS CH# 3))) + (T (* It's regular text.) + (TEDIT.INSERT MENUTEXT (MKSTRING (fetch (MB.INSERT + MBINITENTRY + ) + of DESC)) + (IPLUS CH# 3] + [TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) + '(PROTECTED OFF SELECTPOINT OFF) + (IPLUS CH# 3) + (NCHARS (MKSTRING (fetch (MB.INSERT MBINITENTRY) + of DESC] + (add CH# (NCHARS (fetch (MB.INSERT MBINITENTRY) + of DESC] + (add CH# 4)) + (\ILLEGAL.ARG DESC))) + (replace (TEXTOBJ MENUFLG) of (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) + with T) (* Remember that this is a menu) + [COND + (CH#1 (* We actually inserted some text, + so it makes sense to put up a + selection) + (push (fetch (TEXTOBJ EDITPROPS) of (fetch (TEXTSTREAM TEXTOBJ) + of MENUTEXT)) + (LIST 'SEL CH#1] (* And where the first selection + should be.) + (RETURN MENUTEXT]) + +(TEXTMENU.CLOSEFN + [LAMBDA (W) (* ; "Edited 12-Jun-90 18:59 by mitani") + + (* ;; "CLOSE a TEdit menu window: Detach the menu, then reshape the remaining windows to take up the remaining space") + + (PROG ((MAINW (WINDOWPROP W 'MAINWINDOW)) + TEXTOBJ HEIGHT OHEIGHT OBOTTOM WBOTTOM WINDOWS) + (FREEATTACHEDWINDOW W) (* (DETACHWINDOW W) + (* ; "So detach this window.") + (COND ((IGREATERP (FLENGTH + (ATTACHEDWINDOWS MAINW)) 1) + (SETQ OHEIGHT (fetch + (REGION HEIGHT) of + (WINDOWPROP W (QUOTE REGION)))) + (SETQ OBOTTOM (fetch + (REGION BOTTOM) of + (WINDOWPROP W (QUOTE REGION)))) + (CLOSEW W) (SETQ WINDOWS + (SORT (ATTACHEDWINDOWS MAINW) + (FUNCTION (LAMBDA (WW) + (fetch (REGION BOTTOM) of + (WINDOWPROP WW (QUOTE REGION))))))) + (for WW in WINDOWS when + (IGEQ (SETQ WBOTTOM + (fetch (REGION BOTTOM) of + (WINDOWPROP WW (QUOTE REGION)))) + OBOTTOM) do (MOVEW WW + (fetch (REGION LEFT) of + (WINDOWPROP WW (QUOTE REGION))) + (IDIFFERENCE WBOTTOM OHEIGHT)))))) + (COND + ((SETQ TEXTOBJ (WINDOWPROP W 'TEXTOBJ)) (* ; + "Then, if this window still has a textobj under it, kill off that edit process.") + (TEDIT.KILL TEXTOBJ) + + (* ;; "This has to be TEDIT.KILL to avoid problems with the TTY being handed from main back to menu, causing main never to finish off; menu would quit and hand TTY to top level window.") + + ]) +) + +(RPAQQ TEXTMENUICON #*(16 24)@@@@@@@@@@@@H@@@L@@AK@@GHLAIHCFAJ@HAKFKIJJJAJBKIJBJAH@KIJDHAKDJIJLJIJDJIJDJIH@KIF@HFAHIH@FN@@@H@ +) + +(RPAQQ TEXTMENUICONMASK #*(16 24)@@@@@@@@@@@@H@@@L@@AO@@GOLAOOOGOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOGOONAOOH@GN@@@H@ +) + + + +(* ; "TEdit-specific support") + +(DEFINEQ + +(\TEDITMENU.CREATE + [LAMBDA NIL (* gbn "27-Sep-84 01:04") + (* Creates the TEdit Expanded Menu) + (SETQ TEDIT.EXPANDED.MENU (\TEXTMENU.DOC.CREATE TEDIT.EXPANDEDMENU.SPEC]) + +(\TEDIT.EXPANDED.MENU + [LAMBDA (STREAM) (* ; "Edited 20-Aug-87 16:51 by jds") + (* "27-Sep-84 01:04" gbn) + (PROG (CHARMENUTEXTSTREAM) + (\TEXTMENU.START (SETQ CHARMENUTEXTSTREAM (COPYTEXTSTREAM TEDIT.EXPANDED.MENU T)) + (\TEDIT.PRIMARYW (TEXTOBJ STREAM)) + "TEdit Menu" + (HEIGHTIFWINDOW 60 T)) + (COND + ((OR (TEXTPROP STREAM 'CLEARGET) + (TEXTPROP STREAM 'CLEARPUT)) (* initialise the button) + (\TEXTMENU.SET.TOGGLE "Unformatted" 'ON CHARMENUTEXTSTREAM]) + +(MB.DEFAULTBUTTON.FN + [LAMBDA (OBJ SEL W) (* ; "Edited 30-Mar-94 15:46 by jds") + (* ; + "MBFN for TEdit default menu item buttons.") + (PROG* ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) + (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) + 'TEXTOBJ)) + (MAINSEL (fetch (TEXTOBJ SEL) of MAINTEXT)) + OFILE CH PROC) + (COND + ((EQ (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT) + T) + (TEDIT.PROMPTPRINT MAINTEXT "Edit operation in progress; please wait." T) + (RETURN)) + ((fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT) + (TEDIT.PROMPTPRINT MAINTEXT (CONCAT (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT) + " operation in progress; please wait.") + T) + [AND (NEQ (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT) + (IMAGEOBJPROP OBJ 'MBTEXT] + (RETURN))) + [COND + ((AND (SETQ PROC (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) + 'PROCESS)) + (PROCESSP PROC)) (* ; + "THE MAIN window has a live process behind it; go evaluate the button fn there.") + (PROCESS.EVAL PROC (LIST 'MB.DEFAULTBUTTON.ACTIONFN OBJ SEL W TEXTOBJ MAINTEXT MAINSEL + ))) + ((AND (SETQ PROC (WINDOWPROP W 'PROCESS)) + (PROCESSP PROC)) (* ; + "This window has a live process behind it; go evaluate the button fn there.") + (PROCESS.EVAL PROC (LIST 'MB.DEFAULTBUTTON.ACTIONFN OBJ SEL W TEXTOBJ MAINTEXT MAINSEL + ))) + (T (ADD.PROCESS (LIST 'MB.DEFAULTBUTTON.ACTIONFN OBJ SEL W TEXTOBJ MAINTEXT MAINSEL] + (COND + ((fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ) + (GIVE.TTY.PROCESS W) + (DISMISS 20))) + [COND + ((OR (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ) + (EQ (WINDOWPROP W 'PROCESS) + (TTY.PROCESS))) (* ; + "If the TEDIT MENU still has the tty, give it back to the real TEdit.") + (SETQ TEDIT.SELPENDING NIL) + (GIVE.TTY.PROCESS (WINDOWPROP W 'MAINWINDOW] + + (* ;; "Tell the menu button handler not to turn off this button--it's still active and will turn itself off.") + + (RETURN 'DON'T]) + +(\TEDITMENU.RECORD.UNFORMATTED + [LAMBDA (BUTTON NEWSTATE TEXTSTREAM) (* jds " 7-Feb-85 09:44") + (PROG ((FLG (COND + ((EQ NEWSTATE 'ON) + T) + (T NIL))) + (TEXTOBJ (TEXTOBJ TEXTSTREAM))) + (TEXTPROP TEXTOBJ 'UNFORMATTEDPUT/GET FLG]) + +(MB.DEFAULTBUTTON.ACTIONFN + [LAMBDA (OBJ SEL W TEXTOBJ MAINTEXT MAINSEL) (* ; "Edited 30-Mar-94 16:04 by jds") + (* ; + "MBFN for TEdit default menu item buttons.") + (PROG (OFILE CH %#COPIES PRINTHOST PRINTOPTIONS %#SIDES MSG) + [ERSETQ (RESETLST + [RESETSAVE (\TEDIT.MARKACTIVE MAINTEXT) + '(AND (\TEDIT.MARKINACTIVE OLDVALUE] + [RESETSAVE (\TEDIT.MARKACTIVE TEXTOBJ) + '(AND (\TEDIT.MARKINACTIVE OLDVALUE] + [RESETSAVE (PROG1 OBJ + (IMAGEOBJPROP OBJ 'MENUBUTTON.SELECTED T)) + '(AND (IMAGEOBJPROP OLDVALUE 'MENUBUTTON.SELECTED NIL] + (replace (TEXTOBJ EDITOPACTIVE) of MAINTEXT + with (OR (IMAGEOBJPROP OBJ 'MBTEXT) + T)) (* ; + "So we can tell the guy WHAT op is active.") + (SELECTQ (IMAGEOBJPROP OBJ 'MBTEXT) + (Put [SETQ OFILE (\TEDIT.MAKEFILENAME (MBUTTON.NEXT.FIELD.AS.TEXT + TEXTOBJ + (fetch (SELECTION CH#) + of SEL] + [COND + (OFILE (* ; + "Only try this if he really typed a file name") + (TEDIT.PUT MAINTEXT OFILE NIL (TEXTPROP TEXTOBJ + 'UNFORMATTEDPUT/GET]) + (Get [SETQ OFILE (\TEDIT.MAKEFILENAME (MBUTTON.NEXT.FIELD.AS.TEXT + TEXTOBJ + (fetch (SELECTION CH#) + of SEL] + [COND + (OFILE (* ; + "Only try this if he really typed a file name") + (TEDIT.GET MAINTEXT OFILE (TEXTPROP TEXTOBJ + 'UNFORMATTEDPUT/GET]) + (Include [SETQ OFILE (\TEDIT.MAKEFILENAME (MBUTTON.NEXT.FIELD.AS.TEXT + TEXTOBJ + (fetch (SELECTION CH#) + of SEL] + (COND + (OFILE (TEDIT.INCLUDE MAINTEXT OFILE)))) + (Find (SETQ OFILE (MBUTTON.NEXT.FIELD.AS.TEXT TEXTOBJ + (fetch (SELECTION CH#) of SEL))) + [COND + ((ZEROP (NCHARS OFILE)) (* ; "NOTHING--HE HIT DEL.") + ) + (OFILE (* ; + "There's something to do. Go do it.") + (TEDIT.PROMPTPRINT MAINTEXT "Searching..." T) + [SETQ CH (CAR (ERSETQ (TEDIT.FIND MAINTEXT OFILE NIL NIL T] + (COND + (CH (* ; "We found the target text.") + (TEDIT.PROMPTPRINT MAINTEXT "Done.") + (\SHOWSEL MAINSEL NIL NIL) + (replace (SELECTION CH#) of MAINSEL + with (CAR CH)) + (* ; + "Set up SELECTION to be the found text") + (replace (SELECTION CHLIM) of MAINSEL + with (ADD1 (CADR CH))) + [replace (SELECTION DCH) of MAINSEL + with (ADD1 (IDIFFERENCE (CADR CH) + (CAR CH] + (replace (SELECTION POINT) of MAINSEL + with 'RIGHT) + (replace (TEXTOBJ CARETLOOKS) of MAINTEXT + with (\TEDIT.GET.INSERT.CHARLOOKS MAINTEXT + MAINSEL)) + (* ; + "Set the caret looks to match those of the new selection") + (TEDIT.RESET.EXTEND.PENDING.DELETE MAINSEL) + (* ; "And never pending a deletion.") + (\FIXSEL MAINSEL MAINTEXT) + (TEDIT.NORMALIZECARET MAINTEXT MAINSEL) + (\SHOWSEL MAINSEL NIL T)) + (T (TEDIT.PROMPTPRINT MAINTEXT "(Not found)"]) + (Substitute [PROG* ((SAVECH# (fetch (SELECTION CH#) of SEL)) + (REPLACEMENT (MBUTTON.NEXT.FIELD.AS.TEXT + TEXTOBJ + (fetch (SELECTION CH#) of SEL))) + [PATTERN (MBUTTON.NEXT.FIELD.AS.TEXT + TEXTOBJ + (fetch (SELECTION CHLIM) + of (fetch (TEXTOBJ SCRATCHSEL) + of TEXTOBJ] + CONFIRM? KEEPLOOKS? LOC) + [SETQ LOC (MBUTTON.FIND.NEXT.BUTTON + TEXTOBJ + (fetch (SELECTION CHLIM) + of (fetch (TEXTOBJ SCRATCHSEL) + of TEXTOBJ] + [SETQ CONFIRM? (EQ 'ON (IMAGEOBJPROP (CAR LOC) + 'STATE] + [SETQ LOC (MBUTTON.FIND.NEXT.BUTTON + TEXTOBJ + (ADD1 (CDR LOC] + [SETQ KEEPLOOKS? (EQ 'ON (IMAGEOBJPROP (CAR LOC) + 'STATE] + (COND + ((ZEROP (NCHARS PATTERN)) + (* ; "NOTHING--HE HIT DEL.") + ) + (PATTERN (* ; + "There's something to do. Go do it.") + [COND + (KEEPLOOKS? (SETQ REPLACEMENT + ( + MBUTTON.NEXT.FIELD.AS.PIECES + TEXTOBJ SAVECH#] + (RESETLST + (RESETSAVE (CURSOR WAITINGCURSOR)) + (TEDIT.SUBSTITUTE (fetch (TEXTOBJ + STREAMHINT) + of MAINTEXT) + PATTERN REPLACEMENT CONFIRM?))]) + (Quit (* ; "He wants to QUIT the edit.") + (COND + ((\TEDIT.QUIT (\TEDIT.PRIMARYW MAINTEXT) + T) + (replace (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ + with T)))) + (Page% Layout (* ; "Page layout menu") + (\TEXTMENU.START (COPYTEXTSTREAM TEDIT.EXPANDED.PAGEMENU + T) + (\TEDIT.PRIMARYW MAINTEXT) + "Page Layout Menu" + (HEIGHTIFWINDOW 135 5))) + (Para% Looks (* ; "Page layout menu") + (\TEDIT.EXPANDEDPARA.MENU MAINTEXT)) + (Char% Looks (* ; "Page layout menu") + (\TEDIT.EXPANDEDCHARLOOKS.MENU MAINTEXT)) + (All (* ; "Select the entire document.") + (COND + ((NOT (ZEROP (fetch (TEXTOBJ TEXTLEN) of MAINTEXT))) + (\SHOWSEL MAINSEL NIL NIL) + (TEDIT.RESET.EXTEND.PENDING.DELETE MAINSEL) + (replace (SELECTION CH#) of MAINSEL with 1) + (replace (SELECTION CHLIM) of MAINSEL + with (ADD1 (fetch (TEXTOBJ TEXTLEN) of MAINTEXT))) + (replace (SELECTION DCH) of MAINSEL + with (fetch (TEXTOBJ TEXTLEN) of MAINTEXT)) + (replace (SELECTION POINT) of MAINSEL with + 'LEFT) + (replace (SELECTION SET) of MAINSEL with T) + (\FIXSEL MAINSEL MAINTEXT) + (\SHOWSEL MAINSEL NIL T)))) + (Hardcopy [SETQ PRINTHOST (\TEDIT.MAKEFILENAME ( + MBUTTON.NEXT.FIELD.AS.TEXT + TEXTOBJ + (fetch (SELECTION + CH#) + of SEL] + (COND + ((NOT PRINTHOST) (* ; + "If he didn't specify a particular host, defer to his defaults.") + (TEDIT.PROMPTPRINT MAINTEXT "Using default print server."))) + [SETQ %#COPIES (MBUTTON.NEXT.FIELD.AS.NUMBER + TEXTOBJ + (fetch (SELECTION CH#) + of (fetch (TEXTOBJ SCRATCHSEL) + of TEXTOBJ] + (* ; + "Grab the field that specifies number of copies.") + [COND + (%#COPIES (SETQ PRINTOPTIONS (LIST '%#COPIES %#COPIES] + (SETQ %#SIDES + (SELECTQ (IMAGEOBJPROP [CAR (MBUTTON.FIND.NEXT.BUTTON + TEXTOBJ + (fetch (SELECTION CHLIM) + of (fetch (TEXTOBJ + SCRATCHSEL) + of TEXTOBJ] + 'STATE) + (One% Side 1) + (Duplex 2) + NIL)) + [COND + (%#SIDES (push PRINTOPTIONS %#SIDES) + (push PRINTOPTIONS '%#SIDES] + [SETQ MSG (\TEDIT.MAKEFILENAME (MBUTTON.NEXT.FIELD.AS.TEXT + TEXTOBJ + (fetch (SELECTION CH#) + of (fetch (TEXTOBJ + SCRATCHSEL) + of TEXTOBJ] + [COND + (MSG (push PRINTOPTIONS MSG) + (push PRINTOPTIONS 'MESSAGE] + (TEDIT.HARDCOPY MAINTEXT NIL NIL NIL PRINTHOST PRINTOPTIONS)) + (ERROR)))] + (replace (SELECTION SET) of SEL with T)(* ; + "Now turn the menu button highlighting off.") + (replace (SELECTION ONFLG) of SEL with T) + (\SHOWSEL SEL NIL NIL) + (replace (SELECTION SET) of SEL with NIL) + (* ; + "And forget that anything is selected.") + ]) +) +(DEFINEQ + +(\TEDIT.CHARLOOKSMENU.CREATE + [LAMBDA NIL (* ; "Edited 20-Aug-87 16:50 by jds") + (* ; "Creates the TEdit Expanded Menu") + + (SETQ TEDIT.CHARLOOKS.MENU (\TEXTMENU.DOC.CREATE (APPEND (LIST (create MB.BUTTON + MBLABEL _ 'APPLY + MBBUTTONEVENTFN _ + '\TEDIT.APPLY.CHARLOOKS) + (create MB.TEXT + MBSTRING _ " ") + (create MB.BUTTON + MBLABEL _ 'SHOW + MBBUTTONEVENTFN _ + '\TEDIT.SHOW.CHARLOOKS) + (create MB.TEXT + MBSTRING _ " ") + (create MB.BUTTON + MBLABEL _ 'NEUTRAL + MBBUTTONEVENTFN _ + ' + \TEDIT.NEUTRALIZE.CHARLOOKS + ) + (create MB.TEXT + MBSTRING _ " +")) + TEDIT.CHARLOOKSMENU.SPEC]) + +(\TEDIT.EXPANDEDCHARLOOKS.MENU + [LAMBDA (STREAM) (* ; "Edited 20-Aug-87 16:49 by jds") + + (* ;; "Open a character-looks menu.") + + (\TEXTMENU.START (COPYTEXTSTREAM TEDIT.CHARLOOKS.MENU T) + (\TEDIT.PRIMARYW STREAM) + "Character Looks Menu" + (HEIGHTIFWINDOW 68 T]) + +(\TEDIT.APPLY.BOLDNESS + [LAMBDA (BUTTON NEWLOOKS) (* jds "30-Aug-84 13:55") + (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) + (ON (CONS 'WEIGHT (CONS 'BOLD NEWLOOKS))) + (OFF (CONS 'WEIGHT (CONS 'MEDIUM NEWLOOKS))) + NEWLOOKS]) + +(\TEDIT.APPLY.CHARLOOKS + [LAMBDA (OBJ SEL W) (* ; "Edited 30-May-91 22:17 by jds") + (* MBFN for TEdit default menu item + buttons.) + (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) + (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) + 'TEXTOBJ)) + (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) + SCRATCHSEL OFILE CH NEWLOOKS SIZE SUPER SUB NEXTB BUTTON TEXT OFFSET) + [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#] + (* Skip over the SHOW button) + [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#] + (* And over the NEUTRAL button.) + (SETQ NEWLOOKS (\TEDIT.PARSE.CHARLOOKS.MENU TEXTOBJ CH#)) + (* Now Parse the menu, to give us a + looks spec.) + (TEDIT.LOOKS MAINTEXT NEWLOOKS (fetch (SELECTION CH#) of (fetch (TEXTOBJ SEL) + of MAINTEXT)) + (fetch (SELECTION DCH) of (fetch (TEXTOBJ SEL) of MAINTEXT))) + (* Make the change in looks) + (\SHOWSEL SEL NIL NIL) (* And turn off the APPLY button.) + (TTY.PROCESS (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) + 'PROCESS)) (* Leave him typing in the real + document) + ]) + +(\TEDIT.APPLY.OLINE + [LAMBDA (BUTTON NEWLOOKS) (* jds "30-Aug-84 13:56") + (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) + (ON (CONS 'OVERLINE (CONS 'ON NEWLOOKS))) + (OFF (CONS 'OVERLINE (CONS 'OFF NEWLOOKS))) + NEWLOOKS]) + +(\TEDIT.SHOW.CHARLOOKS + [LAMBDA (OBJ SEL W) (* ; "Edited 30-May-91 22:17 by jds") + + (* ;; "Set the CHARLOOKS menu from the looks of the currently selected character.") + + (LET* ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) + (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) + 'TEXTOBJ)) + (MAINCH# (fetch (SELECTION CH#) of (fetch (TEXTOBJ SEL) of MAINTEXT))) + (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) + (SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + PC OFILE CH NEWLOOKS NEXTB BUTTON TEXT OFFSET) + (COND + ((<= MAINCH# (fetch (TEXTOBJ TEXTLEN) of MAINTEXT)) + [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#] + (* ; "Skip over the NEUTRAL button.") + (\SHOWSEL SEL NIL NIL) + (replace (SELECTION SET) of SEL with NIL) + (SETQ PC (\CHTOPC MAINCH# (fetch (TEXTOBJ PCTB) of MAINTEXT))) + (* ; + "The PIECE containing the text to describe") + (SETQ NEWLOOKS (fetch (PIECE PLOOKS) of PC)) + (* ; + "Get the looks for those characters.") + (WITHOUT-UPDATES TEXTOBJ SCRATCHSEL (\TEDIT.FILL.IN.CHARLOOKS.MENU TEXTOBJ CH# + NEWLOOKS)) + (* ; + "Fill in the menu blanks with that info") + ]) + +(\TEDIT.NEUTRALIZE.CHARLOOKS + [LAMBDA (OBJ SEL W) (* ; "Edited 30-May-91 22:18 by jds") + + (* Handle the NEUTRAL button on a character looks menu. + Sets all the menu settings neutral.) + + (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) + (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) + 'TEXTOBJ)) + (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) + PC SCRATCHSEL OFILE CH NEWLOOKS NEXTB BUTTON TEXT OFFSET) + (\SHOWSEL SEL NIL NIL) + (replace (SELECTION SET) of SEL with NIL) + (\TEDIT.NEUTRALIZE.CHARLOOKS.MENU TEXTOBJ CH#) (* Fill in the menu blanks with that + info) + (TEDIT.UPDATE.SCREEN TEXTOBJ) (* And update the screen image.) + ]) + +(\TEDIT.FILL.IN.CHARLOOKS.MENU + [LAMBDA (TEXTOBJ CH# NEWLOOKS) (* ; "Edited 30-May-91 22:28 by jds") + + (* ;; "Given a TEXTOBJ describing a charlooks menu, the CH# of the start of the charlooks menu, and a set of looks, fill in the menu fields.") + + (PROG (PC SCRATCHSEL OFILE CH NEXTB BUTTON TEXT OFFSET) + (SETQ NEWLOOKS (\TEDIT.PARSE.CHARLOOKS.LIST NEWLOOKS NIL NIL)) + + (* ;; "Make sure the charlooks are in the proper internal format, so this fn can be called from every reasonable place.") + + (SETQ SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + [for PROP in (LIST (fetch (CHARLOOKS CLBOLD) of NEWLOOKS) + (fetch (CHARLOOKS CLITAL) of NEWLOOKS) + (fetch (CHARLOOKS CLULINE) of NEWLOOKS) + (fetch (CHARLOOKS CLSTRIKE) of NEWLOOKS) + (fetch (CHARLOOKS CLOLINE) of NEWLOOKS)) + do (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + [COND + (PROP (* ; "Must set the property") + (IMAGEOBJPROP (CAR NEXTB) + 'STATE + 'ON)) + (T (* ; "Must reset it.") + (IMAGEOBJPROP (CAR NEXTB) + 'STATE + 'OFF] + (SETQ CH# (ADD1 (CDR NEXTB] + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + (* ; "Get to the start of the text.") + (SETQ BUTTON (CAR NEXTB)) + [for ITEM in (IMAGEOBJPROP BUTTON 'BUTTONS) + do (* ; + "Loop thru the font FAMILY name button list, looking for one that matches this text's looks") + (COND + ((STRING-EQUAL [COND + ((AND (type? FONTCLASS (fetch (CHARLOOKS CLFONT) + of NEWLOOKS)) + (NEQ (fetch FONTCLASSNAME + of (fetch (CHARLOOKS CLFONT) + of NEWLOOKS)) + 'DEFAULTFONT)) + (CONCAT (fetch FONTCLASSNAME of (fetch + (CHARLOOKS CLFONT) + of NEWLOOKS)) + '-class)) + ((FONTP (fetch (CHARLOOKS CLFONT) of NEWLOOKS)) + (FONTPROP (fetch (CHARLOOKS CLFONT) of NEWLOOKS) + 'FAMILY] + ITEM) + (IMAGEOBJPROP BUTTON 'STATE ITEM) + (RETURN))) finally (* ; + "This font wasn't found in the list. Add it.") + [MB.NWAYBUTTON.ADDITEM + BUTTON + (COND + ((type? FONTCLASS (fetch (CHARLOOKS CLFONT) + of NEWLOOKS)) + (PACK* (fetch FONTCLASSNAME + of (fetch (CHARLOOKS CLFONT) + of NEWLOOKS)) + '-class)) + ((FONTP (fetch (CHARLOOKS CLFONT) of NEWLOOKS)) + (FONTPROP (fetch (CHARLOOKS CLFONT) of NEWLOOKS) + 'FAMILY] (* ; + "Add this family to the list of items") + (IMAGEOBJPROP BUTTON 'STATE (U-CASE + (FONTPROP (fetch + (CHARLOOKS CLFONT) + of NEWLOOKS) + 'FAMILY] + (* ; + "Now find which text button was 'on'") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (CDR NEXTB)) + NIL) (* ; + "Clean out the 'other font' field") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) + (fetch (CHARLOOKS CLSIZE) of NEWLOOKS)) + (* ; "Set the value in the SIZE field") + [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + (* ; + "Move forward to the SUPERSCRIPT/SUBSCRIPT button") + (SETQ BUTTON (CAR NEXTB)) + (SETQ OFFSET (fetch (CHARLOOKS CLOFFSET) of NEWLOOKS)) + (* ; + "Remember the offset value for later") + [COND + ((OR (NOT (fetch (CHARLOOKS CLOFFSET) of NEWLOOKS)) + (ZEROP (fetch (CHARLOOKS CLOFFSET) of NEWLOOKS))) + (* ; + "There is no subscript or superscript. Mark the text NORMAL.") + (IMAGEOBJPROP BUTTON 'STATE 'Normal) + (SETQ OFFSET NIL) (* ; + "Mark there as being no offset value") + ) + ((ILESSP OFFSET 0) (* ; "SUBSCRIPTING") + (IMAGEOBJPROP BUTTON 'STATE 'Subscript)) + ((IGREATERP OFFSET 0) (* ; "SUBSCRIPTING") + (IMAGEOBJPROP BUTTON 'STATE 'Superscript] + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (CDR NEXTB)) + (AND OFFSET (IABS OFFSET))) (* ; + "Now move up to the offset distance fill-in field.") + (\SHOWSEL SCRATCHSEL NIL NIL) + (replace (SELECTION SET) of SCRATCHSEL with NIL) + (\TEDIT.MARK.LINES.DIRTY TEXTOBJ CH# (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL]) + +(\TEDIT.NEUTRALIZE.CHARLOOKS.MENU + [LAMBDA (TEXTOBJ CH#) (* ; "Edited 30-May-91 22:18 by jds") + + (* ;; +"Set all the fields in the CHARLOOKS menu specified by TEXTOBJ, starting at CH# to neutral values.") + + (PROG ((SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + PC OFILE CH NEXTB BUTTON TEXT OFFSET) + (WITHOUT-UPDATES TEXTOBJ SCRATCHSEL [for PROP + in '(BOLD ITAL ULINE STRIKE OLINE) + do (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON + TEXTOBJ CH#)) + (IMAGEOBJPROP (CAR NEXTB) + 'STATE + 'NEUTRAL) + (SETQ CH# (ADD1 (CDR NEXTB] + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + (* ; "Get to the start of the text.") + (SETQ BUTTON (CAR NEXTB)) + (IMAGEOBJPROP BUTTON 'STATE NIL) (* ; + "Now find which text button was 'on'") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (CDR NEXTB)) + NIL) (* ; + "Clean out the 'other font' field") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of + SCRATCHSEL + )) + NIL) (* ; "Set the value in the SIZE field") + [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + (* ; + "Move forward to the SUPERSCRIPT/SUBSCRIPT button") + (SETQ BUTTON (CAR NEXTB)) (* ; + "Remember the offset value for later") + (IMAGEOBJPROP BUTTON 'STATE NIL) + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (CDR NEXTB)) + NIL) (* ; + "Now move up to the offset distance fill-in field.") + ]) + +(\TEDIT.PARSE.CHARLOOKS.MENU + [LAMBDA (TEXTOBJ CH#) (* ; "Edited 30-May-91 22:18 by jds") + (* MBFN for TEdit default menu item + buttons.) + (PROG (SCRATCHSEL CH NEWLOOKS SIZE SUPER SUB NEXTB BUTTON TEXT OFFSET) + (SETQ SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + [for BUTTON in '(BOLD ITALIC UNDERLINE STRIKEOUT OVERSCORE) + do (* Set the character properties + which are independent) + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + (SELECTQ BUTTON + (BOLD (SETQ NEWLOOKS (\TEDIT.APPLY.BOLDNESS (CAR NEXTB) + NEWLOOKS))) + (ITALIC (SETQ NEWLOOKS (\TEDIT.APPLY.SLOPE (CAR NEXTB) + NEWLOOKS))) + (UNDERLINE (SETQ NEWLOOKS (\TEDIT.APPLY.ULINE (CAR NEXTB) + NEWLOOKS))) + (STRIKEOUT (SETQ NEWLOOKS (\TEDIT.APPLY.STRIKEOUT (CAR NEXTB) + NEWLOOKS))) + (OVERSCORE (SETQ NEWLOOKS (\TEDIT.APPLY.OLINE (CAR NEXTB) + NEWLOOKS))) + NIL) + (SETQ CH# (ADD1 (CDR NEXTB] + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + (* Get to the start of the text.) + (SETQ BUTTON (CAR NEXTB)) + [AND BUTTON + (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) + (Other (* Have to get and add in a new + font.) + (COND + ([SETQ TEXT (MBUTTON.NEXT.FIELD.AS.ATOM TEXTOBJ (ADD1 (CDR NEXTB] + (* He wants some font not on the + list. Add it to the list.) + (SETQ NEWLOOKS (CONS 'FAMILY (CONS (U-CASE TEXT) + NEWLOOKS))) + (COND + ([NOT (FMEMB (U-CASE TEXT) + (U-CASE (IMAGEOBJPROP BUTTON 'BUTTONS] + (* This font name isn't in the list + already; add it.) + (MB.NWAYBUTTON.ADDITEM BUTTON TEXT) + (IMAGEOBJPROP BUTTON 'STATE TEXT)) + (T [IMAGEOBJPROP BUTTON 'STATE (for NAME + in (IMAGEOBJPROP BUTTON + 'BUTTONS) + suchthat (EQ (U-CASE TEXT) + (U-CASE NAME] + (* Select the newly-specified font.) + )) + (TEDIT.DELETE TEXTOBJ SCRATCHSEL) + (* Delete the new font's name from + the fill-in field.) + (TEDIT.OBJECT.CHANGED TEXTOBJ BUTTON)) + (T (* He didn't specify a font. + Complain but keep on.) + (TEDIT.PROMPTPRINT TEXTOBJ + "'Other' font not specified; no change made." T)))) + (COND + ((STRPOS '-class (IMAGEOBJPROP BUTTON 'STATE)) + (* It's a font class. + Grab the name and evaluate it.) + (SETQ NEWLOOKS + (CONS 'FONT (CONS [EVAL (MKATOM (SUBSTRING (IMAGEOBJPROP BUTTON 'STATE) + 1 + (SUB1 (STRPOS '-class + (IMAGEOBJPROP + BUTTON + 'STATE] + NEWLOOKS))) + (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH#)) + (T (SETQ NEWLOOKS (CONS 'FAMILY (CONS (U-CASE (IMAGEOBJPROP BUTTON 'STATE)) + NEWLOOKS))) + (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH#) + (* Skip over the "other text" + fill-in.) + ] (* Now find which text button was "on") + [SETQ SIZE (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + (* Read the contents of the SIZE + menu field) + [COND + (SIZE (* He specified one. + Set it.) + (SETQ NEWLOOKS (CONS 'SIZE (CONS SIZE NEWLOOKS] + [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + (* Get a handle on the + SUPERSCRIPT/SUBSCRIPT button) + (SETQ BUTTON (CAR NEXTB)) + (SETQ SUPER (IMAGEOBJPROP BUTTON 'STATE)) (* Decide which kind it is) + [SETQ OFFSET (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (CDR NEXTB] + (* And get the offset distance, in + points.) + (SELECTQ SUPER + (Superscript + + (* He called for SUPERSCRIPTing. Offset the characters by either the distance + he gave, or 2 pts.) + + (SETQ NEWLOOKS (CONS 'SUPERSCRIPT (CONS (OR OFFSET 2) + NEWLOOKS)))) + (Subscript + + (* He called for SUBSCRIPTING. Offset the characters by either the distance he + gave, or 2 pts if he gave no distance.) + + (SETQ NEWLOOKS (CONS 'SUBSCRIPT (CONS (OR OFFSET 2) + NEWLOOKS)))) + (Normal (* NORMAL => Turn off all super and + subscripting) + (SETQ NEWLOOKS (CONS 'SUPERSCRIPT (CONS 0 NEWLOOKS)))) + NIL) + (RETURN NEWLOOKS]) + +(\TEDIT.APPLY.SLOPE + [LAMBDA (BUTTON NEWLOOKS) (* jds "30-Aug-84 13:56") + (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) + (ON (CONS 'SLOPE (CONS 'ITALIC NEWLOOKS))) + (OFF (CONS 'SLOPE (CONS 'REGULAR NEWLOOKS))) + NEWLOOKS]) + +(\TEDIT.APPLY.STRIKEOUT + [LAMBDA (BUTTON NEWLOOKS) (* jds "30-Aug-84 13:56") + (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) + (ON (CONS 'STRIKEOUT (CONS 'ON NEWLOOKS))) + (OFF (CONS 'STRIKEOUT (CONS 'OFF NEWLOOKS))) + NEWLOOKS]) + +(\TEDIT.APPLY.ULINE + [LAMBDA (BUTTON NEWLOOKS) (* jds "30-Aug-84 13:56") + (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) + (ON (CONS 'UNDERLINE (CONS 'ON NEWLOOKS))) + (OFF (CONS 'UNDERLINE (CONS 'OFF NEWLOOKS))) + NEWLOOKS]) +) +(DEFINEQ + +(\TEDITPARAMENU.CREATE + [LAMBDA NIL (* jds " 2-Aug-84 15:32") + (* Creates the TEdit Expanded + Paragraph Menu) + (SETQ TEDIT.EXPANDEDPARA.MENU (\TEXTMENU.DOC.CREATE TEDIT.PARAMENU.SPEC]) + +(\TEDIT.EXPANDEDPARA.MENU + [LAMBDA (STREAM) (* ; "Edited 20-Aug-87 16:51 by jds") + + (\TEXTMENU.START (COPYTEXTSTREAM TEDIT.EXPANDEDPARA.MENU T) + (\TEDIT.PRIMARYW (TEXTOBJ STREAM)) + "Paragraph-Looks Menu" + (HEIGHTIFWINDOW 141 T]) + +(\TEDIT.APPLY.PARALOOKS + [LAMBDA (OBJ SEL W) (* ; "Edited 22-Apr-93 16:45 by jds") + + (* ;; "Handler for the Paragraph Menu's APPLY button. Collects the specs from the paragraph menu and calls TEDIT.PARALOOKS to effect the change.") + + (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) + (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) + 'TEXTOBJ)) + (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) + SCRATCHSEL QUAD OFILE CH NEWLOOKS SIZE SUPER SUB LINELEAD PARALEAD DEFAULTTAB BUTTON NEXTB + BUTTONDATA L1 LN R PARATYPE SPECIALX SPECIALY) + [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#] + (* ; "Skip the SHOW button") + [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#] + (* ; "and the NEUTRAL button.") + (SETQ SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + (SETQ NEWLOOKS NIL) (* ; + "The list we'll be collecting the looks changes in.") + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + (* ; + "Get the JUSTIFICATION button: Left/Right/Centered/Justified") + (SETQ BUTTON (CAR NEXTB)) + [COND + ((AND (SETQ QUAD (IMAGEOBJPROP BUTTON 'STATE)) + (NEQ QUAD 'OFF)) (* ; "A justification was specified") + (SETQ NEWLOOKS (CONS 'QUAD (CONS (U-CASE (MKATOM QUAD)) + NEWLOOKS] + [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] + (* ; "Go to the 'Page Heading' button") + (SETQ BUTTON (CAR NEXTB)) + [COND + ((EQ (IMAGEOBJPROP BUTTON 'STATE) + 'ON) (* ; + "This paragraph IS a page heading.") + (SETQ NEWLOOKS (CONS 'TYPE (CONS 'PAGEHEADING NEWLOOKS))) + (* ; "Tell him that it's a heading.") + (SETQ NEWLOOKS (CONS 'SUBTYPE (CONS [MKATOM (MBUTTON.NEXT.FIELD.AS.TEXT + TEXTOBJ + (ADD1 (CDR NEXTB] + NEWLOOKS)))(* ; "And say what kind.") + ) + ((EQ (IMAGEOBJPROP BUTTON 'STATE) + 'OFF) (* ; + "This paragraph IS NOT a page heading.") + (SETQ NEWLOOKS (CONS 'TYPE (CONS NIL NEWLOOKS))) + (* ; + "Tell him that it's NOT a heading.") + (SETQ NEWLOOKS (CONS 'SUBTYPE (CONS NIL NEWLOOKS))) + (MBUTTON.NEXT.FIELD.AS.TEXT TEXTOBJ (ADD1 (CDR NEXTB))) + (* ; "And say what kind.") + ) + (T (* ; + "No change specified. Skip over the heading-type fill-in.") + (MBUTTON.NEXT.FIELD.AS.TEXT TEXTOBJ (ADD1 (CDR NEXTB] + [COND + ((SETQ LINELEAD (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (fetch (SELECTION CH#) + of SCRATCHSEL))) + (* ; "Get any line leading") + (SETQ NEWLOOKS (CONS 'LINELEADING (CONS LINELEAD NEWLOOKS] + [COND + ([SETQ PARALEAD (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION + CH#) + of SCRATCHSEL] + (* ; "Get any paragraph leading") + (SETQ NEWLOOKS (CONS 'PARALEADING (CONS PARALEAD NEWLOOKS] + [COND + ([SETQ SPECIALX (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION + CH#) + of SCRATCHSEL] + (* ; + "Get any special X position for the paragraph") + (SETQ NEWLOOKS (CONS 'SPECIALX (CONS (FIXR (TIMES 12 SPECIALX)) + NEWLOOKS] + [COND + ([SETQ SPECIALY (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION + CH#) + of SCRATCHSEL] + (* ; + "Get special Y positioning for the paragraph") + (SETQ NEWLOOKS (CONS 'SPECIALY (CONS (FIXR (TIMES 12 SPECIALY)) + NEWLOOKS] + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (fetch (SELECTION CH#) of + SCRATCHSEL + ))) + (SETQ BUTTON (CAR NEXTB)) + [COND + [(EQ (IMAGEOBJPROP BUTTON 'STATE) + 'ON) (* ; + "This paragraph starts on a new page (or col or box, as apprpopriate)") + (SETQ NEWLOOKS (CONS 'NEWPAGEBEFORE (CONS T NEWLOOKS] + ((EQ (IMAGEOBJPROP BUTTON 'STATE) + 'OFF) (* ; + "This paragraph IS NOT a page heading.") + (SETQ NEWLOOKS (CONS 'NEWPAGEBEFORE (CONS NIL NEWLOOKS] + [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] + (SETQ BUTTON (CAR NEXTB)) + [COND + [(EQ (IMAGEOBJPROP BUTTON 'STATE) + 'ON) (* ; + "The next paragraph starts on a new page....") + (SETQ NEWLOOKS (CONS 'NEWPAGEAFTER (CONS T NEWLOOKS] + ((EQ (IMAGEOBJPROP BUTTON 'STATE) + 'OFF) (* ; + "The next paragraph DOESN'T START on a new page....") + (SETQ NEWLOOKS (CONS 'NEWPAGEAFTER (CONS NIL NEWLOOKS] + [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] + (SETQ BUTTON (CAR NEXTB)) + (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) + (ON (push NEWLOOKS T) + (push NEWLOOKS 'HARDCOPY)) + (OFF (push NEWLOOKS NIL) + (push NEWLOOKS 'HARDCOPY)) + NIL) + +(* ;;; "THE VARIOUS KINDS OF KEEP PROPERTIES (ONLY HEADING-KEEP FOR NOW THO)") + + [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] + (SETQ BUTTON (CAR NEXTB)) + (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) + (ON (push NEWLOOKS 'ON) + (push NEWLOOKS 'HEADINGKEEP)) + (OFF (push NEWLOOKS 'OFF) + (push NEWLOOKS 'HEADINGKEEP)) + NIL) + +(* ;;; "THE DEFAULT TAB WIDTH") + + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (fetch (SELECTION CH#) of + SCRATCHSEL + ))) + (SETQ BUTTON (CAR NEXTB)) + (SETQ DEFAULTTAB (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (CDR NEXTB))) + (while (NOT (type? MARGINBAR BUTTON)) do (SETQ NEXTB ( + MBUTTON.FIND.NEXT.BUTTON + TEXTOBJ + (fetch (SELECTION + CH#) + of SCRATCHSEL))) + (SETQ BUTTON (CAR NEXTB))) + (SETQ BUTTONDATA (IMAGEOBJPROP BUTTON 'OBJECTDATUM)) + [COND + ((IGEQ [SETQ L1 (FIXR (TIMES (fetch MARL1 of BUTTONDATA) + (fetch MARUNIT of BUTTONDATA] + 0) (* ; + "The 1stleftmargin is set, and non-neutral.") + (SETQ NEWLOOKS (CONS '1STLEFTMARGIN (CONS L1 NEWLOOKS] + [COND + ((IGEQ [SETQ LN (FIXR (TIMES (fetch MARLN of BUTTONDATA) + (fetch MARUNIT of BUTTONDATA] + 0) (* ; + "The LEFTMARGIN is set, and non-neutral.") + (SETQ NEWLOOKS (CONS 'LEFTMARGIN (CONS LN NEWLOOKS] + [COND + ((IGEQ [SETQ R (FIXR (TIMES (fetch MARR of BUTTONDATA) + (fetch MARUNIT of BUTTONDATA] + 0) (* ; + "The RIGHTMARGIN is set, and non-neutral.") + (SETQ NEWLOOKS (CONS 'RIGHTMARGIN (CONS R NEWLOOKS] + [COND + ((NEQ (fetch MARTABS of BUTTONDATA) + 'NEUTRAL) (* ; + "If the tab settings are neutral, don't change anything.") + (SETQ NEWLOOKS + (CONS 'TABS + (CONS [CONS DEFAULTTAB + (SORT (for TAB in (fetch MARTABS of BUTTONDATA) + collect (CONS (FIXR (TIMES (CAR TAB) + (fetch MARUNIT + of BUTTONDATA))) + (CDR TAB))) + (FUNCTION (LAMBDA (A B) + (ILEQ (CAR A) + (CAR B] + NEWLOOKS] + (TEDIT.PARALOOKS MAINTEXT NEWLOOKS (fetch (SELECTION CH#) of (fetch + (TEXTOBJ SEL) + of MAINTEXT)) + (fetch (SELECTION DCH) of (fetch (TEXTOBJ SEL) of MAINTEXT))) + (\SHOWSEL SEL NIL NIL) + (TTY.PROCESS (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) + 'PROCESS]) + +(\TEDIT.SHOW.PARALOOKS + [LAMBDA (OBJ SEL W) (* ; "Edited 6-Jul-92 09:42 by jds") + + (* ;; "Fill in the PARAGRAPH LOOKS menu from the para looks for a selected character") + + (PROG* ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) + (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) + 'TEXTOBJ)) + (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) + (SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + (OLDUPDATEFLG (fetch (TEXTOBJ TXTDON'TUPDATE) of TEXTOBJ)) + FMTSPEC BUTTON NEXTB ARB BUTTONDATA) + (\SHOWSEL SEL NIL NIL) + (replace (SELECTION SET) of SEL with NIL) + (COND + ((ZEROP (fetch (TEXTOBJ TEXTLEN) of MAINTEXT)) + (* ; + "If there is no text to take the formatting from, don't bother") + (RETURN))) + (WITHOUT-UPDATES TEXTOBJ SCRATCHSEL + [SETQ FMTSPEC (fetch (PIECE PPARALOOKS) + of (\CHTOPC [IMAX 1 (IMIN (fetch (TEXTOBJ TEXTLEN) + of MAINTEXT) + (fetch (SELECTION CH#) + of (fetch (TEXTOBJ SEL) + of MAINTEXT] + (fetch (TEXTOBJ PCTB) of MAINTEXT] + (* ; "Get to the start of the text.") + [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#] + (* ; "Skip the NEUTRAL button.") + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + (* ; "Grab the justification button") + (SETQ BUTTON (CAR NEXTB)) + [for ITEM in (IMAGEOBJPROP BUTTON 'BUTTONS) + do (COND + ([EQ (fetch (FMTSPEC QUAD) of FMTSPEC) + (U-CASE (COND + ((LISTP ITEM) + (CAR ITEM)) + (T ITEM] (* ; "Turn this button on.") + (IMAGEOBJPROP BUTTON 'STATE ITEM) + (RETURN] (* ; + "Now find which text button was 'on'") + [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] + (* ; "Find the 'Page Heading' button") + (SETQ BUTTON (CAR NEXTB)) + (COND + ((EQ (fetch (FMTSPEC FMTPARATYPE) of FMTSPEC) + 'PAGEHEADING) (* ; + "This IS a page heading. Turn the button ON and set the heading type field") + (IMAGEOBJPROP BUTTON 'STATE 'ON) + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL)) + (fetch (FMTSPEC FMTPARASUBTYPE) of FMTSPEC))) + (T (* ; + "This isn't a page heading; make sure the type field is empty.") + (IMAGEOBJPROP BUTTON 'STATE 'OFF) + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL)) + NIL))) + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of + SCRATCHSEL + )) + (fetch (FMTSPEC LINELEAD) of FMTSPEC)) + (* ; "Update the LINE LEADING field") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of + SCRATCHSEL + )) + (fetch (FMTSPEC LEADBEFORE) of FMTSPEC)) + (* ; "Update the PARA LEADING field") + [MBUTTON.SET.NEXT.FIELD + TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) + (LET ((VAL (/ (FIXR (IQUOTIENT (OR (fetch (FMTSPEC FMTSPECIALX) of FMTSPEC + ) + 0) + 3)) + 4))) + (COND + ((FIXP VAL) + VAL) + (T (FLOAT VAL] + [MBUTTON.SET.NEXT.FIELD + TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) + (LET ((VAL (/ (FIXR (IQUOTIENT (OR (fetch (FMTSPEC FMTSPECIALY) of FMTSPEC + ) + 0) + 3)) + 4))) + (COND + ((FIXP VAL) + VAL) + (T (FLOAT VAL] + [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION + CH#) + of SCRATCHSEL] + (SETQ BUTTON (CAR NEXTB)) + [COND + ((fetch (FMTSPEC FMTNEWPAGEBEFORE) of FMTSPEC) + (IMAGEOBJPROP BUTTON 'STATE 'ON) (* ; "This para starts on a new page") + ) + (T (IMAGEOBJPROP BUTTON 'STATE 'OFF] + [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] + (SETQ BUTTON (CAR NEXTB)) + [COND + ((fetch (FMTSPEC FMTNEWPAGEAFTER) of FMTSPEC) + (IMAGEOBJPROP BUTTON 'STATE 'ON) (* ; "This para starts on a new page") + ) + (T (IMAGEOBJPROP BUTTON 'STATE 'OFF] + + (* ;; "HARDCOPY-DISPLAY MODE") + + [SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ (ADD1 (CDR NEXTB)) + (COND + ((fetch (FMTSPEC FMTHARDCOPY) of FMTSPEC) + (* ; + "This para is to be formatted for hardcopy on the display") + 'ON) + (T 'OFF] + + (* ;; "HEADING KEEP") + + [SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ NEXTB + (COND + ((fetch (FMTSPEC FMTHEADINGKEEP) of FMTSPEC) + (* ; + "This para is to be formatted for hardcopy on the display") + 'ON) + (T 'OFF] + + (* ;; "DEFAULT TAB WIDTH") + + (MBUTTON.SET.NEXT.FIELD TEXTOBJ NEXTB (CAR (fetch (FMTSPEC TABSPEC) + of FMTSPEC))) + (* ; + "Update the DEFAULT TAB SPACING field") + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (fetch (SELECTION CH#) + of SCRATCHSEL))) + (SETQ BUTTON (CAR NEXTB)) + (while (NOT (type? MARGINBAR BUTTON)) + do [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] + (SETQ BUTTON (CAR NEXTB))) + (SETQ BUTTONDATA (IMAGEOBJPROP BUTTON 'OBJECTDATUM)) + (* ; + "(IMAGEOBJPROP BUTTON (QUOTE IMAGECACHE) NIL)") + (* ; "Tell it to reformat itself.") + (replace MARL1 of BUTTONDATA with (FQUOTIENT (fetch (FMTSPEC + 1STLEFTMAR + ) + of FMTSPEC) + (fetch MARUNIT + of BUTTONDATA))) + (replace MARLN of BUTTONDATA with (FQUOTIENT (fetch (FMTSPEC + LEFTMAR) + of FMTSPEC) + (fetch MARUNIT + of BUTTONDATA))) + (replace MARR of BUTTONDATA with (FQUOTIENT (fetch (FMTSPEC + RIGHTMAR) + of FMTSPEC) + (fetch MARUNIT of + BUTTONDATA)) + ) + (replace MARTABS of BUTTONDATA + with (for TAB in (CDR (fetch (FMTSPEC TABSPEC) of FMTSPEC)) + collect (CONS (FQUOTIENT (CAR TAB) + (fetch MARUNIT of BUTTONDATA)) + (CDR TAB]) + +(\TEDIT.NEUTRALIZE.PARALOOKS.MENU + [LAMBDA (OBJ SEL W) (* ; "Edited 30-May-91 22:18 by jds") + + (* ;; "Set all the fields of a PARAGRAPH LOOKS menu to neutral settings.") + + (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) + (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) + SCRATCHSEL FMTSPEC BUTTON NEXTB ARB BUTTONDATA) + (SETQ SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + (* ; "Get to the start of the text.") + (WITHOUT-UPDATES TEXTOBJ SCRATCHSEL (SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE + TEXTOBJ CH# 'NIL)) + (* ; + "Neutralize the justification N-Way button") + (SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ NEXTB 'NEUTRAL)) + (* ; "Find the 'Page Heading' button") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of + SCRATCHSEL + )) + NIL) + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of + SCRATCHSEL + )) + NIL) (* ; "Update the LINE LEADING field") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of + SCRATCHSEL + )) + NIL) (* ; "Update the PARA LEADING field") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of + SCRATCHSEL + )) + NIL) + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of + SCRATCHSEL + )) + NIL) + (SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ (ADD1 (fetch (SELECTION + CH#) + of SCRATCHSEL)) + 'NEUTRAL)) (* ; "New page before") + (SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ NEXTB 'NEUTRAL)) + (* ; "New page after") + (SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ NEXTB 'NEUTRAL)) + (* ; "Hardcopy formatting mode") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ NEXTB NIL) + (* ; + "Update the DEFAULT TAB SPACING field") + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (fetch (SELECTION CH#) + of SCRATCHSEL))) + (SETQ BUTTON (CAR NEXTB)) + (while (NOT (type? MARGINBAR BUTTON)) + do [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] + (SETQ BUTTON (CAR NEXTB))) + (SETQ BUTTONDATA (IMAGEOBJPROP BUTTON 'OBJECTDATUM)) + (* ; + "(IMAGEOBJPROP BUTTON (QUOTE IMAGECACHE) NIL)") + (* ; "Tell it to reformat itself.") + [replace MARL1 of BUTTONDATA + with (COND + ((ILESSP (fetch MARL1 of BUTTONDATA) + 0) + (fetch MARL1 of BUTTONDATA)) + (T (IMIN -0.5 (IMINUS (fetch MARL1 of BUTTONDATA] + [replace MARLN of BUTTONDATA + with (COND + ((ILESSP (fetch MARLN of BUTTONDATA) + 0) + (fetch MARLN of BUTTONDATA)) + (T (IMIN -0.5 (IMINUS (fetch MARLN of BUTTONDATA] + [replace MARR of BUTTONDATA + with (COND + ((ILESSP (fetch MARR of BUTTONDATA) + 0) + (fetch MARR of BUTTONDATA)) + ((ZEROP (fetch MARR of BUTTONDATA)) + (IMINUS (IQUOTIENT (IDIFFERENCE (fetch (TEXTOBJ WRIGHT) + of TEXTOBJ) + 20) + 12))) + (T (IMIN -0.5 (IMINUS (fetch MARR of BUTTONDATA] + (replace MARTABS of BUTTONDATA with 'NEUTRAL]) + +(\TEDIT.RECORD.TABLEADERS + [LAMBDA (BUTTON NEWSTATE TEXTSTREAM SEL) (* ; "Edited 30-May-91 22:18 by jds") + + (* Toggle the dotted-leader state of the margin bar tab-setter. + This is called when the user hits the "dotted leader" toggle button in the menu) + + (PROG* [(FLG (COND + ((EQ NEWSTATE 'ON) + T) + (T NIL))) + (TEXTOBJ (TEXTOBJ TEXTSTREAM)) + (MARGINBAR (CAR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION + CH#) + of SEL] + (replace MARTABTYPE of (IMAGEOBJPROP MARGINBAR 'OBJECTDATUM) + with (SELECTQ (OR (fetch MARTABTYPE of (IMAGEOBJPROP MARGINBAR + 'OBJECTDATUM)) + 'LEFT) + (LEFT 'DOTTEDLEFT) + (DOTTEDLEFT 'LEFT) + (CENTERED 'DOTTEDCENTERED) + (DOTTEDCENTERED + 'CENTERED) + (RIGHT 'DOTTEDRIGHT) + (DOTTEDRIGHT 'RIGHT) + (DECIMAL 'DOTTEDDECIMAL) + (DOTTEDDECIMAL 'DECIMAL) + (SHOULDNT]) +) +(DEFINEQ + +(\TEDIT.SHOW.PAGEFORMATTING + [LAMBDA (OBJ SEL W) (* ; "Edited 4-Feb-92 16:38 by jds") + +(* ;;; "Take a document's page formatting, and display it in the menu.") + + (PROG* ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) + (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) + 'TEXTOBJ)) + (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) + (SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + (OLDUPDATEFLG (fetch (TEXTOBJ TXTDON'TUPDATE) of TEXTOBJ)) + FOLIOINFO NEWLOOKS NEXTB BUTTON PAGEID OPAGEFRAMES FIRST REST PFONT HEADING HEADINGS + PAGEPROPS STARTINGPAGE# PAPERSIZE) + + (* ;; "Start by turning off the selection--and leaving it off afterward.") + + (\SHOWSEL SEL NIL NIL) + (replace (SELECTION SET) of SEL with NIL) + + (* ;; "What kind of page are we looking at the specs for?") + + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + (SETQ BUTTON (CAR NEXTB)) + (SELECTQ (IMAGEOBJPROP (CAR NEXTB) + 'STATE) + (|First(&Default)| + (SETQ PAGEID 'FIRST)) + (Other% Left (SETQ PAGEID 'LEFT)) + (Other% Right (SETQ PAGEID 'RIGHT)) + (PROGN (TEDIT.PROMPTPRINT MAINTEXT "First specify which kind of page you want to see." + T) + (SETQ PAGEID NIL))) + + (* ;; "Now mark the menu for NO SCREEN UPDATES during the button-setting process.") + + (AND PAGEID (WITHOUT-UPDATES TEXTOBJ SCRATCHSEL (replace (TEXTOBJ TXTDON'TUPDATE) + of TEXTOBJ with T) + + (* ;; "Now replace the button values, fill-in fields, etc.") + + (SETQ OPAGEFRAMES (OR (fetch (TEXTOBJ TXTPAGEFRAMES) of + MAINTEXT + ) + TEDIT.PAGE.FRAMES)) + [COND + ((LISTP OPAGEFRAMES) (* ; + "No problem, this is already just a list of first-recto-verso frames") + ) + (T (* ; + "This is probably a parsed-up version of the thing. Fix it to a list.") + (COND + [(EQ (fetch (PAGEREGION REGIONFILLMETHOD) of + OPAGEFRAMES + ) + 'SEQUENCE) + (SETQ FIRST (CAR (fetch (PAGEREGION REGIONSUBBOXES) + of OPAGEFRAMES))) + (SETQ REST (CADR (fetch (PAGEREGION REGIONSUBBOXES) + of OPAGEFRAMES))) + (COND + [(EQ (fetch (PAGEREGION REGIONFILLMETHOD) of + REST) + 'ALTERNATE) + (SETQ OPAGEFRAMES (CONS FIRST (fetch (PAGEREGION + REGIONSUBBOXES) + of REST] + (T (SETQ OPAGEFRAMES NIL] + (T (SETQ OPAGEFRAMES NIL] + (COND + ((NOT OPAGEFRAMES) (* ; + "If the formatting isn't in our simplified 3-way format, punt out of this.") + (TEDIT.PROMPTPRINT MAINTEXT "Format too complex to edit." T) + (SETQ PAGEID NIL))) + (SELECTQ PAGEID + (FIRST (SETQ NEWLOOKS (CAR OPAGEFRAMES))) + (LEFT (SETQ NEWLOOKS (CADR OPAGEFRAMES)) + (SETQ PAPERSIZE (LISTGET [CAR (FLAST ( + TEDIT.UNPARSE.PAGEFORMAT + (CAR OPAGEFRAMES) + 'PICAS] + 'PAPERSIZE))) + (RIGHT (SETQ NEWLOOKS (CADDR OPAGEFRAMES)) + (SETQ PAPERSIZE (LISTGET [CAR (FLAST ( + TEDIT.UNPARSE.PAGEFORMAT + (CAR OPAGEFRAMES) + 'PICAS] + 'PAPERSIZE))) + NIL) + (COND + (PAGEID (SETQ NEWLOOKS (TEDIT.UNPARSE.PAGEFORMAT NEWLOOKS + 'PICAS)) + (SETQ PAGEPROPS (CAR (FLAST NEWLOOKS))) + [COND + ((EQ PAGEID 'FIRST) + (SETQ PAPERSIZE (LISTGET PAGEPROPS 'PAPERSIZE] + (SETQ CH# (ADD1 (CDR NEXTB))) + (* ; + "Move past the kind-of-page button") + (SETQ STARTINGPAGE# (LISTGET PAGEPROPS 'STARTINGPAGE#)) + (* ; + "Grab a potential starting page number.") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ CH# STARTINGPAGE#) + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + (SETQ CH# (ADD1 (CDR NEXTB))) + (IMAGEOBJPROP (CAR NEXTB) + 'STATE + (OR PAPERSIZE 'Letter)) + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + (SETQ CH# (ADD1 (CDR NEXTB))) + [IMAGEOBJPROP (CAR NEXTB) + 'STATE + (COND + ((LISTGET PAGEPROPS 'LANDSCAPE?) + 'ON) + (T 'OFF] (* ; + "Tell whether the page is to be landscape or not.") + (SETQ FOLIOINFO (LISTGET PAGEPROPS 'FOLIOINFO)) + (* ; "Page number fomratting info") + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + (SETQ CH# (ADD1 (CDR NEXTB))) + [IMAGEOBJPROP (CAR NEXTB) + 'STATE + (COND + ((pop NEWLOOKS) + 'Yes) + (T 'No] + (SETQ BUTTON (CAR NEXTB)) + (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (CDR NEXTB)) + (pop NEWLOOKS)) + (* ; "Page # X location") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) + (pop NEWLOOKS)) + (* ; "Page # Y location") + (SETQ PFONT (pop NEWLOOKS)) + (* ; "Skip the font info for now.") + [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON + TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of + SCRATCHSEL + ] + (SETQ CH# (ADD1 (CDR NEXTB))) + (SETQ BUTTON (CAR NEXTB)) + (IMAGEOBJPROP BUTTON 'STATE (SELECTQ (pop FOLIOINFO) + (ARABIC 123) + (LOWERROMAN 'xiv) + (UPPERROMAN 'XIV) + 123)) + (* ; "The format for the page number") + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + (SETQ CH# (ADD1 (CDR NEXTB))) + (SETQ BUTTON (CAR NEXTB)) + (* ; "How to align the page number") + (IMAGEOBJPROP BUTTON 'STATE (SELECTQ (pop NEWLOOKS) + (LEFT 'Left) + (RIGHT 'Right) + (CENTERED 'Centered) + 'Centered)) + (MBUTTON.SET.NEXT.FIELD TEXTOBJ CH# (pop FOLIOINFO)) + (* ; + "The text to surround the page number") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) + (pop FOLIOINFO)) + (MBUTTON.SET.NEXT.FIELD TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) + (pop NEWLOOKS)) + (* ; "Left Margin") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) + (pop NEWLOOKS)) + (* ; "Right Margin") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) + (pop NEWLOOKS)) + (* ; "Top margin") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) + (pop NEWLOOKS)) + (* ; "Bottom Margin") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) + (pop NEWLOOKS)) + (* ; "# of columns") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) + (pop NEWLOOKS)) + (* ; "Column width") + (MBUTTON.SET.NEXT.FIELD TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) + (pop NEWLOOKS)) + (* ; "Intercolumn spacing") + (SETQ HEADINGS (pop NEWLOOKS)) + (for HEADING# from 1 to 8 + do + + (* ;; + "Insert info about up to 8 headings (the # of spots in the menu)") + + (SETQ HEADING (pop HEADINGS)) + (MBUTTON.SET.NEXT.FIELD + TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL) + ) + (pop HEADING)) + (MBUTTON.SET.NEXT.FIELD + TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL) + ) + (pop HEADING)) + (MBUTTON.SET.NEXT.FIELD + TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL) + ) + (pop HEADING))) + (COND + (HEADINGS + + (* ;; + "There were headings left over, so warn user.") + + (PROMPTPRINT "WARNING: This document has more kinds of page heading than the menu has room for. Some will be lost if you APPLY this menu." + ))) + (\TEDIT.FILL.IN.CHARLOOKS.MENU TEXTOBJ + (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) + (OR PFONT TEDIT.DEFAULT.FOLIO.LOOKS)) + (* ; + "The font for the page numbers to appear in.") + ]) + +(\TEDITPAGEMENU.CREATE + [LAMBDA NIL (* gbn " 8-Oct-84 18:25") + (* Creates the TEdit Expanded Menu) + (SETQ TEDIT.EXPANDED.PAGEMENU (\TEXTMENU.DOC.CREATE (APPEND TEDIT.PAGEMENU.SPEC + TEDIT.MENUDIVIDER.SPEC + [LIST (create MB.TEXT + MBSTRING _ + "Character Looks for Page Numbers: " + MBFONT _ + (FONTCREATE 'HELVETICA 10 + 'BOLD] + TEDIT.CHARLOOKSMENU.SPEC]) + +(\TEDIT.APPLY.PAGEFORMATTING + [LAMBDA (OBJ SEL W) (* ; + "Edited 4-Jun-93 12:04 by sybalsky:mv:envos") + +(* ;;; "Change the page formatting for this document") + + (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) + (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) + 'TEXTOBJ)) + (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) + SCRATCHSEL NEXTB BUTTON OPAGEFRAMES PAGEID PX PY LEFT BOTTOM TOP RIGHT ALIGNMENT PAGENOS + COLS COLWIDTH INTERCOL PFONT NPAGEFORMAT HEADINGTYPE HEADINGX HEADINGY HEADINGS + HEADINGINVALID STARTINGPAGE# FOLIOFORMAT FOLIOPRETEXT FOLIOPOSTTEXT PAGEOPTIONS + NFPAGEFORMAT PAPERSIZE LANDSCAPE?) + (SETQ SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#] + (* ; "Skip the SHOW button.") + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + (SETQ CH# (ADD1 (CDR NEXTB))) + (SELECTQ (IMAGEOBJPROP (CAR NEXTB) + 'STATE) + (|First(&Default)| + (SETQ PAGEID 'FIRST)) + (Other% Left (SETQ PAGEID 'LEFT)) + (Other% Right (SETQ PAGEID 'RIGHT)) + (PROGN (TEDIT.PROMPTPRINT MAINTEXT "Set KIND OF PAGE before APPLYing." T) + (RETURN))) (* ; "Find which page, for later.") + (SETQ STARTINGPAGE# (AND (EQ PAGEID 'FIRST) + (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ CH#))) + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + (SETQ CH# (ADD1 (CDR NEXTB))) + (SETQ PAPERSIZE (OR (IMAGEOBJPROP (CAR NEXTB) + 'STATE) + 'Letter)) (* ; + "Get the size of paper this is to be formatted for") + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + (SETQ CH# (ADD1 (CDR NEXTB))) + (SETQ LANDSCAPE? (EQ (IMAGEOBJPROP (CAR NEXTB) + 'STATE) + 'ON)) (* ; + "Decide if this kind of page is to be printed landscape....") + (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) + (SETQ CH# (ADD1 (CDR NEXTB))) + (SELECTQ (IMAGEOBJPROP (CAR NEXTB) + 'STATE) + (No (SETQ PAGENOS NIL)) + (Yes (SETQ PAGENOS T)) + NIL) (* ; "Find about page numbers") + (SETQ PX (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ CH#)) + [SETQ PY (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + [COND + (PAGENOS (* ; + "If he wants page numbers, make sure he said WHERE to put them.") + (COND + ((AND PX PY)) + (T (TEDIT.PROMPTPRINT MAINTEXT + "Please set the X and Y location for page numbers before APPLYing." + T) + (TEDIT.PROMPTFLASH MAINTEXT) + (RETURN] + [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + (* ; + "Get to the numbering-format button") + (SETQ BUTTON (CAR NEXTB)) + (SETQ FOLIOFORMAT (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) + (123 (* ; "arabic numbers") + 'ARABIC) + (xiv (* ; "lower-case roman numerals") + 'LOWERROMAN) + (XIV (* ; "Upper-case roman numerals") + 'UPPERROMAN) + 'ARABIC)) + [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] + (* ; + "Get to the number alignment button") + (SETQ BUTTON (CAR NEXTB)) + [SETQ ALIGNMENT (U-CASE (IMAGEOBJPROP BUTTON 'STATE] + (* ; "PX PY PFONT ALIGNMENT") + (* ; + "Margins: LEFT, RIGHT, TOP, BOTTOM") + (SETQ CH# (ADD1 (CDR NEXTB))) + (SETQ FOLIOPRETEXT (MBUTTON.NEXT.FIELD.AS.TEXT TEXTOBJ CH#)) + [SETQ FOLIOPOSTTEXT (MBUTTON.NEXT.FIELD.AS.TEXT TEXTOBJ (ADD1 (fetch (SELECTION + CH#) + of SCRATCHSEL] + +(* ;;; "Now get the margins on the paper") + + [SETQ LEFT (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + [SETQ RIGHT (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + [SETQ TOP (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + [SETQ BOTTOM (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + (COND + [(SETQ COLS (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + (T (TEDIT.PROMPTPRINT MAINTEXT "Please specify how many columns there should be." T) + (TEDIT.PROMPTFLASH MAINTEXT))) + [SETQ COLWIDTH (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + [SETQ INTERCOL (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + (* ; "Col count, width, spacing") + (SETQ HEADINGS (for HEADING# from 1 to 8 + when (PROG1 [SETQ HEADINGTYPE (MBUTTON.NEXT.FIELD.AS.ATOM + TEXTOBJ + (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + [SETQ HEADINGX (MBUTTON.NEXT.FIELD.AS.NUMBER + TEXTOBJ + (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + [SETQ HEADINGY (MBUTTON.NEXT.FIELD.AS.NUMBER + TEXTOBJ + (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL]) + collect (COND + ((AND HEADINGX HEADINGY)) + (T (TEDIT.PROMPTPRINT MAINTEXT (CONCAT + "You need to say WHERE " + HEADINGTYPE + " headings go.") + T) + (TEDIT.PROMPTFLASH MAINTEXT) + (SETQ HEADINGINVALID T))) + (LIST HEADINGTYPE HEADINGX HEADINGY))) + (COND + (HEADINGINVALID (* ; "Headings invalid.") + (RETURN))) + [SETQ PFONT (\TEDIT.PARSE.CHARLOOKS.MENU TEXTOBJ (ADD1 (fetch (SELECTION CH#) + of SCRATCHSEL] + +(* ;;; "Glom all the oddball options (starting page, folio format &c) together") + + (SETQ PAGEOPTIONS (AND STARTINGPAGE# (LIST 'STARTINGPAGE# STARTINGPAGE#))) + (push PAGEOPTIONS (LIST FOLIOFORMAT FOLIOPRETEXT FOLIOPOSTTEXT)) + (push PAGEOPTIONS 'FOLIOINFO) + [COND + (LANDSCAPE? (* ; + "The pages are to be printed landscape. Remember that fact.") + (push PAGEOPTIONS T) + (push PAGEOPTIONS 'LANDSCAPE?] + (SETQ NPAGEFORMAT (TEDIT.SINGLE.PAGEFORMAT PAGENOS PX PY PFONT (AND (NEQ ALIGNMENT + 'OFF) + ALIGNMENT) + LEFT RIGHT TOP BOTTOM COLS COLWIDTH INTERCOL HEADINGS 'PICAS + PAGEOPTIONS PAPERSIZE)) + (SETQ OPAGEFRAMES (fetch (TEXTOBJ TXTPAGEFRAMES) of MAINTEXT)) + [COND + ((NOT (LISTP OPAGEFRAMES)) + (COND + ((EQ PAGEID 'FIRST) (* ; + "Setting the first page sets them all") + (SETQ PAGEOPTIONS (COPY PAGEOPTIONS)) + (LISTPUT PAGEOPTIONS 'STARTINGPAGE# NIL) (* ; + "Starting page nubmer makes no sense on other than first pages.") + (SETQ NFPAGEFORMAT (TEDIT.SINGLE.PAGEFORMAT PAGENOS PX PY PFONT + (AND (NEQ ALIGNMENT 'OFF) + ALIGNMENT) + LEFT RIGHT TOP BOTTOM COLS COLWIDTH INTERCOL HEADINGS + 'PICAS PAGEOPTIONS PAPERSIZE)) + (SETQ OPAGEFRAMES (LIST NPAGEFORMAT NFPAGEFORMAT NFPAGEFORMAT))) + (T (* ; + "Otherwise, start from the default page layout") + (SETQ OPAGEFRAMES (COPY TEDIT.PAGE.FRAMES] + (SELECTQ PAGEID + (FIRST (RPLACA OPAGEFRAMES NPAGEFORMAT)) + (LEFT (RPLACA (CDR OPAGEFRAMES) + NPAGEFORMAT)) + (RIGHT (RPLACA (CDDR OPAGEFRAMES) + NPAGEFORMAT)) + NIL) + (TEDIT.PAGEFORMAT MAINTEXT OPAGEFRAMES) + (replace (TEXTOBJ \DIRTY) of MAINTEXT with T) + (* ; + "Mark the document as having changed.") + (TTY.PROCESS (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) + 'PROCESS]) + +(TEDIT.UNPARSE.PAGEFORMAT + [LAMBDA (PAGEREGION UNITS) (* ; "Edited 12-Jun-90 18:59 by mitani") + +(* ;;; "Take a page layout and unparse it into a PList of specs.") + + (LET* ((PAPER (fetch (PAGEREGION REGIONSPEC) of PAGEREGION)) + (PAPERWIDTH (fetch (REGION WIDTH) of PAPER)) + (PAPERHEIGHT (fetch (REGION HEIGHT) of PAPER)) + (REGIONS (fetch (PAGEREGION REGIONSUBBOXES) of PAGEREGION)) + PX PY PFONT PQUAD PINFO LEFT RIGHT TOP BOTTOM (COLS 0) + COLWIDTH + (INTERCOL 0) + SPECS PAGENOS (OLDRIGHT NIL) + SCALEFACTOR HEADINGS) + [for REGION in REGIONS + do + + (* ;; + "Run thru the regions on the page, calculating information about the page as a whole.") + + (COND + ((EQ (fetch (PAGEREGION REGIONFILLMETHOD) of REGION) + 'FOLIO) (* ; + "A page-number (%"Folio%") region") + (SETQ PAGENOS T) + (SETQ PX (fetch (REGION LEFT) of (fetch REGIONSPEC of REGION)) + ) + (SETQ PY (fetch (REGION BOTTOM) of (fetch REGIONSPEC of REGION + ))) + (SETQ SPECS (fetch REGIONLOCALINFO of REGION)) + (SETQ PFONT (LISTGET SPECS 'CHARLOOKS)) + [SETQ PQUAD (CADR (LISTGET SPECS 'PARALOOKS] + (SELECTQ PQUAD + (LEFT) + (RIGHT (SETQ PX (IPLUS PX 288))) + (CENTERED (SETQ PX (IPLUS PX 144))) + NIL)) + [(EQ (fetch (PAGEREGION REGIONFILLMETHOD) of REGION) + 'HEADING) (* ; "A page-heading region") + (SETQ HEADINGS (NCONC1 HEADINGS (LIST (LISTGET (fetch REGIONLOCALINFO + of REGION) + 'HEADINGTYPE) + (fetch (REGION LEFT) + of (fetch REGIONSPEC + of REGION)) + (fetch (REGION BOTTOM) + of (fetch REGIONSPEC + of REGION] + (T (* ; "A regular-text region.") + (add COLS 1) (* ; "Count columns") + (SETQ COLWIDTH (fetch (REGION WIDTH) of (fetch REGIONSPEC + of REGION))) + [SETQ RIGHT (IDIFFERENCE PAPERWIDTH (ADD1 (fetch (REGION RIGHT) + of (fetch REGIONSPEC + of REGION] + (COND + ((EQ OLDRIGHT T)) + (OLDRIGHT (SETQ INTERCOL (IDIFFERENCE (fetch (REGION LEFT) + of (fetch REGIONSPEC + of REGION)) + OLDRIGHT)) + (SETQ OLDRIGHT T)) + (T (SETQ OLDRIGHT (fetch (REGION RIGHT) of (fetch REGIONSPEC + of REGION))) + (SETQ LEFT (fetch (REGION LEFT) of (fetch REGIONSPEC + of REGION))) + [SETQ TOP (IDIFFERENCE PAPERHEIGHT (fetch (REGION PTOP) + of (fetch REGIONSPEC + of REGION] + (SETQ BOTTOM (fetch (REGION BOTTOM) of (fetch REGIONSPEC + of REGION] + (SELECTQ UNITS + ((POINTS NIL) (* If units are in printers points, + the default, do no scaling) + ) + (PICAS (* The units are in picas--12pts + per. Scale all values.) + (SETQ SCALEFACTOR 0.12)) + (INCHES (* The units are in inches, at + 72.27pts per. Set the scale factor) + (SETQ SCALEFACTOR 0.7227)) + (CM (* Units are in CM, at 72.27/2.54pts + per.) + (SETQ SCALEFACTOR (CONSTANT (FQUOTIENT 0.7227 2.54)))) + (\ILLEGAL.ARG UNITS)) + [COND + (SCALEFACTOR (* We need to do the scaling.) + (AND PX (SETQ PX (FQUOTIENT (FIXR (FQUOTIENT PX SCALEFACTOR)) + 100))) + (AND PY (SETQ PY (FQUOTIENT (FIXR (FQUOTIENT PY SCALEFACTOR)) + 100))) + (AND LEFT (SETQ LEFT (FQUOTIENT (FIXR (FQUOTIENT LEFT SCALEFACTOR)) + 100))) + (AND RIGHT (SETQ RIGHT (FQUOTIENT (FIXR (FQUOTIENT RIGHT SCALEFACTOR)) + 100))) + (AND TOP (SETQ TOP (FQUOTIENT (FIXR (FQUOTIENT TOP SCALEFACTOR)) + 100))) + (AND BOTTOM (SETQ BOTTOM (FQUOTIENT (FIXR (FQUOTIENT BOTTOM SCALEFACTOR)) + 100))) + (AND COLWIDTH (SETQ COLWIDTH (FQUOTIENT (FIXR (FQUOTIENT COLWIDTH SCALEFACTOR)) + 100))) + (AND INTERCOL (SETQ INTERCOL (FQUOTIENT (FIXR (FQUOTIENT INTERCOL SCALEFACTOR)) + 100))) + (SETQ HEADINGS (for HDG in HEADINGS + collect (LIST (CAR HDG) + (FQUOTIENT (FIXR (FQUOTIENT (CADR HDG) + SCALEFACTOR)) + 100) + (FQUOTIENT (FIXR (FQUOTIENT (CADDR HDG) + SCALEFACTOR)) + 100] + (LIST PAGENOS PX PY PFONT PQUAD LEFT RIGHT TOP BOTTOM COLS COLWIDTH INTERCOL HEADINGS + (fetch (PAGEREGION REGIONLOCALINFO) of PAGEREGION]) +) + + + +(* ; "Initialization Code") + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS TEDIT.EXPANDED.MENU TEDIT.EXPANDEDPARA.MENU TEDIT.CHARLOOKS.MENU TEDIT.MENUDIVIDER.SPEC + TEDIT.EXPANDEDMENU.SPEC TEDIT.CHARLOOKSMENU.SPEC TEDIT.PARAMENU.SPEC TEDIT.PAGEMENU.SPEC + TEDIT.EXPANDED.PAGEMENU) +) +(DEFINEQ + +(\TEDIT.MENU.INIT + [LAMBDA NIL (* ; "Edited 30-Mar-94 15:53 by jds") + +(* ;;; "Initialize the descriptions for all TEdit menus") + +(* ;;; "Divides between the main page layout menu and page-# font submenu") + + (SETQ TEDIT.MENUDIVIDER.SPEC (LIST (create MB.TEXT + MBSTRING _ " + +"))) + +(* ;;; "The principal expanded menu") + + (SETQ TEDIT.EXPANDEDMENU.SPEC (LIST (create MB.BUTTON + MBLABEL _ "Quit") + (create MB.TEXT + MBSTRING _ " ") + (create MB.BUTTON + MBLABEL _ "Page Layout") + (create MB.TEXT + MBSTRING _ " ") + (create MB.BUTTON + MBLABEL _ "Char Looks") + (create MB.TEXT + MBSTRING _ " ") + (create MB.BUTTON + MBLABEL _ "Para Looks") + (create MB.TEXT + MBSTRING _ " ") + (create MB.BUTTON + MBLABEL _ "All") + (create MB.TEXT + MBSTRING _ " ") + (create MB.TOGGLE + MBTEXT _ "Unformatted" + MBCHANGESTATEFN _ (FUNCTION + \TEDITMENU.RECORD.UNFORMATTED)) + (create MB.TEXT + MBSTRING _ " +") + (create MB.BUTTON + MBLABEL _ "Get") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " ") + (create MB.BUTTON + MBLABEL _ "Put") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " ") + (create MB.BUTTON + MBLABEL _ "Include") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " +") + (create MB.BUTTON + MBLABEL _ "Find") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " ") + (create MB.BUTTON + MBLABEL _ "Substitute") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " for") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " ") + (create MB.TOGGLE + MBTEXT _ "Confirm") + (create MB.TEXT + MBSTRING _ " ") + (create MB.TOGGLE + MBTEXT _ "Use New Looks") + (create MB.TEXT + MBSTRING _ " +") + (create MB.BUTTON + MBLABEL _ "Hardcopy") + (create MB.TEXT + MBSTRING _ " server:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " copies:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " +") + (create MB.TEXT + MBSTRING _ "Print ") + (create MB.NWAY + MBBUTTONS _ '(One% Side Duplex) + MBMAXITEMSPERLINE _ 5) + (create MB.TEXT + MBSTRING _ " Message/Phone#:") + (create MB.INSERT))) + +(* ;;; "The character-looks (font, etc.) menu") + + (SETQ TEDIT.CHARLOOKSMENU.SPEC (LIST (create MB.TEXT + MBSTRING _ "Props: " + MBFONT _ (FONTCREATE 'HELVETICA 8)) + (create MB.3STATE + MBLABEL _ 'Bold) + (create MB.TEXT + MBSTRING _ " ") + (create MB.3STATE + MBLABEL _ 'Italic) + (create MB.TEXT + MBSTRING _ " ") + (create MB.3STATE + MBLABEL _ 'Underline) + (create MB.TEXT + MBSTRING _ " ") + (create MB.3STATE + MBLABEL _ 'StrikeThru) + (create MB.TEXT + MBSTRING _ " ") + (create MB.3STATE + MBLABEL _ 'Overbar) + (create MB.TEXT + MBSTRING _ " +") + (create MB.NWAY + MBBUTTONS _ + '(TimesRoman Helvetica Gacha Modern Classic Terminal + Other) + MBMAXITEMSPERLINE _ 5) + (create MB.TEXT + MBSTRING _ "other font:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " +") + (create MB.TEXT + MBSTRING _ "Size: " + MBFONT _ (FONTCREATE 'HELVETICA 8)) + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " ") + (create MB.NWAY + MBBUTTONS _ '(Normal Superscript Subscript)) + (create MB.TEXT + MBSTRING _ " distance: " + MBFONT _ (FONTCREATE 'HELVETICA 8)) + (create MB.INSERT))) + +(* ;;; "The paragraph-formatting menu (margins, etc.)") + + (SETQ TEDIT.PARAMENU.SPEC (LIST (create MB.BUTTON + MBLABEL _ 'APPLY + MBBUTTONEVENTFN _ (FUNCTION \TEDIT.APPLY.PARALOOKS)) + (create MB.TEXT + MBSTRING _ " ") + (create MB.BUTTON + MBLABEL _ 'SHOW + MBBUTTONEVENTFN _ (FUNCTION \TEDIT.SHOW.PARALOOKS)) + (create MB.TEXT + MBSTRING _ " ") + (create MB.BUTTON + MBLABEL _ 'NEUTRAL + MBBUTTONEVENTFN _ (FUNCTION + \TEDIT.NEUTRALIZE.PARALOOKS.MENU)) + (create MB.TEXT + MBSTRING _ " +") + (create MB.NWAY + MBBUTTONS _ '(Left Right Centered Justified)) + (create MB.TEXT + MBSTRING _ " ") + (create MB.3STATE + MBLABEL _ "Page Heading") + (create MB.TEXT + MBSTRING _ " type:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " +Line leading:" + MBFONT _ (FONTCREATE 'HELVETICA 8)) + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ "pts Para Leading:" + MBFONT _ (FONTCREATE 'HELVETICA 8)) + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ "pts Special Locn: X" + MBFONT _ (FONTCREATE 'HELVETICA 8)) + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ "picas, Y" + MBFONT _ (FONTCREATE 'HELVETICA 8)) + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ "picas +New Page: " + MBFONT _ (FONTCREATE 'HELVETICA 8)) + (create MB.3STATE + MBLABEL _ "Before") + (create MB.TEXT + MBSTRING _ " ") + (create MB.3STATE + MBLABEL _ "After") + (create MB.TEXT + MBSTRING _ " Display mode: " + MBFONT _ (FONTCREATE 'HELVETICA 8)) + (create MB.3STATE + MBLABEL _ "Hardcopy") + (create MB.TEXT + MBSTRING _ " Keep: " + MBFONT _ (FONTCREATE 'HELVETICA 8)) + (create MB.3STATE + MBLABEL _ "Heading") + (create MB.TEXT + MBSTRING _ " +Tab Type: " + MBFONT _ (FONTCREATE 'HELVETICA 8)) + [create MB.NWAY + MBBUTTONS _ '((Left \TEDIT.TABTYPE.SET) + (Right \TEDIT.TABTYPE.SET) + (Centered \TEDIT.TABTYPE.SET) + (Decimal \TEDIT.TABTYPE.SET] + (create MB.TEXT + MBSTRING _ " ") + (create MB.TOGGLE + MBTEXT _ "Dotted Leader" + MBCHANGESTATEFN _ (FUNCTION \TEDIT.RECORD.TABLEADERS)) + (create MB.TEXT + MBSTRING _ " Default Tab Size:" + MBFONT _ (FONTCREATE 'HELVETICA 8)) + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " +") + (create MB.MARGINBAR) + (create MB.TEXT + MBSTRING _ " +"))) + +(* ;;; "Page-layout menu for columns, page headings, page numbers, etc.") + + (SETQ TEDIT.PAGEMENU.SPEC (APPEND (LIST (create MB.BUTTON + MBLABEL _ 'APPLY + MBBUTTONEVENTFN _ '\TEDIT.APPLY.PAGEFORMATTING) + (create MB.TEXT + MBSTRING _ " " + MBFONT _ (FONTCREATE 'HELVETICA 8 'BOLD)) + (create MB.BUTTON + MBLABEL _ 'SHOW + MBBUTTONEVENTFN _ '\TEDIT.SHOW.PAGEFORMATTING) + (create MB.TEXT + MBSTRING _ " +") + (create MB.TEXT + MBSTRING _ "For page: ") + (create MB.NWAY + MBBUTTONS _ '(|First(&Default)| Other% Left + Other% Right)) + (create MB.TEXT + MBSTRING _ " + Starting Page #: ") + (create MB.INSERT + MBINITENTRY _ 1) + (create MB.TEXT + MBSTRING _ " Paper Size: ") + (create MB.NWAY + MBBUTTONS _ '(Letter Legal A4) + MBINITSTATE _ 'Letter) + (create MB.TEXT + MBSTRING _ " ") + (create MB.TOGGLE + MBTEXT _ "Landscape") + (create MB.TEXT + MBSTRING _ " + +") + (create MB.TEXT + MBSTRING _ "Page numbers: ") + (create MB.TEXT + MBSTRING _ " " + MBFONT _ (FONTCREATE 'HELVETICA 8 'BOLD)) + (create MB.NWAY + MBBUTTONS _ '(No Yes) + MBINITSTATE _ 'Yes) + (create MB.TEXT + MBSTRING _ " ") + (create MB.TEXT + MBSTRING _ "X: ") + (create MB.INSERT + MBINITENTRY _ 25.5) + (create MB.TEXT + MBSTRING _ " ") + (create MB.TEXT + MBSTRING _ "Y: ") + (create MB.INSERT + MBINITENTRY _ 3) + (create MB.TEXT + MBSTRING _ " Format: ") + (create MB.NWAY + MBBUTTONS _ '(123 xiv XIV) + MBINITSTATE _ '123) + (create MB.TEXT + MBSTRING _ " + ") + (create MB.TEXT + MBSTRING _ "Alignment: ") + (create MB.NWAY + MBBUTTONS _ '(Left Centered Right) + MBINITSTATE _ 'Centered) + (create MB.TEXT + MBSTRING _ " +") + (create MB.TEXT + MBSTRING _ " Text before number: ") + (create MB.INSERT + MBINITENTRY _ "") + (create MB.TEXT + MBSTRING _ " Text after number: ") + (create MB.INSERT + MBINITENTRY _ "") + (create MB.TEXT + MBSTRING _ " +")) + (LIST (create MB.TEXT + MBSTRING _ "Margins: Left") + (create MB.INSERT + MBINITENTRY _ 6) + (create MB.TEXT + MBSTRING _ " Right") + (create MB.INSERT + MBINITENTRY _ 6) + (create MB.TEXT + MBSTRING _ " Top") + (create MB.INSERT + MBINITENTRY _ 6) + (create MB.TEXT + MBSTRING _ " Bottom") + (create MB.INSERT + MBINITENTRY _ 6) + (create MB.TEXT + MBSTRING _ " +") + (create MB.TEXT + MBSTRING _ "Columns: ") + (create MB.INSERT + MBINITENTRY _ 1) + (create MB.TEXT + MBSTRING _ " Col Width: ") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " Space between cols: ") + (create MB.INSERT + MBINITENTRY _ 1) + (create MB.TEXT + MBSTRING _ " +") + (create MB.TEXT + MBSTRING _ "Page Headings:" + MBFONT _ (FONTCREATE 'HELVETICA 10 'BOLD)) + (create MB.TEXT + MBSTRING _ " + Heading Type:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " X:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " Y:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " Heading Type:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " X:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " Y:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " + Heading Type:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " X:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " Y:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " Heading Type:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " X:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " Y:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " + Heading Type:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " X:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " Y:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " Heading Type:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " X:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " Y:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " + Heading Type:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " X:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " Y:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " Heading Type:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " X:") + (create MB.INSERT) + (create MB.TEXT + MBSTRING _ " Y:") + (create MB.INSERT]) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(\TEDIT.MENU.INIT) + +(\TEDITMENU.CREATE) + +(\TEDIT.CHARLOOKSMENU.CREATE) + +(\TEDITPARAMENU.CREATE) + +(\TEDITPAGEMENU.CREATE) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA ) +) +(PUTPROPS TEDITMENU COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 +1991 1992 1993 1994 1995)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (6283 33125 (MB.BUTTONEVENTINFN 6293 . 7624) (MB.DISPLAY 7626 . 9994) (MB.SETIMAGE 9996 + . 10954) (MB.SELFN 10956 . 12371) (MB.SIZEFN 12373 . 13390) (MB.WHENOPERATEDFN 13392 . 13724) ( +MB.COPYFN 13726 . 14188) (MB.GETFN 14190 . 14798) (MB.PUTFN 14800 . 15577) (MB.SHOWSELFN 15579 . 16551 +) (MBUTTON.CREATE 16553 . 17837) (MBUTTON.CHANGENAME 17839 . 18234) (MBUTTON.FIND.BUTTON 18236 . 19252 +) (MBUTTON.FIND.NEXT.BUTTON 19254 . 20649) (MBUTTON.FIND.NEXT.FIELD 20651 . 24365) (MBUTTON.INIT 24367 + . 25157) (MBUTTON.NEXT.FIELD.AS.NUMBER 25159 . 25512) (MBUTTON.NEXT.FIELD.AS.PIECES 25514 . 25944) ( +MBUTTON.NEXT.FIELD.AS.TEXT 25946 . 26368) (MBUTTON.NEXT.FIELD.AS.ATOM 26370 . 27243) ( +MBUTTON.SET.FIELD 27245 . 29301) (MBUTTON.SET.NEXT.FIELD 29303 . 30520) (MBUTTON.SET.NEXT.BUTTON.STATE + 30522 . 31018) (TEDITMENU.STREAM 31020 . 31629) (\TEDITMENU.SELSCREENER 31631 . 33123)) (33429 43852 +(MB.CREATE.THREESTATEBUTTON 33439 . 34610) (MB.THREESTATE.DISPLAY 34612 . 37202) ( +MB.THREESTATE.SHOWSELFN 37204 . 40306) (MB.THREESTATE.WHENOPERATEDFN 40308 . 41687) ( +MB.THREESTATEBUTTON.FN 41689 . 42786) (THREESTATE.INIT 42788 . 43850)) (43953 63189 ( +MB.CREATE.NWAYBUTTON 43963 . 47931) (MB.NB.DISPLAYFN 47933 . 50205) (MB.NB.WHENOPERATEDFN 50207 . +51239) (MB.NB.SIZEFN 51241 . 54780) (MB.NWAYBUTTON.SELFN 54782 . 56726) (MB.NWAYMENU.NEWBUTTON 56728 + . 57314) (NWAYBUTTON.INIT 57316 . 58169) (MB.NB.PACKITEMS 58171 . 60168) (MB.NWAYBUTTON.ADDITEM 60170 + . 63187)) (63443 74091 (\TEXTMENU.TOGGLE.CREATE 63453 . 64854) (\TEXTMENU.TOGGLE.DISPLAY 64856 . +67208) (\TEXTMENU.TOGGLE.SHOWSELFN 67210 . 69572) (\TEXTMENU.TOGGLE.WHENOPERATEDFN 69574 . 70962) ( +\TEXTMENU.TOGGLEFN 70964 . 72044) (\TEXTMENU.TOGGLE.INIT 72046 . 72881) (\TEXTMENU.SET.TOGGLE 72883 . +74089)) (74343 111715 (DRAWMARGINSCALE 74353 . 77897) (MARGINBAR 77899 . 85269) (MARGINBAR.CREATE +85271 . 88181) (MB.MARGINBAR.SELFN 88183 . 100777) (MB.MARGINBAR.SIZEFN 100779 . 101141) ( +MB.MARGINBAR.DISPLAYFN 101143 . 103828) (MDESCALE 103830 . 104269) (MSCALE 104271 . 104605) ( +MB.MARGINBAR.SHOWTAB 104607 . 106778) (MB.MARGINBAR.TABTRACK 106780 . 108115) (\TEDIT.TABTYPE.SET +108117 . 110824) (MARGINBAR.INIT 110826 . 111713)) (112732 130334 (\TEXTMENU.START 112742 . 115934) ( +\TEXTMENU.DOC.CREATE 115936 . 127460) (TEXTMENU.CLOSEFN 127462 . 130332)) (130644 150708 ( +\TEDITMENU.CREATE 130654 . 130954) (\TEDIT.EXPANDED.MENU 130956 . 131660) (MB.DEFAULTBUTTON.FN 131662 + . 134534) (\TEDITMENU.RECORD.UNFORMATTED 134536 . 134874) (MB.DEFAULTBUTTON.ACTIONFN 134876 . 150706) +) (150709 178092 (\TEDIT.CHARLOOKSMENU.CREATE 150719 . 152859) (\TEDIT.EXPANDEDCHARLOOKS.MENU 152861 + . 153235) (\TEDIT.APPLY.BOLDNESS 153237 . 153522) (\TEDIT.APPLY.CHARLOOKS 153524 . 155455) ( +\TEDIT.APPLY.OLINE 155457 . 155738) (\TEDIT.SHOW.CHARLOOKS 155740 . 157653) ( +\TEDIT.NEUTRALIZE.CHARLOOKS 157655 . 158581) (\TEDIT.FILL.IN.CHARLOOKS.MENU 158583 . 166236) ( +\TEDIT.NEUTRALIZE.CHARLOOKS.MENU 166238 . 169121) (\TEDIT.PARSE.CHARLOOKS.MENU 169123 . 177231) ( +\TEDIT.APPLY.SLOPE 177233 . 177516) (\TEDIT.APPLY.STRIKEOUT 177518 . 177805) (\TEDIT.APPLY.ULINE +177807 . 178090)) (178093 210159 (\TEDITPARAMENU.CREATE 178103 . 178483) (\TEDIT.EXPANDEDPARA.MENU +178485 . 178805) (\TEDIT.APPLY.PARALOOKS 178807 . 191037) (\TEDIT.SHOW.PARALOOKS 191039 . 202566) ( +\TEDIT.NEUTRALIZE.PARALOOKS.MENU 202568 . 208639) (\TEDIT.RECORD.TABLEADERS 208641 . 210157)) (210160 +248162 (\TEDIT.SHOW.PAGEFORMATTING 210170 . 226710) (\TEDITPAGEMENU.CREATE 226712 . 227755) ( +\TEDIT.APPLY.PAGEFORMATTING 227757 . 240128) (TEDIT.UNPARSE.PAGEFORMAT 240130 . 248160)) (248467 +275206 (\TEDIT.MENU.INIT 248477 . 275204))))) +STOP diff --git a/library/TEDITPAGE b/library/TEDITPAGE new file mode 100644 index 00000000..d4ec0ec2 --- /dev/null +++ b/library/TEDITPAGE @@ -0,0 +1,1839 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "25-Aug-94 10:55:28" {DSK}export>lispcore>library>TEDITPAGE.;3 123769 + + changes to%: (VARS TEDITPAGECOMS) (FILES TEDITDCL) + + previous date%: " 4-Jul-93 00:42:12" {DSK}export>lispcore>library>TEDITPAGE.;2) + + +(* ; " +Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT TEDITPAGECOMS) + +(RPAQQ TEDITPAGECOMS ((FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (COMS (* ;; "Page-numbering font specification/default") (* ;; "(Must come before calls to TEDIT.SINGLE.PAGEFORMAT below.)") (GLOBALVARS TEDIT.DEFAULT.FOLIO.LOOKS) (INITVARS (TEDIT.DEFAULT.FOLIO.LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST (QUOTE (FAMILY MODERN SIZE 10 WEIGHT MEDIUM SLOPE REGULAR))))) (* ;; "If non-nil, TEdit appends the start & end fileptrs for pages here.") (INITVARS (*TEDIT-PAGE-BREAKS* NIL))) (VARS (MAXPAGE# 65535) (MINPAGE# 1) (TEDIT.PAGE.FRAMES (LIST (TEDIT.SINGLE.PAGEFORMAT NIL NIL NIL NIL NIL 72 72 72 72 NIL 1) (TEDIT.SINGLE.PAGEFORMAT T 72 756 NIL (QUOTE LEFT) 72 72 72 72 NIL 1) (TEDIT.SINGLE.PAGEFORMAT T 540 756 NIL (QUOTE RIGHT) 72 72 72 72 NIL 1)))) (COMS (* ;; "Creation, GET, and PUT of page frames.") (FNS TEDIT.GET.PAGEFRAMES TEDIT.PARSE.PAGEFRAMES TEDIT.PUT.PAGEFRAMES TEDIT.UNPARSE.PAGEFRAMES)) (COMS (* ;; "For setting up page layouts") (FNS TEDIT.SINGLE.PAGEFORMAT TEDIT.COMPOUND.PAGEFORMAT TEDIT.PAGEFORMAT)) (COMS (* ;; "Perform page layout, based on a regular expression of typed regions.") (FNS TEDIT.FORMAT.HARDCOPY TEDIT.FORMATBOX TEDIT.FORMATHEADING TEDIT.FORMATPAGE TEDIT.FORMATTEXTBOX TEDIT.FORMATFOLIO \TEDIT.FORMAT.FOUNDBOX? TEDIT.SKIP.SPECIALCOND) (* ;; "Aux function to capture page headings during line formatting:") (FNS TEDIT.HARDCOPY.PAGEHEADING) (* ;; " Aux function to handle end-of-column processing (paragraph keep, widow elimination, etc):") (FNS TEDIT.HARDCOPY-COLUMN-END)) (COMS (* ;; "Handle varying paper sizes") (FNS SCALEPAGEUNITS SCALEPAGEXUNITS SCALEPAGEYUNITS \TEDIT.PAPERHEIGHT \TEDIT.PAPERWIDTH) (GLOBALVARS TEDIT.PAPER.SIZES) (VARS (TEDIT.PAPER.SIZES (QUOTE ((A0 2384 3370) (A1 1684 2384) (A2 1191 1684) (A3 842 1191) (A4 595 842) (A5 420 595) (B0 2835 4008) (B1 2004 2835) (B2 1417 2004) (B3 1001 1417) (B4 709 1001) (B5 499 709)))))) (COMS (* ; "Page numbering option support") (FNS ROMANNUMERALS)) (COMS (* ;; "Foot note support") (FNS \TEDIT.FORMAT.FOOTNOTE))) +) + +(FILESLOAD TEDITDCL) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ \SCRATCHLEN 64) + + +(CONSTANTS (\SCRATCHLEN 64)) +) + + +(FILESLOAD (LOADCOMP) TEDITDCL) +) + + + +(* ;; "Page-numbering font specification/default") + + + + +(* ;; "(Must come before calls to TEDIT.SINGLE.PAGEFORMAT below.)") + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS TEDIT.DEFAULT.FOLIO.LOOKS) +) + +(RPAQ? TEDIT.DEFAULT.FOLIO.LOOKS (\TEDIT.PARSE.CHARLOOKS.LIST (QUOTE (FAMILY MODERN SIZE 10 WEIGHT MEDIUM SLOPE REGULAR))) +) + + + +(* ;; "If non-nil, TEdit appends the start & end fileptrs for pages here.") + + +(RPAQ? *TEDIT-PAGE-BREAKS* NIL) + +(RPAQQ MAXPAGE# 65535) + +(RPAQQ MINPAGE# 1) + +(RPAQ TEDIT.PAGE.FRAMES (LIST (TEDIT.SINGLE.PAGEFORMAT NIL NIL NIL NIL NIL 72 72 72 72 NIL 1) (TEDIT.SINGLE.PAGEFORMAT T 72 756 NIL (QUOTE LEFT) 72 72 72 72 NIL 1) (TEDIT.SINGLE.PAGEFORMAT T 540 756 NIL (QUOTE RIGHT) 72 72 72 72 NIL 1)) +) + + + +(* ;; "Creation, GET, and PUT of page frames.") + +(DEFINEQ + +(TEDIT.GET.PAGEFRAMES + [LAMBDA (FILE) (* jds "18-Jun-84 02:55") + (* Read a bunch of page frames from + the file, and return it.) + (TEDIT.PARSE.PAGEFRAMES (READ FILE]) + +(TEDIT.PARSE.PAGEFRAMES + [LAMBDA (PAGELIST PARENT) (* jds "31-Jul-84 15:30") + (* Take an external pageframe and + internalize it.) + (PROG (FRAMETYPE PAGEFRAME) + (COND + ((type? PAGEREGION PAGELIST) + (RETURN PAGELIST)) + ((NEQ 'LIST (SETQ FRAMETYPE (pop PAGELIST))) + [SETQ PAGEFRAME (create PAGEREGION + REGIONFILLMETHOD _ FRAMETYPE + REGIONTYPE _ (pop PAGELIST) + REGIONLOCALINFO _ (pop PAGELIST) + REGIONSPEC _ (OR (pop PAGELIST) + (LIST 0 0 0 0] + (replace REGIONSUBBOXES of PAGEFRAME with (for ALIST + in (pop PAGELIST) + collect ( + TEDIT.PARSE.PAGEFRAMES + ALIST PAGEFRAME)) + ) + (RETURN PAGEFRAME)) + (T (RETURN (for FRAMESPEC in (CAR PAGELIST) collect ( + TEDIT.PARSE.PAGEFRAMES + FRAMESPEC NIL]) + +(TEDIT.PUT.PAGEFRAMES + [LAMBDA (FILE PAGEFRAMES) (* jds "13-Nov-86 20:10") + (* Put out a description of a set of + page-layout frames) + (PROG (STR) + (\DWOUT FILE 0) (* The length of this run of looks) + (\SMALLPOUT FILE \PieceDescriptorPAGEFRAME) (* Mark this as a set of page frames) + (PRIN2 (TEDIT.UNPARSE.PAGEFRAMES PAGEFRAMES) + FILE *TEDIT-FILE-READTABLE*]) + +(TEDIT.UNPARSE.PAGEFRAMES + [LAMBDA (PAGEFRAME) (* jds "31-Jul-84 15:00") + (* Take an internal page frame, and + create an equivalent list structure.) + (COND + [(LISTP PAGEFRAME) + (LIST 'LIST (for FRAME in PAGEFRAME collect (TEDIT.UNPARSE.PAGEFRAMES FRAME] + (T (LIST (fetch REGIONFILLMETHOD of PAGEFRAME) + (fetch REGIONTYPE of PAGEFRAME) + (fetch REGIONLOCALINFO of PAGEFRAME) + (fetch REGIONSPEC of PAGEFRAME) + (for SUBREGION in (fetch REGIONSUBBOXES of PAGEFRAME) + collect (TEDIT.UNPARSE.PAGEFRAMES SUBREGION]) +) + + + +(* ;; "For setting up page layouts") + +(DEFINEQ + +(TEDIT.SINGLE.PAGEFORMAT + [LAMBDA (PAGE#S? PX PY PFONT PQUAD LEFT RIGHT TOP BOTTOM COLS COLWIDTH INTERCOL HEADINGS UNITS + PAGEPROPS PAPERSIZE) (* ; "Edited 17-Dec-87 14:54 by jds") + + (* ;; "Given a description in the args, create a pageframe to describe a single kind of page.") + + (PROG* ((LANDSCAPE? (LISTGET PAGEPROPS 'LANDSCAPE?)) + (PAPERWIDTH (\TEDIT.PAPERWIDTH PAPERSIZE LANDSCAPE?)) + (PAPERHEIGHT (\TEDIT.PAPERHEIGHT PAPERSIZE LANDSCAPE?)) + [PAGEREGION (create PAGEREGION + REGIONFILLMETHOD _ 'PAGE + REGIONSPEC _ + (create REGION + LEFT _ 0 + BOTTOM _ 0 + WIDTH _ PAPERWIDTH + HEIGHT _ PAPERHEIGHT) + REGIONLOCALINFO _ (CONS 'PAPERSIZE (CONS PAPERSIZE PAGEPROPS] + PAGEWIDTH SUBREGIONS FOLIO FOLIOLEFT SCALEFACTOR HEADINGREGIONS) + (SELECTQ UNITS + ((POINTS NIL) (* ; + "If units are in printers points, the default, do no scaling") + (SETQ SCALEFACTOR 1)) + (PICAS (* ; + "The units are in picas--12pts per. Scale all values.") + (SETQ SCALEFACTOR 12)) + (INCHES (* ; + "The units are in inches, at 72.27pts per. Set the scale factor") + (SETQ SCALEFACTOR 72)) + (MICAS (* ; + "The units are MICAS, at 2540 to the inch.") + (SETQ SCALEFACTOR 0.02834646)) + (CM (* ; + "Units are in CM, at 72.27/2.54pts per.") + (SETQ SCALEFACTOR (CONSTANT (FQUOTIENT 72 2.54)))) + (\ILLEGAL.ARG UNITS)) (* ; "We need to do the scaling.") + (SETQ PX (SCALEPAGEXUNITS PX SCALEFACTOR PAPERSIZE LANDSCAPE?)) + (SETQ PY (SCALEPAGEYUNITS PY SCALEFACTOR PAPERSIZE LANDSCAPE?)) + [AND LEFT (SETQ LEFT (FIXR (FTIMES LEFT SCALEFACTOR] + [AND RIGHT (SETQ RIGHT (FIXR (FTIMES RIGHT SCALEFACTOR] + [AND TOP (SETQ TOP (FIXR (FTIMES TOP SCALEFACTOR] + [AND BOTTOM (SETQ BOTTOM (FIXR (FTIMES BOTTOM SCALEFACTOR] + [AND COLWIDTH (SETQ COLWIDTH (FIXR (FTIMES COLWIDTH SCALEFACTOR] + [AND INTERCOL (SETQ INTERCOL (FIXR (FTIMES INTERCOL SCALEFACTOR] + [SETQ HEADINGS (for HDG in HEADINGS collect (LIST (CAR HDG) + (SCALEPAGEXUNITS + (CADR HDG) + SCALEFACTOR PAPERSIZE + LANDSCAPE?) + (SCALEPAGEYUNITS + (CADDR HDG) + SCALEFACTOR PAPERSIZE + LANDSCAPE?] + (SETQ PAGEWIDTH (IDIFFERENCE (IDIFFERENCE PAPERWIDTH RIGHT) + LEFT)) + (COND + [PAGE#S? (SELECTQ PQUAD + (LEFT (* ; + "If the page number is flush left, set up the region to start where he specified.") + (SETQ FOLIOLEFT PX)) + (RIGHT (* ; + "If it's flush right, set up the region to END there") + (SETQ FOLIOLEFT (IDIFFERENCE PX 288))) + ((CENTERED NIL) (* ; + "Otherwise, center the page number around the point he specifies") + (SETQ FOLIOLEFT (IDIFFERENCE PX 144))) + (SHOULDNT)) + [SETQ SUBREGIONS + (LIST (SETQ FOLIO + (create PAGEREGION + REGIONFILLMETHOD _ 'FOLIO + REGIONSPEC _ + (create REGION + LEFT _ FOLIOLEFT + BOTTOM _ PY + WIDTH _ 288 + HEIGHT _ 36] + (replace REGIONLOCALINFO of FOLIO + with (LIST 'PARALOOKS (LIST 'QUAD (OR PQUAD 'CENTERED)) + 'CHARLOOKS + (\TEDIT.UNPARSE.CHARLOOKS.LIST (\TEDIT.PARSE.CHARLOOKS.LIST + PFONT + TEDIT.DEFAULT.FOLIO.LOOKS)) + 'FORMATINFO + (LISTGET PAGEPROPS 'FOLIOINFO] + (T (SETQ SUBREGIONS NIL))) + [COND + (HEADINGS (* ; + "There are page headings specified for this page.") + [SETQ HEADINGREGIONS (for HEADING in HEADINGS + collect + + (* ;; "Run thru the list of headings, building a box for each. By default, a heading will have the same width right margin as the left margin that was specified.") + + (create PAGEREGION + REGIONFILLMETHOD _ 'HEADING + REGIONSPEC _ + (create REGION + LEFT _ (CADR HEADING) + BOTTOM _ (CADDR HEADING) + WIDTH _ (IMAX (IDIFFERENCE + PAPERWIDTH + (CADR HEADING)) + 72) + HEIGHT _ 36) + REGIONLOCALINFO _ (LIST 'HEADINGTYPE + (CAR HEADING] + (SETQ SUBREGIONS (APPEND SUBREGIONS HEADINGREGIONS] + [COND + [(OR (NULL COLS) + (IEQP COLS 1)) (* ; + "There is a single column, so treat it as just one text region bounded by the page margins.") + (SETQ SUBREGIONS + (NCONC1 SUBREGIONS + (create PAGEREGION + REGIONFILLMETHOD _ 'TEXT + REGIONSPEC _ + (create REGION + LEFT _ LEFT + BOTTOM _ BOTTOM + WIDTH _ PAGEWIDTH + HEIGHT _ (IDIFFERENCE (IDIFFERENCE PAPERHEIGHT TOP) + BOTTOM] + (T (* ; + "There are several columns. We need to create a text box for each col.") + [COND + [(NULL COLWIDTH) (* ; + "He wants us to fill in the column width, given margins and intercolumn spacing.") + (COND + [INTERCOL (SETQ COLWIDTH (FIXR (FQUOTIENT (IDIFFERENCE PAGEWIDTH + (ITIMES INTERCOL + (SUB1 COLS))) + COLS] + (T (* ; "Can't default both of them.") + (SHOULDNT "Can't default both Col width and spacing"] + ((NULL INTERCOL) (* ; + "Or else he wants to give us just the col width and have us calc the spacing.") + (SETQ INTERCOL (FIXR (FQUOTIENT (IDIFFERENCE PAGEWIDTH (ITIMES COLWIDTH COLS)) + (SUB1 COLS] + (for COL from 1 to COLS as CLEFT from LEFT + by (IPLUS COLWIDTH INTERCOL) + do (SETQ SUBREGIONS + (NCONC1 SUBREGIONS + (create PAGEREGION + REGIONFILLMETHOD _ 'TEXT + REGIONSPEC _ + (create REGION + LEFT _ CLEFT + BOTTOM _ BOTTOM + WIDTH _ COLWIDTH + HEIGHT _ (IDIFFERENCE (IDIFFERENCE PAPERHEIGHT TOP) + BOTTOM] + (replace REGIONSUBBOXES of PAGEREGION with SUBREGIONS) + (RETURN PAGEREGION]) + +(TEDIT.COMPOUND.PAGEFORMAT + [LAMBDA (FIRST VERSO RECTO) (* jds "27-Jul-84 10:15") + (create PAGEREGION + REGIONFILLMETHOD _ 'SEQUENCE + REGIONSUBBOXES _ (LIST FIRST (create PAGEREGION + REGIONFILLMETHOD _ 'ALTERNATE + REGIONSUBBOXES _ (LIST (OR VERSO FIRST) + (OR RECTO VERSO FIRST)) + REGIONSPEC _ (LIST 0 0 0 0))) + REGIONSPEC _ (LIST 0 0 0 0]) + +(TEDIT.PAGEFORMAT + [LAMBDA (STREAM FORMAT) (* ; "Edited 12-Jun-90 19:13 by mitani") + +(* ;;; "Programmatic interface for page formatting") + + (PROG ((TEXTOBJ (TEXTOBJ STREAM))) + (COND + ((AND (type? PAGEREGION FORMAT) + (EQ 'PAGE (fetch (PAGEREGION REGIONFILLMETHOD) of FORMAT))) + (* ; + "This is a single page format. Make it a compound for ALL the pages.") + (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with (LIST FORMAT FORMAT FORMAT + )) + (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T)) + ([OR (type? PAGEREGION FORMAT) + (AND (LISTP FORMAT) + (type? PAGEREGION (CAR FORMAT] + + (* ;; "It's in one of the two forms acceptable to the page formatter--either a real tree of layout info, or a list of first/left/right infos") + + (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with FORMAT) + (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T)) + ((LISTP FORMAT) (* ; + "It's likely to be a list acceptable to the parser. Try it that way.") + (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with FORMAT) + (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T)) + (T (\ILLEGAL.ARG FORMAT]) +) + + + +(* ;; "Perform page layout, based on a regular expression of typed regions.") + +(DEFINEQ + +(TEDIT.FORMAT.HARDCOPY + [LAMBDA (STREAM FILE DONTSEND BREAKPAGETITLE SERVER PRINTOPTIONS IMAGETYPE FIRSTPG# STARTPG ENDPG) + (* ; + "Edited 25-May-93 13:06 by sybalsky:mv:envos") + +(* ;;; "Format a document for hardcopy") + +(* ;;; "Returns the number of pages printed (not the final page number!). Returns NIL if the before-print-fn said not to print.") + + (* ;; "You want both TEXTOBJ and TEXTSTREAM here so that it hangs onto them even if the window goes away out from under it. DON'T REMOVE THEM!!!!") + + (RESETLST + (PROG ((TEXTOBJ (TEXTOBJ STREAM)) + (TEXTSTREAM (TEXTSTREAM STREAM)) + (FORCENEXTPAGE NIL) + [FORMATTINGSTATE (create PAGEFORMATTINGSTATE + PAGE# _ (COND + ((NUMBERP FIRSTPG#)) + (T NIL)) + FIRSTPAGE _ T + STATE _ FIRSTPG# + MINPAGE# _ STARTPG + MAXPAGE# _ (OR ENDPG 65535) + CHNO _ 1 + PAGEHEADINGS _ (LIST NIL NIL) + PAGE#GENERATOR _ (AND (LISTP FIRSTPG#) + (CDR FIRSTPG#)) + PAGE#TEXT _ (AND (LISTP FIRSTPG#) + (CAR FIRSTPG#] + TEXTLEN THISLINE LINE REGION LINES NCHNO PRSTREAM PAGEFRAMES SCRATCHFILE WASOPEN + BEFOREFN AFTERFN) + (SETQ PAGEFRAMES (OR (fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ) + TEDIT.PAGE.FRAMES)) + [COND + ((LISTP PAGEFRAMES) (* ; + "If it's a list, pack it into a real set of specs.") + (SETQ PAGEFRAMES (TEDIT.COMPOUND.PAGEFORMAT (CAR PAGEFRAMES) + (CADR PAGEFRAMES) + (CADDR PAGEFRAMES] + (SETQ THISLINE (fetch (TEXTOBJ THISLINE) of TEXTOBJ)) + (replace PRESSREGION of FORMATTINGSTATE with TEDIT.DEFAULTPAGEREGION) + (* ; + "Print in the usual region on the page") + [SETQ BREAKPAGETITLE (COND + (BREAKPAGETITLE) + ((LISTGET PRINTOPTIONS 'DOCUMENT.NAME)) + ([OR (NOT (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) + (type? STRINGP (fetch (TEXTOBJ TXTFILE) + of TEXTOBJ)) + (type? STREAM (fetch (STREAM FULLNAME) + of (fetch (TEXTOBJ TXTFILE) + of TEXTOBJ))) + (type? STRINGP (fetch (STREAM FULLNAME) + of (fetch (TEXTOBJ TXTFILE) + of TEXTOBJ] + (* ; + "This isn't a real file, so print a generic name on the document break page.") + "TEdit Hardcopy Output") + (T (* ; + "It's a real file, so use the file name on the break page.") + (fetch (STREAM FULLNAME) of (fetch (TEXTOBJ + TXTFILE) + of TEXTOBJ] + (SETQ BEFOREFN (TEXTPROP TEXTOBJ 'BEFOREHARDCOPYFN)) + [COND + (BEFOREFN (* ; + "Let the guy do any pre-hardcopy processing he wants to do") + (COND + ((EQ 'DON'T (APPLY* BEFOREFN TEXTSTREAM TEXTOBJ)) + (* ; + "If it says not to do the hardcopy, then don't.") + (RETURN] + [SETQ SCRATCHFILE (OR FILE (PRINTER.SCRATCH.FILE (TEXTSTREAM STREAM] + (RESETLST + (SETQ AFTERFN (TEXTPROP TEXTOBJ 'AFTERHARDCOPYFN)) + (AND AFTERFN (RESETSAVE NIL (LIST AFTERFN TEXTSTREAM TEXTOBJ))) + (* ; + "Set up to do the user's cleanup on the way out, as well.") + (TEDIT.PROMPTPRINT TEXTOBJ "Formatting for print..." T) + [COND + ((AND FILE (OPENP FILE) + (IMAGESTREAMTYPE FILE)) (* ; + "The file he handed us is already an image-type file. Just append the new stuff to it.") + (SETQ WASOPEN T) + (SETQ PRSTREAM FILE)) + (T (* ; + "T'wasn't an image stream, so let's open us one.") + (RESETSAVE (SETQ PRSTREAM (OPENIMAGESTREAM + SCRATCHFILE + [OR IMAGETYPE (SETQ IMAGETYPE + (CAR (PRINTERPROP (PRINTERTYPE + SERVER) + 'CANPRINT] + (LIST 'FONT (FONTCREATE 'GACHA 10) + 'BREAKPAGEFILENAME BREAKPAGETITLE))) + '(AND RESETSTATE (DELFILE (CLOSEF? OLDVALUE] + (* ; + "So we close and delete the file in case of trouble.") + (STREAMPROP PRSTREAM 'FORMATTINGSTATE FORMATTINGSTATE) + (* ; + "So that subsidiary people can find out the state of the formatting.") + + (* ;; "The right margin must be big enough to prevent line wrap on landscaped 14 inch paper, with Postscript's scaling of .01-point increments. (~ 101,000). Thiss will cause a performance hit. Sigh. JDS 9/5/89") + + (DSPRIGHTMARGIN 131072 PRSTREAM) + [while (ILEQ (fetch CHNO of FORMATTINGSTATE) + (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + do + + (* ;; "Must use (fetch TEXTLEN...) so that NS characters in an unformatted doc don't cause infinite loops.") + + (* ;; "Format pages according to the existing layout:") + + (for REGION inside PAGEFRAMES + do (TEDIT.FORMATBOX TEXTOBJ PRSTREAM (fetch CHNO + of FORMATTINGSTATE) + REGION FORMATTINGSTATE IMAGETYPE)) + (COND + ((EQ (fetch (PAGEFORMATTINGSTATE STATE) of FORMATTINGSTATE) + :NEW-PAGE-LAYOUT) + + (* ;; "New page layout got specified. Prepare to re-enter the formatting code and skip to the equivalent page in the new format.") + + (SETQ PAGEFRAMES (fetch (PAGEFORMATTINGSTATE NEWPAGELAYOUT) + of FORMATTINGSTATE)) + + (* ;; "Set up the formatting state so code knows we're looking for an equivalent page, and which page it is. (The SUB1 is because we counted an extra page for the page on which the new payout was detected.)") + + (replace (PAGEFORMATTINGSTATE REQUIREDREGIONTYPE) of + FORMATTINGSTATE + with (SUB1 (fetch (PAGEFORMATTINGSTATE PAGECOUNT) + of FORMATTINGSTATE))) + (replace (PAGEFORMATTINGSTATE PAGECOUNT) of FORMATTINGSTATE + with 0) + (replace (PAGEFORMATTINGSTATE STATE) of FORMATTINGSTATE + with :SEARCHING-FOR-EQUIVALENT-PAGE) + (COND + ((LISTP PAGEFRAMES) (* ; + "If it's a list, pack it into a real set of specs.") + (SETQ PAGEFRAMES (TEDIT.COMPOUND.PAGEFORMAT (CAR PAGEFRAMES) + (CADR PAGEFRAMES) + (CADDR PAGEFRAMES] + [COND + ((NOT WASOPEN) (* ; + "Only if we created the image stream should we close it.") + (SETQ PRSTREAM (CLOSEF PRSTREAM)) + (OR DONTSEND (SEND.FILE.TO.PRINTER PRSTREAM SERVER (APPEND PRINTOPTIONS + (LIST 'DOCUMENT.NAME + BREAKPAGETITLE] + (OR FILE (DELFILE SCRATCHFILE))) + (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT (MKSTRING (fetch (PAGEFORMATTINGSTATE PAGECOUNT) + of FORMATTINGSTATE)) + "pg done.")) + (RETURN (fetch (PAGEFORMATTINGSTATE PAGECOUNT) of FORMATTINGSTATE))))]) + +(TEDIT.FORMATBOX + [LAMBDA (TEXTOBJ PRSTREAM CH# REGION FORMATTINGSTATE SERVERTYPE) + (* ; "Edited 30-May-91 12:51 by jds") + + (* ;; "Grab text from the TEXTOBJ, starting with CH#, and use it to fill REGION on a page. Return a list of line descriptors which, taken together, fill the region.") + + (PROG ((REGIONSPEC (fetch (PAGEREGION REGIONSPEC) of REGION)) + CHNO NCHNO LINES LAST-CHNO SUBREGIONSPEC) + (SETQ LINES NIL) + (SELECTQ (fetch REGIONFILLMETHOD of REGION) + (TEXT (* ; + "A normal text region. Fill it with text formatted the usual way.") + [COND + ((\TEDIT.FORMAT.FOUNDBOX? REGION FORMATTINGSTATE) + (* ; + "Only format if we're not looking for something else.") + (CL:MULTIPLE-VALUE-SETQ (LINES NIL LAST-CHNO) + (TEDIT.FORMATTEXTBOX TEXTOBJ PRSTREAM CH# REGION FORMATTINGSTATE]) + (FOLIO (* ; + "A Page Number. Fill it in according to the instructions") + [COND + ((\TEDIT.FORMAT.FOUNDBOX? REGION FORMATTINGSTATE) + (* ; + "Only format if we're not looking for something else.") + (SETQ LINES (TEDIT.FORMATFOLIO TEXTOBJ PRSTREAM FORMATTINGSTATE REGION]) + (HEADING (* ; + "A Page heading. Fill it in from a text source we saved for the occasion.") + [COND + ((\TEDIT.FORMAT.FOUNDBOX? REGION FORMATTINGSTATE) + (* ; + "Only format if we're not looking for something else.") + (SETQ LINES (TEDIT.FORMATHEADING TEXTOBJ PRSTREAM FORMATTINGSTATE + REGION]) + (PAGE + (* ;; "This box is really a PAGE FRAME. Fill it in and do whatever other processing is needful for end of page.") + + (SETQ LINES NIL) (* ; + "This will send along its own lines to the printer.") + (\TEDIT.FORMAT.FOUNDBOX? REGION FORMATTINGSTATE) + (* ; + "So that if this is the box he's looking for, we'll spot it and stop searching") + (TEDIT.FORMATPAGE TEXTOBJ PRSTREAM CH# REGION FORMATTINGSTATE)) + ((RECURSIVE SEQUENCE ALTERNATE SELECTION REPEAT) + (* ; + "This box is really a list of boxes. Fill them.") + (\TEDIT.FORMAT.FOUNDBOX? REGION FORMATTINGSTATE) + (* ; + "So that if this is the box he's looking for, we'll spot it and stop searching") + (SELECTQ (fetch REGIONFILLMETHOD of REGION) + ((SEQUENCE RECURSIVE) (* ; + "Just run thru filling in the sub-boxes in order.") + (bind SUBREGIONSPEC for SUBREGION + in (fetch (PAGEREGION REGIONSUBBOXES) of REGION) + while (AND (ILEQ (fetch (PAGEFORMATTINGSTATE CHNO) + of FORMATTINGSTATE) + (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (OR (NOT (fetch (PAGEFORMATTINGSTATE PAGE#) + of FORMATTINGSTATE)) + (NOT (fetch (PAGEFORMATTINGSTATE MAXPAGE#) + of FORMATTINGSTATE)) + (ILEQ (fetch (PAGEFORMATTINGSTATE PAGE#) + of FORMATTINGSTATE) + (fetch (PAGEFORMATTINGSTATE MAXPAGE#) + of FORMATTINGSTATE))) + (NEQ (fetch (PAGEFORMATTINGSTATE STATE) + of FORMATTINGSTATE) + :NEW-PAGE-LAYOUT)) + do [SETQ SUBREGIONSPEC (create REGION + using (fetch REGIONSPEC + of SUBREGION) + LEFT _ + (IPLUS (fetch (REGION LEFT) + of (fetch + REGIONSPEC + of + SUBREGION + )) + (fetch (REGION LEFT) + of REGIONSPEC)) + BOTTOM _ + (IPLUS (fetch (REGION BOTTOM) + of (fetch + REGIONSPEC + of + SUBREGION + )) + (fetch (REGION BOTTOM) + of REGIONSPEC] + (TEDIT.FORMATBOX TEXTOBJ PRSTREAM (fetch ( + PAGEFORMATTINGSTATE + CHNO) + of FORMATTINGSTATE) + (create PAGEREGION using SUBREGION REGIONSPEC _ + SUBREGIONSPEC) + FORMATTINGSTATE))) + (ALTERNATE (* ; + "Run through the sub-boxes repeatedly in sequence.") + (while (AND (ILEQ (fetch (PAGEFORMATTINGSTATE CHNO) + of FORMATTINGSTATE) + (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (NEQ (fetch (PAGEFORMATTINGSTATE STATE) + of FORMATTINGSTATE) + :NEW-PAGE-LAYOUT)) + do (bind SUBREGIONSPEC for SUBREGION + in (fetch (PAGEREGION REGIONSUBBOXES) + of REGION) + while (AND (ILEQ (fetch (PAGEFORMATTINGSTATE + CHNO) of + FORMATTINGSTATE + ) + (fetch (TEXTOBJ TEXTLEN) + of TEXTOBJ)) + (NEQ (fetch (PAGEFORMATTINGSTATE + STATE) of + FORMATTINGSTATE + ) + :NEW-PAGE-LAYOUT)) + do [SETQ SUBREGIONSPEC + (create REGION + using (fetch REGIONSPEC + of SUBREGION) + LEFT _ + (IPLUS (fetch (REGION LEFT) + of (fetch + REGIONSPEC + of SUBREGION) + ) + (fetch (REGION LEFT) + of REGIONSPEC)) + BOTTOM _ + (IPLUS (fetch (REGION BOTTOM) + of (fetch + REGIONSPEC + of SUBREGION) + ) + (fetch (REGION BOTTOM) + of REGIONSPEC] + (TEDIT.FORMATBOX TEXTOBJ PRSTREAM + (fetch (PAGEFORMATTINGSTATE CHNO) + of FORMATTINGSTATE) + (create PAGEREGION + using SUBREGION REGIONSPEC _ + SUBREGIONSPEC) + FORMATTINGSTATE)))) + (SELECTION (* ; + "Do one or another box, depending on some criterion.")) + (SHOULDNT)) (* ; + "For now, draw a box around it, too.") + ) + NIL) + (for LINE in LINES when LINE + do (* ; + "Run thru the lines displaying them all.") + (BLOCK) + (COND + ((OR (NOT (fetch (PAGEFORMATTINGSTATE MINPAGE#) of FORMATTINGSTATE)) + (IGEQ (fetch (PAGEFORMATTINGSTATE PAGE#) of FORMATTINGSTATE) + (fetch (PAGEFORMATTINGSTATE MINPAGE#) of FORMATTINGSTATE))) + (* ; + "We're beyond the min page number -- go ahead and print the line") + (\TEDIT.HARDCOPY.DISPLAYLINE (fetch (TEXTSTREAM TEXTOBJ) + of (fetch (LINEDESCRIPTOR LTEXTOBJ) + of LINE)) + LINE + (fetch (LINEDESCRIPTOR CACHE) of LINE) + REGION PRSTREAM))) + [COND + ((EQ TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of (fetch (LINEDESCRIPTOR + LTEXTOBJ) + of LINE))) + + (* ;; + "This line refers back to the main text, so update the current-char pointer.") + + (* ;; + "[NB that footnotes could cause the count to be non-monotonic; hence the IMAX.]") + + (SETQ CHNO (IMAX (OR CHNO 0) + (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) of LINE] + (push (fetch (PAGEFORMATTINGSTATE PAGELINECACHE) of FORMATTINGSTATE) + LINE) + (replace (LINEDESCRIPTOR LTEXTOBJ) of LINE with NIL)) + (COND + (LAST-CHNO (* ; + "We got a definite last chno from FORMATTEXTBOX, so use it.") + (replace (PAGEFORMATTINGSTATE CHNO) of FORMATTINGSTATE with LAST-CHNO + )) + (CHNO (* ; + "Otherwise, use the new char no if we computed one.") + (replace (PAGEFORMATTINGSTATE CHNO) of FORMATTINGSTATE with CHNO]) + +(TEDIT.FORMATHEADING + [LAMBDA (TEXTOBJ PRSTREAM FORMATTINGSTATE PAGEREGION) (* ; "Edited 9-Oct-90 13:24 by jds") + + (* ;; "Grab text from the TEXTOBJ, starting with CH#, and use it to fill REGION on a page. Return a list of line descriptors which, taken together, fill the region.") + + (PROG ((CHNO 1) + [REGION (for VALUE in (fetch (PAGEREGION REGIONSPEC) of PAGEREGION) + collect (FIXR (FTIMES (DSPSCALE NIL PRSTREAM) + VALUE] + (LOCALINFO (fetch (PAGEREGION REGIONLOCALINFO) of PAGEREGION)) + HEADINGSTREAM HEADINGTEXTOBJ PRECONDITIONS THISLINE LINE YBOT (FORCENEXTPAGE NIL) + LINES HEADING) + [COND + ((SETQ PRECONDITIONS (LISTGET LOCALINFO 'PRECONDITIONS)) + (* ; + "There are preconditions for this heading to appear. Check them.") + (COND + ((for FORM inside PRECONDITIONS thereis (NOT (EVAL FORM))) + (* ; + "One of the predicates returned NIL, so don't display this heading.") + (RETURN] + (COND + ([NOT (SETQ HEADING (LISTGET (fetch (PAGEFORMATTINGSTATE PAGEHEADINGS) of + FORMATTINGSTATE + ) + (LISTGET LOCALINFO 'HEADINGTYPE] + (* ; + "There's no text for this heading. Punt.") + (RETURN))) + [SETQ HEADINGTEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) + of (SETQ HEADINGSTREAM (OPENTEXTSTREAM + "" NIL NIL NIL + (LIST 'PARALOOKS (fetch + (PIECE PPARALOOKS) + of (CAR HEADING + ] + (\TEDIT.INSERT.PIECES HEADINGTEXTOBJ 1 HEADING) + (for PC in HEADING do (add (fetch (TEXTOBJ TEXTLEN) of + HEADINGTEXTOBJ + ) + (fetch (PIECE PLEN) of PC))) + (SETQ LINES (while (AND (ILESSP CHNO (fetch (TEXTOBJ TEXTLEN) of HEADINGTEXTOBJ + )) + (NOT FORCENEXTPAGE)) + collect (SETQ THISLINE (create THISLINE)) + (SETQ FORCENEXTPAGE (\TEDIT.HARDCOPY.FORMATLINE HEADINGTEXTOBJ + (fetch (REGION WIDTH) of REGION) + CHNO THISLINE (SETQ LINE (create + LINEDESCRIPTOR + )) + PRSTREAM T)) + (replace (LINEDESCRIPTOR CACHE) of LINE with THISLINE) + (* ; + "Mark this line as having cached print info.") + (replace (LINEDESCRIPTOR LTEXTOBJ) of LINE with + HEADINGSTREAM + ) (* ; + "And remember the document it came from.") + (add (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE) + (fetch (REGION LEFT) of REGION)) + (add (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE) + (fetch (REGION LEFT) of REGION)) + (* ; "Format the next possible line") + [COND + [YBOT (* ; + "We're into it; take account of this line's height") + (SETQ YBOT (IDIFFERENCE YBOT (fetch (LINEDESCRIPTOR + LHEIGHT) + of LINE] + (T (* ; + "Just starting out; find the line's position with respect to the top of the region to be filled.") + (SETQ YBOT (IDIFFERENCE (fetch (REGION BOTTOM) of REGION + ) + (fetch (LINEDESCRIPTOR DESCENT) + of LINE] + (* ; "This line is good; use it.") + (replace (LINEDESCRIPTOR YBOT) of LINE with YBOT) + (replace (LINEDESCRIPTOR YBASE) of LINE + with (IPLUS YBOT (fetch (LINEDESCRIPTOR DESCENT) + of LINE))) + (SETQ CHNO (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) of LINE))) + (* ; + "Keep track of the next character...") + LINE)) + (RETURN LINES]) + +(TEDIT.FORMATPAGE + [LAMBDA (TEXTOBJ PRSTREAM CH# REGION FORMATTINGSTATE) + (* ; + "Edited 4-Jul-93 00:29 by sybalskY:MV:ENVOS") + + (* ;; "Format a whole page -- run thru the page's sub-boxes filling them in by type:") + + (* ;; " FOLIO -- page number") + + (* ;; " PAGEHEADING -- running heads/footers") + + (* ;; " TEXT -- plain running text.") + + [COND + ((NOT (EQ (fetch (PAGEFORMATTINGSTATE STATE) of FORMATTINGSTATE) + :SEARCHING-FOR-EQUIVALENT-PAGE)) + + (* ;; "Only do real page formatting work if we're not trying to get ourselves to an equivalent page frame spec (having switched page layouts in mid-document).") + + (PROG ((FORCENEXTPAGE NIL) + (CHNO CH#) + (PAGE# (fetch (PAGEFORMATTINGSTATE PAGE#) of FORMATTINGSTATE)) + (PAGEPROPS (fetch (PAGEREGION REGIONLOCALINFO) of REGION)) + (PAGEREGION (\TEDIT.SCALEREGION (fetch (PAGEREGION REGIONSPEC) of REGION) + (DSPSCALE NIL PRSTREAM))) + (END-OF-PAGE-FN (TEXTPROP TEXTOBJ 'END-OF-PAGE-FN)) + (PRE-EXISTING-FONT (DSPFONT NIL PRSTREAM)) + TEXTLEN THISLINE LINE LINES NCHNO TPAGE END-OF-PAGE-MARKER STARTING-FILEPTR PC + NEWPARALOOKS) + + (* ;; "For real page independence, we need to reset the font to where it was as of the beginning of the page before calling DSPNEWPAGE. This avoids font creation in a page prolog, which might get missed otherwise.") + + (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (SETQ THISLINE (fetch (TEXTOBJ THISLINE) of TEXTOBJ)) + (* ; + "Print in the usual region on the page") + (COND + ([AND (ILEQ CHNO TEXTLEN) + (EQ 'NEWPAGELAYOUT (fetch FMTPARATYPE + of (SETQ NEWPARALOOKS + (\TEDIT.APPLY.PARASTYLES + [fetch (PIECE PPARALOOKS) + of (SETQ PC (\CHTOPC CHNO + (fetch + (TEXTOBJ PCTB) + of TEXTOBJ] + PC TEXTOBJ] + + (* ;; "The first paragraph on this page starts a new page layout.") + + (replace (PAGEFORMATTINGSTATE STATE) of FORMATTINGSTATE with + :NEW-PAGE-LAYOUT + ) + [replace (PAGEFORMATTINGSTATE CHNO) of FORMATTINGSTATE + with (ADD1 (CDR (\TEDIT.PARABOUNDS TEXTOBJ CHNO] + [replace (PAGEFORMATTINGSTATE NEWPAGELAYOUT) of FORMATTINGSTATE + with (TEDIT.PARSE.PAGEFRAMES (LISTGET (fetch (FMTSPEC FMTUSERINFO) + of NEWPARALOOKS) + 'NEWPAGELAYOUT] + (RETURN))) + (COND + (PAGE# (* ; + "If we've already got a starting page number, don't set another one") + ) + ((SETQ TPAGE (LISTGET PAGEPROPS 'STARTINGPAGE#)) + (* ; + "If this page template specifies a starting page number, use it.") + (SETQ PAGE# TPAGE) + (replace (PAGEFORMATTINGSTATE PAGE#) of FORMATTINGSTATE with TPAGE)) + (T (SETQ PAGE# 1) + (replace (PAGEFORMATTINGSTATE PAGE#) of FORMATTINGSTATE with PAGE#))) + (COND + ((LISTGET PAGEPROPS 'LANDSCAPE?) (* ; "This is a landscape page.") + [COND + ((fetch (STREAM OTHERPROPS) of PRSTREAM) + (LISTPUT (fetch (STREAM OTHERPROPS) of PRSTREAM) + 'PRINTERMODE + 'LANDSCAPE)) + (T (NCONC (fetch (STREAM OTHERPROPS) of PRSTREAM) + (LIST 'PRINTERMODE 'LANDSCAPE](* ; + "Puts the info. into stream , IP creater may use") + (DSPPUSHSTATE PRSTREAM) + (DSPROTATE 90 PRSTREAM) + (DSPTRANSLATE 0 (- (ffetch (REGION HEIGHT) of PAGEREGION)) + PRSTREAM))) + [COND + (*TEDIT-PAGE-BREAKS* + + (* ;; "Only save the starting fileptr if we're making signatures, since we could be paginating to the screen as well.") + + (SETQ STARTING-FILEPTR (GETFILEPTR PRSTREAM] + (DSPCLIPPINGREGION PAGEREGION PRSTREAM) (* ; + "Set the clipping region to the whole sheet of paper.") + (DSPRIGHTMARGIN (fetch (REGION WIDTH) of PAGEREGION) + PRSTREAM) + [while [AND (ILEQ CHNO TEXTLEN) + (EQ 'PAGEHEADING (fetch FMTPARATYPE + of (fetch (PIECE PPARALOOKS) + of (\CHTOPC CHNO (fetch + (TEXTOBJ PCTB) + of TEXTOBJ] + do (* ; + "Go thru any leading page heading paras on the page.") + (\TEDIT.HARDCOPY.FORMATLINE TEXTOBJ 1 CHNO THISLINE (SETQ LINE (create + LINEDESCRIPTOR + )) + PRSTREAM) + (SETQ CHNO (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) of LINE] + (replace (PAGEFORMATTINGSTATE CHNO) of FORMATTINGSTATE with CHNO) + (for SUBREGION in (fetch (PAGEREGION REGIONSUBBOXES) of REGION) + while (ILEQ (fetch (PAGEFORMATTINGSTATE CHNO) of FORMATTINGSTATE) + TEXTLEN) do (* ; + "Now format the subregions of the page.") + (TEDIT.FORMATBOX TEXTOBJ PRSTREAM + (fetch (PAGEFORMATTINGSTATE CHNO) + of FORMATTINGSTATE) + SUBREGION FORMATTINGSTATE)) + (DSPFONT PRE-EXISTING-FONT PRSTREAM) + [COND + (*TEDIT-PAGE-BREAKS* (SHOW.IP PRSTREAM) + (SETQ *TEDIT-PAGE-BREAKS* (NCONC1 *TEDIT-PAGE-BREAKS* (CONS STARTING-FILEPTR + (GETFILEPTR + PRSTREAM] + (COND + ((LISTGET PAGEPROPS 'LANDSCAPE?) (* ; "This is a landscape page.") + (AND (fetch (STREAM OTHERPROPS) of PRSTREAM) + (LISTPUT (fetch (STREAM OTHERPROPS) of PRSTREAM) + 'PRINTERMODE NIL)) + (DSPTRANSLATE 0 (ffetch (REGION HEIGHT) of PAGEREGION) + PRSTREAM) + (DSPROTATE 0 PRSTREAM) + (DSPPOPSTATE PRSTREAM))) + [COND + ([AND (ILEQ (fetch (PAGEFORMATTINGSTATE CHNO) of FORMATTINGSTATE) + TEXTLEN) + (OR (NOT END-OF-PAGE-FN) + (NEQ (SETQ END-OF-PAGE-MARKER (APPLY* END-OF-PAGE-FN TEXTOBJ + FORMATTINGSTATE)) + 'DON'T)) + (OR (NOT (fetch (PAGEFORMATTINGSTATE MINPAGE#) of FORMATTINGSTATE)) + (IGEQ PAGE# (fetch (PAGEFORMATTINGSTATE MINPAGE#) of + FORMATTINGSTATE + ))) + (OR (NOT (fetch (PAGEFORMATTINGSTATE MAXPAGE#) of FORMATTINGSTATE)) + (ILESSP PAGE# (fetch (PAGEFORMATTINGSTATE MAXPAGE#) of + FORMATTINGSTATE + ] (* ; "There is more to print....") + (DSPNEWPAGE PRSTREAM) (* ; "Force the new page") + ) + ((AND (fetch (PAGEFORMATTINGSTATE MAXPAGE#) of FORMATTINGSTATE) + (IGEQ PAGE# (fetch (PAGEFORMATTINGSTATE MAXPAGE#) of FORMATTINGSTATE)) + ) (* ; + "We've run past the last page it wants formatted. Stop the world.") + (replace (PAGEFORMATTINGSTATE CHNO) of FORMATTINGSTATE with + (ADD1 TEXTLEN))) + ((EQ END-OF-PAGE-MARKER 'DON'T) (* ; + "The guy's e-o-page fn said stop. So stop.") + (replace (PAGEFORMATTINGSTATE CHNO) of FORMATTINGSTATE with + (ADD1 TEXTLEN] + (add (fetch (PAGEFORMATTINGSTATE PAGE#) of FORMATTINGSTATE) + 1) + (replace (PAGEFORMATTINGSTATE FIRSTPAGE) of FORMATTINGSTATE with NIL) + (replace (PAGEFORMATTINGSTATE PAGE#TEXT) of FORMATTINGSTATE + with (pop (fetch (PAGEFORMATTINGSTATE PAGE#GENERATOR) of + FORMATTINGSTATE + ] + + (* ;; "Some things happen regardless of whether we're searching or not: Need to count pages we pass over to find an equivalent page in the new layout:") + + (add (fetch (PAGEFORMATTINGSTATE PAGECOUNT) of FORMATTINGSTATE) + 1]) + +(TEDIT.FORMATTEXTBOX + [LAMBDA (TEXTOBJ PRSTREAM CH# PAGEREGION FORMATTINGSTATE) + (* ; + "Edited 3-Jul-93 22:14 by sybalskY:MV:ENVOS") + + (* ;; "Grab text from the TEXTOBJ, starting with CH#, and use it to fill REGION on a page. Return a list of line descriptors which, taken together, fill the region.") + + (COND + ((NEQ (fetch (PAGEFORMATTINGSTATE STATE) of FORMATTINGSTATE) + 'SEARCHING) + + (* ;; "Only format text if we're really formatting.") + + (LET* + ((CHNO CH#) + [REGION (for VALUE in (ffetch (PAGEREGION REGIONSPEC) of PAGEREGION) + collect (FIXR (FTIMES (DSPSCALE NIL PRSTREAM) + VALUE] + (COLUMNBOTTOM (fetch (REGION BOTTOM) of REGION)) + (FIRSTLINE T) + (BREAKAFTERLASTPARA NIL) + (STREAMSCALE (DSPSCALE NIL PRSTREAM)) + (FORCENEXTPAGE NIL) + (FOOTNOTELINES (ffetch PAGEFOOTNOTELINES of FORMATTINGSTATE)) + (PAGEFOOTNOTES NIL) + COLUMN-YBASE PRIOR-COLUMN-YBOT THISLINE LINE YBOT LINES ORPHAN LASTLINE PREVLINE LHEIGHT + FMTSPEC SPECIALYPOS NEWPAGETYPE FINAL-CHNO FOOTNOTE-REMNANTS KEPT-ONE-LINE) + + (* ;; "Account for lines carried over from prior columns:") + + [while (AND (ILEQ COLUMNBOTTOM (fetch (REGION TOP) of REGION)) + (SETQ LINE (pop FOOTNOTELINES))) + do + + (* ;; "Move as many potential footnote lines into this column as will fit.") + (* ; + "And move the bottom of the column up to account for them") + (COND + ((IGREATERP (+ COLUMNBOTTOM (fetch (LINEDESCRIPTOR LHEIGHT) of LINE)) + (fetch (REGION TOP) of REGION)) + (* ; + "If we ran out of room for footnotes, put this line back on the queue") + (CL:MULTIPLE-VALUE-SETQ (PAGEFOOTNOTES FOOTNOTE-REMNANTS IGNORE KEPT-ONE-LINE) + (TEDIT.HARDCOPY-COLUMN-END PAGEFOOTNOTES LINE NIL 1 NIL REGION + TEXTOBJ FORMATTINGSTATE)) + [COND + (KEPT-ONE-LINE (add COLUMNBOTTOM (ffetch (LINEDESCRIPTOR LHEIGHT) + of LINE] + (SETQ FOOTNOTELINES (APPEND FOOTNOTE-REMNANTS FOOTNOTELINES)) + (RETURN)) + (T (SETQ PAGEFOOTNOTES (NCONC1 PAGEFOOTNOTES LINE)) + (add COLUMNBOTTOM (ffetch (LINEDESCRIPTOR LHEIGHT) of LINE] + (freplace (PAGEFORMATTINGSTATE PAGEFOOTNOTELINES) of FORMATTINGSTATE with + FOOTNOTELINES + ) (* ; + "Remember any remaining footnotes") + [SETQ LINES + (while (AND (ILEQ CHNO (ffetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (NOT FORCENEXTPAGE)) + collect (SETQ LINE (OR (pop (fetch (PAGEFORMATTINGSTATE PAGELINECACHE) + of FORMATTINGSTATE)) + (create LINEDESCRIPTOR))) + (* ; + "Grab a line descriptor from the recycling list, or create a new one.") + (SETQ THISLINE (OR (fetch (LINEDESCRIPTOR CACHE) of LINE) + (create THISLINE))) + (* ; + "And a recycled or new THISLINE cache for char widths &c") + (BLOCK) (* ; + "Allow other things to happen while we format....") + (SETQ FORCENEXTPAGE (\TEDIT.HARDCOPY.FORMATLINE TEXTOBJ (fetch (REGION WIDTH) + of REGION) + CHNO THISLINE LINE PRSTREAM)) + (* ; + "Format the line, noting any form-feeds") + (replace (LINEDESCRIPTOR CACHE) of LINE with THISLINE) + (* ; + "Mark this line as having cached print info.") + (replace (LINEDESCRIPTOR LTEXTOBJ) of LINE with (fetch + (TEXTOBJ STREAMHINT) + of TEXTOBJ)) + (* ; + "And remember the document it came from.") + (COND + ((fetch (LINEDESCRIPTOR LMARK) of LINE) + + (* ;; "This line is a placeholder for a page heading, OR for a conditional line that is to be skipped (e.g., and EVEN text para on an odd page). All it tells us is what character to skip to so we can continue.") + + (SETQ CHNO (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) of LINE))) + LINE) + ((LISTGET (fetch (FMTSPEC FMTUSERINFO) of (fetch (LINEDESCRIPTOR + LFMTSPEC) + of LINE)) + 'FOOTNOTE) + + (* ;; "This paragraph is a footnote para.") + + (COND + (FORCENEXTPAGE (HELP))) + (SETQ FOOTNOTELINES (\TEDIT.FORMAT.FOOTNOTE TEXTOBJ PRSTREAM LINE REGION + PAGEREGION FORMATTINGSTATE)) + [SETQ CHNO (PLUS 1 (fetch (LINEDESCRIPTOR CHARLIM) + of (CAR (FLAST FOOTNOTELINES] + (* ; "Grab the lines of this footnote") + [COND + [(fetch (PAGEFORMATTINGSTATE PAGEFOOTNOTELINES) of FORMATTINGSTATE) + + (* ;; + "There are overflow footnote lines from this page already. Add to them.") + + (replace (PAGEFORMATTINGSTATE PAGEFOOTNOTELINES) of + FORMATTINGSTATE + with (COPY (APPEND (fetch (PAGEFORMATTINGSTATE + PAGEFOOTNOTELINES) + of FORMATTINGSTATE) + FOOTNOTELINES] + (T + (* ;; + "No overflow footnote lines yet. Try adding more footnotes to this page/column.") + + (for LINE in FOOTNOTELINES as REST on FOOTNOTELINES + do (COND + ((IGREATERP (+ COLUMNBOTTOM (fetch (LINEDESCRIPTOR + LHEIGHT) + of LINE)) + (OR YBOT (fetch (REGION TOP) of REGION))) + (CL:MULTIPLE-VALUE-SETQ (PAGEFOOTNOTES FOOTNOTE-REMNANTS + IGNORE) + (TEDIT.HARDCOPY-COLUMN-END PAGEFOOTNOTES LINE + NIL 1 NIL REGION TEXTOBJ FORMATTINGSTATE 3 + (NOT FIRSTLINE))) + [replace (PAGEFORMATTINGSTATE PAGEFOOTNOTELINES) + of FORMATTINGSTATE + with (COPY (APPEND FOOTNOTE-REMNANTS (CDR REST] + [SETQ FINAL-CHNO (IMAX CHNO + (ADD1 (fetch (LINEDESCRIPTOR + CHARLIM) + of (CAR (FLAST REST] + [COND + (FIRSTLINE (* ; "If this overflowing footnote line happens before any real text line, go ahead and update the colbottom, because we want to stop here anyhow.") + (add COLUMNBOTTOM (fetch (LINEDESCRIPTOR + LHEIGHT) + of LINE] + (RETURN)) + (T (SETQ PAGEFOOTNOTES (NCONC1 PAGEFOOTNOTES LINE)) + (add COLUMNBOTTOM (fetch (LINEDESCRIPTOR LHEIGHT + ) of LINE] + NIL) + (T (* ; + "This line must not represent a special item, e.g. a page heading. If it does, ignore it.") + (SETQ FMTSPEC (fetch (LINEDESCRIPTOR LFMTSPEC) of LINE)) + (add (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE) + (OR (AND (fetch (FMTSPEC FMTSPECIALX) of FMTSPEC) + (NOT (ZEROP (fetch (FMTSPEC FMTSPECIALX) of FMTSPEC) + )) + (fetch (FMTSPEC FMTSPECIALX) of FMTSPEC)) + (fetch (REGION LEFT) of REGION))) + (add (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE) + (OR (AND (fetch (FMTSPEC FMTSPECIALX) of FMTSPEC) + (NOT (ZEROP (fetch (FMTSPEC FMTSPECIALX) of FMTSPEC) + )) + (fetch (FMTSPEC FMTSPECIALX) of FMTSPEC)) + (fetch (REGION LEFT) of REGION))) + (* ; "Format the next possible line") + (SETQ SPECIALYPOS NIL) + + (* ;; "So that only the first line of a specially-placed paragraph is guaranteed to appear in the current box.") + + [COND + [(AND (fetch (FMTSPEC FMTSPECIALY) of FMTSPEC) + (NOT (ZEROP (fetch (FMTSPEC FMTSPECIALY) of FMTSPEC))) + (fetch (LINEDESCRIPTOR 1STLN) of LINE)) + (* ; + "There is a special Y location for this paragraph. Move there") + (SETQ SPECIALYPOS (SETQ YBOT (fetch (FMTSPEC FMTSPECIALY) + of FMTSPEC] + [(AND COLUMN-YBASE (\NEW-COLUMN-START LINE FMTSPEC)) + + (* ;; + "This is the first line of a new column; back YBOT back down to match the prior column.") + + (SETQ YBOT (- COLUMN-YBASE (fetch (LINEDESCRIPTOR DESCENT) + of LINE] + [YBOT (* ; + "We're into it; take account of this line's height") + (COND + [(fetch (FMTSPEC FMTBASETOBASE) of FMTSPEC) + (SETQ LHEIGHT + (IPLUS (fetch (LINEDESCRIPTOR DESCENT) of LINE) + (fetch (FMTSPEC FMTBASETOBASE) of FMTSPEC) + (COND + ((fetch (LINEDESCRIPTOR 1STLN) of LINE) + (IPLUS (OR (fetch (FMTSPEC LEADBEFORE) + of FMTSPEC) + 0) + (OR (fetch (FMTSPEC LEADAFTER) + of (fetch (LINEDESCRIPTOR + LFMTSPEC) + of PREVLINE)) + 0))) + (T 0] + (T (COND + [(\FIRST-COLUMN-START LINE FMTSPEC) + (SETQ YBOT (IDIFFERENCE (IMIN PRIOR-COLUMN-YBOT YBOT) + (fetch (LINEDESCRIPTOR LHEIGHT) + of LINE] + (T (SETQ YBOT (IDIFFERENCE YBOT (fetch (LINEDESCRIPTOR + LHEIGHT) + of LINE] + (T (* ; + "Just starting out; find the line's position with respect to the top of the region to be filled.") + (SETQ YBOT (IDIFFERENCE (fetch (REGION TOP) of REGION) + (IPLUS (fetch (LINEDESCRIPTOR LTRUEASCENT) + of LINE) + (fetch (LINEDESCRIPTOR DESCENT) + of LINE] + (COND + ((AND (ILESSP YBOT COLUMNBOTTOM) + (NOT SPECIALYPOS)) + + (* ;; "This line hangs off the bottom; (and isn't the first line of a specially-placed paragraph) punt it.") + + (SETQ FORCENEXTPAGE T) + (SETQ FINAL-CHNO (fetch (LINEDESCRIPTOR CHAR1) of LINE)) + (SETQ ORPHAN LINE) (* ; "Remember this potential orphan") + NIL) + ((AND (NOT FIRSTLINE) + (fetch (LINEDESCRIPTOR 1STLN) of LINE) + (SETQ NEWPAGETYPE (OR (fetch (FMTSPEC FMTNEWPAGEBEFORE) + of (fetch (LINEDESCRIPTOR LFMTSPEC + ) of LINE)) + BREAKAFTERLASTPARA))) + + (* ;; + "We're supposed to put this line at the start of a new page/column (any box, later)") + + (SETQ FORCENEXTPAGE 'USERBREAK) + (SETQ FINAL-CHNO (fetch (LINEDESCRIPTOR CHAR1) of LINE)) + (SETQ ORPHAN NIL) + (COND + ((NEQ NEWPAGETYPE T) (* ; + "This isn't simply go to a new box; we need to set up the search for it.") + (replace (PAGEFORMATTINGSTATE STATE) of FORMATTINGSTATE + with 'SEARCHING) + (replace (PAGEFORMATTINGSTATE REQUIREDREGIONTYPE) of + FORMATTINGSTATE + with NEWPAGETYPE))) + NIL) + (T (* ; "This line is good; use it.") + (COND + ((AND (fetch (FMTSPEC FMTNEWPAGEAFTER) + of (fetch (LINEDESCRIPTOR LFMTSPEC) of LINE))) + (* ; + "We're supposed to put the line after this one at the start of a new page/column (any box, later)") + (SETQ BREAKAFTERLASTPARA T))) + (replace (LINEDESCRIPTOR YBOT) of LINE with YBOT) + (COND + (PRIOR-COLUMN-YBOT (SETQ PRIOR-COLUMN-YBOT (IMIN PRIOR-COLUMN-YBOT + YBOT))) + (T (SETQ PRIOR-COLUMN-YBOT YBOT))) + (replace (LINEDESCRIPTOR YBASE) of LINE + with (IPLUS YBOT (fetch (LINEDESCRIPTOR DESCENT) + of LINE))) + [COND + ((\FIRST-COLUMN-START LINE FMTSPEC) + + (* ;; "This is the start of a new group of paragraphs to be lined up in columns. Save the YBASE for these guys for the other columns.") + + (SETQ COLUMN-YBASE (fetch (LINEDESCRIPTOR YBASE) of LINE] + (SETQ FIRSTLINE NIL) (* ; + "Note that we have put text out on this page/column/box, for first line checking.") + (SETQ CHNO (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) of LINE))) + (* ; + "Keep track of the next character...") + (SETQ PREVLINE LINE) + LINE] + (SETQ LINES (DREMOVE NIL LINES)) (* ; + "Remove any NILs from the line list; they're artifacts of running across page headings in-stream") + (TEDIT.HARDCOPY-COLUMN-END LINES ORPHAN FORCENEXTPAGE CHNO PAGEFOOTNOTES REGION TEXTOBJ + FORMATTINGSTATE FINAL-CHNO]) + +(TEDIT.FORMATFOLIO + [LAMBDA (TEXTOBJ PRSTREAM FORMATTINGSTATE REGIONSPEC) (* ; "Edited 30-May-91 12:51 by jds") + + (* ;; "Print a page number (called a %"folio%" in the biz) at the location and with the alignment specified in the REGIONSPEC.") + + (PROG ([REGION (for VALUE in (fetch (PAGEREGION REGIONSPEC) of REGIONSPEC) + collect (FIXR (FTIMES (DSPSCALE NIL PRSTREAM) + VALUE] + (FOLIOINFO (fetch (PAGEREGION REGIONLOCALINFO) of REGIONSPEC)) + (FORCENEXTPAGE NIL) + (CHNO 1) + FOLIOTEXTOBJ FOLIOSTREAM THISLINE LINE YBOT PARALOOKS CHARLOOKS NOFIRSTPAGE PAGE# + FOLIOFORMAT PRETEXT POSTTEXT INFOLIST) + (SETQ PARALOOKS (LISTGET FOLIOINFO 'PARALOOKS)) + (SETQ CHARLOOKS (OR (LISTGET FOLIOINFO 'CHARLOOKS) + TEDIT.DEFAULT.FOLIO.LOOKS)) + (SETQ NOFIRSTPAGE (LISTGET FOLIOINFO 'NOFIRSTPAGE)) + (SETQ INFOLIST (LISTGET FOLIOINFO 'FORMATINFO)) (* ; + "A LIST OF (FORMAT PRETEXT POSTTEXT)") + (SETQ FOLIOFORMAT (CAR INFOLIST)) + (SETQ PRETEXT (CADR INFOLIST)) + (SETQ POSTTEXT (CADDR INFOLIST)) + [SETQ PAGE# (COND + ((fetch (PAGEFORMATTINGSTATE PAGE#TEXT) of FORMATTINGSTATE) + (MKSTRING (fetch (PAGEFORMATTINGSTATE PAGE#TEXT) of FORMATTINGSTATE + ))) + (T (SELECTQ FOLIOFORMAT + (LOWERROMAN (ROMANNUMERALS (fetch (PAGEFORMATTINGSTATE PAGE#) + of FORMATTINGSTATE))) + (UPPERROMAN (ROMANNUMERALS (fetch (PAGEFORMATTINGSTATE PAGE#) + of FORMATTINGSTATE) + T)) + (MKSTRING (fetch (PAGEFORMATTINGSTATE PAGE#) of + FORMATTINGSTATE + ] + [COND + (PRETEXT (SETQ PAGE# (CONCAT PRETEXT PAGE#] + [COND + (POSTTEXT (SETQ PAGE# (CONCAT PAGE# POSTTEXT] + [SETQ FOLIOTEXTOBJ (TEXTOBJ (SETQ FOLIOSTREAM (OPENTEXTSTREAM PAGE# NIL NIL NIL + (LIST 'PARALOOKS PARALOOKS + 'LOOKS CHARLOOKS] + (COND + ((OR (NOT (fetch (PAGEFORMATTINGSTATE FIRSTPAGE) of FORMATTINGSTATE)) + (NOT NOFIRSTPAGE)) (* ; + "If this isn't the first page, OR we want a page # on the first page, go ahead and format it.") + (RETURN (while (AND (ILEQ CHNO (fetch (TEXTOBJ TEXTLEN) of FOLIOTEXTOBJ)) + (NOT FORCENEXTPAGE)) + collect (SETQ THISLINE (create THISLINE)) + (SETQ FORCENEXTPAGE (\TEDIT.HARDCOPY.FORMATLINE FOLIOTEXTOBJ + (fetch (REGION WIDTH) of REGION) + CHNO THISLINE (SETQ LINE (create + LINEDESCRIPTOR + )) + PRSTREAM)) + (replace (LINEDESCRIPTOR CACHE) of LINE with THISLINE) + (replace (LINEDESCRIPTOR LTEXTOBJ) of LINE with + FOLIOSTREAM) + (add (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE) + (fetch (REGION LEFT) of REGION)) + (add (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE) + (fetch (REGION LEFT) of REGION)) + (* ; "Format the next possible line") + (SETQ CHNO (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) of LINE))) + (* ; + "Keep track of the next character...") + [COND + [YBOT (* ; + "We're into it; take account of this line's height") + (SETQ YBOT (IDIFFERENCE YBOT (fetch (LINEDESCRIPTOR + LHEIGHT) + of LINE] + (T (* ; + "Just starting out; find the line's position with respect to the top of the region to be filled.") + (SETQ YBOT (SETQ YBOT (IDIFFERENCE (fetch (REGION BOTTOM) + of REGION) + (fetch (LINEDESCRIPTOR DESCENT) + of LINE] + (COND + ((ILESSP YBOT (IDIFFERENCE (fetch (REGION BOTTOM) of REGION + ) + (fetch (LINEDESCRIPTOR DESCENT) + of LINE))) + (* ; + "This line hangs off the bottom; punt it.") + NIL) + (T (* ; "This line is good; use it.") + (replace (LINEDESCRIPTOR YBOT) of LINE with YBOT) + (replace (LINEDESCRIPTOR YBASE) of LINE + with (IPLUS YBOT (fetch (LINEDESCRIPTOR DESCENT) + of LINE))) + LINE]) + +(\TEDIT.FORMAT.FOUNDBOX? + [LAMBDA (PAGEREGION FORMATTINGSTATE) (* ; "Edited 19-Apr-88 17:35 by jds") + +(* ;;; "Return T if we're either not looking to begin in a new box, or we are and we've found it.") + +(* ;;; "This is part of generalizing the 'go to a new page' code to allow going to an arbitrary new formatting box.") + + (SELECTQ (fetch (PAGEFORMATTINGSTATE STATE) of FORMATTINGSTATE) + (FORMATTING (* ; + "we're just munching along formatting. Keep going.") + T) + (SEARCHING (* ; + "We're searching for a page box of the right type. Decide if this is it or not.") + (COND + ((EQ (fetch (PAGEFORMATTINGSTATE REQUIREDREGIONTYPE) of FORMATTINGSTATE + ) + (fetch (PAGEREGION REGIONTYPE) of PAGEREGION)) + (* ; + "What we're looking for matches what we've got. Turn off the search and return T") + (replace (PAGEFORMATTINGSTATE STATE) of FORMATTINGSTATE + with 'FORMATTING) + T))) + (:SEARCHING-FOR-EQUIVALENT-PAGE + (* ;; "We've switched document formats in mid-document, and need to find the corresponding page frame to continue properly.") + + [COND + ((IEQP (fetch (PAGEFORMATTINGSTATE REQUIREDREGIONTYPE) of FORMATTINGSTATE) + (fetch (PAGEFORMATTINGSTATE PAGECOUNT) of FORMATTINGSTATE)) + (* ; + "We've formatted enough pages up to now.") + (replace (PAGEFORMATTINGSTATE STATE) of FORMATTINGSTATE with + 'FORMATTING]) + T]) + +(TEDIT.SKIP.SPECIALCOND + [LAMBDA (TEXTOBJ TEXTSTREAM LINE PARALOOKS CHNO IMAGESTREAM) + (* ; + "Edited 25-May-93 13:44 by sybalsky:mv:envos") + + (* ;; "This is a special-paragraph that should be skipped in this context (e.g. an EVEN para on an odd page). Then set LINE:CHARLIM so it will move the document ahead to the next real text.") + + (PROG ((PC (fetch (TEXTSTREAM PIECE) of TEXTSTREAM)) + (LEN 0) + (FORMATTINGSTATE (STREAMPROP IMAGESTREAM 'FORMATTINGSTATE)) + (HEADINGTYPE (fetch FMTPARASUBTYPE of PARALOOKS)) + NPC PIECES) + (SETQ NPC PC) + (SETQ PIECES (repeatuntil [OR (NOT PC) + (AND (fetch (PIECE PPARALAST) of PC) + (OR (NOT NPC) + (NEQ (fetch FMTPARATYPE + of (fetch (PIECE PPARALOOKS) + of NPC)) + 'PAGEHEADING) + (NEQ HEADINGTYPE (fetch FMTPARASUBTYPE + of (fetch + (PIECE PPARALOOKS) + of NPC] + collect (* ; + "GRAB THE PIECES FOR THIS HEADING.") + (SETQ PC NPC) + (AND PC (add LEN (fetch (PIECE PLEN) of PC)) + (SETQ NPC (fetch (PIECE NEXTPIECE) of PC))) + NIL)) + (replace (LINEDESCRIPTOR LMARK) of LINE with 'SPECIAL) + (* ; + "Mark this as text to skip, as far as the main formatter's concerned.") + (replace (LINEDESCRIPTOR 1STLN) of LINE with T) + (replace (LINEDESCRIPTOR LSTLN) of LINE with T) + (replace (LINEDESCRIPTOR LHEIGHT) of LINE with 0) + (replace (LINEDESCRIPTOR ASCENT) of LINE with 0) + (replace (LINEDESCRIPTOR DESCENT) of LINE with 0) + (replace (LINEDESCRIPTOR LTRUEASCENT) of LINE with 0) + (replace (LINEDESCRIPTOR LTRUEDESCENT) of LINE with 0) + (replace (LINEDESCRIPTOR CHARLIM) of LINE with (SUB1 (IPLUS CHNO LEN))) + (* ; + "Set the line's CHARLIM to be the last character in the page heading.") + ]) +) + + + +(* ;; "Aux function to capture page headings during line formatting:") + +(DEFINEQ + +(TEDIT.HARDCOPY.PAGEHEADING + [LAMBDA (TEXTOBJ TEXTSTREAM LINE PARALOOKS CHNO IMAGESTREAM) + (* ; "Edited 18-Mar-93 13:07 by jds") + + (* ;; "Capture the text for this page heading. Then set LINE:CHARLIM so it will move the document ahead to the next real text.") + + (PROG ((PC (fetch (TEXTSTREAM PIECE) of TEXTSTREAM)) + (LEN 0) + (FORMATTINGSTATE (STREAMPROP IMAGESTREAM 'FORMATTINGSTATE)) + (HEADINGTYPE (fetch FMTPARASUBTYPE of PARALOOKS)) + NPC PIECES) + (SETQ NPC PC) + [SETQ PIECES (repeatuntil [OR (NOT PC) + (NOT (type? PIECE PC)) + (AND (fetch (PIECE PPARALAST) of PC) + (OR (NOT NPC) + (NEQ (fetch FMTPARATYPE + of (fetch (PIECE PPARALOOKS) + of NPC)) + 'PAGEHEADING) + (NEQ HEADINGTYPE (fetch FMTPARASUBTYPE + of (fetch + (PIECE PPARALOOKS) + of NPC] + collect (* ; + "GRAB THE PIECES FOR THIS HEADING.") + (SETQ PC NPC) + (COND + ((type? PIECE PC) + (add LEN (fetch (PIECE PLEN) of PC)) + (SETQ NPC (fetch (PIECE NEXTPIECE) of PC)) + (\TEDIT.COPYTEXTSTREAM.PIECEMAPFN PC TEXTOBJ TEXTOBJ TEXTOBJ] + (replace (LINEDESCRIPTOR LMARK) of LINE with T) + (replace (LINEDESCRIPTOR CHARLIM) of LINE with (SUB1 (IPLUS CHNO LEN))) + (* ; + "Set the line's CHARLIM to be the last character in the page heading.") + (replace (LINEDESCRIPTOR 1STLN) of LINE with T) + (replace (LINEDESCRIPTOR LSTLN) of LINE with T) + (replace (LINEDESCRIPTOR LHEIGHT) of LINE with 0) + (replace (LINEDESCRIPTOR ASCENT) of LINE with 0) + (replace (LINEDESCRIPTOR DESCENT) of LINE with 0) + (replace (LINEDESCRIPTOR LTRUEASCENT) of LINE with 0) + (replace (LINEDESCRIPTOR LTRUEDESCENT) of LINE with 0) + (LISTPUT (fetch PAGEHEADINGS of FORMATTINGSTATE) + (fetch FMTPARASUBTYPE of PARALOOKS) + PIECES]) +) + + + +(* ;; " Aux function to handle end-of-column processing (paragraph keep, widow elimination, etc):") + +(DEFINEQ + +(TEDIT.HARDCOPY-COLUMN-END + [LAMBDA (ORIGINAL-LINES ORPHAN FORCENEXTPAGE CHNO FOOTNOTELINES REGION TEXTOBJ FORMATTINGSTATE + FINAL-CHNO DONT-KEEP-SINGLE-LINE) (* ; "Edited 11-May-93 01:21 by jds") + + (* ;; "Do column-end processing for TEdit hardcopy -- widow elimination, respect keep-together specifications, etc.") + + (* ;; "RETURNS:") + + (* ;; " -- List of line descriptors in the column") + + (* ;; " -- List of line descriptors removed from the end of the column.") + + (* ;; " -- ?? CHNO for start of next line in sequence??") + + (SETQ ORIGINAL-LINES (DREMOVE NIL ORIGINAL-LINES)) (* ; "Remove any NILs from the list of lines; they're artifacts of running into page headings in mid-page.") + (LET ((LINES (COPY ORIGINAL-LINES)) + LASTLINE + (REMOVED-LINES (LIST ORPHAN))) + [COND + (LINES (* ; + "Only worry about widows and orphans if there are really lines to worry about") + [for LINE in LINES when (fetch (LINEDESCRIPTOR LMARK) of + LINE) + do (DREMOVE LINE LINES) + (SETQ FINAL-CHNO (AND FINAL-CHNO (IMAX FINAL-CHNO + (ADD1 (fetch (LINEDESCRIPTOR + CHARLIM) + of LINE] + (SETQ LASTLINE (CAR (FLAST LINES))) (* ; + "Find the last line in this box (column or page)") + [COND + ((AND ORPHAN (fetch (LINEDESCRIPTOR LSTLN) of ORPHAN) + (NOT (fetch (LINEDESCRIPTOR 1STLN) of ORPHAN))) + + (* ;; "There was an overhanging line, and it was the last line of the paragraph. Remove the penultimate line.") + + (SETQ LINES (DREMOVE LASTLINE LINES)) + (CL:PUSH LASTLINE REMOVED-LINES) + (SETQ FINAL-CHNO (fetch (LINEDESCRIPTOR CHAR1) of LASTLINE)) + (SETQ LASTLINE (CAR (FLAST LINES] + [COND + ((AND LASTLINE (fetch (LINEDESCRIPTOR 1STLN) of LASTLINE) + (NOT (fetch (LINEDESCRIPTOR LSTLN) of LASTLINE)) + (ILESSP (fetch (LINEDESCRIPTOR CHARLIM) of LASTLINE) + (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) + (* ; + "The last line on the page is a widow. Remove it, too.") + (SETQ LINES (DREMOVE LASTLINE LINES)) + (CL:PUSH LASTLINE REMOVED-LINES) + (SETQ FINAL-CHNO (fetch (LINEDESCRIPTOR CHAR1) of LASTLINE)) + (SETQ LASTLINE (CAR (FLAST LINES] + (COND + [(NOT LINES) + + (* ;; "This is a 2- or 3-line paragraph, with only the first 1 or 2 lines fitting on ANY page. Just return the first 1 or two lines, and we'll have to eat the widow.") + + (SETQ LINES ORIGINAL-LINES) + (SETQ FINAL-CHNO (COND + (ORPHAN (fetch (LINEDESCRIPTOR CHAR1) of ORPHAN)) + (T (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) + of (CAR (FLAST ORIGINAL-LINES] + ([AND (NEQ FORCENEXTPAGE 'USERBREAK) + (ILEQ CHNO (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (OR (fetch FMTHEADINGKEEP of (fetch (LINEDESCRIPTOR LFMTSPEC) + of LASTLINE)) + (AND (fetch (FMTSPEC FMTKEEP) of (fetch (LINEDESCRIPTOR + LFMTSPEC) + of LASTLINE)) + (NOT (FETCH (LINEDESCRIPTOR LSTLN) OF LASTLINE] + + (* ;; "Only do widow/orphan detection if this is NOT a page break the user asked for. And this isn't the end of the document.") + + (for LASTLINE in (REVERSE LINES) + while [OR (fetch FMTHEADINGKEEP of (fetch (LINEDESCRIPTOR + LFMTSPEC) + of LASTLINE)) + (AND (fetch (FMTSPEC FMTKEEP) of (fetch + (LINEDESCRIPTOR + LFMTSPEC) + of LASTLINE)) + (NOT (fetch (LINEDESCRIPTOR LSTLN) of LASTLINE] + do + + (* ;; "Run thru, removing any trailing headings. However, assure that there's at least one line on a page.") + finally (COND + [(AND LASTLINE (AND (NOT (fetch FMTHEADINGKEEP of (fetch (LINEDESCRIPTOR + LFMTSPEC) + of LASTLINE))) + (fetch (LINEDESCRIPTOR LSTLN) of LASTLINE))) + + (* ;; "OK we found a line that DOESN'T need to be kept with the other paragraphs. Chop off the list starting AFTER it.") + + [SETQ LINES (LDIFF LINES (SETQ LASTLINE (CDR (MEMB LASTLINE LINES] + (SETQ REMOVED-LINES (APPEND LASTLINE REMOVED-LINES)) + (SETQ FINAL-CHNO (fetch (LINEDESCRIPTOR CHAR1) of (CAR LASTLINE] + (T (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "WARNING: Page full of headings on page " + (fetch (PAGEFORMATTINGSTATE PAGE#) + of FORMATTINGSTATE] + [COND + (FOOTNOTELINES + + (* ;; "There are footnotes--fix up their vertical locations, so they're aligned on the botton of the column.") + + (bind [YBOT _ (IDIFFERENCE (fetch (REGION BOTTOM) of REGION) + (fetch (LINEDESCRIPTOR DESCENT) + of (CAR (FLAST FOOTNOTELINES] for LINE + in (REVERSE FOOTNOTELINES) do (replace (LINEDESCRIPTOR YBOT) + of LINE with YBOT) + (replace (LINEDESCRIPTOR YBASE) + of LINE + with (IPLUS YBOT + (fetch ( + LINEDESCRIPTOR + DESCENT) + of LINE))) + (add YBOT (fetch (LINEDESCRIPTOR + LHEIGHT) + of LINE] + (COND + ((OR LINES FOOTNOTELINES) (* ; + "There really ARE lines in this column; take care of them.") + (CL:VALUES (APPEND LINES FOOTNOTELINES) + REMOVED-LINES FINAL-CHNO NIL)) + ((AND ORPHAN (NOT ORIGINAL-LINES) + (NOT DONT-KEEP-SINGLE-LINE)) (* ; + "If there's only one line left for this box, return it anyhow.") + (CL:VALUES (CONS ORPHAN FOOTNOTELINES) + NIL + (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) of ORPHAN)) + T)) + ((AND (NOT DONT-KEEP-SINGLE-LINE) + REMOVED-LINES) + (CL:VALUES (LIST (SETQ LASTLINE (CAR REMOVED-LINES))) + (CDR REMOVED-LINES) + (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) of LASTLINE)) + NIL)) + (ORPHAN (* ; "WAS ORPHAN.") + + (* ;; "There's only the one line, so let's go back and try again.") + + (CL:VALUES NIL (LIST ORPHAN) + FINAL-CHNO NIL]) +) + + + +(* ;; "Handle varying paper sizes") + +(DEFINEQ + +(SCALEPAGEUNITS + [LAMBDA (VALUE FACTOR PAPERSIZE) (* jds "14-Jun-85 15:34") + + (* Scale a page-relative value into points%: Scale VALUE by FACTOR, then allow + for negative values to mean "come in from the other side by that much") + + (AND VALUE (PROG [(TVAL (FIXR (FTIMES VALUE FACTOR))) + (OTHEREDGE (SELECTQ PAPERSIZE + ((NIL LETTER) + 612) + (LEGAL 612) + (fetch (TEDITPAPERSIZE TPSWIDTH) of (ASSOC PAPERSIZE + TEDIT.PAPER.SIZES + ] + [COND + ((ILESSP TVAL 0) (* He specified this value as an + offset from the opposite edge. + Convert it.) + (SETQ TVAL (IPLUS OTHEREDGE TVAL] + (RETURN TVAL]) + +(SCALEPAGEXUNITS + [LAMBDA (VALUE FACTOR PAPERSIZE LANDSCAPE?) (* ; "Edited 21-Apr-88 10:46 by jds") + + (* ;; "Scale a page-relative value into points: Scale VALUE by FACTOR, then allow for negative values to mean 'come in from the other side by that much'") + + (AND VALUE (PROG ((TVAL (FIXR (FTIMES VALUE FACTOR))) + OTHEREDGE) + [COND + ((ILESSP TVAL 0) (* ; + "He specified this value as an offset from the opposite edge. Convert it.") + (SETQ OTHEREDGE (\TEDIT.PAPERWIDTH PAPERSIZE LANDSCAPE?)) + (SETQ TVAL (IPLUS OTHEREDGE TVAL] + (RETURN TVAL]) + +(SCALEPAGEYUNITS + [LAMBDA (VALUE FACTOR PAPERSIZE LANDSCAPE?) (* ; "Edited 17-Dec-87 14:52 by jds") + + (* ;; "Scale a page-relative value into points: Scale VALUE by FACTOR, then allow for negative values to mean 'come in from the other side by that much'") + + (AND VALUE (PROG ((TVAL (FIXR (FTIMES VALUE FACTOR))) + OTHEREDGE) + [COND + ((ILESSP TVAL 0) (* ; + "He specified this value as an offset from the opposite edge. Convert it.") + (SETQ OTHEREDGE (\TEDIT.PAPERHEIGHT PAPERSIZE LANDSCAPE?)) + (SETQ TVAL (IPLUS OTHEREDGE TVAL] + (RETURN TVAL]) + +(\TEDIT.PAPERHEIGHT + [LAMBDA (PAPERSIZE LANDSCAPE?) (* ; "Edited 29-Dec-86 15:06 by jds") + +(* ;;; "Compute the HEIGHT of a sheet of paper, according to PAPERSIZE, in points.") + + (COND + (LANDSCAPE? (* ; + "The paper is landscape, so its height is the WIDTH of the same paper size, normal.") + (\TEDIT.PAPERWIDTH PAPERSIZE NIL)) + (T (* ; + "Not landscape, so look up the size spec:") + (SELECTQ PAPERSIZE + ((NIL LETTER Letter) + 792) + ((Legal |8.5x14| LEGAL) + 1008) + ((A4 a4) + 842) + (fetch (TEDITPAPERSIZE TPSHEIGHT) of (ASSOC PAPERSIZE TEDIT.PAPER.SIZES]) + +(\TEDIT.PAPERWIDTH + [LAMBDA (PAPERSIZE LANDSCAPE?) (* ; "Edited 9-Dec-87 20:10 by jds") + +(* ;;; "Compute the WIDTH of a sheet of paper, according to PAPERSIZE and LANDSCAPE?") + + (LET (CANONICAL-PAPERSIZE) + (COND + (LANDSCAPE? (* ; + "It's landscape paper, so look at the HEIGHT of the corresponding normal paper.") + (\TEDIT.PAPERHEIGHT PAPERSIZE NIL)) + (T (* ; + "Not landscape, so look up the size spec:") + (SELECTQ PAPERSIZE + ((NIL Letter LETTER |8.5x11|) (* ; "letter size paper, 8.5inx11in") + 612) + ((Legal LEGAL |8.5x14|) + 612) + ((A4 a4) (* ; "A4 ISO-size paper, 210mmx297mm") + 595) + (COND + ((SETQ CANONICAL-PAPERSIZE (ASSOC PAPERSIZE TEDIT.PAPER.SIZES)) + (fetch (TEDITPAPERSIZE TPSWIDTH) of CANONICAL-PAPERSIZE)) + (T (\ILLEGAL.ARG PAPERSIZE]) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS TEDIT.PAPER.SIZES) +) + +(RPAQQ TEDIT.PAPER.SIZES ((A0 2384 3370) (A1 1684 2384) (A2 1191 1684) (A3 842 1191) (A4 595 842) (A5 420 595) (B0 2835 4008) (B1 2004 2835) (B2 1417 2004) (B3 1001 1417) (B4 709 1001) (B5 499 709)) +) + + + +(* ; "Page numbering option support") + +(DEFINEQ + +(ROMANNUMERALS + [LAMBDA (NUMBER UCFLG) (* jds "12-Jul-85 13:19") + + (* * Take a NUMBER, and render it as a string of roman numerals. + If UCFLG, then the numerals will be upper-case; + otherwise, they are lower-case.) + + (PROG ((CHARS NIL)) + [while (NOT (ZEROP NUMBER)) do (COND + ((IGEQ NUMBER 1000) + (push CHARS 'm) + (add NUMBER -1000)) + ((IGEQ NUMBER 900) + (push CHARS 'c) + (push CHARS 'm) + (add NUMBER -900)) + ((IGEQ NUMBER 500) + (push CHARS 'd) + (add NUMBER -500)) + ((IGEQ NUMBER 400) + (push CHARS 'c) + (push CHARS 'd) + (add NUMBER -400)) + ((IGEQ NUMBER 100) + (push CHARS 'c) + (add NUMBER -100)) + ((IGEQ NUMBER 90) + (push CHARS 'x) + (push CHARS 'c) + (add NUMBER -90)) + ((IGEQ NUMBER 50) + (push CHARS 'l) + (add NUMBER -50)) + ((IGEQ NUMBER 40) + (push CHARS 'x) + (push CHARS 'l) + (add NUMBER -40)) + ((IGEQ NUMBER 10) + (push CHARS 'x) + (add NUMBER -10)) + ((IGEQ NUMBER 9) + (push CHARS 'i) + (push CHARS 'x) + (add NUMBER -9)) + ((IGEQ NUMBER 5) + (push CHARS 'v) + (add NUMBER -5)) + ((IGEQ NUMBER 4) + (push CHARS 'i) + (push CHARS 'v) + (add NUMBER -4)) + (T (push CHARS 'i) + (add NUMBER -1] + (RETURN (COND + [UCFLG (* The caller wants his roman + numerals upper case) + (U-CASE (CONCATLIST (REVERSE CHARS] + (T (CONCATLIST (REVERSE CHARS]) +) + + + +(* ;; "Foot note support") + +(DEFINEQ + +(\TEDIT.FORMAT.FOOTNOTE + [LAMBDA (TEXTOBJ PRSTREAM LINE REGION PAGEREGION FORMATTINGSTATE) + (* ; "Edited 30-May-91 12:52 by jds") + + (* ;; "Grab text from the TEXTOBJ, starting with CH#, and use it to fill REGION on a page. Return a list of line descriptors which, taken together, fill the region.") + + (LET* ((CHNO (fetch (LINEDESCRIPTOR CHAR1) of LINE)) + (STREAMSCALE (DSPSCALE NIL PRSTREAM)) + THISLINE LINE YBOT LINES ORPHAN LASTLINE PREVLINE LHEIGHT FMTSPEC SPECIALYPOS NEWPAGETYPE) + (SETQ LINES (while [AND (ILEQ CHNO (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (OR (NOT PREVLINE) + (NOT (fetch (LINEDESCRIPTOR LSTLN) of PREVLINE] + collect (SETQ LINE (OR (pop (fetch (PAGEFORMATTINGSTATE + PAGELINECACHE) + of FORMATTINGSTATE)) + (create LINEDESCRIPTOR))) + (* ; + "Grab a line descriptor from the recycling list, or create a new one.") + (SETQ THISLINE (OR (fetch (LINEDESCRIPTOR CACHE) of LINE) + (create THISLINE))) + (* ; + "And a recycled or new THISLINE cache for char widths &c") + (BLOCK) (* ; + "Allow other things to happen while we format....") + (\TEDIT.HARDCOPY.FORMATLINE TEXTOBJ (fetch (REGION WIDTH) + of REGION) + CHNO THISLINE LINE PRSTREAM) + (* ; + "Format the line, noting any form-feeds") + (replace (LINEDESCRIPTOR CACHE) of LINE with THISLINE) + (* ; + "Mark this line as having cached print info.") + (replace (LINEDESCRIPTOR LTEXTOBJ) of LINE + with (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) + (* ; + "And remember the document it came from.") + (SETQ FMTSPEC (fetch (LINEDESCRIPTOR LFMTSPEC) of LINE)) + (add (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE) + (fetch (REGION LEFT) of REGION)) + (add (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE) + (fetch (REGION LEFT) of REGION)) + (* ; "Format the next possible line") + (SETQ CHNO (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) of LINE))) + (* ; + "Keep track of the next character...") + (SETQ PREVLINE LINE) + LINE)) + (SETQ LINES (DREMOVE NIL LINES)) (* ; + "Remove any NILs from the line list; they're artifacts of running across page headings in-stream") + LINES]) +) +(PUTPROPS TEDITPAGE COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990 1991 +1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (3553 7108 (TEDIT.GET.PAGEFRAMES 3563 . 3915) (TEDIT.PARSE.PAGEFRAMES 3917 . 5620) ( +TEDIT.PUT.PAGEFRAMES 5622 . 6250) (TEDIT.UNPARSE.PAGEFRAMES 6252 . 7106)) (7154 19997 ( +TEDIT.SINGLE.PAGEFORMAT 7164 . 17723) (TEDIT.COMPOUND.PAGEFORMAT 17725 . 18351) (TEDIT.PAGEFORMAT +18353 . 19995)) (20084 97190 (TEDIT.FORMAT.HARDCOPY 20094 . 31166) (TEDIT.FORMATBOX 31168 . 46475) ( +TEDIT.FORMATHEADING 46477 . 53053) (TEDIT.FORMATPAGE 53055 . 64626) (TEDIT.FORMATTEXTBOX 64628 . 84946 +) (TEDIT.FORMATFOLIO 84948 . 91873) (\TEDIT.FORMAT.FOUNDBOX? 91875 . 94064) (TEDIT.SKIP.SPECIALCOND +94066 . 97188)) (97270 100471 (TEDIT.HARDCOPY.PAGEHEADING 97280 . 100469)) (100580 110247 ( +TEDIT.HARDCOPY-COLUMN-END 100590 . 110245)) (110292 115296 (SCALEPAGEUNITS 110302 . 111530) ( +SCALEPAGEXUNITS 111532 . 112296) (SCALEPAGEYUNITS 112298 . 113063) (\TEDIT.PAPERHEIGHT 113065 . 113994 +) (\TEDIT.PAPERWIDTH 113996 . 115294)) (115618 119532 (ROMANNUMERALS 115628 . 119530)) (119568 123634 +(\TEDIT.FORMAT.FOOTNOTE 119578 . 123632))))) +STOP diff --git a/library/TEDITSCREEN b/library/TEDITSCREEN new file mode 100644 index 00000000..420a9e8b --- /dev/null +++ b/library/TEDITSCREEN @@ -0,0 +1,2961 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "25-Aug-94 13:26:23" {DSK}export>lispcore>library>TEDITSCREEN.;5 221448 + + changes to%: (FNS \MAIKO.DISPLAYLINE) (VARS TEDITSCREENCOMS) (FILES TEDITDCL) + + previous date%: "25-Aug-94 10:55:48" {DSK}export>lispcore>library>TEDITSCREEN.;4) + + +(* ; " +Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT TEDITSCREENCOMS) + +(RPAQQ TEDITSCREENCOMS ((FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (FNS \FORMATLINE \TEDIT.NSCHAR.RUN \TEDIT.PURGE.SPACES \DOFORMATTING) (FNS \DISPLAYLINE \MAIKO.DISPLAYLINE \TEDIT.LINECACHE \TEDIT.CREATE.LINECACHE \TEDIT.BLTCHAR) (FNS TEDIT.CR.UPDATESCREEN TEDIT.DELETELINE TEDIT.INSERT.DISPLAYTEXT TEDIT.INSERT.UPDATESCREEN TEDIT.UPDATE.SCREEN \BACKFORMAT \FILLWINDOW \FIXDLINES \FIXILINES \SHOWTEXT \TEDIT.ADJUST.LINES \TEDIT.CLEAR.SCREEN.BELOW.LINE \TEDIT.CLOSEUPLINES \TEDIT.COPY.LINEDESCRIPTOR \TEDIT.FIXCHANGEDLINE \TEDIT.FIXCHANGEDPART \TEDIT.INSERTLINE \TEDIT.LINE.LIST \TEDIT.MARK.LINES.DIRTY \TEDIT.NEXT.LINE.BOTTOM) (VARS (TEDIT.DONT.BREAK.CHARS (QUOTE (8482 8483 8491 8492 8508 8525 8539 8537 8535 9249 9251 9253 9255 9257 9283 9315 9317 9319 9326 9505 9507 9509 9511 9513 9539 9571 9573 9575 9582))) (TEDIT.DONT.LAST.CHARS (QUOTE (8524 8538 8536 8534)))) (GLOBALVARS TEDIT.DONT.BREAK.CHARS TEDIT.DONT.LAST.CHARS) (P (COND ((EQ (MACHINETYPE) (QUOTE MAIKO)) (MOVD (QUOTE \MAIKO.DISPLAYLINE) (QUOTE \DISPLAYLINE))) (T (ADDTOVAR \MAIKO.MOVDS (\MAIKO.DISPLAYLINE \DISPLAYLINE)))))) +) + +(FILESLOAD TEDITDCL) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ \SCRATCHLEN 64) + + +(CONSTANTS (\SCRATCHLEN 64)) +) + + +(FILESLOAD (LOADCOMP) TEDITDCL) +) +(DEFINEQ + +(\FORMATLINE + [LAMBDA (TEXTOBJ FMTSPEC CH#1 OLINE 1STLN) (* ; "Edited 29-Mar-94 16:20 by jds") + + (* ;; "Given a starting place, format the next line of text. Return the LINEDESCRIPTOR; reusing OLINE if it's given.") + + (* ;; "If CH#1 is past end of document, \FORMATLINE returns an empty line descriptor that is set up right wrt leading and font. This is used by \FILLWINDOW to create the dummy line at end of document when you hit a CR there.") + + (DECLARE (SPECVARS LOOKS CHLIST WLIST FONTWIDTHS CHNO ASCENT DESCENT LOOKNO LINE FONT + INVISIBLERUNS DEVICE SCALE NEWASCENT NEWDESCENT TLEN)) + (PROG ([LINE (OR OLINE (create LINEDESCRIPTOR + RIGHTMARGIN _ (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) + YBOT _ (SUB1 (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ] + (CH#B (IMAX CH#1 1)) + (GATHERBLANK T) + (TLEN 0) + (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (THISLINE (ffetch (TEXTOBJ THISLINE) of TEXTOBJ)) + (CHNO (IMAX CH#1 1)) + (LOOKNO 0) + (INVISIBLERUNS 0) + (ASCENT 0) + (DESCENT 0) + (PREVSP 0) + (%#BLANKS 0) + (DEFAULTTAB 36) + (DS (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) + 'DSP)) + LEFTEDGE TX DX TXB CH FORCEEND T1SPACE TXB1 DXB WIDTH LOOK#B FONT FONTWIDTHS TERMSA CLOOKS + TEXTSTREAM CHLIST WLIST LOOKS ASCENTB DESCENTB INVISIBLERUNSB TABPENDING BOX PC PCNO + DEVICE SCALE NEWASCENT NEWDESCENT TABSPEC HARDCOPYMODE ORIGFMTSPEC PREVHYPH PREVDHYPH + ORIGCHLIST ORIGWLIST) + + (* ;; "Variables (TLEN = Current character count on the line)") + + (* ;; "(CHNO = Current character # in the text)") + + (* ;; "(DX = width of current char/object)") + + (* ;; "(TX = current right margin) ") + + (* ;; "(TXB1 = right margin of the first space/tab/CR in a row of space/tab/CR) ") + + (* ;; "(CH#B = The CHNO of most recent space/tab)") + + (* ;; "(TXB = right margin of most recent space/tab)") + + (* ;; "(DXB = width of most recent space/tab)") + + (* ;; "(PREVSP = location on the line of the previous space/tab to this space/tab + 1)") + + (* ;; "(T1SPACE = a space/CR/TAB has been seen)") + + (* ;; "(#BLANKS = # of spaces/tabs seen) ") + + (* ;; " (LOOKNO = Current index into the LOOKS array. Updated by \TEDIT.LOOKS.UPDATE as characters are read in)") + + (* ;; "(LOOK#B = The LOOKNO of the most recent space/tab)") + + (* ;; "(ASCENTB = Ascent at most recent potential line break point)") + + (* ;; "(DESCENTB = Descent at most recent potential line break point)") + + (SETQ CH#1 (IMAX CH#1 1)) + [SETQ ORIGCHLIST (SETQ CHLIST (fetch (ARRAYP BASE) of (fetch (THISLINE CHARS) + of THISLINE] + [SETQ ORIGWLIST (SETQ WLIST (fetch (ARRAYP BASE) of (fetch (THISLINE WIDTHS) + of THISLINE] + (SETQ LOOKS (fetch (THISLINE LOOKS) of THISLINE)) + (SETQ TEXTSTREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) + (SETQ TERMSA (fetch (TEXTOBJ TXTTERMSA) of TEXTOBJ)) + (replace (TEXTSTREAM LOOKSUPDATEFN) of TEXTSTREAM with (FUNCTION + \TEDIT.LOOKS.UPDATE)) + (freplace (LINEDESCRIPTOR CHARLIM) of LINE with TEXTLEN) + (* ; + "Force each new line to find its true CHARLIM.") + (freplace (LINEDESCRIPTOR DIRTY) of LINE with NIL) + (* ; + "And as unchanged since the last formatting.") + (freplace (LINEDESCRIPTOR CHAR1) of LINE with CH#1) + (freplace (LINEDESCRIPTOR CR\END) of LINE with NIL) + (* ; "Assume we won't see a CR.") + (freplace (LINEDESCRIPTOR LHASTABS) of LINE with NIL) + (* ; "And has no TABs.") + (COND + [(COND + ((AND (ILEQ CH#1 TEXTLEN) + (NOT (ZEROP TEXTLEN))) (* ; + "Only continue if there's really text we can format.") + (\SETUPGETCH CH#1 TEXTOBJ) (* ; "Starting place") + (* ; "And starting character looks") + (SETQ CLOOKS (fetch (TEXTSTREAM CURRENTLOOKS) of TEXTSTREAM)) + (COND + ((fetch CLINVISIBLE of CLOOKS) (* ; + "We've hit a run of invisible characters. Skip them, and insert a marker in the line cache") + (add LOOKNO 1) (* ; + "Fix the counter of charlooks changes") + (SETQ PC (fetch (TEXTSTREAM PIECE) of TEXTSTREAM)) + (\EDITSETA LOOKS LOOKNO (SETQ INVISIBLERUNS (fetch (PIECE PLEN) + of PC))) + (\RPLPTR CHLIST 0 LMInvisibleRun) + (\RPLPTR WLIST 0 0) + (add TLEN 1) + (SETQ CHLIST (\ADDBASE CHLIST 2)) + (SETQ WLIST (\ADDBASE WLIST 2)) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) + (AND PC (SETQ CLOOKS (\TEDIT.APPLY.STYLES (ffetch (PIECE PLOOKS) + of PC) + PC TEXTOBJ))) + [while (AND PC (fetch CLINVISIBLE of CLOOKS)) + do (\EDITSETA LOOKS LOOKNO (add INVISIBLERUNS (fetch + (PIECE PLEN) + of PC))) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) + (AND PC (SETQ CLOOKS (\TEDIT.APPLY.STYLES (ffetch (PIECE PLOOKS) + of PC) + PC TEXTOBJ] + (add CHNO (\EDITELT LOOKS LOOKNO)) + (\SETUPGETCH (create EDITMARK + PC _ (OR PC 'LASTPIECE) + PCOFF _ 0 + PCNO _ NIL) + TEXTOBJ))) + (ILEQ CHNO TEXTLEN))) + (replace (LINEDESCRIPTOR LHASPROT) of LINE with (fetch CLPROTECTED + of CLOOKS)) + (* ; + "Remember if the first character on the line is protected.") + (SETQ ORIGFMTSPEC (SETQ FMTSPEC + (\TEDIT.APPLY.PARASTYLES + [OR FMTSPEC (SETQ FMTSPEC (OR (AND (fetch (TEXTSTREAM PIECE) + of TEXTSTREAM) + (fetch (PIECE PPARALOOKS) + of (fetch + (TEXTSTREAM PIECE) + of TEXTSTREAM)) + ) + (fetch (TEXTOBJ FMTSPEC) + of TEXTOBJ] + PC TEXTOBJ))) (* ; "Get the paragraph looks") + (COND + ((NEQ ORIGFMTSPEC *TEDIT-CACHED-FMTSPEC*) + + (* ;; "The cache of character styles for the current paragrpah is invalid; flush it, and note the new paragraph to cache for.") + + (SETQ *TEDIT-CURRENTPARA-CACHE* NIL) + (SETQ *TEDIT-CACHED-FMTSPEC* ORIGFMTSPEC))) + (COND + [(SETQ HARDCOPYMODE (fetch FMTHARDCOPY of FMTSPEC)) + (* ; + "This line is a hardcopy line. Scale things for it.") + [SETQ DEVICE (OR (fetch (TEXTOBJ DISPLAYHCPYDS) of TEXTOBJ) + (replace (TEXTOBJ DISPLAYHCPYDS) of TEXTOBJ + with (OPENIMAGESTREAM '{NODIRCORE} 'INTERPRESS] + (SETQ SCALE (DSPSCALE NIL DEVICE)) + (SETQ FMTSPEC (\TEDIT.HCPYFMTSPEC FMTSPEC DEVICE)) + (SETQ DEFAULTTAB (FIXR (FTIMES 36 SCALE))) + (SETQ LEFTEDGE (FIXR (FTIMES 8 SCALE] + (T (* ; + "Regular line. Format at display resolutions") + (SETQ DEVICE (fetch (TEXTOBJ DISPLAYCACHEDS) of TEXTOBJ)) + (SETQ SCALE 1) + (SETQ LEFTEDGE 8))) + (SETQ TABSPEC (fetch TABSPEC of FMTSPEC)) + [COND + ((type? FONTCLASS (SETQ FONT (fetch CLFONT of CLOOKS))) + (SETQ FONT (FONTCOPY (fetch CLFONT of CLOOKS) + 'DEVICE + 'DISPLAY] (* ; + "Grab the initial font for this line") + [SETQ ASCENTB (SETQ NEWASCENT (IPLUS (fetch \SFAscent of FONT) + (OR (fetch CLOFFSET of CLOOKS) + 0] (* ; + "The initial ascent, per the initial font") + [SETQ DESCENTB (SETQ NEWDESCENT (IDIFFERENCE (fetch \SFDescent of FONT) + (OR (fetch CLOFFSET of CLOOKS) + 0] (* ; + "Initial descent, per the initial font.") + [COND + (HARDCOPYMODE (* ; + "If this is a hardcopy line, fetch the hardcopy version of the font") + (SETQ FONT (FONTCOPY (fetch CLFONT of CLOOKS) + 'DEVICE DEVICE] + (\EDITSETA LOOKS 0 CLOOKS) (* ; "Save looks in the line cache") + [SETQ 1STLN (OR (IEQP CH#1 1) + (AND (fetch (TEXTSTREAM PIECE) of TEXTSTREAM) + (fetch (PIECE PREVPIECE) of (fetch (TEXTSTREAM PIECE) + of TEXTSTREAM)) + (fetch (PIECE PPARALAST) of (fetch (PIECE PREVPIECE) + of (fetch + (TEXTSTREAM PIECE) + of TEXTSTREAM + ))) + (IEQP (fetch (TEXTSTREAM PCSTARTCH) of TEXTSTREAM) + (fetch (STREAM COFFSET) of TEXTSTREAM)) + (IEQP (fetch (TEXTSTREAM PCSTARTPG) of TEXTSTREAM) + (fetch (STREAM CPAGE) of TEXTSTREAM] + (* ; + "If this is the start of a paragraph, mark it so.") + (replace (LINEDESCRIPTOR LMARK) of LINE with NIL) + (* ; + "Start by assuming that we don't want a margin marker for this line.") + (replace (LINEDESCRIPTOR 1STLN) of LINE with 1STLN) + (* ; + "Are we on the first line of a paragraph?") + [COND + (1STLN + (* ;; "This is the first line of a paragraph. Check for special paragraph types, like headings, that get marked in the margin.") + + (COND + ((EQ (fetch FMTPARATYPE of FMTSPEC) + 'PAGEHEADING) + (replace (LINEDESCRIPTOR LMARK) of LINE with 'GREY)) + ((OR (fetch FMTNEWPAGEBEFORE of FMTSPEC) + (fetch FMTNEWPAGEAFTER of FMTSPEC)) + (replace (LINEDESCRIPTOR LMARK) of LINE with 'GREY)) + ([AND (fetch FMTSPECIALX of FMTSPEC) + (NOT (ZEROP (fetch FMTSPECIALX of FMTSPEC] + (replace (LINEDESCRIPTOR LMARK) of LINE with 'GREY)) + ([AND (fetch FMTSPECIALY of FMTSPEC) + (NOT (ZEROP (fetch FMTSPECIALY of FMTSPEC] + (replace (LINEDESCRIPTOR LMARK) of LINE with 'GREY] + [SETQ TX (replace (LINEDESCRIPTOR LEFTMARGIN) of LINE + with (IPLUS [FIXR (FTIMES SCALE (IPLUS 8 (fetch (TEXTOBJ WLEFT) + of TEXTOBJ] + (COND + (1STLN (fetch 1STLEFTMAR of FMTSPEC)) + (T (fetch LEFTMAR of FMTSPEC] + (* ; "Set the left margin accordingly") + [replace (LINEDESCRIPTOR RIGHTMARGIN) of LINE + with (SETQ WIDTH (COND + ((NOT (ZEROP (fetch RIGHTMAR of FMTSPEC))) + (IPLUS LEFTEDGE (fetch RIGHTMAR of FMTSPEC))) + (T (FIXR (FTIMES SCALE (IDIFFERENCE (fetch (TEXTOBJ + WRIGHT) + of TEXTOBJ) + 8] + (* ; + "RIGHTMAR = 0 => follow the window's width.") + (SETQ TXB1 WIDTH) + (for old TLEN from TLEN to 254 as old CHNO from CHNO + while (ILEQ CHNO TEXTLEN) when (SETQ CH (\BIN TEXTSTREAM)) + do (* ; "(The WHILE is there because we may reset TEXTLEN within the loop, and TO TEXTLEN only evaluates it once.)") + + (* ;; "The character loop") + + (* ;; "Get the next character for the line.") + + [SETQ DX (COND + [(SMALLP CH) (* ; "CH is really a character") + (COND + ((AND (IGEQ CH 192) + (ILEQ CH 207)) (* ; + "This is an NS accent character. Space it 0.") + (SETQ DX 0)) + (T (* ; + "Regular character. Get it's width.") + (\FGETCHARWIDTH FONT CH] + (T (* ; "CH is an object") + (SETQ BOX (APPLY* (IMAGEOBJPROP CH 'IMAGEBOXFN) + CH DS TX WIDTH)) + (* ; "Get its size") + (SETQ NEWASCENT (IDIFFERENCE (fetch YSIZE of BOX) + (fetch YDESC of BOX))) + (SETQ NEWDESCENT (fetch YDESC of BOX)) + (IMAGEOBJPROP CH 'BOUNDBOX BOX) + (COND + ([NEQ 1 (fetch (PIECE PLEN) of (SETQ PC + (fetch + (TEXTSTREAM PIECE) + of TEXTSTREAM + ] + + (* ;; "The object is several chars wide, but doesn't have a subsidiary stream to pull those chars from. Build an invisible run to fill the space.") + + (add LOOKNO 1) (* ; + "Fix the counter of charlooks changes") + (\EDITSETA LOOKS LOOKNO (SUB1 (fetch (PIECE PLEN) + of PC))) + (\RPLPTR CHLIST 0 LMInvisibleRun) + (* ; + "Note the existence of an invisible run of characters here.") + (\RPLPTR WLIST 0 0) + (add TLEN 1) + (SETQ CHLIST (\ADDBASE CHLIST 2)) + (SETQ WLIST (\ADDBASE WLIST 2)) + (add CHNO (SUB1 (fetch (PIECE PLEN) of PC))) + (add INVISIBLERUNS (\EDITELT LOOKS LOOKNO)) + (* ; + "Keep track of how much invisible text we cross over") + )) + (COND + [HARDCOPYMODE (FIXR (FTIMES SCALE (fetch XSIZE + of BOX] + (T (fetch XSIZE of BOX] + (* ; "Get CH's X width.") + [SELCHARQ CH + (SPACE (* ; + "CH is a . Remember it, in case we need to break the line.") + (COND + (GATHERBLANK (SETQ TXB1 TX) + (SETQ GATHERBLANK NIL))) + (SETQ CH#B CHNO) (* ; + "put the location # of the previous space/tab in the character array instead of the space itself") + (\RPLPTR CHLIST 0 PREVSP) + (\RPLPTR WLIST 0 DX) + (SETQ PREVSP (ADD1 TLEN)) + (SETQ T1SPACE T) + (SETQ PREVDHYPH NIL) + (SETQ PREVHYPH NIL) (* ; + "We're now past needing any hyphens for line breaking, so forget the last hyphen spot.") + (add TX DX) + (SETQ TXB TX) + (SETQ DXB DX) + (SETQ LOOK#B LOOKNO) + (COND + (NEWASCENT (* ; + "The ascent has changed; catch it") + (SETQ ASCENT (IMAX ASCENT NEWASCENT)) + (SETQ DESCENT (IMAX DESCENT NEWDESCENT)) + (SETQ NEWASCENT NIL))) + (SETQ ASCENTB ASCENT) + (SETQ DESCENTB DESCENT) + (SETQ INVISIBLERUNSB INVISIBLERUNS) + (add %#BLANKS 1)) + (CR (* ; + "Ch is a . Force an end to the line.") + (freplace (LINEDESCRIPTOR CHARLIM) of LINE with CHNO) + (COND + ((AND NEWASCENT (ZEROP ASCENT) + (ZEROP DESCENT)) (* ; + "The ascent has changed; catch it") + (SETQ ASCENT NEWASCENT) + (SETQ DESCENT NEWDESCENT))) + (SETQ FORCEEND T) + (SETQ PREVDHYPH NIL) + (SETQ PREVHYPH NIL) (* ; + "We're now past needing any hyphens for line breaking, so forget the last hyphen spot.") + (\RPLPTR CHLIST 0 (CHARCODE CR)) + (\RPLPTR WLIST 0 (SETQ DX (IMAX DX 6))) + (COND + (GATHERBLANK (SETQ TXB1 TX) + (SETQ GATHERBLANK NIL))) + (SETQ T1SPACE T) + (freplace (LINEDESCRIPTOR CR\END) of LINE with T) + (SETQ TX (IPLUS TX DX)) + (replace (LINEDESCRIPTOR LSTLN) of LINE with T) + (* ; + "This has to be done better when we get non-para breaking CRs.") + (RETURN)) + (TAB + (* ;; "Try to be reasonable with tabs. This will create trouble when doing fast-case insert/delete, but Pah! for now.") + + (replace (LINEDESCRIPTOR LHASTABS) of LINE with T) + (* ; "To disable smart screen update") + (COND + (NEWASCENT (* ; + "The ascent has changed; catch it") + (SETQ ASCENT (IMAX ASCENT NEWASCENT)) + (SETQ DESCENT (IMAX DESCENT NEWDESCENT)) + (SETQ NEWASCENT NIL))) + (\RPLPTR CHLIST 0 CH) + (SETQ TABPENDING + (\TEDIT.FORMATTABS TEXTOBJ TABSPEC THISLINE CHLIST WLIST TX + DEFAULTTAB LEFTEDGE TABPENDING 0 NIL)) + (* ; + "Figure out which tab stop to use, and what we need to do to get there.") + [COND + ((FIXP TABPENDING) (* ; + "If it returns a number, that is the new TX, adjusted for any prior tabs") + (SETQ TX TABPENDING) + (SETQ TABPENDING NIL)) + (TABPENDING (* ; + "Otherwise, look in the PENDINGTAB for the new TX") + (SETQ TX (fetch PTNEWTX of TABPENDING] + (COND + (GATHERBLANK (SETQ TXB1 TX) + (SETQ GATHERBLANK NIL))) + (SETQ CH#B CHNO) + (SETQ DX (\GETBASEPTR WLIST 0)) + (\TEDIT.PURGE.SPACES (fetch (THISLINE CHARS) of THISLINE + ) + PREVSP) (* ; + "All the spaces before a tab don't take part in justification from here on.") + (SETQ %#BLANKS 0) (* ; + "Also reset the count of spaces on this line, so we widen later spaces enough.") + (SETQ PREVSP 0) + (SETQ T1SPACE T) + (SETQ TX (IPLUS TX DX)) + (SETQ TXB TX) (* ; + "Remember the world in case this is the 'space' before the line breaks") + (SETQ DXB DX) + (SETQ LOOK#B LOOKNO) + (SETQ ASCENTB ASCENT) + (SETQ DESCENTB DESCENT) + (SETQ PREVDHYPH NIL) + (SETQ PREVHYPH NIL) (* ; + "We're now past needing any hyphens for line breaking, so forget the last hyphen spot.") + (SETQ INVISIBLERUNSB INVISIBLERUNS)) + (PROGN (COND + ((AND (EQ CH (CHARCODE "0,377")) + (NOT (ffetch (TEXTOBJ TXTNONSCHARS) of TEXTOBJ))) + + (* ;; + "Character-set change character. This suggests undetected NS characters.") + + (\TEDIT.NSCHAR.RUN CHNO TEXTOBJ TEXTSTREAM) + (* ; + "Leaves us ready to BIN again at the same place.") + + (* ;; "Back up the cache pointers and counters so that when we go to the top of the loop we're where we are now.") + + (SETQ CHLIST (\ADDBASE CHLIST -2)) + (SETQ WLIST (\ADDBASE WLIST -2)) + (add CHNO -1) + (add TLEN -1) + (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (* ; + "Because moving to NS characters changes the TEXTLEN for the shorter.") + ) + (T + (* ;; "Not a formatting character, so gather") + + (SETQ GATHERBLANK T)(* ; "Blanks are interesting again.") + (COND + ((IGREATERP (SETQ TX (IPLUS TX DX)) + WIDTH) (* ; + "We're past the right margin; stop formatting at the last blank.") + (SETQ FORCEEND T) + [COND + (PREVDHYPH (* ; + "There's a hyphen we can break at. Go back there and break the line.") + (freplace (LINEDESCRIPTOR CHARLIM) + of LINE with CH#B) + (\RPLPTR ORIGCHLIST (LLSH (SUB1 PREVDHYPH) + 1) + (CHARCODE "-")) + (\RPLPTR ORIGWLIST (LLSH (SUB1 PREVDHYPH) + 1) + (\FGETCHARWIDTH FONT (CHARCODE "-"))) + (SETQ TX TXB) + (SETQ DX DXB) + (SETQ ASCENT ASCENTB) + (SETQ DESCENT DESCENTB) + (SETQ LOOKNO LOOK#B) + (SETQ INVISIBLERUNS INVISIBLERUNSB)) + (PREVHYPH (* ; + "There's a hyphen we can break at. Go back there and break the line.") + (freplace (LINEDESCRIPTOR CHARLIM) + of LINE with CH#B) + (SETQ TX TXB) + (SETQ DX DXB) + (SETQ ASCENT ASCENTB) + (SETQ DESCENT DESCENTB) + (SETQ LOOKNO LOOK#B) + (SETQ INVISIBLERUNS INVISIBLERUNSB)) + (T1SPACE (* ; + "There's a breaking point on this line. Go back there and break the line.") + (freplace (LINEDESCRIPTOR CHARLIM) + of LINE with CH#B) + (SETQ TX TXB) + (SETQ DX DXB) + (SETQ ASCENT ASCENTB) + (SETQ DESCENT DESCENTB) + (SETQ LOOKNO LOOK#B) + (SETQ INVISIBLERUNS INVISIBLERUNSB)) + ((IGREATERP TLEN 0) + (freplace (LINEDESCRIPTOR CHARLIM) of LINE + with (IMAX (SUB1 CHNO) + CH#1)) + (SETQ TX (IDIFFERENCE TX DX)) + (* ; + "No spaces on this line; break it before this character.") + + (* ;; "Check line break character.") + + (while (OR (MEMBER (\GETBASEPTR CHLIST -2) + TEDIT.DONT.LAST.CHARS) + (MEMBER CH TEDIT.DONT.BREAK.CHARS)) + do + + (* ;; + "This character ch doesn't appear at first of lines. or") + + (* ;; + "Previous character doesn't appear at the end of lines.") + + (* ;; + "So,move previous character to next line.") + + (SETQ CHLIST (\ADDBASE CHLIST -2)) + (SETQ WLIST (\ADDBASE WLIST -2)) + (add TLEN -1) + (add CHNO -1) + (SETQ CH (\GETBASEPTR CHLIST 0))) + (freplace (LINEDESCRIPTOR CHARLIM) of LINE + with (IMAX (SUB1 CHNO) + CH#1))) + (T (* ; + "Can't split BEFORE the first thing on the line!") + (freplace (LINEDESCRIPTOR CHARLIM) + of LINE with CHNO) + (\RPLPTR CHLIST 0 CH) + (\RPLPTR WLIST 0 DX) + (COND + (NEWASCENT + (* ; + "The ascent has changed; catch it") + (SETQ ASCENT (IMAX ASCENT NEWASCENT)) + (SETQ DESCENT (IMAX DESCENT NEWDESCENT)) + (SETQ NEWASCENT NIL] + (RETURN)) + (T (* ; "Not past the rightmargin yet...") + (COND + (NEWASCENT (* ; + "The ascent has changed; catch it") + (SETQ ASCENT (IMAX ASCENT NEWASCENT)) + (SETQ DESCENT (IMAX DESCENT NEWDESCENT)) + (SETQ NEWASCENT NIL))) + (\RPLPTR CHLIST 0 CH) + (\RPLPTR WLIST 0 DX) + (SELCHARQ CH + (%. (* ; "Check for decimal tabs") + (COND + ((AND TABPENDING (NOT (FIXP TABPENDING)) + (EQ (fetch PTTYPE of + TABPENDING + ) + 'DECIMAL)) + (* ; + "Figure out which tab stop to use, and what we need to do to get there.") + (add (fetch (PENDINGTAB PTTABX) + of TABPENDING) + DX) + (* ; + "Adjust the tab stop's X value so that the LEFT edge of the decimal point goes there.") + (SETQ TABPENDING + (\TEDIT.FORMATTABS TEXTOBJ TABSPEC + THISLINE CHLIST WLIST TX + DEFAULTTAB LEFTEDGE TABPENDING 0 + T)) + (* ; + "Tab over to the LEFT side of the decimal point.") + [COND + ((FIXP TABPENDING) + (* ; + "If it returns a number, that is the new TX, adjusted for any prior tabs") + (SETQ TX TABPENDING) + (SETQ TABPENDING NIL)) + (TABPENDING + (* ; + "Otherwise, look in the PENDINGTAB for the new TX") + (SETQ TX (fetch PTNEWTX + of TABPENDING] + (COND + (GATHERBLANK (SETQ TXB1 TX) + (SETQ GATHERBLANK NIL))) + (SETQ CH#B CHNO) + (\TEDIT.PURGE.SPACES + (fetch (THISLINE CHARS) of + THISLINE) + PREVSP) + (* ; + "All the spaces before a tab don't take part in justification from here on.") + (SETQ %#BLANKS 0) + (* ; + "Also reset the count of spaces on this line, so we widen later spaces enough.") + (SETQ PREVSP 0) + (SETQ T1SPACE T) + (SETQ TXB TX) + (* ; + "Remember the world in case this is the 'space' before the line breaks") + (SETQ DXB DX) + (SETQ LOOK#B LOOKNO) + (SETQ ASCENTB ASCENT) + (SETQ DESCENTB DESCENT) + (SETQ INVISIBLERUNSB INVISIBLERUNS)))) + ((- "357,045") + (* ; "Hyphen, M-dash") + (SETQ PREVHYPH (ADD1 TLEN)) + (SETQ PREVDHYPH NIL) + (SETQ TXB1 (SETQ TXB TX)) + (SETQ DXB DX) + (SETQ LOOK#B LOOKNO) + (SETQ CH#B CHNO) + (SETQ ASCENTB ASCENT) + (SETQ DESCENTB DESCENT) + (SETQ INVISIBLERUNSB INVISIBLERUNS)) + ("357,042" + (* ; "non-breaking hyphen") + (\RPLPTR CHLIST 0 (CHARCODE "-"))) + ("357,043" + (* ; "Discretionary hyphen") + (* ; "And isn't actually displayed.") + (SETQ PREVDHYPH (ADD1 TLEN)) + (SETQ PREVHYPH NIL) + (SETQ TXB1 (SETQ TXB TX)) + (SETQ DXB DX) + (SETQ LOOK#B LOOKNO) + (SETQ CH#B CHNO) + (SETQ ASCENTB ASCENT) + (SETQ DESCENTB DESCENT) + (\RPLPTR WLIST 0 0) + (* ; + "Unless we use it, the prevhyph is 0 wide.") + (\RPLPTR CHLIST 0 NIL) + (add TX (IMINUS DX)) + (SETQ INVISIBLERUNSB INVISIBLERUNS)) + ("357,041" + (* ; "non-breaking space.")) + NIL] + (SETQ CHLIST (\ADDBASE CHLIST 2)) (* ; + "Move the pointers forward for the next character.") + (SETQ WLIST (\ADDBASE WLIST 2))) (* ; "End of char loop") + (COND + ((AND (IEQP TLEN 255) + (ILESSP CHNO TEXTLEN)) (* ; + "This line is too long for us to format??") + (TEDIT.PROMPTPRINT TEXTOBJ "Line too long to format." T))) + (COND + (TABPENDING (* ; + "There is a TAB outstanding. Go handle it.") + (add (fetch (PENDINGTAB PTTABX) of TABPENDING) + DX) (* ; + "Adjust the tab stop's X value so that the LEFT edge of the CR goes there.") + (SETQ TABPENDING + (\TEDIT.FORMATTABS TEXTOBJ TABSPEC THISLINE CHLIST WLIST TX DEFAULTTAB + LEFTEDGE TABPENDING 0 T)) + + (* ;; "Finish up processing the outstanding TAB. We get back the new X position, with that taken into account.") + + (SETQ TX TABPENDING) + (SETQ TABPENDING NIL) + (\TEDIT.PURGE.SPACES (fetch (THISLINE CHARS) of THISLINE) + PREVSP) (* ; + "Don't use the spaces before the TAB in justification.") + (SETQ PREVSP 0] + (T (* ; + "No text to go in this line; set Ascent/Descent to the default font from the window.") + [SETQ PC (AND (IGREATERP TEXTLEN 0) + (\CHTOPC TEXTLEN (fetch (TEXTOBJ PCTB) of TEXTOBJ] + (* ; + "Grab the last real part of the document, to get paragraph looks") + (\EDITSETA LOOKS 0 CLOOKS) (* ; + "Set up the initial looks so that \DISPLAYLINE doesn't complain") + (SETQ FONT (OR (AND (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) + (fetch CLFONT of (fetch (TEXTOBJ CARETLOOKS) + of TEXTOBJ))) + (AND (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) + (fetch CLFONT of (fetch (TEXTOBJ DEFAULTCHARLOOKS) + of TEXTOBJ))) + DEFAULTFONT)) + + (* ;; "The font we use is preferably the caret looks, else the default for this edit, else the system default") + + (SETQ ASCENT (FONTPROP FONT 'ASCENT)) + (SETQ DESCENT (FONTPROP FONT 'DESCENT)) + (SETQ FMTSPEC (OR FMTSPEC (AND PC (fetch (PIECE PPARALOOKS) of PC)) + (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ))) + (* ; + "Use the preceding paragraph's looks") + (SETQ 1STLN (OR (NOT PC) + (fetch (PIECE PPARALAST) of PC))) + (replace (LINEDESCRIPTOR 1STLN) of LINE with 1STLN) + [SETQ TX (COND + [1STLN (replace (LINEDESCRIPTOR LEFTMARGIN) of LINE + with (IPLUS 8 (fetch (TEXTOBJ WLEFT) of TEXTOBJ) + (fetch 1STLEFTMAR of FMTSPEC] + (T (replace (LINEDESCRIPTOR LEFTMARGIN) of LINE + with (IPLUS 8 (fetch (TEXTOBJ WLEFT) of TEXTOBJ) + (fetch LEFTMAR of FMTSPEC] + [replace (LINEDESCRIPTOR RIGHTMARGIN) of LINE + with (SETQ WIDTH (COND + ((NOT (ZEROP (fetch RIGHTMAR of FMTSPEC))) + (fetch RIGHTMAR of FMTSPEC)) + (T (IDIFFERENCE (fetch (TEXTOBJ WRIGHT) of TEXTOBJ + ) + 8] + (SETQ TXB1 WIDTH))) + [COND + ((ZEROP (freplace (LINEDESCRIPTOR LHEIGHT) of LINE with (IPLUS ASCENT + DESCENT))) + (replace (LINEDESCRIPTOR LHEIGHT) of LINE + with (FONTPROP (OR (AND (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ) + (fetch CLFONT of (fetch (TEXTOBJ + DEFAULTCHARLOOKS + ) + of TEXTOBJ))) + DEFAULTFONT) + 'HEIGHT] (* ; + "Line's height (or 12 for an empty line)") + (replace (LINEDESCRIPTOR ASCENT) of LINE with ASCENT) + (replace (LINEDESCRIPTOR DESCENT) of LINE with DESCENT) + (freplace (LINEDESCRIPTOR CHARTOP) of LINE with CHNO) + [COND + (FORCEEND NIL) + (T (SETQ CHNO (SUB1 CHNO)) + (SETQ TLEN (SUB1 TLEN] (* ; + "If we ran off the end of the text, then keep true space left on the line.") + (freplace (LINEDESCRIPTOR LXLIM) of LINE with TX) + [freplace (LINEDESCRIPTOR SPACELEFT) of LINE with (COND + (FORCEEND + (* ; + "The line was forced to end. Back up to start of last blank section") + (IDIFFERENCE WIDTH + TXB1)) + (GATHERBLANK + (* ; + "Otherwise, use the rightmost character on the line.") + (IDIFFERENCE WIDTH + TX)) + (T + + (* ;; "The line ended with a run of white space. Ignore it for purposes of deciding how much more we can fit on the line.") + + (IDIFFERENCE WIDTH TXB1 + ] + (freplace (THISLINE DESC) of THISLINE with LINE) + [freplace (THISLINE LEN) of THISLINE + with (IMIN 254 (COND + ((ILESSP TEXTLEN CH#1) + -1) + (T (IPLUS LOOKNO (IDIFFERENCE (IMIN (fetch (LINEDESCRIPTOR + CHARLIM) + of LINE) + TEXTLEN) + (IPLUS INVISIBLERUNS (fetch + (LINEDESCRIPTOR + CHAR1) of + LINE] + (\DOFORMATTING TEXTOBJ LINE (OR ORIGFMTSPEC FMTSPEC) + THISLINE %#BLANKS PREVSP 1STLN) + (replace (LINEDESCRIPTOR LFMTSPEC) of LINE with FMTSPEC) + (replace (TEXTSTREAM LOOKSUPDATEFN) of TEXTSTREAM with NIL) + (RETURN LINE]) + +(\TEDIT.NSCHAR.RUN + [LAMBDA (CHNO TEXTOBJ STREAM) (* ; "Edited 29-Apr-93 16:42 by jds") + + (* ;; "Given that we've just BIN'd from TEXTOBJ at character # CHNO and it was a 255, rearrange the piece table so that NS characters are available transparently %"as far ahead as makes sense%".") + + (* ;; "Leave TEXTOBJ ready to BIN at CHNO again, so the line formatter can carry on.") + + (LET* [(PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + PC START-OF-PIECE OFFSET PLEN CH NEXTCH PFPOS NEWPC NEWPLEN PF PS CHARSET TFILE + (OLDFILEPTR (SUB1 (GETFILEPTR STREAM] + (SETQ PC (\CHTOPC CHNO PCTB T)) + (SETQ OFFSET (- CHNO START-OF-PIECE)) + (SETQ PLEN (fetch (PIECE PLEN) of PC)) + (COND + ((fetch (PIECE PFATP) of PC) + (HELP "Hit charset change in a FAT piece"))) + (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) + (* ; + "This rearranges the piece table, so later insertions better use a fresh piece.") + (* ; "Back up over the 255") + (SETQ CH (BIN STREAM)) + [COND + [(IEQP CH 255) (* ; "A steady run of fat characters.") + (COND + ((SETQ PS (fetch (PIECE PSTR) of PC)) + (* ; "This piece is in a string.") + (HELP "NS characters in a STRING??")) + ((SETQ PF (fetch (PIECE PFILE) of PC)) + (* ; "This piece is in a file.") + (SETQ PFPOS (fetch (PIECE PFPOS) of PC)) + (SETQ NEXTCH (FFILEPOS (MKSTRING (CHARACTER 255)) + PF + (IPLUS OFFSET PFPOS 3) + (IPLUS PFPOS PLEN))) (* ; + "Find the succeeding 255, or end of piece.") + [SETQ NEWPLEN (COND + (NEXTCH (IQUOTIENT (IDIFFERENCE NEXTCH (IPLUS PFPOS OFFSET 3)) + 2)) + (T (IQUOTIENT (IDIFFERENCE (IDIFFERENCE PLEN OFFSET) + 3) + 2] + (\DELETECH (IPLUS START-OF-PIECE OFFSET) + (IPLUS START-OF-PIECE OFFSET 5 (ITIMES NEWPLEN 2)) + (IPLUS 5 (ITIMES NEWPLEN 2)) + TEXTOBJ T) + (\TEDIT.INSERT.PIECES TEXTOBJ (IPLUS START-OF-PIECE OFFSET) + (create PIECE using PC PFILE _ PF PFPOS _ (IPLUS PFPOS OFFSET 3) + PFATP _ T PSTR _ NIL PLEN _ NEWPLEN) + NEWPLEN NIL NIL NIL T) + (add (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) + NEWPLEN] + (T (* ; + "Changing to a new character set for succeeding characters.") + (COND + ((SETQ PS (fetch (PIECE PSTR) of PC)) + (* ; "This piece is in a string.") + (HELP "NS characters in a STRING??")) + ((SETQ PF (fetch (PIECE PFILE) of PC)) + (* ; "This piece is in a file.") + (SETQ CHARSET CH) + (SETQ PFPOS (fetch (PIECE PFPOS) of PC)) + (SETQ NEXTCH (FFILEPOS (MKSTRING (CHARACTER 255)) + PF + (IPLUS OFFSET PFPOS 2) + (IPLUS PFPOS PLEN))) (* ; + "Find the succeeding 255, or end of piece.") + [SETQ NEWPLEN (COND + ((ZEROP CHARSET) (* ; "If we're moving back to charset 0, we just want to delete the charset change marker, so the newPlen is 0.") + 0) + (NEXTCH (IDIFFERENCE NEXTCH (IPLUS OFFSET PFPOS 2))) + (T (IDIFFERENCE (IDIFFERENCE PLEN OFFSET) + 2] + (\DELETECH (IPLUS START-OF-PIECE OFFSET) + (IPLUS START-OF-PIECE OFFSET 2 NEWPLEN) + (IPLUS NEWPLEN 2) + TEXTOBJ T) + (COND + ((ZEROP NEWPLEN) (* ; + "Do nothing if there weren't really any characters to be put in the new character set.") + ) + ((ZEROP CHARSET) (* ; + "Do nothing if we're switching back to normal character.") + ) + (T (* ; "There really are characters to be moved to the new character set. Create the temporary file for them.") + + (* ;; "Create the file") + + (SETQ TFILE (OPENSTREAM '{NODIRCORE} 'BOTH)) + (SETFILEPTR PF (IPLUS OFFSET PFPOS 2)) + (for I from 1 to NEWPLEN do + + (* ;; + "Copy the newly fattened characters into the temp file.") + + (BOUT TFILE CHARSET) + (BOUT TFILE (BIN PF))) + + (* ;; "Insert a new piece in the document holding the fat characters.") + + (\TEDIT.INSERT.PIECES TEXTOBJ (IPLUS START-OF-PIECE OFFSET) + (create PIECE + using PC PFILE _ TFILE PFPOS _ 0 PFATP _ T PSTR _ NIL PLEN _ + NEWPLEN) + 1 NIL NIL NIL T) + (add (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) + NEWPLEN] + (\SETUPGETCH CHNO TEXTOBJ]) + +(\TEDIT.PURGE.SPACES + (LAMBDA (CHLIST PREVSP) (* jds " 9-NOV-83 17:12") + (bind OPREVSP while (IGREATERP PREVSP 0) do (SETQ OPREVSP (SUB1 PREVSP)) + (SETQ PREVSP (\EDITELT CHLIST OPREVSP)) + (\EDITSETA CHLIST OPREVSP (CONSTANT (CHARCODE SPACE)) + )))) + +(\DOFORMATTING + [LAMBDA (TEXTOBJ LINE FMTSPEC THISLINE %#BLANKS PREVSP 1STLN) + (* ; "Edited 29-Mar-94 12:36 by jds") + (* ; + "Do the formatting work for justified, centered, etc. lines") + (PROG ((QUAD (fetch QUAD of FMTSPEC)) + (SPACELEFT (LLSH (fetch (LINEDESCRIPTOR SPACELEFT) of LINE) + 5)) + (EXISTINGSPACE 0) + (CHLIST (fetch (THISLINE CHARS) of THISLINE)) + (WLIST (fetch (THISLINE WIDTHS) of THISLINE)) + (SPACEOFLOW 0) + EXTRASP OPREVSP LINELEAD) (* ; + "NB that SPACELEFT, OFLOW, etc. are kept in 32 x value form, for rounding ease.") + (replace (LINEDESCRIPTOR LTRUEDESCENT) of LINE with (fetch (LINEDESCRIPTOR + DESCENT) + of LINE)) + (replace (LINEDESCRIPTOR LTRUEASCENT) of LINE with (fetch (LINEDESCRIPTOR + ASCENT) + of LINE)) + (* ; + "Save the true ascent value for display purposes") + (replace (THISLINE TLSPACEFACTOR) of THISLINE with 1) + (* ; + "Start by assuming that we want a space factor of 1.0") + [COND + ((SETQ LINELEAD (fetch LINELEAD of FMTSPEC)) + (* ; + "If line leading was specified, set it") + (COND + (T (add (fetch (LINEDESCRIPTOR LHEIGHT) of LINE) + (fetch LINELEAD of FMTSPEC)) + (* ; + "And adjust the line's descent accordingly") + (add (fetch (LINEDESCRIPTOR DESCENT) of LINE) + (fetch LINELEAD of FMTSPEC] + [COND + ((AND 1STLN (fetch LEADBEFORE of FMTSPEC)) + (* ; + "If paragraph pre-leading was specified, set it") + (add (fetch (LINEDESCRIPTOR LHEIGHT) of LINE) + (fetch LEADBEFORE of FMTSPEC)) (* ; + "And adjust the line's ascent accordingly.") + (add (fetch (LINEDESCRIPTOR ASCENT) of LINE) + (fetch LEADBEFORE of FMTSPEC] + [COND + ((AND (fetch (LINEDESCRIPTOR LSTLN) of LINE) + (fetch LEADAFTER of FMTSPEC)) (* ; + "If paragraph pre-leading was specified, set it") + (add (fetch (LINEDESCRIPTOR LHEIGHT) of LINE) + (fetch LEADAFTER of FMTSPEC)) (* ; + "And adjust the line's ascent accordingly.") + (add (fetch (LINEDESCRIPTOR DESCENT) of LINE) + (fetch LEADAFTER of FMTSPEC] + (SELECTQ QUAD + (LEFT (* ; + "Do nothing for left-justified lines except replace the character codes")) + (RIGHT (* ; "Just move the right margin over") + (replace (LINEDESCRIPTOR LEFTMARGIN) of LINE + with (IPLUS (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE) + (fetch (LINEDESCRIPTOR SPACELEFT) of LINE))) + (replace (LINEDESCRIPTOR LXLIM) of LINE with (fetch ( + LINEDESCRIPTOR + RIGHTMARGIN + ) + of LINE)) + (COND + ((OR (ILESSP (fetch (THISLINE LEN) of THISLINE) + 0) + (ZEROP %#BLANKS) + (ZEROP PREVSP)) (* ; + "For empty lines, and lines with no spaces, don't bother fixing blank widths.") + (RETURN)))) + (CENTERED (* ; + "Split the difference for centering") + (add (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE) + (LRSH SPACELEFT 6)) + (add (fetch (LINEDESCRIPTOR LXLIM) of LINE) + (LRSH SPACELEFT 6)) + (COND + ((OR (ILESSP (fetch (THISLINE LEN) of THISLINE) + 0) + (ZEROP %#BLANKS) + (ZEROP PREVSP)) (* ; + "For empty lines, and lines with no spaces, don't bother fixing blank widths.") + (RETURN)))) + (JUSTIFIED (* ; + "For justified lines, stretch each space so line reaches the right margin") + (COND + ((OR (ILESSP (fetch (THISLINE LEN) of THISLINE) + 0) + (ZEROP %#BLANKS) + (ZEROP PREVSP)) (* ; + "For empty lines, and lines with no spaces, don't bother fixing blank widths.") + (RETURN))) + (COND + ((OR (fetch (LINEDESCRIPTOR CR\END) of LINE) + (IGEQ (fetch (LINEDESCRIPTOR CHARLIM) of LINE) + (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) + (* ; + "This is the last line in the paragraph; don't stretch it out.") + (SETQ EXTRASP 0)) + ((IEQP PREVSP (ADD1 (fetch (THISLINE LEN) of THISLINE))) + (* ; + "Only if the last character on the line is a space should we remove trailing spaces from the list") + (bind (OPREVSP _ (SUB1 PREVSP)) while (AND (IGREATERP PREVSP 0) + (ILEQ OPREVSP PREVSP) + ) + do + + (* ;; "Back up over all trailing white space on the line. So that those blanks don't get counted when computing the space to be added to each REAL space on the line, when it is justified.") + + (SETQ OPREVSP (SUB1 PREVSP)) + (SETQ PREVSP (\EDITELT CHLIST OPREVSP)) + (\EDITSETA CHLIST OPREVSP (CONSTANT (CHARCODE SPACE))) + (add %#BLANKS -1)) + (COND + ((ZEROP %#BLANKS) (* ; + "If there aren't any blanks except at end-of-line, don't bother going further.") + (RETURN))) + (replace (LINEDESCRIPTOR LXLIM) of LINE + with (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE)) + (* ; + "Fix the right margin for showing selections &c") + (SETQ EXTRASP (IQUOTIENT SPACELEFT %#BLANKS)) + (* ; + "Now apportion the extra space evenly among blanks.") + ) + (T + (* ;; + "NO SPACE AT END OF LINE -- LINE ENDS IN HYPHEN, ETC, OR MAYBE IS TOO LONG WITH NO SPACES.") + + (COND + ((ZEROP %#BLANKS) (* ; + "If there aren't any blanks, don't bother going further.") + (RETURN))) + (replace (LINEDESCRIPTOR LXLIM) of LINE + with (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE)) + (* ; + "Fix the right margin for showing selections &c") + (SETQ EXTRASP (IQUOTIENT SPACELEFT %#BLANKS)) + (* ; + "Now apportion the extra space evenly among blanks.") + )) + [while (IGREATERP PREVSP 0) + do (* ; + "Fix up the widths of spaces in the line") + (SETQ OPREVSP (SUB1 PREVSP)) + (SETQ PREVSP (\EDITELT CHLIST OPREVSP)) + (add EXISTINGSPACE (\EDITELT WLIST OPREVSP)) + (\EDITSETA CHLIST OPREVSP (CONSTANT (CHARCODE SPACE))) + [OR (fetch (LINEDESCRIPTOR CR\END) of LINE) + (\EDITSETA WLIST OPREVSP (IPLUS (LRSH (IPLUS EXTRASP SPACEOFLOW + ) + 5) + (\EDITELT WLIST OPREVSP] + (SETQ SPACEOFLOW (LOGAND 31 (IPLUS EXTRASP SPACEOFLOW] + (COND + ([AND (NOT (ZEROP EXISTINGSPACE)) + (OR (NOT (ZEROP EXTRASP)) + (NOT (ZEROP (fetch (LINEDESCRIPTOR SPACELEFT) of LINE] + (* ; "Only if we really expanded the line -- and there are spaces to expand (or else EXISTINGSPACE is 0).") + (replace (THISLINE TLSPACEFACTOR) of THISLINE + with (FQUOTIENT (IPLUS EXISTINGSPACE (fetch (LINEDESCRIPTOR + SPACELEFT) + of LINE)) + EXISTINGSPACE)) + (* ; + "And set the space factor for display") + ) + (T (* ; "Pathological cases ") + (replace (THISLINE TLSPACEFACTOR) of THISLINE with 1))) + (RETURN)) + NIL) + (\TEDIT.PURGE.SPACES CHLIST PREVSP) (* ; +"Change all the spaces--chained for justification--back into regular spaces, for the display code.") + ]) +) +(DEFINEQ + +(\DISPLAYLINE + [LAMBDA (TEXTOBJ LINE WINDOW) (* ; "Edited 29-Mar-94 15:26 by jds") + + (* ;; "Display the line of text LINE in the edit window where it belongs.") + + (PROG ((CH 0) + (CHLIST (fetch (THISLINE CHARS) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ))) + (WLIST (fetch (THISLINE WIDTHS) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ))) + (LOOKS (fetch (THISLINE LOOKS) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ))) + (WINDOWDS (WINDOWPROP (OR WINDOW (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ))) + 'DSP)) + (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (THISLINE (fetch (TEXTOBJ THISLINE) of TEXTOBJ)) + (TERMSA (fetch (TEXTOBJ TXTTERMSA) of TEXTOBJ)) + (STREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) + (OLDCACHE (fetch LCBITMAP of (fetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ))) + (DS (fetch (TEXTOBJ DISPLAYCACHEDS) of TEXTOBJ)) + (HCPYDS (fetch (TEXTOBJ DISPLAYHCPYDS) of TEXTOBJ)) + (HARDCOPYMODE (fetch (FMTSPEC FMTHARDCOPY) of (fetch (LINEDESCRIPTOR LFMTSPEC) + of LINE))) + LOOKSTARTX CACHE \PCHARSLEFT \PSTRING \PFILE FONT OFONT OLOOKS XOFFSET CLIPLEFT CLIPRIGHT + DISPLAYDATA DDPILOTBBT DDWIDTHCACHE DDOFFSETCACHE CURY LHEIGHT SCALE) + [SETQ LHEIGHT (COND + ((fetch (LINEDESCRIPTOR PREVLINE) of LINE) + (* ; + "So if theres a base-to-base measure, we clear everything right.") + (IMAX (IDIFFERENCE (fetch (LINEDESCRIPTOR YBOT) + of (fetch (LINEDESCRIPTOR PREVLINE) + of LINE)) + (fetch (LINEDESCRIPTOR YBOT) of LINE)) + (fetch (LINEDESCRIPTOR LHEIGHT) of LINE))) + (T (fetch (LINEDESCRIPTOR LHEIGHT) of LINE] + (COND + (HARDCOPYMODE (* ; + "This is a hardcopy-mode line. Scale things.") + (* ; "(SETQ DS HCPYDS)") + (SETQ SCALE (DSPSCALE NIL HCPYDS))) + (T (SETQ SCALE 1))) + (SETQ CACHE (\TEDIT.LINECACHE (fetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ) + (COND + (HARDCOPYMODE (FIXR (FQUOTIENT (fetch (LINEDESCRIPTOR RIGHTMARGIN + ) of LINE) + SCALE))) + (T (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE))) + LHEIGHT)) + (COND + ((NEQ CACHE OLDCACHE) (* ; + "We changed the bitmaps because this line was bigger--update the displaystream, too") + (DSPDESTINATION CACHE DS) + (DSPCLIPPINGREGION (create REGION + LEFT _ 0 + BOTTOM _ 0 + WIDTH _ (fetch BITMAPWIDTH of CACHE) + HEIGHT _ (fetch BITMAPHEIGHT of CACHE)) + DS))) + (BITBLT NIL 0 0 CACHE 0 0 NIL NIL 'TEXTURE 'REPLACE WHITESHADE) + (* ; "Clear the line cache") + (COND + (HARDCOPYMODE (* ; + "This is a hardcopy-mode line. Scale things.") + (* ; "(SETQ DS HCPYDS)") + (SETQ SCALE (DSPSCALE NIL HCPYDS))) + (T (SETQ SCALE 1))) + [COND + ((AND (NOT (ZEROP (fetch (LINEDESCRIPTOR CHAR1) of LINE))) + (ILEQ (fetch (LINEDESCRIPTOR CHAR1) of LINE) + TEXTLEN) + (IGEQ (fetch (LINEDESCRIPTOR YBOT) of LINE) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ))) + + (* ;; "Only display the line of it contains text (CHAR1 > 0), appears before the end of the test, and is on-screen.") + + (COND + ((NEQ (fetch (THISLINE DESC) of THISLINE) + LINE) (* ; + "No image cache -- re-format and display") + (\FORMATLINE TEXTOBJ NIL (fetch (LINEDESCRIPTOR CHAR1) of LINE) + LINE))) + (MOVETO (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE) + (fetch (LINEDESCRIPTOR DESCENT) of LINE) + DS) + (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DS)) + (SETQ DDPILOTBBT (ffetch DDPILOTBBT of DISPLAYDATA)) + (SETQ XOFFSET (fetch DDXOFFSET of DISPLAYDATA)) + + (* ;; "The X position of the left edge of the window, since \TEDIT.BLTCHAR works on the screen bitmap itself.") + + (SETQ CLIPLEFT (fetch DDClippingLeft of DISPLAYDATA)) + (* ; + "The left and right edges of the clipping region for the text display window.") + (SETQ CLIPRIGHT (fetch DDClippingRight of DISPLAYDATA)) + (SETQ OFONT (DSPFONT (fetch CLFONT of (SETQ OLOOKS (\EDITELT LOOKS 0))) + DS)) (* ; "The starting font") + (SETQ DDWIDTHCACHE (ffetch DDWIDTHSCACHE of DISPLAYDATA)) + (* ; + "Cache the character-image widths") + (SETQ DDOFFSETCACHE (ffetch DDOFFSETSCACHE of DISPLAYDATA)) + (* ; + "And the offset-into-strike-bitmap array") + (SETQ LOOKSTARTX (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE)) + (* ; + "Starting X position for the current-looks text.") + (AND (fetch CLOFFSET of OLOOKS) + (RELMOVETO 0 (FIXR (FTIMES SCALE (fetch CLOFFSET of OLOOKS))) + DS)) (* ; + "Any sub- or superscripting at start of line") + (bind (LOOKNO _ 1) + DX + (TX _ (IPLUS XOFFSET (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE))) + for I from 0 to (fetch (THISLINE LEN) of THISLINE) + do + + (* ;; "Display the line character by character") + + (SETQ CH (\EDITELT CHLIST I)) (* ; + "Grab the character (or IMAGEOBJ) to display") + (SETQ DX (\EDITELT WLIST I)) (* ; "And its width") + [SELECTC CH + (LMInvisibleRun (* ; + "An INVISIBLE run -- skip it, and skip over the char count") + (add LOOKNO 1)) + (LMLooksChange (* ; "A LOOKS change") + (replace DDXPOSITION of DISPLAYDATA + with (IDIFFERENCE TX XOFFSET)) + (* ; + "Make the displaystream reflect our current X position") + (TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS + (fetch (LINEDESCRIPTOR DESCENT) of LINE)) + (* ; + "Make any necessary changes to the preceding characters (underline, strike-out &c)") + (DSPFONT (fetch CLFONT of (SETQ OLOOKS + (\EDITELT LOOKS LOOKNO)) + ) + DS) (* ; "Set the new font") + (add LOOKNO 1) (* ; "Grab the next set of char looks") + (AND (fetch CLOFFSET of OLOOKS) + (RELMOVETO 0 (fetch CLOFFSET of OLOOKS) + DS)) (* ; "Account for super/subscripting") + (SETQ LOOKSTARTX (IDIFFERENCE TX XOFFSET)) + (* ; + "Remember the starting Xpos for possible later underlining &c") + ) + ((CHARCODE (TAB %#^I)) (* ; + "TAB: use the width from the cache to decide the right formatting.") + [COND + ((OR (IEQP CH (CHARCODE %#^I)) + (fetch CLLEADER of OLOOKS) + (EQ (fetch CLUSERINFO of OLOOKS) + 'DOTTEDLEADER)) + (LET* [[LEADERFONT (COND + (HARDCOPYMODE (FONTCOPY (fetch CLFONT + of OLOOKS) + 'DEVICE HCPYDS)) + (T (fetch CLFONT of OLOOKS] + (DOTWIDTH (CHARWIDTH (CHARCODE %.) + LEADERFONT)) + (TTX (IPLUS TX DOTWIDTH (IDIFFERENCE DOTWIDTH + (IREMAINDER TX DOTWIDTH] + (while (ILEQ TTX (IPLUS TX DX)) + do (COND + (HARDCOPYMODE + (\TEDIT.BLTCHAR + (CHARCODE %.) + DS + (FIXR (FQUOTIENT (IDIFFERENCE TTX DOTWIDTH) + SCALE)) + DISPLAYDATA DDPILOTBBT CLIPRIGHT)) + ((OR TERMSA HARDCOPYMODE) + (* ; + "Using special instrns from TERMSA") + (\DSPPRINTCHAR DS (CHARCODE %.))) + (T (* ; "Native charcodes") + (\TEDIT.BLTCHAR (CHARCODE %.) + DS + (IDIFFERENCE TTX DOTWIDTH) + DISPLAYDATA DDPILOTBBT CLIPRIGHT))) + (add TTX DOTWIDTH]) + (13 (* ; "It's a CR") + NIL) + (NIL (* ; "NIL signifies a character we've suppressed as part of line formatting (e.g., a discretionary hyphen we didn't use to break the line). Show it as a thin black line.") + (BLTSHADE BLACKSHADE DS TX 0 1 100 'PAINT)) + (COND + [(SMALLP CH) (* ; + "Normal character -- just display it.") + (COND + (HARDCOPYMODE (\TEDIT.BLTCHAR CH DS (FIXR (FQUOTIENT TX SCALE)) + DISPLAYDATA DDPILOTBBT CLIPRIGHT)) + ((OR TERMSA HARDCOPYMODE) (* ; + "Using special instrns from TERMSA") + (\DSPPRINTCHAR DS CH)) + (T (* ; "Native charcodes") + (\TEDIT.BLTCHAR CH DS TX DISPLAYDATA DDPILOTBBT CLIPRIGHT] + (T (* ; "CH is an object.") + (MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) + XOFFSET) + (SETQ CURY (DSPYPOSITION NIL DS)) + DS) (* ; + "Go to the base line, left edge of the image region.") + (APPLY* (IMAGEOBJPROP CH 'DISPLAYFN) + CH DS 'DISPLAY (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ + )) + (* ; + "Tell him to display himself here.") + (DSPFONT (fetch CLFONT of OLOOKS) + DS) + (MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) + XOFFSET) + CURY DS) (* ; + "Move to after the object's image") + ] + (add TX DX) (* ; "Update our X position") + finally (replace DDXPOSITION of DISPLAYDATA + with (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) + XOFFSET)) (* ; + "Make any necessary looks mods to the last run of characters") + (TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS (fetch (LINEDESCRIPTOR + DESCENT) + of LINE] + (BITBLT CACHE 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBOT) of LINE) + (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) + LHEIGHT + 'INPUT + 'REPLACE) (* ; + "Paint the cached image on the screen (this lessens flicker during update)") + (COND + ((fetch (FMTSPEC FMTREVISED) of (fetch (LINEDESCRIPTOR LFMTSPEC) + of LINE)) + (* ; + "This paragraph has been revised, so mark it.") + (\TEDIT.MARK.REVISION TEXTOBJ (fetch (LINEDESCRIPTOR LFMTSPEC) of LINE) + WINDOWDS LINE))) + (SELECTQ (fetch (LINEDESCRIPTOR LMARK) of LINE) + (GREY (* ; + "This line has some property that isn't visible to the user. Tell him to be careful") + (BITBLT NIL 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBASE) of LINE) + 6 6 'TEXTURE 'PAINT 42405)) + (SOLID (* ; + "This line has some property that isn't visible to the user. Tell him to be careful") + (BITBLT NIL 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBASE) of LINE) + 6 6 'TEXTURE 'PAINT BLACKSHADE)) + (BITBLT NIL 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBASE) of LINE) + 6 6 'TEXTURE 'REPLACE WHITESHADE]) + +(\MAIKO.DISPLAYLINE +(LAMBDA (TEXTOBJ LINE WINDOW) (* ; "Edited 25-Aug-94 13:25 by sybalsky") (* ;; "Display the line of text LINE in the edit window where it belongs.") (* ;; " This Function works on MIAKO") (PROG ((CH 0) (CHLIST (fetch (THISLINE CHARS) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ))) (WLIST (fetch (THISLINE WIDTHS) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ))) (LOOKS (fetch (THISLINE LOOKS) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ))) (WINDOWDS (WINDOWPROP (OR WINDOW (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ))) (QUOTE DSP))) (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) (THISLINE (fetch (TEXTOBJ THISLINE) of TEXTOBJ)) (TERMSA (fetch (TEXTOBJ TXTTERMSA) of TEXTOBJ)) (STREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) (OLDCACHE (fetch LCBITMAP of (fetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ))) (DS (fetch (TEXTOBJ DISPLAYCACHEDS) of TEXTOBJ)) (HCPYDS (fetch (TEXTOBJ DISPLAYHCPYDS) of TEXTOBJ)) (HARDCOPYMODE (fetch (FMTSPEC FMTHARDCOPY) of (fetch (LINEDESCRIPTOR LFMTSPEC) of LINE))) LOOKSTARTX CACHE \PCHARSLEFT \PSTRING \PFILE FONT OFONT OLOOKS XOFFSET CLIPLEFT CLIPRIGHT DISPLAYDATA DDPILOTBBT DDWIDTHCACHE DDOFFSETCACHE CURY LHEIGHT SCALE) (SETQ LHEIGHT (COND ((fetch (LINEDESCRIPTOR PREVLINE) of LINE) (* ; "So if theres a base-to-base measure, we clear everything right.") (IMAX (IDIFFERENCE (fetch (LINEDESCRIPTOR YBOT) of (fetch (LINEDESCRIPTOR PREVLINE) of LINE)) (fetch (LINEDESCRIPTOR YBOT) of LINE)) (fetch (LINEDESCRIPTOR LHEIGHT) of LINE))) (T (fetch (LINEDESCRIPTOR LHEIGHT) of LINE)))) (COND (HARDCOPYMODE (* ; "This is a hardcopy-mode line. Scale things.") (* ; "(SETQ DS HCPYDS)") (SETQ SCALE (DSPSCALE NIL HCPYDS))) (T (SETQ SCALE 1))) (SETQ CACHE (\TEDIT.LINECACHE (fetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ) (COND (HARDCOPYMODE (FIXR (FQUOTIENT (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE) SCALE))) (T (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE))) LHEIGHT)) (COND ((NEQ CACHE OLDCACHE) (* ; "We changed the bitmaps because this line was bigger--update the displaystream, too") (DSPDESTINATION CACHE DS) (DSPCLIPPINGREGION (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (fetch BITMAPWIDTH of CACHE) HEIGHT _ (fetch BITMAPHEIGHT of CACHE)) DS))) (BITBLT NIL 0 0 CACHE 0 0 NIL NIL (QUOTE TEXTURE) (QUOTE REPLACE) WHITESHADE) (* ; "Clear the line cache") (COND (HARDCOPYMODE (* ; "This is a hardcopy-mode line. Scale things.") (* ; "(SETQ DS HCPYDS)") (SETQ SCALE (DSPSCALE NIL HCPYDS))) (T (SETQ SCALE 1))) (COND ((AND (NOT (ZEROP (fetch (LINEDESCRIPTOR CHAR1) of LINE))) (ILEQ (fetch (LINEDESCRIPTOR CHAR1) of LINE) TEXTLEN) (IGEQ (fetch (LINEDESCRIPTOR YBOT) of LINE) (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ))) (* ;; "Only display the line of it contains text (CHAR1 > 0), appears before the end of the test, and is on-screen.") (COND ((NEQ (fetch (THISLINE DESC) of THISLINE) LINE) (* ; "No image cache -- re-format and display") (\FORMATLINE TEXTOBJ NIL (fetch (LINEDESCRIPTOR CHAR1) of LINE) LINE))) (MOVETO (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE) (fetch (LINEDESCRIPTOR DESCENT) of LINE) DS) (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DS)) (SETQ DDPILOTBBT (ffetch DDPILOTBBT of DISPLAYDATA)) (SETQ XOFFSET (fetch DDXOFFSET of DISPLAYDATA)) (* ;; "The X position of the left edge of the window, since \TEDIT.BLTCHAR works on the screen bitmap itself.") (SETQ CLIPLEFT (fetch DDClippingLeft of DISPLAYDATA)) (* ; "The left and right edges of the clipping region for the text display window.") (SETQ CLIPRIGHT (fetch DDClippingRight of DISPLAYDATA)) (SETQ OFONT (DSPFONT (fetch CLFONT of (SETQ OLOOKS (\EDITELT LOOKS 0))) DS)) (* ; "The starting font") (SETQ DDWIDTHCACHE (ffetch DDWIDTHSCACHE of DISPLAYDATA)) (* ; "Cache the character-image widths") (SETQ DDOFFSETCACHE (ffetch DDOFFSETSCACHE of DISPLAYDATA)) (* ; "And the offset-into-strike-bitmap array") (SETQ LOOKSTARTX (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE)) (* ; "Starting X position for the current-looks text.") (AND (fetch CLOFFSET of OLOOKS) (RELMOVETO 0 (FIXR (FTIMES SCALE (fetch CLOFFSET of OLOOKS))) DS)) (* ; "Any sub- or superscripting at start of line") (bind (LOOKNO _ 1) DX (TX _ (IPLUS XOFFSET (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE))) for I from 0 to (fetch (THISLINE LEN) of THISLINE) do (* ;; "Display the line character by character") (SETQ CH (\EDITELT CHLIST I)) (* ; "Grab the character (or IMAGEOBJ) to display") (SETQ DX (\EDITELT WLIST I)) (* ; "And its width") (SELECTC CH (LMInvisibleRun (* ; "An INVISIBLE run -- skip it, and skip over the char count") (add LOOKNO 1)) (LMLooksChange (* ; "A LOOKS change") (replace DDXPOSITION of DISPLAYDATA with (IDIFFERENCE TX XOFFSET)) (* ; "Make the displaystream reflect our current X position") (TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS (fetch (LINEDESCRIPTOR DESCENT) of LINE)) (* ; "Make any necessary changes to the preceding characters (underline, strike-out &c)") (DSPFONT (fetch CLFONT of (SETQ OLOOKS (\EDITELT LOOKS LOOKNO))) DS) (* ; "Set the new font") (add LOOKNO 1) (* ; "Grab the next set of char looks") (AND (fetch CLOFFSET of OLOOKS) (RELMOVETO 0 (fetch CLOFFSET of OLOOKS) DS)) (* ; "Account for super/subscripting") (SETQ LOOKSTARTX (IDIFFERENCE TX XOFFSET)) (* ; "Remember the starting Xpos for possible later underlining &c")) ((CHARCODE (TAB %#^I)) (* ; "TAB: use the width from the cache to decide the right formatting.") (COND ((OR (IEQP CH (CHARCODE %#^I)) (fetch CLLEADER of OLOOKS) (EQ (fetch CLUSERINFO of OLOOKS) (QUOTE DOTTEDLEADER))) (LET* ((LEADERFONT (COND (HARDCOPYMODE (FONTCOPY (fetch CLFONT of OLOOKS) (QUOTE DEVICE) HCPYDS)) (T (fetch CLFONT of OLOOKS)))) (DOTWIDTH (CHARWIDTH (CHARCODE %.) LEADERFONT)) (TTX (IPLUS TX DOTWIDTH (IDIFFERENCE DOTWIDTH (IREMAINDER TX DOTWIDTH))))) (while (ILEQ TTX (IPLUS TX DX)) do (COND (HARDCOPYMODE (SUBRCALL TEDIT.BLTCHAR (CHARCODE %.) DS (FIXR (FQUOTIENT (IDIFFERENCE TTX DOTWIDTH) SCALE)) DISPLAYDATA DDPILOTBBT CLIPRIGHT)) ((OR TERMSA HARDCOPYMODE) (* ; "Using special instrns from TERMSA") (\DSPPRINTCHAR DS (CHARCODE %.))) (T (* ; "Native charcodes") (SUBRCALL TEDIT.BLTCHAR (CHARCODE %.) DS (IDIFFERENCE TTX DOTWIDTH) DISPLAYDATA DDPILOTBBT CLIPRIGHT))) (add TTX DOTWIDTH)))))) (13 (* ; "It's a CR") NIL) (NIL (* ; "NIL signifies a character we've suppressed as part of line formatting (e.g., a discretionary hyphen we didn't use to break the line). Show it as a thin black line.") (BLTSHADE BLACKSHADE DS TX 0 1 100 (QUOTE PAINT))) (COND ((SMALLP CH) (* ; "Normal character -- just display it.") (COND (HARDCOPYMODE (SUBRCALL TEDIT.BLTCHAR CH DS (FIXR (FQUOTIENT TX SCALE)) DISPLAYDATA DDPILOTBBT CLIPRIGHT)) ((OR TERMSA HARDCOPYMODE) (* ; "Using special instrns from TERMSA") (\DSPPRINTCHAR DS CH)) (T (* ; "Native charcodes") (SUBRCALL TEDIT.BLTCHAR CH DS TX DISPLAYDATA DDPILOTBBT CLIPRIGHT)))) (T (* ; "CH is an object.") (MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) XOFFSET) (SETQ CURY (DSPYPOSITION NIL DS)) DS) (* ; "Go to the base line, left edge of the image region.") (APPLY* (IMAGEOBJPROP CH (QUOTE DISPLAYFN)) CH DS (QUOTE DISPLAY) (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) (* ; "Tell him to display himself here.") (DSPFONT (fetch CLFONT of OLOOKS) DS) (MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) XOFFSET) CURY DS) (* ; "Move to after the object's image")))) (add TX DX) (* ; "Update our X position") finally (replace DDXPOSITION of DISPLAYDATA with (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) XOFFSET)) (* ; "Make any necessary looks mods to the last run of characters") (TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS (fetch (LINEDESCRIPTOR DESCENT) of LINE))))) (BITBLT CACHE 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBOT) of LINE) (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) LHEIGHT (QUOTE INPUT) (QUOTE REPLACE)) (* ; "Paint the cached image on the screen (this lessens flicker during update)") (COND ((fetch (FMTSPEC FMTREVISED) of (fetch (LINEDESCRIPTOR LFMTSPEC) of LINE)) (* ; "This paragraph has been revised, so mark it.") (\TEDIT.MARK.REVISION TEXTOBJ (fetch (LINEDESCRIPTOR LFMTSPEC) of LINE) WINDOWDS LINE))) (SELECTQ (fetch (LINEDESCRIPTOR LMARK) of LINE) (GREY (* ; "This line has some property that isn't visible to the user. Tell him to be careful") (BITBLT NIL 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBASE) of LINE) 6 6 (QUOTE TEXTURE) (QUOTE PAINT) 42405)) (SOLID (* ; "This line has some property that isn't visible to the user. Tell him to be careful") (BITBLT NIL 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBASE) of LINE) 6 6 (QUOTE TEXTURE) (QUOTE PAINT) BLACKSHADE)) (BITBLT NIL 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBASE) of LINE) 6 6 (QUOTE TEXTURE) (QUOTE REPLACE) WHITESHADE)))) +) + +(\TEDIT.LINECACHE + (LAMBDA (CACHE WIDTH HEIGHT) (* jds "21-Apr-84 00:52") + + (* Given a candidate line cache, return the bitmap, making sure it's at least + WIDTH by HEIGHT big.) + + (PROG ((BITMAP (fetch LCBITMAP of CACHE)) + CW CH) + (SETQ CW (fetch BITMAPWIDTH of BITMAP)) + (SETQ CH (fetch BITMAPHEIGHT of BITMAP)) + (COND + ((AND (IGEQ CW WIDTH) + (IGEQ CH HEIGHT)) + (RETURN BITMAP)) + (T (RETURN (replace LCBITMAP of CACHE with (BITMAPCREATE (IMAX CW WIDTH) + (IMAX CH HEIGHT))))))))) + +(\TEDIT.CREATE.LINECACHE + (LAMBDA (%#CACHES) (* jds "21-Apr-84 00:58") + + (* Create a linked-together set of LINECACHEs, for saving line images.) + + (PROG ((CACHES (for I from 1 to %#CACHES collect (create LINECACHE + LCBITMAP _ (BITMAPCREATE 100 15))))) + (for CACHE on CACHES do (* Link the caches together.) + (replace LCNEXTCACHE of (CAR CACHE) with (OR (CADR CACHE) + (CAR CACHES)))) + (RETURN CACHES)))) + +(\TEDIT.BLTCHAR + (LAMBDA (CHARCODE DISPLAYSTREAM CURX DISPLAYDATA DDPILOTBBT CLIPRIGHT) + (* jds " 9-Jan-86 17:14") + + (* Version of BLTCHAR peculiar to TEdit -- + relies on \DISPLAYLINE to make sure things keep working right.) + + (* puts a character on a guaranteed display stream. + Much of the information needed by the BitBlt microcode is prestored by the + routines that change it. This is kept in the BitBltTable.) + (* knows about the representation of + display stream image data) + (* MUST NOT POINT AT A WINDOW'S + DISPLAYSTREAM!!!) + + (* ASSUMES THAT WE NEVER WANT TO PRINT TO THE LEFT OF ORIGIN 0 ON THE LINE + CACHE BITMAP, OR THAT IF WE DO, ALL BETS ARE OFF) + + (DECLARE (LOCALVARS . T)) + (PROG (NEWX LEFT RIGHT IMAGEWIDTH (CHAR8CODE (\CHAR8CODE CHARCODE))) + (COND + ((NEQ (ffetch DDCHARSET of DISPLAYDATA) + (\CHARSET CHARCODE)) + (\CHANGECHARSET.DISPLAY DISPLAYDATA (\CHARSET CHARCODE)))) + (SETQ IMAGEWIDTH (\GETBASE (fetch DDCHARIMAGEWIDTHS of DISPLAYDATA) + (\CHAR8CODE CHARCODE))) + (SETQ NEWX (IPLUS CURX IMAGEWIDTH)) + (SETQ LEFT (IMAX 0 CURX)) + (SETQ RIGHT (IMIN CLIPRIGHT NEWX)) + (COND + ((ILESSP LEFT RIGHT) + + (* Only print anything if there is a place to put it) + + (UNINTERRUPTABLY + (freplace PBTDESTBIT of DDPILOTBBT with LEFT) + (* Set up the bitblt-table source left) + (freplace PBTWIDTH of DDPILOTBBT with (IMIN IMAGEWIDTH (IDIFFERENCE RIGHT LEFT))) + (freplace PBTSOURCEBIT of DDPILOTBBT with (\GETBASE (fetch DDOFFSETSCACHE + of DISPLAYDATA) + (\CHAR8CODE CHARCODE))) + (\PILOTBITBLT DDPILOTBBT 0)) + T))))) +) +(DEFINEQ + +(TEDIT.CR.UPDATESCREEN + [LAMBDA (CH# XPOINT TEXTOBJ SEL LINE BLANKSEEN CRSEEN DS CHWIDTH DONTSCROLL) + (* ; "Edited 23-Feb-88 11:12 by jds") + + (* ;; "Update the edit window image after a CR is typed. Move any text after the CR to a new line, and push or pull text as needed.") + + (* ;; "(PROG ((WINDOW (fetch \WINDOW of TEXTOBJ)) (PREVLINE (fetch PREVLINE of LINE))) (COND ((AND (NOT (fetch CR\END of PREVLINE)) (ILEQ (IDIFFERENCE XPOINT (fetch LEFTMARGIN of LINE)) (IDIFFERENCE (fetch RIGHTMARGIN of PREVLINE) (fetch LXLIM of PREVLINE)))) (* This CR should push the start of the line back upward.) (replace DIRTY of PREVLINE with T) (replace TXTNEEDSUPDATE of TEXTOBJ with T))) (TEDIT.UPDATE.SCREEN TEXTOBJ PREVLINE T) (\FIXSEL SEL TEXTOBJ) (\SHOWSEL SEL NIL T) (COND (DONTSCROLL (* SO DO NOTHING)) ((OR (NOT (fetch NEXTLINE of LINE)) (ILEQ (fetch YBOT of (fetch NEXTLINE of LINE)) (fetch BOTTOM of (DSPCLIPPINGREGION NIL WINDOW)))) (* This pushed the caret off-screen. Move it up.) (replace EDITOPACTIVE of TEXTOBJ with NIL) (SCROLLW WINDOW 0 (LLSH (fetch LHEIGHT of (COND ((fetch NEXTLINE of LINE)) (LINE))) 1)))))") + + (HELP]) + +(TEDIT.DELETELINE + [LAMBDA (LINE TEXTOBJ WINDOW) (* ; "Edited 30-May-91 15:58 by jds") + + (* Remove a complete text line descriptor from the edit window, then move lower + lines up over it.) + + (PROG ((PREV (fetch (LINEDESCRIPTOR PREVLINE) of LINE)) + (NEXT (fetch (LINEDESCRIPTOR NEXTLINE) of LINE))) + (* Fix up the line-descriptor chain + to dis-include line) + (COND + (PREV (replace (LINEDESCRIPTOR NEXTLINE) of PREV with NEXT))) + (COND + (NEXT (replace (LINEDESCRIPTOR PREVLINE) of NEXT with PREV))) + (\TEDIT.CLOSEUPLINES TEXTOBJ PREV NEXT NIL WINDOW) + (* And fix up the screen to cover + the blank space.) + ]) + +(TEDIT.INSERT.DISPLAYTEXT + [LAMBDA (TEXTOBJ CH CHWIDTH LINE XPOINT DS SEL) (* ; "Edited 30-May-91 16:56 by jds") + (* This function does the actual + displaying of typed-in text on the + edit window.) + (* (PROG ((LOOKS ( + \TEDIT.APPLY.STYLES + (fetch (TEXTOBJ CARETLOOKS) of + TEXTOBJ) (fetch (TEXTOBJ \INSERTPC) + of TEXTOBJ) TEXTOBJ)) + (TERMSA (fetch (TEXTOBJ TXTTERMSA) + of TEXTOBJ)) DY FONT) + (DSPFONT (SETQ FONT + (fetch CLFONT of LOOKS)) DS) + (* Change the font) + (COND ((IGREATERP (FONTPROP + (fetch CLFONT of LOOKS) + (QUOTE ASCENT)) (fetch + (LINEDESCRIPTOR LTRUEASCENT) of LINE)) + (* The font this character is in is + taller than the existing line. + Adjust the LINEDESCRIPTOR's ascent.) + (\TEDIT.ADJUST.LINES TEXTOBJ LINE DS + (fetch (LINEDESCRIPTOR YBOT) of + (fetch (LINEDESCRIPTOR PREVLINE) of + LINE)) (IDIFFERENCE + (fetch (LINEDESCRIPTOR LTRUEASCENT) + of LINE) (FONTPROP + (fetch CLFONT of LOOKS) + (QUOTE ASCENT)))) (* Move other text + to allow for the new height) + (add (fetch (LINEDESCRIPTOR ASCENT) + of LINE) (IDIFFERENCE + (FONTPROP (fetch CLFONT of LOOKS) + (QUOTE ASCENT)) (fetch + (LINEDESCRIPTOR LTRUEASCENT) of LINE))) + (replace (LINEDESCRIPTOR LTRUEASCENT) + of LINE with (FONTPROP (fetch CLFONT of LOOKS) (QUOTE ASCENT))))) (COND ((IGREATERP + (FONTPROP (fetch CLFONT of LOOKS) + (QUOTE DESCENT)) (fetch + (LINEDESCRIPTOR LTRUEDESCENT) of + LINE)) (* If the caret's font will + change the line's descent, adjust + lower lines downward) + (\TEDIT.ADJUST.LINES TEXTOBJ + (fetch (LINEDESCRIPTOR NEXTLINE) of + LINE) DS (fetch (LINEDESCRIPTOR YBOT) + of LINE) (IDIFFERENCE (fetch (LINEDESCRIPTOR LTRUEDESCENT) of LINE) (FONTPROP + (fetch CLFONT of LOOKS) + (QUOTE DESCENT)))) + (add (fetch (LINEDESCRIPTOR DESCENT) + of LINE) (IDIFFERENCE + (FONTPROP (fetch CLFONT of LOOKS) + (QUOTE DESCENT)) (fetch + (LINEDESCRIPTOR LTRUEDESCENT) of + LINE))) (* Fix the line's + leading-adjusted descent to account + for this change) (replace + (LINEDESCRIPTOR LTRUEDESCENT) of + LINE with (FONTPROP + (fetch CLFONT of LOOKS) + (QUOTE DESCENT))) (* Also the + unadjusted descent) + (replace (LINEDESCRIPTOR YBOT) of + LINE with (IDIFFERENCE + (fetch (LINEDESCRIPTOR YBASE) of + LINE) (fetch (LINEDESCRIPTOR DESCENT) + of LINE))) (* And note our new location.))) (BITBLT DS XPOINT (fetch (LINEDESCRIPTOR YBOT) of + LINE) DS (IPLUS XPOINT CHWIDTH) + (fetch (LINEDESCRIPTOR YBOT) of LINE) + (IDIFFERENCE (fetch + (LINEDESCRIPTOR RIGHTMARGIN) of LINE) + XPOINT) (fetch (LINEDESCRIPTOR LHEIGHT) of LINE) (QUOTE INPUT) (QUOTE REPLACE)) + (* Move the old text over) + (BITBLT NIL 0 0 DS XPOINT + (fetch (LINEDESCRIPTOR YBOT) of LINE) + CHWIDTH (fetch (LINEDESCRIPTOR LHEIGHT) of LINE) (QUOTE TEXTURE) (QUOTE REPLACE) WHITESHADE) + (* Blank out the area we're going to + write into) (MOVETO XPOINT + (IPLUS (fetch (LINEDESCRIPTOR YBASE) + of LINE) (OR (fetch CLOFFSET of + LOOKS) 0)) DS) (* Set the display + stream position) (COND + (TERMSA (* Special terminal table + for controlling character display. + Use it.) (RESETLST + (RESETSAVE \PRIMTERMSA TERMSA) + (replace (TEXTSTREAM REALFILE) of + (fetch (TEXTOBJ STREAMHINT) of + TEXTOBJ) with DS) (COND + ((STRINGP CH) (for CHAR instring CH + do (SELCHARQ CHAR (TAB + (* Put down white) + (BITBLT NIL 0 0 DS XPOINT + (fetch (LINEDESCRIPTOR YBOT) of LINE) + 36 (fetch (LINEDESCRIPTOR LHEIGHT) of LINE) (QUOTE TEXTURE) (QUOTE REPLACE) WHITESHADE) + (RELMOVETO 36 0 DS)) + (CR (BITBLT NIL 0 0 DS XPOINT + (fetch (LINEDESCRIPTOR YBOT) of LINE) + (IMAX 6 (CHARWIDTH CHAR FONT)) + (fetch (LINEDESCRIPTOR LHEIGHT) of + LINE) (QUOTE TEXTURE) + (QUOTE REPLACE) WHITESHADE)) + (\DSPPRINTCHAR (fetch + (TEXTOBJ STREAMHINT) of TEXTOBJ) + CHAR)))) (T (SELCHARQ CH + (TAB (* Put down white) + (BITBLT NIL 0 0 DS XPOINT + (fetch (LINEDESCRIPTOR YBOT) of LINE) + 36 (fetch (LINEDESCRIPTOR LHEIGHT) of LINE) (QUOTE TEXTURE) (QUOTE REPLACE) WHITESHADE) + (RELMOVETO 36 0 DS)) + (CR (BITBLT NIL 0 0 DS XPOINT + (fetch (LINEDESCRIPTOR YBOT) of LINE) + (IMAX 6 (CHARWIDTH CH FONT)) + (fetch (LINEDESCRIPTOR LHEIGHT) of + LINE) (QUOTE TEXTURE) + (QUOTE REPLACE) WHITESHADE)) + (\DSPPRINTCHAR (fetch + (TEXTOBJ STREAMHINT) of TEXTOBJ) CH)))))) + (T (* No special handling; + just use native character codes) + (COND ((STRINGP CH) + (for CHAR instring CH do + (SELCHARQ CHAR (TAB + (* Put down white) + (BITBLT NIL 0 0 DS + (DSPXPOSITION NIL DS) + (fetch (LINEDESCRIPTOR YBOT) of LINE) + 36 (fetch (LINEDESCRIPTOR LHEIGHT) of LINE) (QUOTE TEXTURE) (QUOTE REPLACE) WHITESHADE) + (RELMOVETO 36 0 DS)) + (CR (BITBLT NIL 0 0 DS + (DSPXPOSITION NIL DS) + (fetch (LINEDESCRIPTOR YBOT) of LINE) + (IMAX 6 (CHARWIDTH CHAR FONT)) + (fetch (LINEDESCRIPTOR LHEIGHT) of + LINE) (QUOTE TEXTURE) + (QUOTE REPLACE) WHITESHADE)) + (BLTCHAR CHAR DS)))) + (T (SELCHARQ CH (TAB + (* Put down white) + (BITBLT NIL 0 0 DS + (DSPXPOSITION NIL DS) + (fetch (LINEDESCRIPTOR YBOT) of LINE) + 36 (fetch (LINEDESCRIPTOR LHEIGHT) of LINE) (QUOTE TEXTURE) (QUOTE REPLACE) WHITESHADE) + (RELMOVETO 36 0 DS)) + (CR (* Blank out the CR's width.) + (BITBLT NIL 0 0 DS + (DSPXPOSITION NIL DS) + (fetch (LINEDESCRIPTOR YBOT) of LINE) + (IMAX 6 (CHARWIDTH CH FONT)) + (fetch (LINEDESCRIPTOR LHEIGHT) of + LINE) (QUOTE TEXTURE) + (QUOTE REPLACE) WHITESHADE)) + (BLTCHAR CH DS)))))) + (BITBLT NIL 0 0 DS + (fetch (LINEDESCRIPTOR LXLIM) of + LINE) (fetch (LINEDESCRIPTOR YBOT) + of LINE) (fetch (TEXTOBJ WRIGHT) of + TEXTOBJ) (fetch (LINEDESCRIPTOR + LHEIGHT) of LINE) (QUOTE TEXTURE) + (QUOTE REPLACE) WHITESHADE) + (* Clear after EOL) + (TEDIT.MODIFYLOOKS LINE XPOINT DS + LOOKS (fetch (LINEDESCRIPTOR YBASE) + of LINE)) (* Do underlining, + strike-out, etc.))) + (HELP]) + +(TEDIT.INSERT.UPDATESCREEN + [LAMBDA (CH CH# CHARS XPOINT TEXTOBJ SEL OTEXTLEN BLANKSEEN CRSEEN DONTSCROLL INCREMENTAL) + (* ; "Edited 30-May-91 16:06 by jds") + (* ; + "Update the edit window after an insertion") + (PROG ((THISLINE (fetch (TEXTOBJ THISLINE) of TEXTOBJ)) + (WINDOW (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) + SELINE EOLFLAG CHORIG CHWIDTH OXLIM OCHLIM OCR\END PREVSPACE FIXEDLINE NEXTLINE LINES + NEWLINEFLG DX PREVLINE SAVEWIDTH OFLOWFN OLHEIGHT DY TABSEEN IMAGECACHE) + (replace (SELECTION CH#) of SEL with (IPLUS CHARS CH#)) + (* ; + "These must be here, since SELs are valid even without a window.") + (replace (SELECTION CHLIM) of SEL with (fetch (SELECTION CH#) of SEL)) + (replace (SELECTION POINT) of SEL with 'LEFT) + (replace (SELECTION DCH) of SEL with 0) + (replace (SELECTION SELKIND) of SEL with 'CHAR) + (COND + ((AND INCREMENTAL (\SYSBUFP)) + + (* ;; "We're doing incremental updates, and there's type-in waiting. Bail out, now that we have fixed up the selection.") + + (RETURN)) + ((fetch (TEXTOBJ TXTDON'TUPDATE) of TEXTOBJ) + (* ; + "Don't update the screen if updates are being inhibited.") + (RETURN)) + ((NOT WINDOW) (* ; + "If this textobj has no window to update, don't bother") + (RETURN)) + ((OR T (LISTP WINDOW) + (TEXTPROP TEXTOBJ 'SLOWUPDATE)) (* ; + "FOR NOW, ALWAYS UPDATE THE SCREEN THE HARD WAY") + (TEDIT.UPDATE.SCREEN TEXTOBJ NIL T (fetch (SELECTION CH#) of SEL)) + (\FIXSEL SEL TEXTOBJ) + (\SHOWSEL SEL NIL T))) + (\COPYSEL SEL TEDIT.SELECTION) + [for WW inside WINDOW as L1 inside (fetch (SELECTION L1) of SEL) + as LN inside (fetch (SELECTION LN) of SEL) as L1LIST + on (fetch (SELECTION L1) of SEL) as LNLIST + on (fetch (SELECTION LN) of SEL) + do (COND + (DONTSCROLL + + (* ;; "If scrolling is suppressed, don't bother with the next check:") + + (\TEDIT.SET.WINDOW.EXTENT TEXTOBJ WW)) + [(EQ WW (fetch (TEXTOBJ SELWINDOW) of TEXTOBJ)) + (COND + ([OR (NULL (SELECTQ (fetch (SELECTION POINT) of SEL) + (LEFT L1) + (RIGHT LN) + NIL)) + (ILEQ (SELECTQ (fetch (SELECTION POINT) of SEL) + (LEFT (fetch (LINEDESCRIPTOR YBOT) of L1)) + (RIGHT (fetch (LINEDESCRIPTOR YBOT) of LN)) + 0) + (fetch (REGION BOTTOM) of (DSPCLIPPINGREGION NIL WW] + + (* ;; + "The caret is off-window in the selection window. Need to scroll it up so the caret is visible.") + + (while (OR [COND + ((SETQ SELINE (SELECTQ (fetch (SELECTION POINT) + of SEL) + (LEFT (CAR L1LIST)) + (RIGHT (CAR LNLIST)) + NIL)) + (ILESSP (fetch (LINEDESCRIPTOR YBOT) of SELINE + ) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ))) + (T (ILESSP (fetch (SELECTION Y0) of SEL) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ] + (AND (IGEQ (fetch (SELECTION Y0) of SEL) + (fetch (TEXTOBJ WTOP) of TEXTOBJ)) + (NULL SELINE))) + do + + (* ;; "The caret just went off-screen. Move it up some.") + + (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with + NIL) + (SCROLLW WW 0 (LLSH (COND + [(SELECTQ (fetch (SELECTION POINT) + of SEL) + (LEFT (CAR L1LIST)) + (RIGHT (CAR LNLIST)) + NIL) + (fetch (LINEDESCRIPTOR LHEIGHT) + of (SELECTQ (fetch + (SELECTION POINT) + of SEL) + (LEFT (CAR L1LIST)) + (RIGHT (CAR LNLIST)) + (SHOULDNT] + (T 12)) + 1] + (T (\TEDIT.SET.WINDOW.EXTENT TEXTOBJ WW] + (\COPYSEL SEL TEDIT.SELECTION]) + +(TEDIT.UPDATE.SCREEN + [LAMBDA (TEXTOBJ STARTINGLINE INCREMENTAL? NEXTCARETCH#) + (* ; "Edited 30-May-91 15:58 by jds") + (* Update the screen, as needed to + fix up "dirty" lines.) + (SETQ TEXTOBJ (TEXTOBJ TEXTOBJ)) + (COND + ((NOT (fetch (TEXTOBJ TXTDON'TUPDATE) of TEXTOBJ)) + (* ; + "Only update the screen if we aren't suppressing updating.") + (bind NLINE for WW inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + as LINE inside (OR STARTINGLINE (fetch (TEXTOBJ LINES) of TEXTOBJ)) + do (SETQ NLINE (\TEDIT.FIXCHANGEDPART TEXTOBJ LINE WW INCREMENTAL? NEXTCARETCH#)) + (* The last line in the edit window) + (AND NLINE (\FILLWINDOW (fetch (LINEDESCRIPTOR YBOT) of NLINE) + NLINE TEXTOBJ NIL WW NEXTCARETCH#]) + +(\BACKFORMAT + [LAMBDA (LINES TEXTOBJ WHEIGHT) (* ; "Edited 30-May-91 15:58 by jds") + + (* Move back to the next preceding CR (to guarantee a line break)%, then format + lines to reach where we are now.) + (* LINES is the dummy first line for + this window in TEXTOBJ) + + (* Returns a pointer to the last of the back-formatted lines + (i.e., the one that comes latest in the document)%, or to LINES if no lines are + formatted) + + (PROG ((LINE1 (fetch (LINEDESCRIPTOR NEXTLINE) of LINES)) + CH1 CHNO CH NLINE) + [SETQ CH1 (COND + (LINE1 (fetch (LINEDESCRIPTOR CHAR1) of LINE1)) + (T (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ] + (COND + ((ILEQ CH1 1) (* No more lines can be formatted -- + we're at the front of the file.) + (RETURN LINES)) + (T (* There is more to do.) + (\SETUPGETCH (IDIFFERENCE CH1 1) + TEXTOBJ) + [for old CHNO from (IDIFFERENCE CH1 2) to 1 by -1 + do (* Back up until we find a CR) + (SETQ CH (\GETCHB TEXTOBJ)) + (COND + ((EQ CH (CHARCODE CR)) + (RETURN] + (SETQ CHNO (IMAX (ADD1 CHNO) + 1)) (* But never further than the front + of the document) + (while (ILEQ CHNO (SUB1 CH1)) do (* Now move forward, formatting + lines until we catch up with where + we were.) + (SETQ NLINE (\FORMATLINE TEXTOBJ NIL CHNO + )) + (* Format the next line) + (replace (LINEDESCRIPTOR YBOT) + of NLINE with WHEIGHT) + (* Make sure it thinks it's + off-window) + (replace (LINEDESCRIPTOR YBASE) + of NLINE with WHEIGHT) + (replace (LINEDESCRIPTOR PREVLINE) + of NLINE with LINES) + (* Hook it onto the end of the chain) + (replace (LINEDESCRIPTOR NEXTLINE) + of LINES with NLINE) + (SETQ LINES NLINE) + (SETQ CHNO (ADD1 (fetch (LINEDESCRIPTOR + CHARLIM) + of NLINE))) + (* And find the start of the next + line)) + (replace (LINEDESCRIPTOR NEXTLINE) of NLINE with LINE1) + + (* Now, with the final line we formatted, hook the rest of the line chain onto + it.) + + (AND LINE1 (replace (LINEDESCRIPTOR PREVLINE) of LINE1 with NLINE)) + (RETURN NLINE]) + +(\FILLWINDOW + [LAMBDA (YBOT CURLINE TEXTOBJ DONTFILLFLG WINDOW NEXTCARETCH#) + (* ; "Edited 30-May-91 16:57 by jds") + (* Fill out TEXTOBJ's window, + starting with the line after + CURLINE, whose ybottom is YBOT) + (* Return T if any lines are moved + up.) + (* DONTFILLFLG => Don't bother + printing any new lines at the bottom + of the screen.) + + (* NEXTCARETCH# => always format to at least this CH#, to assure that we know + where the caret will next be.) + + (PROG* ((LINE (fetch (LINEDESCRIPTOR NEXTLINE) of CURLINE)) + (CHARLIM (fetch (LINEDESCRIPTOR CHARLIM) of CURLINE)) + (PREVLINE CURLINE) + (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (LINES\DELETED NIL) + (WINDOW (OR WINDOW (fetch (TEXTOBJ \WINDOW) of TEXTOBJ))) + (WHEIGHT (WINDOWPROP WINDOW 'HEIGHT)) + NEXTLINE OFLOWFN) + (replace (TEXTOBJ TXTNEEDSUPDATE) of TEXTOBJ with NIL) + (while (AND LINE (IGEQ (fetch (LINEDESCRIPTOR YBOT) of LINE) + WHEIGHT)) do (* Do not start with a line which is + above the top of the screen.) + (SETQ PREVLINE LINE) + (SETQ CHARLIM (fetch (LINEDESCRIPTOR + CHARLIM) + of LINE)) + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) + of LINE))) + [repeatwhile (ILESSP CHARLIM TEXTLEN) + do (* Walk thru the lines below the + starting line.) + [COND + ((AND LINE (IGEQ (SETQ YBOT (\TEDIT.NEXT.LINE.BOTTOM YBOT LINE PREVLINE)) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ))) + (* If there is a line to display, + and space to display it, go ahead.) + (replace (LINEDESCRIPTOR YBOT) of LINE with YBOT) + (replace (LINEDESCRIPTOR YBASE) of LINE + with (IPLUS YBOT (fetch (LINEDESCRIPTOR DESCENT) of LINE))) + (\DISPLAYLINE TEXTOBJ LINE WINDOW)) + [(AND LINE NEXTCARETCH# (ILEQ (fetch (LINEDESCRIPTOR CHAR1) of LINE) + NEXTCARETCH#)) + (* There's a line, and it's earlier + than the next caret location. + Keep going.) + (replace (LINEDESCRIPTOR YBOT) of LINE with YBOT) + (replace (LINEDESCRIPTOR YBASE) of LINE + with (IPLUS YBOT (fetch (LINEDESCRIPTOR DESCENT) of LINE] + (LINE (* There is a line, but it won't + fit.) + [COND + ((fetch FMTBASETOBASE of (fetch (LINEDESCRIPTOR LFMTSPEC) + of LINE)) + (SETQ YBOT (fetch (LINEDESCRIPTOR YBOT) of PREVLINE))) + (T (SETQ YBOT (IPLUS YBOT (fetch (LINEDESCRIPTOR LHEIGHT) + of LINE] + + (* This existing line won't fit. Punt out of this, setting YBOT so the screen + gets cleared right.) + + [COND + ((SETQ OFLOWFN (TEXTPROP TEXTOBJ 'OVERFLOWFN)) + (* Try calling any user-supplied + overflow fn, to handle the space + overflow) + (AND (APPLY* OFLOWFN WINDOW TEXTOBJ) + (RETFROM '\FILLWINDOW NIL] + (RETURN)) + (DONTFILLFLG (* We are instructed NOT to try + filling the screen, so punt out.) + (RETURN)) + ((OR (ILESSP CHARLIM TEXTLEN) + (AND (IEQP CHARLIM TEXTLEN) + (fetch (LINEDESCRIPTOR CR\END) of CURLINE)) + (ZEROP TEXTLEN)) (* No existing lines to display, but + there's text left (or the doc is + empty and we need a dummy first line)) + (SETQ LINE (\FORMATLINE TEXTOBJ NIL (ADD1 CHARLIM))) + (* Format the next line) + (replace (LINEDESCRIPTOR PREVLINE) of LINE with PREVLINE) + (* Hook it into the chain of line + descriptors) + (replace (LINEDESCRIPTOR NEXTLINE) of LINE + with (SETQ NEXTLINE (fetch (LINEDESCRIPTOR NEXTLINE) of + PREVLINE + ))) + (replace (LINEDESCRIPTOR NEXTLINE) of PREVLINE with LINE) + (AND NEXTLINE (replace (LINEDESCRIPTOR PREVLINE) of NEXTLINE + with LINE)) + (COND + ((IGEQ [COND + [(fetch FMTBASETOBASE of (fetch (LINEDESCRIPTOR + LFMTSPEC) + of LINE)) + (SETQ YBOT (IDIFFERENCE (IPLUS YBOT (fetch (LINEDESCRIPTOR + DESCENT) + of PREVLINE)) + (IPLUS (fetch FMTBASETOBASE + of (fetch (LINEDESCRIPTOR + LFMTSPEC) + of LINE)) + (fetch (LINEDESCRIPTOR DESCENT) + of LINE] + (T (SETQ YBOT (IDIFFERENCE YBOT (fetch (LINEDESCRIPTOR + LHEIGHT) + of LINE] + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + (* If there's room, display the new + line) + (replace (LINEDESCRIPTOR YBOT) of LINE with YBOT) + (replace (LINEDESCRIPTOR YBASE) of LINE + with (IPLUS YBOT (fetch (LINEDESCRIPTOR DESCENT) of LINE)) + ) + (\DISPLAYLINE TEXTOBJ LINE WINDOW)) + [(AND NEXTCARETCH# (ILEQ (fetch (LINEDESCRIPTOR CHAR1) of LINE) + NEXTCARETCH#)) + + (* This line is needed to find the next caret location, even tho it won't fit + on the screen) + + (replace (LINEDESCRIPTOR YBOT) of LINE with YBOT) + (replace (LINEDESCRIPTOR YBASE) of LINE + with (IPLUS YBOT (fetch (LINEDESCRIPTOR DESCENT) of LINE] + (T (* Otherwise, we've overflown the + window again) + (SETQ YBOT (IPLUS YBOT (fetch (LINEDESCRIPTOR LHEIGHT) of + LINE))) + [COND + ((SETQ OFLOWFN (TEXTPROP TEXTOBJ 'OVERFLOWFN)) + (AND (APPLY* OFLOWFN WINDOW TEXTOBJ) + (RETFROM '\FILLWINDOW NIL] + (RETURN] + (COND + (LINE (* Move forward to the next line in + the chain, if any) + (SETQ CHARLIM (fetch (LINEDESCRIPTOR CHARLIM) of LINE)) + (SETQ PREVLINE LINE) + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE))) + (T (* Otherwise, note that we ran off + the end of the file.) + (SETQ CHARLIM (ADD1 TEXTLEN] + (while LINE do + + (* If there are any existing lines which didn't fit, set their YBOTs to 0 so + they don't show) + + [AND (ILEQ (fetch (LINEDESCRIPTOR CHAR1) of LINE) + TEXTLEN) + (replace (LINEDESCRIPTOR YBOT) of LINE + with (SUB1 (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ] + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE))) + (COND + ((IGEQ YBOT (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + (* If there is space left at the + bottom of the window, blank it out.) + (BITBLT NIL 0 0 WINDOW 0 (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ) + (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) + (IDIFFERENCE YBOT (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + 'TEXTURE + 'REPLACE WHITESHADE))) + (COND + ((AND PREVLINE (fetch (LINEDESCRIPTOR CR\END) of PREVLINE) + (OR (ILESSP (fetch (LINEDESCRIPTOR YBOT) of PREVLINE) + WHEIGHT) + (ILEQ (fetch (LINEDESCRIPTOR CHARTOP) of PREVLINE) + 0)) + (IGEQ (fetch (LINEDESCRIPTOR CHARLIM) of PREVLINE) + TEXTLEN)) (* If the last line ends in a CR, + put a dummy line below it.) + [SETQ LINE (replace (LINEDESCRIPTOR NEXTLINE) of PREVLINE + with (\FORMATLINE TEXTOBJ NIL (ADD1 TEXTLEN] + (replace (LINEDESCRIPTOR PREVLINE) of LINE with PREVLINE) + (replace (LINEDESCRIPTOR YBOT) of LINE with (IDIFFERENCE + (fetch (LINEDESCRIPTOR + YBOT) + of PREVLINE) + (fetch (LINEDESCRIPTOR + LHEIGHT) + of LINE))) + (replace (LINEDESCRIPTOR YBASE) of LINE with (IDIFFERENCE + (fetch (LINEDESCRIPTOR + YBOT) + of PREVLINE) + (fetch (LINEDESCRIPTOR + ASCENT) + of LINE))) + (replace (LINEDESCRIPTOR CHARLIM) of LINE with (ADD1 TEXTLEN)) + (SETQ PREVLINE LINE))) + (COND + ((AND (IGEQ (fetch (LINEDESCRIPTOR CHARLIM) of PREVLINE) + TEXTLEN) + (NOT (fetch (LINEDESCRIPTOR CR\END) of PREVLINE))) + (* This line lies at end of text, so + chop off any following lines.) + (replace (LINEDESCRIPTOR NEXTLINE) of PREVLINE with NIL))) + (RETURN LINES\DELETED]) + +(\FIXDLINES + [LAMBDA (LINES SEL CH#1 CH#LIM TEXTOBJ) (* ; "Edited 30-May-91 15:59 by jds") + + (* ;; + "Fix up the list LINES of line descriptors, given that characters CH#1 thru CH#LIM were deleted.") + + (* ;; "Change CHAR1 and CHARLIM entries in each descriptor, and remove any descriptors for lines which disappeared entirely.") + + (COND + ((NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)) + + (* ;; "Only do this if we're allowed to change the document.") + + (for WW inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + do (SETQ LINES (WINDOWPROP WW 'LINES)) + (PROG ((NLINES LINES) + (DCH (IDIFFERENCE CH#LIM CH#1)) + (CH#1L (SUB1 CH#1)) + PL NL CHARLIM) + (bind (LINE _ (fetch (LINEDESCRIPTOR NEXTLINE) of LINES)) + CHARLIM CHAR1 while LINE + do (SETQ CHARLIM (fetch (LINEDESCRIPTOR CHARLIM) of LINE)) + (SETQ CHAR1 (fetch (LINEDESCRIPTOR CHAR1) of LINE)) + (COND + [(ILESSP CHARLIM CH#1) + (COND + ((AND (IGEQ CH#1 CHAR1) + (ILEQ CH#1 (fetch (LINEDESCRIPTOR CHARTOP) + of LINE))) + + (* ;; "This change happened in a place where it may affect this line's break decision. Better reformat to be safe.") + + (replace (LINEDESCRIPTOR DIRTY) of LINE with + T) + (replace (TEXTOBJ TXTNEEDSUPDATE) of TEXTOBJ + with T)) + ((AND (fetch (LINEDESCRIPTOR CR\END) of LINE) + (IEQP CHARLIM CH#1L)) + + (* ;; "This line ends in CR, and the deletion starts immediately thereafter. Best to reformat, for safety.") + + (replace (LINEDESCRIPTOR DIRTY) of LINE with + T) + (replace (TEXTOBJ TXTNEEDSUPDATE) of TEXTOBJ + with T] + ((IGEQ CHAR1 CH#LIM) (* ; + "This line contains none of the deleted text but is after it. Update CHAR1, CHARLIM and CHARTOP") + (replace (LINEDESCRIPTOR CHAR1) of LINE + with (IMAX 1 (IDIFFERENCE CHAR1 DCH))) + (replace (LINEDESCRIPTOR CHARLIM) of LINE + with (IDIFFERENCE CHARLIM DCH)) + (replace (LINEDESCRIPTOR CHARTOP) of LINE + with (IDIFFERENCE (fetch (LINEDESCRIPTOR CHARTOP) + of LINE) + DCH))) + [(OR (ILESSP CHAR1 CH#1) + (IGEQ CHARLIM CH#LIM)) + (* ; + "This line contains some of the deleted text, mark it as dirty and update CHAR1 and CHARLIM") + (replace (LINEDESCRIPTOR DIRTY) of LINE with T) + (replace (TEXTOBJ TXTNEEDSUPDATE) of TEXTOBJ with + T) + (replace (LINEDESCRIPTOR CHAR1) of LINE + with (IMAX 1 (IMIN CHAR1 CH#1))) + (COND + [(IGEQ CHARLIM CH#LIM) + (replace (LINEDESCRIPTOR CHARLIM) of LINE + with (IDIFFERENCE CHARLIM (IMIN DCH (IDIFFERENCE + CH#LIM CHAR1] + (T (replace (LINEDESCRIPTOR CHARLIM) of LINE + with CH#1L] + (T (* ; + "This line is totally within the deleted text, remove it") + (SETQ NL (fetch (LINEDESCRIPTOR NEXTLINE) of LINE)) + (SETQ PL (fetch (LINEDESCRIPTOR PREVLINE) of LINE)) + (COND + (PL (replace (LINEDESCRIPTOR NEXTLINE) of PL + with NL))) + (COND + (NL (replace (LINEDESCRIPTOR PREVLINE) of NL + with PL))) + (COND + ((EQ NLINES LINE) + (SETQ NLINES NL))) + (replace (LINEDESCRIPTOR DELETED) of LINE with + T) + (* ; + "Mark this line deleted, so DELETETEXTCHARS know to ignore it.") + (AND NL (replace (LINEDESCRIPTOR DIRTY) of NL + with T))(* ; + "This may well force a reformatting of the next line. Mark it dirty just in case.") + )) + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE))) + (\TEDIT.FIXDELSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) + TEXTOBJ CH#1 CH#LIM DCH) (* ; + "Fix up the selections in this textobj") + (\TEDIT.FIXDELSEL (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) + TEXTOBJ CH#1 CH#LIM DCH) + (\TEDIT.FIXDELSEL (fetch (TEXTOBJ MOVESEL) of TEXTOBJ) + TEXTOBJ CH#1 CH#LIM DCH) + (\TEDIT.FIXDELSEL (fetch (TEXTOBJ DELETESEL) of TEXTOBJ) + TEXTOBJ CH#1 CH#LIM DCH) + (RETURN NLINES]) + +(\FIXILINES + [LAMBDA (TEXTOBJ SEL CH#1 DCH OTEXTLEN) (* ; "Edited 30-May-91 16:07 by jds") + + (* ;; + "Fix the list LINES of line descriptors to account for DCH characters inserted before CH#1") + + (COND + ((NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)) + + (* ;; "Only make this change if you're allowed to change the document.") + + (LET (LINES CH# CHLIM CHAR1 CHARLIM) + (SETQ CH#1 (IMAX CH#1 1)) (* ; + "Make sure we're inserting in a legit spot.") + [for WW inside (ffetch (TEXTOBJ \WINDOW) of TEXTOBJ) as LINES + inside (fetch (TEXTOBJ LINES) of TEXTOBJ) as L1 + in (fetch (SELECTION L1) of SEL) + do + + (* ;; "For each pane in the editing window, examine the pane's list of lines") + + (bind [LINE _ (COND + ((IGEQ (ffetch (LINEDESCRIPTOR CHARTOP) of LINES) + 0) (* ; + "Make sure to skip the initial dummy line") + LINES) + (T (ffetch (LINEDESCRIPTOR NEXTLINE) of LINES] + while LINE do (\DTEST LINE 'LINEDESCRIPTOR) + (COND + ((IGREATERP (SETQ CHAR1 (ffetch (LINEDESCRIPTOR + CHAR1) + of LINE)) + CH#1) + (* ; + "This line starts after the insertion point. Update it's CHAR1") + (freplace (LINEDESCRIPTOR CHAR1) of LINE + with (IPLUS CHAR1 DCH))) + ((AND (IEQP CH#1 CHAR1) + (NEQ LINE L1)) + (* ; + "The insertion is at the end of the PRIOR line--so go ahead and update this CHAR1") + (freplace (LINEDESCRIPTOR CHAR1) of LINE + with (IPLUS CHAR1 DCH)) + (COND + ((ffetch (LINEDESCRIPTOR PREVLINE) + of LINE) + (freplace (LINEDESCRIPTOR DIRTY) + of (ffetch (LINEDESCRIPTOR PREVLINE) + of LINE) with T))) + (freplace (LINEDESCRIPTOR DIRTY) of LINE + with T) + (replace (TEXTOBJ TXTNEEDSUPDATE) of + TEXTOBJ + with T)) + ((IGEQ (ffetch (LINEDESCRIPTOR CHARTOP) + of LINE) + CH#1)(* ; + "This line spans the insert point. Mark it DIRTY.") + (freplace (LINEDESCRIPTOR DIRTY) of LINE + with T) + (replace (TEXTOBJ TXTNEEDSUPDATE) of + TEXTOBJ + with T)) + ((AND (IGEQ (SETQ CHARLIM (ffetch ( + LINEDESCRIPTOR + CHARLIM) + of LINE)) + OTEXTLEN) + (NOT (ffetch (LINEDESCRIPTOR CR\END) + of LINE))) + + (* ;; "This line is the last in the file, and its CHAR1 is <= the insert point, and it doesn't end in a CR. Therefore, move the line's end upward to accomodate the insertion.") + + (freplace (LINEDESCRIPTOR DIRTY) of LINE + with T) + (replace (TEXTOBJ TXTNEEDSUPDATE) of + TEXTOBJ + with T))) + [COND + ([OR (IGEQ (SETQ CHARLIM (ffetch (LINEDESCRIPTOR + CHARLIM) + of LINE)) + CH#1) + (AND (IGEQ CHARLIM OTEXTLEN) + (NOT (ffetch (LINEDESCRIPTOR CR\END) + of LINE] + (freplace (LINEDESCRIPTOR CHARLIM) of + LINE + with (IPLUS CHARLIM DCH)) + (COND + ((IGEQ (ffetch (LINEDESCRIPTOR CHARTOP) + of LINE) + CH#1) + (freplace (LINEDESCRIPTOR CHARTOP) + of LINE + with (IPLUS (ffetch (LINEDESCRIPTOR + CHARTOP) + of LINE) + DCH] + (SETQ LINE (ffetch (LINEDESCRIPTOR NEXTLINE) + of LINE] + (\TEDIT.FIXINSSEL (fetch (TEXTOBJ MOVESEL) of TEXTOBJ) + TEXTOBJ CH#1 DCH) + (\TEDIT.FIXINSSEL (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) + TEXTOBJ CH#1 DCH) + (\TEDIT.FIXINSSEL SEL TEXTOBJ CH#1 DCH]) + +(\SHOWTEXT + [LAMBDA (TEXTOBJ LINES WINDOW) (* ; "Edited 12-Jun-90 19:22 by mitani") + (* Fill the editor window with text, + starting from the top of the file.) + (COND + ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) (* If there is no edit window, just + return.) + (PROG (WREG) + (SETQ WINDOW (OR WINDOW (\TEDIT.PRIMARYW TEXTOBJ))) + (DSPFILL (PROG1 (DSPCLIPPINGREGION NIL WINDOW) (* For region within a window%:) + (* (CREATEREGION (fetch + (TEXTOBJ WLEFT) of TEXTOBJ) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ) + (IDIFFERENCE (fetch + (TEXTOBJ WRIGHT) of TEXTOBJ) + (fetch (TEXTOBJ WLEFT) of TEXTOBJ)) + (IDIFFERENCE (fetch + (TEXTOBJ WTOP) of TEXTOBJ) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)))) + ) + WHITESHADE + 'REPLACE WINDOW) (* Clear the window.) + (RETURN (RESETLST + (RESETSAVE (CURSOR WAITINGCURSOR)) (* Display the hourglass cursor as + we work) + (SETQ LINES + (create LINEDESCRIPTOR + YBOT _ (WINDOWPROP WINDOW 'HEIGHT) + CHAR1 _ 0 + CHARLIM _ 0 + SPACELEFT _ -1 + RIGHTMARGIN _ (SUB1 (fetch (TEXTOBJ WRIGHT) of TEXTOBJ)) + NEXTLINE _ NIL + CHARTOP _ -1 + LHEIGHT _ 0 + LXLIM _ (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) + CR\END _ T + ASCENT _ 0 + DESCENT _ 0 + LTRUEASCENT _ 0 + LFMTSPEC _ TEDIT.DEFAULT.FMTSPEC)) + (* Make sure we have the anchor + pseudo-line) + (WINDOWPROP WINDOW 'LINES LINES) + (\FILLWINDOW (WINDOWPROP WINDOW 'HEIGHT) + LINES TEXTOBJ NIL WINDOW) (* Fill the window as usual) + (\TEDIT.SET.WINDOW.EXTENT TEXTOBJ WINDOW) + LINES)]) + +(\TEDIT.ADJUST.LINES + [LAMBDA (TEXTOBJ FIRSTLINE WINDOW LINETOP DY) (* ; "Edited 30-May-91 15:59 by jds") + + (* Move all lines from FIRSTLINE (inclusive) on up or down. + Fill in a line or drop one off, accordingly. + Positive DY means move UP.) + + (* LINETOP is the top of the region to be moved as the adjustment is made. + It corresponds to the TOP of FIRSTLINE.) + + (PROG ((OFLOW NIL) + OFLOWFN OYBOT PREVLINE) + [COND + ((ZEROP DY) (* This line's total height HAS NOT + CHANGED. Don't make any adjustments.) + ) + ((ILESSP LINETOP (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + (* This line is off the screen. + Don't bother adjusting it.) + ) + (FIRSTLINE + + (* This line's total height changed -- must move the rest of the window, and + adjust YBOT/BASEs.) + + (bind (LL _ FIRSTLINE) while (AND LL (IGEQ (fetch (LINEDESCRIPTOR + YBOT) of + LL) + (fetch (TEXTOBJ WBOTTOM) + of TEXTOBJ))) + do + + (* Loop thru the line descriptors that are affected by the change + (i.e., those below it)%, and adjust their Y locations.) + + (SETQ OYBOT (fetch (LINEDESCRIPTOR YBOT) of LL)) + [COND + ((ILESSP (replace (LINEDESCRIPTOR YBOT) of LL + with (IPLUS OYBOT DY)) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + (* This line moved below the bottom + of the screen) + (BITBLT NIL 0 0 WINDOW 0 OYBOT (fetch (TEXTOBJ WRIGHT) + of TEXTOBJ) + (fetch (LINEDESCRIPTOR LHEIGHT) of LL) + 'TEXTURE + 'REPLACE WHITESHADE) (* So clear the space it used to + occupy.) + (COND + ((AND (SETQ OFLOWFN (TEXTPROP TEXTOBJ 'OVERFLOWFN)) + (SETQ OFLOW T) + (APPLY* OFLOWFN WINDOW TEXTOBJ) + (RETURN NIL)) + + (* We walked off the bottom, and the user gave us an OFLOWFN to handle it. + Give it a try.) + + ] + (add (fetch (LINEDESCRIPTOR YBASE) of LL) + DY) (* Adjust the baseline of the line, + as well as its physical bottom.) + (replace (LINEDESCRIPTOR YBOT) of LL + with (IDIFFERENCE (fetch (LINEDESCRIPTOR YBASE) of LL) + (fetch (LINEDESCRIPTOR DESCENT) of LL))) + (* I realize this looks redundant, + but the line's descent may have + changed, too.) + (SETQ PREVLINE LL) + + (* Remember the prior line, since we'll need it if we later try to fill out the + window with more text.) + + (SETQ LL (fetch (LINEDESCRIPTOR NEXTLINE) of LL)) + (* Move to the next line.)) + (AND OFLOW (RETURN NIL)) + + (* If there was an overflow, and it got handled by the user's OFLOWFN, don't + bother trying anything further.) + + (COND + [(IGREATERP DY 0) (* The line is shorter; + move the rest up.) + (BITBLT WINDOW 0 (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ) + WINDOW 0 (IPLUS DY (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) + LINETOP + 'INPUT + 'REPLACE) (* Move the text up) + (BITBLT NIL 0 0 WINDOW 0 (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ) + (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) + DY + 'TEXTURE + 'REPLACE WHITESHADE) (* Now clear the bottom part of the + window, which got vacated by the + adjustment) + (COND + ((AND PREVLINE (IGEQ (fetch (LINEDESCRIPTOR YBOT) of PREVLINE) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ))) + + (* If there is space left on the screen, try to fill it with new text.) + + (\FILLWINDOW (fetch (LINEDESCRIPTOR YBOT) of PREVLINE) + PREVLINE TEXTOBJ NIL WINDOW] + (T (* The line is taller; + move the rest down.) + (BITBLT WINDOW 0 (IPLUS (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ) + (IMINUS DY)) + WINDOW 0 (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ) + (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) + (IDIFFERENCE LINETOP (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + 'INPUT + 'REPLACE) (* Move the text down) + (BITBLT NIL 0 0 WINDOW 0 (IPLUS LINETOP DY) + (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) + (IMINUS DY) + 'TEXTURE + 'REPLACE WHITESHADE) (* Now clear the region we moved it + out of.) + ] + (RETURN T]) + +(\TEDIT.CLEAR.SCREEN.BELOW.LINE + [LAMBDA (TEXTOBJ WINDOW LINE) (* ; "Edited 30-May-91 15:59 by jds") + (* Clears the edit window to white, + clearing only the sapce below the + line given.) + (BITBLT NIL 0 0 WINDOW 0 (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ) + (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) + (IDIFFERENCE (fetch (LINEDESCRIPTOR YBOT) of LINE) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + 'TEXTURE + 'REPLACE WHITESHADE]) + +(\TEDIT.CLOSEUPLINES + [LAMBDA (TEXTOBJ PREVLINE NEXTLINE DONTFILLFLG WINDOW) (* ; "Edited 30-May-91 15:59 by jds") + + (* ;; "Given a gap between PREVLINE and NEXTLINE, move NEXTLINE et seq up to coverthe gap, and adjust the YBOTs. If DONTFILLFLG is T then we're not filling the screen") + (* ; + "NEXTLINE = NIL => remove all lower lines.") + (COND + (PREVLINE (* ; + "PREVLINE = NIL => DON'T close up anything.") + (PROG [DY (WWIDTH (IDIFFERENCE (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) + (fetch (TEXTOBJ WLEFT) of TEXTOBJ))) + (LOWESTY (COND + (PREVLINE (fetch (LINEDESCRIPTOR YBOT) of PREVLINE)) + (T (ADD1 (fetch (TEXTOBJ WTOP) of TEXTOBJ] + [COND + (NEXTLINE (* ; + "If the gap isn't at the end, move whatever else up over it.") + [SETQ DY (IDIFFERENCE LOWESTY (IPLUS (fetch (LINEDESCRIPTOR YBOT) + of NEXTLINE) + (fetch (LINEDESCRIPTOR LHEIGHT + ) of + NEXTLINE + ] + (AND (ILEQ DY 0) + (RETURN)) (* ; + "If there's no gap, don't bother with anything else.") + (BITBLT WINDOW (fetch (TEXTOBJ WLEFT) of TEXTOBJ) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ) + WINDOW + (fetch (TEXTOBJ WLEFT) of TEXTOBJ) + (IPLUS DY (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + WWIDTH + (IPLUS (IDIFFERENCE (fetch (LINEDESCRIPTOR YBOT) + of NEXTLINE) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + (fetch (LINEDESCRIPTOR LHEIGHT) of NEXTLINE)) + 'INPUT + 'REPLACE) (* ; + "Move the remaining lines upward.") + (bind (LINE _ NEXTLINE) + (NYBOT _ LOWESTY) while LINE + do (* ; + "Scan the remaining lines, fixing up the vertical spacing information") + (SETQ NYBOT (IDIFFERENCE NYBOT (fetch (LINEDESCRIPTOR + LHEIGHT) + of LINE))) + (COND + ((IGEQ NYBOT (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + (SETQ LOWESTY NYBOT))) + [COND + [(ILESSP (fetch (LINEDESCRIPTOR YBOT) of LINE) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + (* ; + "Line is off screen. Display it at the right spot.") + (AND DONTFILLFLG (RETURN)) + (* ; + "If we're not filling the screen, then stop here.") + (replace (LINEDESCRIPTOR YBOT) of LINE + with NYBOT) + (replace (LINEDESCRIPTOR YBASE) of LINE + with (IPLUS NYBOT (fetch (LINEDESCRIPTOR + DESCENT) + of LINE))) + (\DISPLAYLINE TEXTOBJ LINE WINDOW) + (COND + ((fetch (LINEDESCRIPTOR NEXTLINE) of LINE) + (* ; + "There's a next line after the current one. Use it") + ) + ((IGEQ (fetch (LINEDESCRIPTOR CHARLIM) of + LINE) + (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (* ; + "We're at the end of the text; don't bother trying to add more lines") + ) + (T (* ; + "There's more; try adding another line.") + [replace (LINEDESCRIPTOR NEXTLINE) of LINE + with (\FORMATLINE + TEXTOBJ NIL (ADD1 (fetch + (LINEDESCRIPTOR + CHARLIM) + of LINE] + (replace (LINEDESCRIPTOR PREVLINE) + of (fetch (LINEDESCRIPTOR NEXTLINE) + of LINE) with LINE] + (T (* ; + "Line is visible; just update YBOT/YBASE") + (replace (LINEDESCRIPTOR YBOT) of LINE + with NYBOT) + (replace (LINEDESCRIPTOR YBASE) of LINE + with (IPLUS (fetch (LINEDESCRIPTOR YBOT) + of LINE) + (fetch (LINEDESCRIPTOR DESCENT) + of LINE] + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE)) + until (ILESSP NYBOT (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ] + (BITBLT NIL 0 0 WINDOW (fetch (TEXTOBJ WLEFT) of TEXTOBJ) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ) + WWIDTH + (IDIFFERENCE LOWESTY (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + 'TEXTURE + 'REPLACE WHITESHADE) (* ; + "Clear the part of the screen below the lowest line now displayed") + (RETURN T]) + +(\TEDIT.COPY.LINEDESCRIPTOR + [LAMBDA (FROMLINE TOLINE) (* ; "Edited 30-May-91 16:57 by jds") + + (* Copy the contents of one line descriptor into another -- + except for chaining and Y-location info.) + + (freplace (LINEDESCRIPTOR LEFTMARGIN) of TOLINE with (ffetch (LINEDESCRIPTOR + LEFTMARGIN) + of FROMLINE)) + (freplace (LINEDESCRIPTOR RIGHTMARGIN) of TOLINE with (ffetch (LINEDESCRIPTOR + RIGHTMARGIN) + of FROMLINE)) + (freplace (LINEDESCRIPTOR LXLIM) of TOLINE with (ffetch (LINEDESCRIPTOR LXLIM) + of FROMLINE)) + (freplace (LINEDESCRIPTOR SPACELEFT) of TOLINE with (ffetch (LINEDESCRIPTOR + SPACELEFT) + of FROMLINE)) + (freplace (LINEDESCRIPTOR LHEIGHT) of TOLINE with (ffetch (LINEDESCRIPTOR LHEIGHT + ) of + FROMLINE + )) + (freplace (LINEDESCRIPTOR CHAR1) of TOLINE with (ffetch (LINEDESCRIPTOR CHAR1) + of FROMLINE)) + (freplace (LINEDESCRIPTOR CHARLIM) of TOLINE with (ffetch (LINEDESCRIPTOR CHARLIM + ) of + FROMLINE + )) + (freplace (LINEDESCRIPTOR CHARTOP) of TOLINE with (ffetch (LINEDESCRIPTOR CHARTOP + ) of + FROMLINE + )) + (freplace (LINEDESCRIPTOR DIRTY) of TOLINE with NIL) + (freplace (LINEDESCRIPTOR CR\END) of TOLINE with (ffetch (LINEDESCRIPTOR CR\END) + of FROMLINE)) + (freplace (LINEDESCRIPTOR LDOBJ) of TOLINE with (ffetch (LINEDESCRIPTOR LDOBJ) + of FROMLINE)) + (freplace (LINEDESCRIPTOR LHASPROT) of TOLINE with (ffetch (LINEDESCRIPTOR + LHASPROT) + of FROMLINE)) + (freplace (LINEDESCRIPTOR LFMTSPEC) of TOLINE with (ffetch (LINEDESCRIPTOR + LFMTSPEC) + of FROMLINE)) + (freplace (LINEDESCRIPTOR LTRUEDESCENT) of TOLINE with (ffetch (LINEDESCRIPTOR + LTRUEDESCENT) + of FROMLINE)) + (freplace (LINEDESCRIPTOR LTRUEASCENT) of TOLINE with (ffetch (LINEDESCRIPTOR + LTRUEASCENT) + of FROMLINE)) + (freplace (LINEDESCRIPTOR ASCENT) of TOLINE with (ffetch (LINEDESCRIPTOR ASCENT) + of FROMLINE)) + (freplace (LINEDESCRIPTOR DESCENT) of TOLINE with (ffetch (LINEDESCRIPTOR DESCENT + ) of + FROMLINE + )) + (freplace (LINEDESCRIPTOR LHASTABS) of TOLINE with (ffetch (LINEDESCRIPTOR + LHASTABS) + of FROMLINE)) + (freplace (LINEDESCRIPTOR LMARK) of TOLINE with (ffetch (LINEDESCRIPTOR LMARK) + of FROMLINE)) + (freplace (LINEDESCRIPTOR 1STLN) of TOLINE with (ffetch (LINEDESCRIPTOR 1STLN) + of FROMLINE)) + (freplace (LINEDESCRIPTOR LSTLN) of TOLINE with (ffetch (LINEDESCRIPTOR LSTLN) + of FROMLINE]) + +(\TEDIT.FIXCHANGEDLINE + [LAMBDA (TEXTOBJ PREVYBOT LINES WINDOW TEXTLEN THISLINE WHEIGHT CHARLIM NEXTCARETCH# PREVDESCENT) + (* ; "Edited 30-May-91 16:57 by jds") + (* Reformat a single line, if need + be. Returns the changed line) + (PROG ((YBOT PREVYBOT) + (FORMATDONE NIL) + LIMITCHANGED WASDIRTY OCHLIM OLHEIGHT (PREVLINE NIL) + (FOUND NIL) + DY OFLOWFN NEWLINE) + [COND + ((IEQP CHARLIM 1) + (SETQ CHARLIM (fetch (LINEDESCRIPTOR CHAR1) of LINES] + (COND + ([OR (fetch (LINEDESCRIPTOR DIRTY) of LINES) + (NOT (IEQP CHARLIM (fetch (LINEDESCRIPTOR CHAR1) of LINES] + + (* Only act if this line has changed, or if there is a gap or overlap between + this line and the prior one) + + (SETQ OCHLIM (fetch (LINEDESCRIPTOR CHARLIM) of LINES)) + (* This line's old CHLIM, for seeing + if it changes) + (SETQ OLHEIGHT (fetch (LINEDESCRIPTOR LHEIGHT) of LINES)) + (* This line's old height, for + seeing if it changes.) + (SETQ NEWLINE (\FORMATLINE TEXTOBJ NIL CHARLIM)) + (* Create the fresh line) + (COND + ((AND (ILESSP CHARLIM (fetch (LINEDESCRIPTOR CHAR1) of LINES)) + (IEQP (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) of NEWLINE)) + (fetch (LINEDESCRIPTOR CHAR1) of LINES))) + (* If this is a space-filling line, + just move the other lines down.) + (\TEDIT.INSERTLINE NEWLINE LINES)) + (T (* Otherwise, write over existing + lines) + (\TEDIT.COPY.LINEDESCRIPTOR NEWLINE LINES) + (* Move it into place in the chain) + (replace (THISLINE DESC) of THISLINE with LINES) + (* And pretend that LINES is the + line we just formatted--since it + effectively IS.) + (SETQ NEWLINE LINES) (* And copy it back over the + original) + )) + (SETQ CHARLIM (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) of NEWLINE))) + (* Find the end of the new line + (this MUST be before this COND, + because LINES is set to NIL inside + it.)) + (COND + ((IGEQ (fetch (LINEDESCRIPTOR YBOT) of LINES) + WHEIGHT) (* Do nothing until we see a change + to a line which is on-screen.) + (replace (LINEDESCRIPTOR YBOT) of NEWLINE with (fetch ( + LINEDESCRIPTOR + YBOT) + of LINES)) + (* Except to make sure that the + fresh line also thinks it is off + screen) + ) + ((AND (IGEQ (SETQ YBOT (\TEDIT.NEXT.LINE.BOTTOM YBOT NEWLINE (fetch + (LINEDESCRIPTOR + PREVLINE) + of NEWLINE)) + ) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + (NEQ LINES NEWLINE)) (* If there's space left on the + screen for this line, + (and it is a new line)) + (\TEDIT.ADJUST.LINES TEXTOBJ (fetch (LINEDESCRIPTOR NEXTLINE) of + NEWLINE + ) + WINDOW + (fetch (LINEDESCRIPTOR YBOT) of (fetch (LINEDESCRIPTOR PREVLINE) + of NEWLINE)) + (IMINUS (fetch (LINEDESCRIPTOR LHEIGHT) of NEWLINE))) + (* Move the existing lines down to + fit it in) + (replace (LINEDESCRIPTOR YBOT) of NEWLINE with YBOT) + (* Display it where we are now) + (replace (LINEDESCRIPTOR YBASE) of NEWLINE + with (IPLUS YBOT (fetch (LINEDESCRIPTOR DESCENT) of NEWLINE))) + (* Base line for the characters to + sit on) + (\DISPLAYLINE TEXTOBJ NEWLINE WINDOW) (* Display it) + ) + ((IGEQ YBOT (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + + (* If there's space left on the screen for this line, and we're overlaying an + existing line.) + + [\TEDIT.ADJUST.LINES TEXTOBJ (fetch (LINEDESCRIPTOR NEXTLINE) of LINES) + WINDOW + (IPLUS YBOT (fetch (LINEDESCRIPTOR LHEIGHT) of LINES) + (IMINUS OLHEIGHT)) + (COND + ((fetch FMTBASETOBASE of (fetch (LINEDESCRIPTOR LFMTSPEC) + of LINES)) + (IDIFFERENCE (fetch (LINEDESCRIPTOR YBOT) of LINES) + YBOT)) + (T (IDIFFERENCE OLHEIGHT (fetch (LINEDESCRIPTOR LHEIGHT) of + LINES] + (* Adjust for the possible + difference in heights between old + and new line) + (replace (LINEDESCRIPTOR YBOT) of LINES with YBOT) + (* Display it where we are now) + (replace (LINEDESCRIPTOR YBASE) of LINES with + (IPLUS YBOT (fetch + (LINEDESCRIPTOR + DESCENT) + of LINES))) + (* Base line for the characters to + sit on) + (\DISPLAYLINE TEXTOBJ LINES WINDOW) (* Display it) + ) + ((AND NEXTCARETCH# (ILEQ (fetch (LINEDESCRIPTOR CHAR1) of LINES) + NEXTCARETCH#)) (* This line is off-screen, but is + needed for finding the caret's new + location) + (replace (LINEDESCRIPTOR YBOT) of LINES with YBOT) + (replace (LINEDESCRIPTOR YBASE) of LINES with YBOT)) + (T + + (* We have walked off the bottom of the screen. + Chop off the lines from here.) + + (SETQ LINES NEWLINE) + (AND (SETQ OFLOWFN (TEXTPROP TEXTOBJ 'OVERFLOWFN)) + (APPLY* OFLOWFN WINDOW TEXTOBJ) + (RETFROM (FUNCTION \TEDIT.FIXCHANGEDLINE))) + [replace (LINEDESCRIPTOR YBOT) of LINES + with (replace (LINEDESCRIPTOR YBASE) of LINES + with (SUB1 (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ] + (* Mark this line as being + off-screen) + (COND + ((IGREATERP (fetch (LINEDESCRIPTOR CHARLIM) of LINES) + NEXTCARETCH#) + (replace (LINEDESCRIPTOR NEXTLINE) of LINES with NIL))) + + (* Chop off any lines below it, to preserve changes that may propogate off the + bottom of the window) + + (\TEDIT.CLEAR.SCREEN.BELOW.LINE TEXTOBJ WINDOW (fetch (LINEDESCRIPTOR + PREVLINE) + of LINES)) + (* And clear the space below the + bottom line on the screen) + (RETURN))) + (SETQ LINES NEWLINE) + + (* So that if we inserted a line, we start by moving up to the pre-existing + line) + + )) + (RETURN LINES]) + +(\TEDIT.FIXCHANGEDPART + [LAMBDA (TEXTOBJ STARTINGLINE WINDOW INCREMENTAL? NEXTCARETCH#) + (* ; "Edited 30-May-91 16:07 by jds") + + (* ;; "Reformat lines as needed after a change. Return the last line changed, or NIL if there's no need for a \FILLWINDOW.") + + (PROG* ((THISW (OR WINDOW (\TEDIT.PRIMARYW TEXTOBJ))) + [LINES (fetch (LINEDESCRIPTOR NEXTLINE) of (WINDOWPROP THISW 'LINES] + (REGION (DSPCLIPPINGREGION NIL THISW)) + (YBOT (fetch (REGION PTOP) of REGION)) + (FORMATDONE NIL) + LIMITCHANGED WASDIRTY CHARLIM OCHLIM OLHEIGHT (PREVLINE NIL) + (TPREVLINE NIL) + (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (THISLINE (fetch (TEXTOBJ THISLINE) of TEXTOBJ)) + (WHEIGHT (fetch (REGION PTOP) of REGION)) + (WBOTTOM (fetch (REGION BOTTOM) of REGION)) + (CLEARBOTTOM T) + [NEXTCARETCH# (OR NEXTCARETCH# (fetch (SELECTION CH#) of (fetch (TEXTOBJ + SEL) + of TEXTOBJ] + DY OFLOWFN NEWLINE TYBOT) + (AND LINES (SETQ TPREVLINE (fetch (LINEDESCRIPTOR PREVLINE) of LINES))) + [while LINES do (* ; + "Find the first line descriptor of a DIRTY line.") + (SETQ YBOT (fetch (LINEDESCRIPTOR YBOT) of LINES)) + (COND + ((ILESSP 0 (SETQ DY (IDIFFERENCE (\TEDIT.NEXT.LINE.BOTTOM + YBOT LINES (fetch + (LINEDESCRIPTOR + PREVLINE) + of LINES)) + YBOT))) + (* ; + "There used to be another line above this one. Move this up to cover it.") + (\TEDIT.CLOSEUPLINES TEXTOBJ (fetch (LINEDESCRIPTOR + PREVLINE) + of LINES) + LINES NIL (OR WINDOW (\TEDIT.PRIMARYW TEXTOBJ))) + (* ; + "This HAS to fill the window, or we may wind up with missing lines at the bottom of the screen") + )) + (COND + ((AND (ILESSP YBOT (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + (IGREATERP (fetch (LINEDESCRIPTOR CHAR1) of LINES) + NEXTCARETCH#)) + (* ; + "We've run off the bottom of the screen.") + (replace (LINEDESCRIPTOR NEXTLINE) of TPREVLINE + with NIL) (* ; + "There may be unfixed changes there, so chop off any further lines.") + (SETQ LINES NIL)) + ((fetch (LINEDESCRIPTOR DIRTY) of LINES) + (RETURN)) + ([AND [NOT (IEQP (fetch (LINEDESCRIPTOR CHAR1) of LINES) + (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) + of TPREVLINE] + (NOT (ZEROP (fetch (LINEDESCRIPTOR CHARLIM) + of TPREVLINE] + + (* ;; "This line doesn't match up with the previous line; we should start updating here. But don't worry about the dummy first line") + + (RETURN)) + (T (SETQ TPREVLINE LINES) + (SETQ LINES (fetch (LINEDESCRIPTOR NEXTLINE) of + LINES] + [COND + ((AND LINES (ILESSP (fetch (LINEDESCRIPTOR CHARTOP) of LINES) + 0)) (* ; + "If we hit on the dummy first line, skip over it -- never try to reformat it.") + (SETQ LINES (fetch (LINEDESCRIPTOR NEXTLINE) of LINES] + [COND + ((NOT LINES) (* ; + "No changed lines found -- clear below last line on screen") + (BITBLT NIL 0 0 WINDOW 0 (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ) + (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL WINDOW)) + (IDIFFERENCE YBOT (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + 'TEXTURE + 'REPLACE WHITESHADE) + (COND + [[OR (ZEROP TEXTLEN) + (NOT (fetch (LINEDESCRIPTOR NEXTLINE) of (WINDOWPROP + (OR WINDOW (\TEDIT.PRIMARYW + TEXTOBJ)) + 'LINES] + + (* ;; "If there is no text, or no image, force a call to \FILLWINDOW, to provide a dummy empty line descriptor for the guy to type at.") + + (RETURN (WINDOWPROP WINDOW 'LINES] + (T (* ; + "We found no changes; return a NIL last-line-changed") + (replace (TEXTOBJ TXTNEEDSUPDATE) of TEXTOBJ with NIL) + (* ; + "Reset the 'needs-update' flag so we don't come back looking for work again.") + (RETURN NIL] + [SETQ YBOT (fetch (LINEDESCRIPTOR YBOT) of (SETQ PREVLINE (fetch ( + LINEDESCRIPTOR + PREVLINE) + of LINES] + (* ; + "Y bottom of the first line to reformat.") + (SETQ CHARLIM (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) of PREVLINE))) + (* ; "char to start formatting with") + (while (AND LINES (OR (IGEQ YBOT (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)) + (ILEQ CHARLIM NEXTCARETCH#))) + do + + (* ;; "Run thru lines, cleaning them up. Start with the first dirty line, and only stop if we're both past the place the caret will be AND off the bottom of the screen.") + + [COND + ([ILESSP 0 (SETQ DY (IDIFFERENCE (\TEDIT.NEXT.LINE.BOTTOM + YBOT LINES (fetch (LINEDESCRIPTOR + PREVLINE) + of LINES)) + (fetch (LINEDESCRIPTOR YBOT) of LINES] + (* ; + "There used to be another line above this one. Move this up to cover it.") + (\TEDIT.CLOSEUPLINES TEXTOBJ (fetch (LINEDESCRIPTOR PREVLINE) + of LINES) + LINES NIL (OR WINDOW (\TEDIT.PRIMARYW TEXTOBJ] + [COND + ((IGREATERP CHARLIM (IMIN (IMAX 1 (fetch (LINEDESCRIPTOR CHARLIM) + of LINES)) + TEXTLEN)) (* ; + "This line has been rendered superfluous -- Delete it.") + (TEDIT.DELETELINE LINES TEXTOBJ WINDOW)) + (T + (* ;; "Try updating the line. If the updater returns NIL, it ran off the bottom of the screen, and we should give up.") + + (COND + ((SETQ LINES (\TEDIT.FIXCHANGEDLINE TEXTOBJ YBOT LINES WINDOW + TEXTLEN THISLINE WHEIGHT CHARLIM NEXTCARETCH# + (fetch (LINEDESCRIPTOR DESCENT) of PREVLINE) + )) (* ; + "We're still on screen; update the character and Y-position counters for the next loop") + (SETQ CHARLIM (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) of LINES))) + (SETQ YBOT (fetch (LINEDESCRIPTOR YBOT) of LINES))) + (T (* ; + "Ran off the bottom of the window; the bottom has already been cleared, so avoid doing it here.") + (SETQ CLEARBOTTOM NIL) + (RETURN] + (COND + ((IGEQ CHARLIM TEXTLEN) (* ; +"If we've run out of text, chop off any remaining line descriptors, since we won't be needing them.") + (replace (LINEDESCRIPTOR NEXTLINE) of LINES with NIL) + (replace (TEXTOBJ TXTNEEDSUPDATE) of TEXTOBJ with NIL) + (* ; + "And there's no more screen updating to do, either.") + ) + ((AND INCREMENTAL? (fetch (LINEDESCRIPTOR NEXTLINE) of LINES) + (IGREATERP CHARLIM NEXTCARETCH#) + (\SYSBUFP)) (* ; + "This is an incremental update, and he hit a key. Stop updating and listen to him") + (* ; + "HOWEVER, NEVER STOP ON THE LAST LINE -- IF THERE ARE NEW LINES TO ADD, ADD ONE.") + (SETQ PREVLINE NIL) + (SETQ CLEARBOTTOM NIL) + (RETURN))) + (SETQ PREVLINE LINES) (* ; + "Remember the last line we really formatted.") + (SETQ LINES (fetch (LINEDESCRIPTOR NEXTLINE) of LINES)) + (* ; "Move to the next line")) + (COND + (CLEARBOTTOM (* ; + "There had been lines yet to be formatted, so there may be garbage below the end of the screen.") + (\TEDIT.CLEAR.SCREEN.BELOW.LINE TEXTOBJ WINDOW PREVLINE))) + (RETURN PREVLINE]) + +(\TEDIT.INSERTLINE + [LAMBDA (NEWLINE BEFORELINE) (* ; "Edited 30-May-91 16:05 by jds") + (* Inserts NEWLINE in front of + BEFORELINE in the line-descriptor + chain) + (PROG ((PREVLINE (fetch (LINEDESCRIPTOR PREVLINE) of BEFORELINE))) + (replace (LINEDESCRIPTOR PREVLINE) of NEWLINE with PREVLINE) + (replace (LINEDESCRIPTOR NEXTLINE) of NEWLINE with BEFORELINE) + (replace (LINEDESCRIPTOR PREVLINE) of BEFORELINE with NEWLINE) + (AND PREVLINE (replace (LINEDESCRIPTOR NEXTLINE) of PREVLINE with NEWLINE]) + +(\TEDIT.LINE.LIST + [LAMBDA (TEXTOBJ WINDOW) (* ; "Edited 12-Jun-90 19:23 by mitani") + (for WW inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) as LINES + inside (fetch (TEXTOBJ LINES) of TEXTOBJ) when (EQ WW WINDOW) + do (RETURN LINES]) + +(\TEDIT.MARK.LINES.DIRTY + [LAMBDA (TEXTOBJ CH1 CHLIM) (* ; "Edited 30-May-91 16:05 by jds") + (* Mark dirty the lines that + intersect the range ch1 t chlim + inclusive) + (bind (CH# _ (IMIN CH1 (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) + (CHLIM# _ (COND + ((IEQP CHLIM -1) + (ADD1 (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) + (T CHLIM))) for WW inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ + ) + do (bind (LL _ (WINDOWPROP WW 'LINES)) while LL + do (* Mark changed lines as DIRTY.) + (COND + ((AND (ILEQ (fetch (LINEDESCRIPTOR CHAR1) of LL) + CHLIM#) + (IGEQ (fetch (LINEDESCRIPTOR CHARTOP) of LL) + CH#)) + + (* The dirty range overlaps with this line -- + it is between the 1st char on the line, and the last char examined when + deciding where to break the line.) + + (replace (LINEDESCRIPTOR DIRTY) of LL with T))) + (SETQ LL (fetch (LINEDESCRIPTOR NEXTLINE) of LL))) + finally (replace (TEXTOBJ TXTNEEDSUPDATE) of TEXTOBJ with T]) + +(\TEDIT.NEXT.LINE.BOTTOM + [LAMBDA (CURYBOT LINE PREVLINE) (* ; "Edited 24-Sep-87 10:00 by jds") + +(* ;;; "Given a current Y-bottom for PREVLINE, and a LINE to follow it, compute the new line's YBOT value. Takes into account Base-to-base leading, as well as paragraph leadings.") + + (PROG (NEWYBOT PARALEADING PARALOOKS BASETOBASE) + [COND + [[SETQ BASETOBASE (fetch (FMTSPEC FMTBASETOBASE) of (SETQ PARALOOKS (fetch ( + LINEDESCRIPTOR + LFMTSPEC) + of LINE] + + (* ;; "If base-to-base spacing is specified, we have to do this in two parts: First, compute the proper spacing between the lines; then add in any paragraph leading.") + + [SETQ NEWYBOT (IDIFFERENCE (IPLUS CURYBOT (fetch (LINEDESCRIPTOR DESCENT) of PREVLINE)) + (IPLUS BASETOBASE (fetch (LINEDESCRIPTOR DESCENT) of LINE] + (COND + ((fetch (LINEDESCRIPTOR 1STLN) of LINE) (* ; + "This is the first line of a new paragraph. Add in any paragraph leading.") + + [SETQ PARALEADING (IPLUS (fetch (FMTSPEC LEADBEFORE) of PARALOOKS) + (fetch (FMTSPEC LEADAFTER) of (fetch (LINEDESCRIPTOR + LFMTSPEC) + of PREVLINE] + + (* ;; "The inter-paragraph space is the sum of the previous para's post-leading and this para's pre-leading.") + + (SETQ NEWYBOT (IDIFFERENCE NEWYBOT PARALEADING] + (T + + (* ;; "If there's no base-to-base spacing, then paragraph leading was taken into account in the line formatter, and is already part of LHEIGHT.") + + (SETQ NEWYBOT (IDIFFERENCE CURYBOT (fetch (LINEDESCRIPTOR LHEIGHT) of LINE] + (RETURN NEWYBOT]) +) + +(RPAQQ TEDIT.DONT.BREAK.CHARS (8482 8483 8491 8492 8508 8525 8539 8537 8535 9249 9251 9253 9255 9257 9283 9315 9317 9319 9326 9505 9507 9509 9511 9513 9539 9571 9573 9575 9582) +) + +(RPAQQ TEDIT.DONT.LAST.CHARS (8524 8538 8536 8534)) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS TEDIT.DONT.BREAK.CHARS TEDIT.DONT.LAST.CHARS) +) + +(COND ((EQ (MACHINETYPE) (QUOTE MAIKO)) (MOVD (QUOTE \MAIKO.DISPLAYLINE) (QUOTE \DISPLAYLINE))) (T (ADDTOVAR \MAIKO.MOVDS (\MAIKO.DISPLAYLINE \DISPLAYLINE)))) +(PUTPROPS TEDITSCREEN COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 +1991 1992 1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (1875 75847 (\FORMATLINE 1885 . 55593) (\TEDIT.NSCHAR.RUN 55595 . 62412) ( +\TEDIT.PURGE.SPACES 62414 . 62872) (\DOFORMATTING 62874 . 75845)) (75848 106348 (\DISPLAYLINE 75858 . +93778) (\MAIKO.DISPLAYLINE 93780 . 102348) (\TEDIT.LINECACHE 102350 . 103101) (\TEDIT.CREATE.LINECACHE + 103103 . 103847) (\TEDIT.BLTCHAR 103849 . 106346)) (106349 220804 (TEDIT.CR.UPDATESCREEN 106359 . +107610) (TEDIT.DELETELINE 107612 . 108646) (TEDIT.INSERT.DISPLAYTEXT 108648 . 123887) ( +TEDIT.INSERT.UPDATESCREEN 123889 . 130641) (TEDIT.UPDATE.SCREEN 130643 . 131861) (\BACKFORMAT 131863 + . 136174) (\FILLWINDOW 136176 . 151280) (\FIXDLINES 151282 . 158519) (\FIXILINES 158521 . 166496) ( +\SHOWTEXT 166498 . 169754) (\TEDIT.ADJUST.LINES 169756 . 177223) (\TEDIT.CLEAR.SCREEN.BELOW.LINE +177225 . 177955) (\TEDIT.CLOSEUPLINES 177957 . 186473) (\TEDIT.COPY.LINEDESCRIPTOR 186475 . 192041) ( +\TEDIT.FIXCHANGEDLINE 192043 . 203222) (\TEDIT.FIXCHANGEDPART 203224 . 215651) (\TEDIT.INSERTLINE +215653 . 216473) (\TEDIT.LINE.LIST 216475 . 216801) (\TEDIT.MARK.LINES.DIRTY 216803 . 218489) ( +\TEDIT.NEXT.LINE.BOTTOM 218491 . 220802))))) +STOP diff --git a/library/TEDITSELECTION b/library/TEDITSELECTION new file mode 100644 index 00000000..87d68a1b --- /dev/null +++ b/library/TEDITSELECTION @@ -0,0 +1,2277 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "25-Aug-94 10:56:07" {DSK}export>lispcore>library>TEDITSELECTION.;4 157341 + + changes to%: (VARS TEDITSELECTIONCOMS) (FILES TEDITDCL) + + previous date%: "29-Mar-94 13:45:15" {DSK}export>lispcore>library>TEDITSELECTION.;3) + + +(* ; " +Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993, 1994 by John Sybalsky & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT TEDITSELECTIONCOMS) + +(RPAQQ TEDITSELECTIONCOMS ((FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (FNS TEDIT.SEL.AS.STRING TEDIT.SELECTED.PIECES \TEDIT.FIND.FIRST.LINE \TEDIT.FIND.LAST.LINE \TEDIT.FIND.OVERLAPPING.LINE \TEDIT.FIND.PROTECTED.END \TEDIT.FIND.PROTECTED.START \TEDIT.WORD.BOUND) (INITVARS (TEDIT.EXTEND.PENDING.DELETE T)) (FNS \CREATE.TEDIT.SELECTION \CREATE.TEDIT.SHIFTEDSELECTION \CREATE.TEDIT.MOVESELECTION \CREATE.TEDIT.DELETESELECTION) (* ; "Added by yabu.fx, for LOADUP without DWIM.") (VARS (TEDIT.SELECTION (\CREATE.TEDIT.SELECTION)) (* ; "Original was %"(create SELECTION)%".") (TEDIT.SCRATCHSELECTION (\CREATE.TEDIT.SELECTION)) (* ; "Original was %"(create SELECTION)%".") (TEDIT.SHIFTEDSELECTION (\CREATE.TEDIT.SHIFTEDSELECTION)) (* ; "Original was %"(create SELECTION HASCARET _ NIL)%".") (TEDIT.COPYLOOKSSELECTION (\CREATE.TEDIT.SHIFTEDSELECTION)) (* ; "Original was %"(create SELECTION HASCARET _ NIL)%".") (TEDIT.MOVESELECTION (\CREATE.TEDIT.MOVESELECTION)) (* ; "Original was %"(CREATE SELECTION HASCARET _ NIL HOWHEIGHT _ 32767)%".") (TEDIT.DELETESELECTION (\CREATE.TEDIT.DELETESELECTION)) (* ; "Original was %"(CREATE SELECTION HOW _ BLACKSHADE HASCARET _ NIL HOWHEIGHT _ 32767)%".") (* ; "Changed by yabu.fx, for LOADUP without DWIM.") (TEDIT.SELPENDING NIL)) (GLOBALVARS TEDIT.SELECTION TEDIT.SCRATCHSELECTION TEDIT.MOVESELECTION TEDIT.SHIFTEDSELECTION TEDIT.COPYLOOKSSELECTION TEDIT.DELETESELECTION TEDIT.SELPENDING TEDIT.EXTEND.PENDING.DELETE) (COMS (* ; "Selection manipulating code") (FNS TEDIT.EXTEND.SEL TEDIT.SELECT TEDIT.SCAN.LINE TEDIT.SELECT.LINE.SCANNER \TEDIT.SELECT.CHARACTER) (FNS \FIXSEL \TEDIT.FIXDELSEL \TEDIT.FIXINSSEL \TEDIT.FIXSELS) (FNS TEDIT.RESET.EXTEND.PENDING.DELETE \TEDIT.SET.SEL.LOOKS) (FNS \SHOWSEL \SHOWSEL.HILIGHT \TEDIT.UPDATE.SHOWSEL \TEDIT.SHOWSELS \TEDIT.REFRESH.SHOWSEL) (FNS \COPYSEL \TEDIT.SEL.CHANGED?)) (COMS (* ;; "User entries to the selection code") (FNS TEDIT.GETPOINT TEDIT.GETSEL TEDIT.MAKESEL TEDIT.SCANSEL TEDIT.SET.SEL.LOOKS TEDIT.SETSEL TEDIT.SHOWSEL))) +) + +(FILESLOAD TEDITDCL) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ \SCRATCHLEN 64) + + +(CONSTANTS (\SCRATCHLEN 64)) +) + + +(FILESLOAD (LOADCOMP) TEDITDCL) +) +(DEFINEQ + +(TEDIT.SEL.AS.STRING + [LAMBDA (STREAM SEL) (* ; "Edited 22-Apr-93 16:44 by jds") + + (* ;; + "Given a text stream, go to the TEXTOBJ, get the current selection, and return it as a string.") + + (SETQ STREAM (TEXTSTREAM STREAM)) + (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) + LEN TSEL RESULT OFFST BASE) + (SETQ TSEL (OR SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))) + (SETQ LEN (fetch (SELECTION DCH) of TSEL)) + (COND + ((ZEROP LEN) (* ; + "There is no selection, or it's zero-width. Return ''") + (RETURN "")) + (T (SETQ RESULT (ALLOCSTRING LEN (CHARCODE SPACE))) + (* ; "The resulting string") + (\SETUPGETCH (fetch (SELECTION CH#) of TSEL) + TEXTOBJ) (* ; + "Starting point for the string is start of selection.") + (for I from 1 to LEN do (* ; + "Get chars from the stream, and put them in the string.") + (RPLCHARCODE RESULT I (\GETCH TEXTOBJ))) + (RETURN RESULT]) + +(TEDIT.SELECTED.PIECES + [LAMBDA (TEXTOBJ SEL CROSSCOPY PIECEMAPFN FNARG1 FNARG2) + (* ; "Edited 20-Apr-93 17:06 by jds") + + (* ;; "Create a list of pieces corresponding to the selection; if FNARG, apply it to each piece, and use the result as the copy of the piece") + + (PROG ((CH1 (fetch (SELECTION CH#) of SEL)) + (CHLIM (fetch (SELECTION CHLIM) of SEL)) + (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + (INSERTPC (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ)) + LEN INSPC INSPC# PC NPC (PCCH 1) + NPCCH OPLEN EVENT REPLACING INSERTCH# PCLST OBJ COPYFN UNDOCHAIN NODE) + (* ; "Find the insertion point") + (AND (ZEROP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (RETURN NIL)) + (SETQ PCLST (TCONC NIL)) + (first (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB) + 0)) while PC for I from 1 + do + + (* ;; "Gather a list of pieces to be copied") + + (SETQ NODE PC) + [COND + ((IGEQ PCCH CHLIM) (* ; + "We've passed beyond the copy region. Bail out.") + (RETURN)) + ((ILEQ (SETQ NPCCH (IPLUS PCCH (fetch (PIECE PLEN) of PC))) + CH1) (* ; + "The current piece isn't inside the region to be copied.") + ) + (T (* ; + "This piece overlaps the copy-source region of the document") + (* ; "Add it to the copy list.") + (COND + ((ILESSP PCCH CH1) (* ; + "The piece overlaps the bottom of the copy region: Chop off its front part.") + (COND + ((EQ PC INSERTPC) + + (* ;; + "We're splitting the insertion piece. Never let the underlying string be touched again.") + + (replace (TEXTOBJ \INSERTPC) of TEXTOBJ with NIL))) + (SETQ PC (\SPLITPIECE PC (- CH1 PCCH) + TEXTOBJ I)) + (SETQ PCCH CH1))) + (COND + ((ILESSP CHLIM NPCCH) (* ; + "This piece overlaps the end of the copy region. Shorten it at the end.") + (\SPLITPIECE PC (- CHLIM PCCH) + TEXTOBJ I))) + (TCONC PCLST (SETQ NPC (COND + (PIECEMAPFN (APPLY* PIECEMAPFN PC TEXTOBJ FNARG1 + FNARG2)) + (T PC] + (add PCCH (fetch (PIECE PLEN) of PC)) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC))) + (RETURN (CDAR PCLST]) + +(\TEDIT.FIND.FIRST.LINE + [LAMBDA (TEXTOBJ WHEIGHT CH# WINDOW) (* ; "Edited 30-May-91 23:02 by jds") + (* Find the first line to be + displayed, given that it must + include character CH#) + (PROG ((LINES (OR (AND WINDOW (WINDOWPROP WINDOW 'LINES)) + (fetch (TEXTOBJ LINES) of TEXTOBJ))) + (WWIDTH (fetch (TEXTOBJ WRIGHT) of TEXTOBJ)) + (TEXTSTREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) + LINE CHNO CH) + [COND + ((ZEROP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (* If there's no text, force an + empty line) + (SETQ CHNO 1) + (replace (LINEDESCRIPTOR NEXTLINE) of LINES with NIL) + (RETURN LINES)) + ((IGREATERP CH# (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (* If there's no text on the screen, + just return nil) + (RETURN NIL)) + [(fetch (TEXTOBJ FORMATTEDP) of TEXTOBJ)(* For a para-formatted object, back + up to the prior para bound.) + (SETQ CHNO (CAR (\TEDIT.PARABOUNDS TEXTOBJ CH#] + (T (* Otherwise, move back thru the + text until we find a for-sure line + break) + (\SETUPGETCH CH# TEXTOBJ) + (SETQ CH 0) + (for old CHNO from (SUB1 CH#) to 2 by -1 + repeatwhile (NOT (EQ CH (CHARCODE CR))) do (SETQ CH (\BACKBIN TEXTSTREAM)) + ) + (SETQ CHNO (COND + ((ILEQ CHNO 1) (* If we moved back to + start-of-file, move forward from + there;) + 1) + ((IEQP CHNO CH#) (* If we landed on a CR first shot, + let's try moving forward from there.) + CH#) + (T (* Else, skip the CR we passed over) + (ADD1 CHNO] + (SETQ CH# (IMIN CH# (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) + [repeatwhile (ILEQ CHNO CH#) do + + (* Starting from the known line break, move forward until we find the line + which has the right CH# in it) + + (SETQ LINE (\FORMATLINE TEXTOBJ NIL CHNO)) + (replace (LINEDESCRIPTOR YBOT) of LINE + with WHEIGHT) + (replace (LINEDESCRIPTOR NEXTLINE) of LINES + with LINE) + (replace (LINEDESCRIPTOR PREVLINE) of LINE + with LINES) + (SETQ LINES LINE) + (SETQ CHNO (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) + of LINE] + (RETURN LINE]) + +(\TEDIT.FIND.LAST.LINE + [LAMBDA (TEXTOBJ LINES) (* ; "Edited 30-May-91 23:02 by jds") + + (* Among the line descriptors in LINES, find the last one on the screen; + then return it.) + + (OR LINES (SETQ LINES (fetch (TEXTOBJ LINES) of TEXTOBJ))) + (* Make sure a list of line + descriptors is specified.) + (COND + ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) (* If there's no window, return NIL.) + (bind (OLINE _ LINES) + (LINE _ LINES) + (CURY _ (fetch (LINEDESCRIPTOR YBOT) of LINES)) + while (AND LINE (IGEQ (fetch (LINEDESCRIPTOR YBOT) of LINE) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ))) + do (* Find the lowest line above screen + bottom, and put it in OLINE.) + (SETQ OLINE LINE) + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE)) + finally (RETURN OLINE))) + (T NIL]) + +(\TEDIT.FIND.OVERLAPPING.LINE + [LAMBDA (LINES Y) (* ; "Edited 30-May-91 22:57 by jds") + (while LINES do (COND + ((ILEQ (fetch (LINEDESCRIPTOR YBOT) of LINES) + Y) + (RETURN LINES)) + (T (SETQ LINES (fetch (LINEDESCRIPTOR NEXTLINE) of LINES]) + +(\TEDIT.FIND.PROTECTED.END + [LAMBDA (TEXTOBJ CH# LIMITCH#) (* ; "Edited 18-Apr-93 23:49 by jds") + + (* ;; "Starting from a CH# in a selectable region, find the CH# of the last selectable character following that. This is used to limit selections to unprotected text, and to prevent selection of the protected text between tow unprotected areas.") + + (* ;; "If LIMITCH# is given, the search will stop there.") + + (bind (OURLIMIT _ (IMIN (OR LIMITCH# (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) + (PCTB _ (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + START-OF-PIECE PC first (SETQ PC (\CHTOPC CH# (fetch (TEXTOBJ PCTB) of TEXTOBJ + ) + T)) while PC + do + + (* ;; "Move forward thru the pieces of the document, looking for one that contains protected text. If that comes before the end of the region we're interested in, tell the caller about the earlier end to selectable text.") + + [COND + ((IGREATERP START-OF-PIECE OURLIMIT) (* ; + "We've passed the limit, so it's time to give up. Just return the LIMITCH#") + (RETURN OURLIMIT)) + ((fetch (CHARLOOKS CLPROTECTED) of (fetch (PIECE PLOOKS) of PC)) + + (* ;; "We've found the beginning of a protected region -- i.e., the end of the selectable region. Tell the caller about it.") + + (RETURN (SUB1 START-OF-PIECE] + (add START-OF-PIECE (fetch (PIECE PLEN) of PC)) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) + finally (RETURN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ]) + +(\TEDIT.FIND.PROTECTED.START + [LAMBDA (TEXTOBJ CH# LIMITCH#) (* ; "Edited 30-Apr-93 01:39 by jds") + + (* ;; "Starting from a CH# in a selectable region, find the CH# of the earliest contiguously-selectable character preceding that. This is used to limit selections to unprotected text, and to prevent selection of the protected text between tow unprotected areas.") + + (* ;; "Will stop looking when it passes LIMITCH#, or at the beginning of the document.") + + (bind (OURLIMIT _ (OR LIMITCH# 1)) + (PCTB _ (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + PC START-OF-PIECE first (SETQ PC (\CHTOPC CH# PCTB T)) + (AND (LITATOM PC) + (SETQ PC (\CHTOPC CH# (SUB1 START-OF-PIECE) + T))) while PC + do [COND + ((ILEQ START-OF-PIECE OURLIMIT) (* ; + "If he specified a LIMITCH#, and we have passed it, stop bothering and return the LIMITCH#") + (RETURN OURLIMIT)) + ((fetch (CHARLOOKS CLPROTECTED) of (fetch (PIECE PLOOKS) of PC)) + + (* ;; "We hit a PROTECTED piece of text. This is the place to stop. Return the CH# just AFTER the protected text we found.") + + (RETURN (IPLUS START-OF-PIECE (fetch (PIECE PLEN) of PC] + (SETQ PC (fetch (PIECE PREVPIECE) of PC)) + (SETQ START-OF-PIECE (IDIFFERENCE START-OF-PIECE (fetch (PIECE PLEN) of PC]) + +(\TEDIT.WORD.BOUND + [LAMBDA (TEXTOBJ PREVCH CH) (* ; "Edited 30-May-91 23:02 by jds") + (PROG ((READSA (fetch READSA of (OR (fetch (TEXTOBJ TXTWTBL) of TEXTOBJ) + TEDIT.WORDBOUND.READTABLE))) + SYN1 SYN2) + (COND + ((NOT (AND (FIXP PREVCH) + (FIXP CH))) + (RETURN T))) + (SETQ SYN1 (\SYNCODE READSA PREVCH)) + (SETQ SYN2 (\SYNCODE READSA CH)) + (RETURN (NEQ SYN1 SYN2]) +) + +(RPAQ? TEDIT.EXTEND.PENDING.DELETE T) +(DEFINEQ + +(\CREATE.TEDIT.SELECTION + [LAMBDA NIL + (create SELECTION]) + +(\CREATE.TEDIT.SHIFTEDSELECTION + [LAMBDA NIL + (create SELECTION + HASCARET _ NIL]) + +(\CREATE.TEDIT.MOVESELECTION + [LAMBDA NIL + (CREATE SELECTION + HASCARET _ NIL + HOWHEIGHT _ 32767]) + +(\CREATE.TEDIT.DELETESELECTION + [LAMBDA NIL + (CREATE SELECTION + HOW _ BLACKSHADE + HASCARET _ NIL + HOWHEIGHT _ 32767]) +) + + + +(* ; "Added by yabu.fx, for LOADUP without DWIM.") + + +(RPAQ TEDIT.SELECTION (\CREATE.TEDIT.SELECTION)) + +(RPAQ TEDIT.SCRATCHSELECTION (\CREATE.TEDIT.SELECTION)) + +(RPAQ TEDIT.SHIFTEDSELECTION (\CREATE.TEDIT.SHIFTEDSELECTION)) + +(RPAQ TEDIT.COPYLOOKSSELECTION (\CREATE.TEDIT.SHIFTEDSELECTION)) + +(RPAQ TEDIT.MOVESELECTION (\CREATE.TEDIT.MOVESELECTION)) + +(RPAQ TEDIT.DELETESELECTION (\CREATE.TEDIT.DELETESELECTION)) + +(RPAQQ TEDIT.SELPENDING NIL) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS TEDIT.SELECTION TEDIT.SCRATCHSELECTION TEDIT.MOVESELECTION TEDIT.SHIFTEDSELECTION TEDIT.COPYLOOKSSELECTION TEDIT.DELETESELECTION TEDIT.SELPENDING TEDIT.EXTEND.PENDING.DELETE) +) + + + +(* ; "Selection manipulating code") + +(DEFINEQ + +(TEDIT.EXTEND.SEL + [LAMBDA (X Y OSEL TEXTOBJ SELOPERATION SELWINDOW NEWSEL) + (* ; "Edited 19-Apr-93 13:49 by jds") + (* ; + "Gather a new selected character, and extend OSEL to include it. Return the extended selection.") + (PROG ((NSEL (OR NEWSEL (TEDIT.SELECT X Y TEXTOBJ (SELECTQ (fetch (SELECTION SELKIND) + of OSEL) + ((LINE PARA) + 'LINE) + ((WORD CHAR) + 'TEXT) + 'TEXT) + (OR (EQ (fetch (SELECTION SELKIND) of OSEL) + 'WORD) + (EQ (fetch (SELECTION SELKIND) of OSEL) + 'PARA)) + SELOPERATION SELWINDOW T))) + (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (NPOINT NIL) + (SETOSELFLG NIL) + (FIXUPNEEDED NIL)) + (COND + ((ZEROP TEXTLEN) (* ; + "No sense in extending a selection if there's no text!") + (RETURN NSEL))) + (COND + ((AND NSEL (fetch (SELECTION SET) of NSEL)) + (* ; + "If there's no second selection, don't bother trying") + (\TEDIT.SET.SEL.LOOKS NSEL SELOPERATION) + + (* ;; "Make the new selection be the same kind as the original, as to what it's for -- regular, copy-source, etc.") + + [SETQ NPOINT (COND + ((IGEQ (fetch (SELECTION CHLIM) of NSEL) + (fetch (SELECTION CHLIM) of OSEL)) + (* ; + "The new selection ends to the right of the old one. Move this edge.") + 'RIGHT) + ((ILEQ (fetch (SELECTION CH#) of NSEL) + (fetch (SELECTION CH#) of OSEL)) + (* ; + "If the new selection starts to left of old one, caret goes at the LEFT") + 'LEFT) + ([IGREATERP (IABS (IDIFFERENCE (fetch (SELECTION CHLIM) + of NSEL) + (fetch (SELECTION CHLIM) of OSEL))) + (IABS (IDIFFERENCE (fetch (SELECTION CH#) of NSEL) + (fetch (SELECTION CH#) of OSEL] + (SETQ SETOSELFLG T) + 'LEFT) + (T (SETQ SETOSELFLG T) + 'RIGHT] + [SELECTQ NPOINT + (LEFT (* ; + "Caret's to the left. Keep the same right end") + [replace (SELECTION CHLIM) of NSEL + with (IMAX (fetch (SELECTION CHLIM) of NSEL) + (SELECTQ (fetch (SELECTION POINT) of OSEL) + (LEFT (IPLUS (fetch (SELECTION CH#) of OSEL) + (fetch (SELECTION DCH) of OSEL))) + (RIGHT (fetch (SELECTION CHLIM) of OSEL)) + (SHOULDNT] + (replace (SELECTION XLIM) of NSEL with (fetch (SELECTION + XLIM) + of OSEL)) + (replace (SELECTION YLIM) of NSEL with (fetch (SELECTION + YLIM) + of OSEL)) + (replace (SELECTION LN) of NSEL with (COPY (fetch + (SELECTION LN) + of OSEL))) + (COND + ((NEQ SELOPERATION 'COPY) (* ; + "The old sel is in a protected area. Only let him extend to the start of it.") + [replace (SELECTION CH#) of NSEL + with (IMAX (fetch (SELECTION CH#) of NSEL) + (\TEDIT.FIND.PROTECTED.START + TEXTOBJ + (SUB1 (fetch (SELECTION CHLIM) of OSEL)) + (fetch (SELECTION CH#) of NSEL] + (SETQ FIXUPNEEDED T) (* ; + "Note that the L1/LN may be invalid as a result of this contraction. Force a \FIXSEL later.") + ))) + (RIGHT (* ; + "Point's to the right; keep the same left end.") + [replace (SELECTION CH#) of NSEL + with (IMIN (fetch (SELECTION CH#) of NSEL) + (SELECTQ (fetch (SELECTION POINT) of OSEL) + (LEFT (fetch (SELECTION CH#) of OSEL)) + (RIGHT (IDIFFERENCE (fetch (SELECTION CHLIM) + of OSEL) + (fetch (SELECTION DCH) of OSEL))) + (SHOULDNT] + (replace (SELECTION X0) of NSEL with (fetch (SELECTION + X0) + of OSEL)) + (replace (SELECTION Y0) of NSEL with (fetch (SELECTION + Y0) + of OSEL)) + (replace (SELECTION L1) of NSEL with (COPY (fetch + (SELECTION L1) + of OSEL))) + (COND + ((NEQ SELOPERATION 'COPY) (* ; + "The old sel is in a protected area. Only let him extend to the start of it.") + [replace (SELECTION CHLIM) of NSEL + with + (IMIN (fetch (SELECTION CHLIM) of NSEL) + (ADD1 (\TEDIT.FIND.PROTECTED.END + TEXTOBJ + (fetch (SELECTION CH#) of OSEL) + (ADD1 (\TEDIT.FIND.PROTECTED.END + TEXTOBJ + (fetch (SELECTION CH#) of OSEL) + (SUB1 (fetch (SELECTION CHLIM) of NSEL] + (replace (SELECTION CH#) of NSEL + with (IMIN (fetch (SELECTION CHLIM) of NSEL) + (fetch (SELECTION CH#) of NSEL))) + (SETQ FIXUPNEEDED T) (* ; + "Note that the L1/LN may be invalid as a result of this contraction. Force a \FIXSEL later.") + ))) + (PROGN (replace (SELECTION CHLIM) of NSEL with (fetch (SELECTION + CHLIM) + of OSEL)) + (replace (SELECTION XLIM) of NSEL with (fetch (SELECTION + XLIM) + of OSEL)) + (replace (SELECTION YLIM) of NSEL with (fetch (SELECTION + YLIM) + of OSEL)) + (replace (SELECTION LN) of NSEL with (COPY (fetch + (SELECTION LN) + of OSEL))) + (replace (SELECTION CH#) of NSEL with (fetch (SELECTION + CH#) + of OSEL)) + (replace (SELECTION X0) of NSEL with (fetch (SELECTION + X0) + of OSEL)) + (replace (SELECTION Y0) of NSEL with (fetch (SELECTION + Y0) + of OSEL)) + (replace L1 of NSEL with (COPY (fetch L1 of OSEL))) + (SETQ NPOINT (fetch POINT of OSEL] + (replace DCH of NSEL with (IDIFFERENCE (IMIN (ADD1 TEXTLEN) + (fetch CHLIM of NSEL)) + (fetch CH# of NSEL))) + (* ; + "The selection's length cannot exceed that of the whole text.") + (replace CHLIM of NSEL with (IPLUS (fetch CH# of NSEL) + (fetch DCH of NSEL))) + (* ; + "This assures that the CHLIM corresponds to the DCH.") + (replace POINT of NSEL with NPOINT) + (replace (SELECTION DX) of NSEL with (IDIFFERENCE (fetch XLIM + of NSEL) + (fetch X0 of NSEL))) + (COND + ((NEQ (fetch SELOBJ of OSEL) + (fetch SELOBJ of NSEL)) + (replace SELOBJ of NSEL with NIL))) + (COND + (FIXUPNEEDED + + (* ;; "We're in a menu, and this selection got contracted because of a protection violation. Fix up everything.") + + (\FIXSEL NSEL TEXTOBJ))) + (COND + (SETOSELFLG (* ; + "For whatever reason, it is wise to copy the new sel into the old one.") + (\COPYSEL NSEL OSEL)) + (T (* ; + "Otherwise, set the POINT of the old sel to correspond to the new sel's.") + (* ; + "(replace POINT of OSEL with NPOINT)") + (* ; + "THIS WAS REMOVED, BECAUSE EXTENDING A POINT-SELECTION WOULD DIE WHEN THIS WAS DONE") + )) + (RETURN NSEL)) + (T (* ; + "No new selection was made; just return the old one.") + (RETURN OSEL]) + +(TEDIT.SELECT + [LAMBDA (X Y TEXTOBJ REGION WORDSELFLG SELOPERATION WINDOW EXTENDING) + (* ; "Edited 30-May-91 23:07 by jds") + (* Select the character word, line, + or paragraph the mouse is pointing + at.) + (PROG ((SEL NIL) + (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + PREVLINE L1 LN) + (SETQ SEL (TEDIT.SELECT.LINE.SCANNER X Y TEXTOBJ (\TEDIT.LINE.LIST TEXTOBJ WINDOW) + REGION WORDSELFLG SELOPERATION WINDOW EXTENDING)) + (COND + ((AND (type? SELECTION SEL) + (fetch (SELECTION SET) of SEL)) (* He pointed at something real; + return that.) + (\TEDIT.SET.SEL.LOOKS SEL SELOPERATION) + [COND + ([AND (CAR (fetch (SELECTION L1) of SEL)) + (fetch (FMTSPEC FMTHARDCOPY) of (fetch (LINEDESCRIPTOR LFMTSPEC) + of (CAR (fetch (SELECTION + L1) + of SEL] + (replace (SELECTION X0) of SEL with (FIXR (FQUOTIENT + (fetch (SELECTION X0) + of SEL) + 35.27778] + [COND + ([AND (CAR (fetch (SELECTION LN) of SEL)) + (fetch (FMTSPEC FMTHARDCOPY) of (fetch (LINEDESCRIPTOR LFMTSPEC) + of (CAR (fetch (SELECTION + LN) + of SEL] + (replace (SELECTION XLIM) of SEL with (FIXR (FQUOTIENT + (fetch (SELECTION + XLIM) + of SEL) + 35.27778] + (replace (SELECTION DX) of SEL with (IDIFFERENCE (fetch (SELECTION + XLIM) + of SEL) + (fetch (SELECTION X0) + of SEL))) + (\FIXSEL SEL TEXTOBJ WINDOW T) + (RETURN SEL)) + ((type? LINEDESCRIPTOR SEL) + + (* He pointed below the bottom of the text. + Select to the right of the last character on the screen.) + + (COND + ((fetch (LINEDESCRIPTOR LHASPROT) of SEL) + (* The last line is protected. + Don't select anything.) + (RETURN))) + (SETQ PREVLINE SEL) + (SETQ SEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + (replace (SELECTION SET) of SEL with T) + (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ) + [replace (SELECTION CH#) of SEL with + (IMAX 1 (ADD1 (IMIN TEXTLEN (fetch + (LINEDESCRIPTOR + CHARLIM) + of PREVLINE] + (replace (SELECTION CHLIM) of SEL with (fetch (SELECTION CH#) + of SEL)) + (replace (SELECTION DCH) of SEL with 0) + [replace (SELECTION POINT) of SEL with (COND + ((IGREATERP (fetch + (SELECTION CH#) + of SEL) + (fetch (TEXTOBJ + TEXTLEN) + of TEXTOBJ)) + + (* Can't select to the right of a character past EOF, only to the left -- + which is the right edge of the text.) + + 'LEFT) + (T 'RIGHT] + (\TEDIT.SET.SEL.LOOKS SEL SELOPERATION) + (\FIXSEL SEL TEXTOBJ) + (RETURN SEL]) + +(TEDIT.SCAN.LINE + [LAMBDA (TEXTOBJ LINE THISLINE X Y WORDSELFLG SELOPERATION WINDOW EXTENDING) + (* ; "Edited 31-May-91 12:26 by jds") + + (* ;; "Given a line, find the character which straddles the mouse.") + + (PROG ((L NIL) + (WLIST (fetch (THISLINE WIDTHS) of THISLINE)) + (CHLIST (fetch (THISLINE CHARS) of THISLINE)) + (LLIST (fetch (THISLINE LOOKS) of THISLINE)) + (LOOKNO 1) + (DX 0) + OTX YBOT YBASE TX (CH (CHARCODE SPACE)) + PREVCH CHOBJB TXB CHB (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + L1 LN CLOOKS PCLOOKS) + (COND + ((NEQ (fetch DESC of THISLINE) + LINE) (* ; + "If the cache doesn't describe this line, call \FORMATLINE so it will.") + (\FORMATLINE TEXTOBJ NIL (fetch (LINEDESCRIPTOR CHAR1) of LINE) + LINE))) + [COND + ((fetch (FMTSPEC FMTHARDCOPY) of (fetch (LINEDESCRIPTOR LFMTSPEC) + of LINE)) + (* ; + "This is a hardcopy-mode line. Convert units to micas") + (SETQ X (FIXR (FTIMES X 35.27778] + [SETQ OTX (SETQ TXB (SETQ TX (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE] + (SETQ X (IMAX X TX)) (* ; + "The mouse MUST be inside the line being selected.") + (SETQ CHB (SUB1 (fetch (LINEDESCRIPTOR CHAR1) of LINE))) + (SETQ CLOOKS (\EDITELT LLIST 0)) + (\TEDIT.CHECK (IGEQ X (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE))) + (* ; + "The mouse MUST be inside the line being selected.") + (for I from 0 to (fetch LEN of THISLINE) as CHNO + from (SUB1 (fetch (LINEDESCRIPTOR CHAR1) of LINE)) + do (SETQ PREVCH CH) + (SETQ PCLOOKS CLOOKS) + (SETQ CH (\EDITELT CHLIST I)) + [COND + ((EQ CH LMInvisibleRun) (* ; "An invisible run -- skip it") + (add CHNO (\EDITELT LLIST LOOKNO))(* ; "The length of the run") + (add LOOKNO 1) (* ; + "Move to next CLook for next transition") + (add I 1) (* ; + "Don't count this toward the CHNO counter.") + (SETQ CH (\EDITELT CHLIST I] + (\TEDIT.CHECK (NEQ CH LMInvisibleRun)) (* ; + "Can't have 2 invisible runs in a row.") + [COND + ((EQ CH LMLooksChange) (* ; + "Change of CharLooks -- make the switch") + (SETQ CLOOKS (\EDITELT LLIST LOOKNO)) (* ; "New looks") + (add LOOKNO 1) (* ; + "Move to next CLook for next transition") + (add I 1) (* ; + "Don't count this toward the CHNO counter.") + (SETQ CH (\EDITELT CHLIST I] + [COND + ((AND (ILESSP X TX) + (OR (EQ SELOPERATION 'COPY) + (fetch (CHARLOOKS CLSELHERE) of PCLOOKS) + (NOT (fetch (CHARLOOKS CLPROTECTED) of PCLOOKS))) + (OR (NOT WORDSELFLG) + (NOT (SMALLP PREVCH)) + (\TEDIT.WORD.BOUND TEXTOBJ PREVCH CH))) + + (* ;; "If we're beyond the mouse's X, and the character is selectable, and we're in char select or this is a word boundary then SELECT!!!") + + (\TEDIT.CHECK (NOT (ZEROP I))) (* ; + "We had best not have fouled out to the left of the left margin!") + (SETQ L (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + (* ; "Grab the scratch sel") + (replace (SELECTION SET) of L with T) + (* ; "Mark it valid") + [replace (SELECTION SELKIND) of L with (COND + (WORDSELFLG 'WORD) + (T 'CHAR] + (\TEDIT.SELECT.CHARACTER TEXTOBJ L PREVCH LINE X Y TXB WINDOW SELOPERATION + EXTENDING) + (replace (SELECTION Y0) of L with (fetch (LINEDESCRIPTOR + YBOT) of LINE)) + (replace (SELECTION X0) of L with (COND + ((fetch (CHARLOOKS + CLSELHERE) + of PCLOOKS) + (* ; + "If CLSelHere, then select to RIGHT always.") + TX) + (WORDSELFLG TXB) + (T OTX))) + (replace (SELECTION DX) of L with (COND + ((fetch (CHARLOOKS + CLSELHERE) + of PCLOOKS) + 0) + (WORDSELFLG (IDIFFERENCE + TX TXB)) + (T DX))) + [replace (SELECTION CH#) of L with (IMAX 1 (COND + ((fetch + (CHARLOOKS + CLSELHERE) + of PCLOOKS) + (ADD1 CHNO)) + (WORDSELFLG + (ADD1 CHB)) + (T CHNO] + (replace (SELECTION XLIM) of L with (COND + ((fetch (CHARLOOKS + CLSELHERE) + of PCLOOKS) + TX) + (WORDSELFLG TX) + (T TX))) + [replace (SELECTION CHLIM) of L with + (ADD1 (COND + ((fetch (CHARLOOKS + CLSELHERE) + of PCLOOKS) + CHNO) + (WORDSELFLG CHNO) + (T CHNO] + (replace (SELECTION YLIM) of L with (fetch (LINEDESCRIPTOR + YBOT) of + LINE)) + (for L1 on (fetch (SELECTION L1) of L) as LN + on (fetch (SELECTION LN) of L) as WW + inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + when (EQ WW WINDOW) do (RPLACA L1 LINE) + (RPLACA LN LINE)) + [replace (SELECTION POINT) of L + with (COND + ((fetch (CHARLOOKS CLSELHERE) of PCLOOKS) + (* ; + "Always to the right of an otherwise-protected insertion point marker") + 'RIGHT) + [WORDSELFLG (COND + ((AND (NEQ PREVCH (CHARCODE CR)) + (IGEQ X (LRSH (IPLUS TX TXB) + 1))) + (* ; + "To the right if it isn't a CR and we're right of center.") + 'RIGHT) + (T 'LEFT] + (T (COND + ((AND (IGEQ DX 3) + (NEQ PREVCH (CHARCODE CR)) + (IGEQ X (LRSH (IPLUS TX OTX) + 1))) + + (* ;; "If it's wide enough to sensibly decide on an edge for, this isn't a CR, and we're right of center, then put the caret to the RIGHT") + + 'RIGHT) + (T 'LEFT] + (replace (SELECTION DCH) of L with (COND + ((fetch (CHARLOOKS + CLSELHERE) + of PCLOOKS) + 0) + (WORDSELFLG (IDIFFERENCE + CHNO CHB)) + (T 1))) + (RETURN)) + (T + (* ;; "We're not past the mouse yet; just track the last word boundary (or protected-text boundary) for word selection.") + + (COND + ((OR (AND (NOT (fetch (CHARLOOKS CLPROTECTED) of CLOOKS)) + (\TEDIT.WORD.BOUND TEXTOBJ PREVCH CH)) + (NEQ (fetch (CHARLOOKS CLPROTECTED) of PCLOOKS) + (fetch (CHARLOOKS CLPROTECTED) of CLOOKS)) + (fetch (CHARLOOKS CLSELHERE) of PCLOOKS)) + (SETQ TXB TX) + (SETQ CHB CHNO) + (SETQ CHOBJB PREVCH] + (SETQ OTX TX) + (SETQ DX (\EDITELT WLIST I)) + (SETQ TX (IPLUS TX DX))) + [COND + ((AND (NOT L) + (IGEQ (fetch LEN of THISLINE) + 0) + (fetch (CHARLOOKS CLPROTECTED) of CLOOKS)) + + (* ;; "He's pointing to the right of the line, but there's protected text at the end. Select a point at the last legal spot.") + + (COND + ((SMALLP CHOBJB) (* ; + "And the last item wasn't a menu button") + (SETQ L (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + (replace (SELECTION SET) of L with T) + (replace (SELECTION Y0) of L with (fetch (LINEDESCRIPTOR YBOT) + of LINE)) + (replace (SELECTION X0) of L with TXB) + (replace (SELECTION DX) of L with 0) + (replace (SELECTION CH#) of L with (IMAX 1 (ADD1 CHB))) + (replace (SELECTION XLIM) of L with TXB) + (replace (SELECTION CHLIM) of L with (IMAX 1 (ADD1 CHB))) + (replace (SELECTION YLIM) of L with (fetch (LINEDESCRIPTOR YBOT) + of LINE)) + (for L1 on (fetch (SELECTION L1) of L) as LN + on (fetch (SELECTION LN) of L) as WW + inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + when (EQ WW WINDOW) do (RPLACA L1 LINE) + (RPLACA LN LINE)) + (replace (SELECTION POINT) of L with 'LEFT) + (replace (SELECTION DCH) of L with 0) + (replace (SELECTION SELOBJ) of L with NIL)) + (T (* ; + "Oops--the last item WAS a menu button. Don't let it be selected.") + (RETURN 'DON'T] + (COND + (L (* ; + "If we found the place he's pointing, set up the inter-pointers so each can find the other") + (replace (SELECTION \TEXTOBJ) of L with TEXTOBJ)) + (T (* ; + "We didn't find what he was pointing at. Point to the end of the line.") + (SETQ L (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + (replace (SELECTION SET) of L with T) + [replace (SELECTION SELKIND) of L with (COND + (WORDSELFLG 'WORD) + (T 'CHAR] + (* ; + "THIS MUST PRECEDE THE \TEDIT.SELECT.CHARACTER, SO OBJECTS CAN TURN THE SELECTION VOLATILE.") + (\TEDIT.SELECT.CHARACTER TEXTOBJ L CH LINE X Y TXB WINDOW SELOPERATION EXTENDING) + (replace (SELECTION Y0) of L with (fetch (LINEDESCRIPTOR YBOT) + of LINE)) + [replace (SELECTION X0) of L with (COND + (WORDSELFLG TXB) + (T (IDIFFERENCE TX DX] + (replace (SELECTION XLIM) of L with TX) + (replace (SELECTION DX) of L with (COND + (WORDSELFLG (IDIFFERENCE TX TXB)) + (T DX))) + [replace (SELECTION CH#) of L with (COND + (WORDSELFLG (ADD1 CHB)) + (T (IMIN (fetch (LINEDESCRIPTOR + CHARLIM) + of LINE) + TEXTLEN] + (replace (SELECTION YLIM) of L with (fetch (LINEDESCRIPTOR YBOT) + of LINE)) + (replace (SELECTION CHLIM) of L with (ADD1 (IMIN (fetch ( + LINEDESCRIPTOR + CHARLIM) + of LINE) + TEXTLEN))) + [replace (SELECTION POINT) of L + with (COND + [(NEQ CH (CHARCODE CR)) (* ; + "You can select only to the left of a CR; elsewhere, you can select to the right") + (COND + ([IGEQ X (COND + (WORDSELFLG (* ; + "If it's a word, check our location against mid-word to see which side to put the caret on") + (LRSH (IPLUS TX TXB) + 1)) + (T (* ; + "Otherwise, check against mid-character") + (IDIFFERENCE TX (LRSH DX 1] + (* ; + "If we're to the right of mid-item, put the caret on the right.") + 'RIGHT) + (T (* ; "Otherwise, put it on the left.") + 'LEFT] + (T 'LEFT] + (for L1 on (fetch (SELECTION L1) of L) as LN + on (fetch (SELECTION LN) of L) as WW + inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + when (EQ WW WINDOW) do (RPLACA L1 LINE) + (RPLACA LN LINE)) + (replace (SELECTION DCH) of L + with (COND + (WORDSELFLG (IDIFFERENCE (IMIN (fetch (LINEDESCRIPTOR CHARLIM) + of LINE) + TEXTLEN) + CHB)) + (T 1))) + (replace (SELECTION \TEXTOBJ) of L with TEXTOBJ))) + (RETURN L]) + +(TEDIT.SELECT.LINE.SCANNER + [LAMBDA (X Y TEXTOBJ LINE.LIST REGION WORDSELFLG SELOPERATION WINDOW EXTENDING) + (* ; "Edited 31-May-91 12:26 by jds") + (* ; + "Find the text line the mouse is pointing at.") + (* ; + "LINE.LIST is the dummy first line for the window in which selection happened.") + (PROG ((L NIL) + (WWIDTH (fetch (TEXTOBJ WRIGHT) of TEXTOBJ)) + (THISLINE (fetch (TEXTOBJ THISLINE) of TEXTOBJ)) + (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (WREG (DSPCLIPPINGREGION NIL WINDOW)) + PREVLINE PARABOUNDS PARASTART PARAEND L1 LN) + (bind (LINE _ (fetch (LINEDESCRIPTOR NEXTLINE) of LINE.LIST)) + while (AND LINE (IGEQ (fetch (LINEDESCRIPTOR YBOT) of LINE) + (fetch BOTTOM of WREG))) + do + + (* ;; "Search thru the list of (real) displayed lines, looking for the first one whose bottom is below the mouse. That's the line we're pointing at.") + + (COND + ((ILEQ (fetch (LINEDESCRIPTOR YBOT) of LINE) + Y) (* ; "Found it.") + (SELECTQ REGION + ((TEXT WINDOW) (* ; + "We're in the regular text area, so scan accross looking for the character.") + (SETQ L (TEDIT.SCAN.LINE TEXTOBJ LINE THISLINE X Y WORDSELFLG + SELOPERATION WINDOW EXTENDING))) + (LINE (* ; + "He is selecting an entire line, or a paragraph.") + (SETQ L (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + (for TL1 on (fetch (SELECTION L1) of L) as TLN + on (fetch (SELECTION LN) of L) as WW + inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + when (EQ WW WINDOW) do (SETQ L1 TL1) + (SETQ LN TLN) + (RETURN)) + (COND + ((AND (fetch (LINEDESCRIPTOR LHASPROT) of LINE) + (NEQ SELOPERATION 'COPY))(* ; + "In a TEDIT menu, you can't select a whole paragraph or line.") + (replace (SELECTION SET) of L with NIL) + (RETURN L))) (* ; "The scratch selection") + (replace (SELECTION \TEXTOBJ) of L with TEXTOBJ) + (* ; + "Make sure he knows what document the selection's in.") + (replace (SELECTION SET) of L with T) + (* ; "Mark it valid.") + (replace (SELECTION SELOBJ) of L with NIL) + (* ; + "Not selecting an object just yet") + (COND + [WORDSELFLG (* ; "Select a paragraph.") + (replace (SELECTION SELKIND) of L with 'PARA) + (* ; + "SEARCH FORWARD FROM THE CURRENT LINE TO A LINE WITH A CR OR CHARLIM=EOTEXT") + [COND + ((fetch (TEXTOBJ FORMATTEDP) of TEXTOBJ) + + (* ;; "If this is a para-formatted document, use the paragraph bounds. Otherwise, delimit a para by the surrounding CRs.") + + (SETQ PARABOUNDS (\TEDIT.PARABOUNDS TEXTOBJ (fetch + (LINEDESCRIPTOR + CHAR1) of LINE)) + ) + (SETQ PARASTART (\TEDIT.FIND.PROTECTED.START + TEXTOBJ + (fetch (LINEDESCRIPTOR CHAR1) of LINE) + (CAR PARABOUNDS))) + (SETQ PARAEND (\TEDIT.FIND.PROTECTED.END TEXTOBJ + (fetch (LINEDESCRIPTOR CHAR1) + of LINE) + (CDR PARABOUNDS] + (RPLACA L1 LINE) + (RPLACA LN LINE) + (bind (LL _ LINE) + while (AND [COND + ((fetch (TEXTOBJ FORMATTEDP) of TEXTOBJ) + (ILESSP (fetch (LINEDESCRIPTOR CHARLIM) + of LL) + PARAEND)) + (T (NOT (fetch (LINEDESCRIPTOR CR\END) + of LL] + (ILESSP (fetch (LINEDESCRIPTOR CHARLIM) + of LL) + TEXTLEN)) + do (* ; + "Walk forward thru the lines, looking for the last line in the paragraph.") + [COND + ((fetch (LINEDESCRIPTOR NEXTLINE) of LL) + (SETQ LL (fetch (LINEDESCRIPTOR NEXTLINE) + of LL))) + (T [replace (LINEDESCRIPTOR NEXTLINE) of LL + with (\FORMATLINE TEXTOBJ NIL + (ADD1 (fetch (LINEDESCRIPTOR + CHARLIM) + of LL] + (replace (LINEDESCRIPTOR PREVLINE) + of (fetch (LINEDESCRIPTOR NEXTLINE) + of LL) with LL) + (SETQ LL (fetch (LINEDESCRIPTOR NEXTLINE) + of LL] finally (RPLACA LN LL)) + (* ; + "SEARCH BACK TO A LINE WITH A CR OR BOTEXT") + [COND + ((IGREATERP (fetch (LINEDESCRIPTOR CHAR1) of LINE) + 1) (* ; + "Only search backward if we're not on the first line already.") + (bind (LL _ LINE) + while [AND (IGREATERP (fetch (LINEDESCRIPTOR CHAR1) + of LL) + 1) + (COND + ((fetch (TEXTOBJ FORMATTEDP) of + TEXTOBJ) + (IGREATERP (fetch (LINEDESCRIPTOR CHAR1) + of LL) + PARASTART)) + (T (NOT (fetch (LINEDESCRIPTOR CR\END) + of (fetch (LINEDESCRIPTOR + PREVLINE) + of LL] + do + + (* ;; "Back up until we find the first line of the paragraph, or we hit the dummy top line (which claims to end in CR.)") + + (SETQ LL (fetch (LINEDESCRIPTOR PREVLINE) + of LL)) + finally + (RPLACA L1 (COND + ((AND (fetch (TEXTOBJ FORMATTEDP) + of TEXTOBJ) + (IEQP (fetch (LINEDESCRIPTOR CHAR1) + of LL) + PARASTART)) + (* ; "We found a true start of para.") + LL) + ([AND (fetch (LINEDESCRIPTOR PREVLINE) + of LL) + (NOT (ZEROP (fetch (LINEDESCRIPTOR + CHARLIM) + of (fetch + (LINEDESCRIPTOR + PREVLINE) + of LL] + (* ; + "We hit the first line in the paragraph, fair and square") + LL) + ((IEQP 1 (fetch (LINEDESCRIPTOR CHAR1) + of LL)) + (* ; + "We hit the front of the document.") + LL) + (T (\BACKFORMAT LINE.LIST TEXTOBJ + (fetch PTOP of WREG)) + (fetch (LINEDESCRIPTOR NEXTLINE) + of LINE.LIST] + [replace (SELECTION CH#) of L + with (OR PARASTART (fetch (LINEDESCRIPTOR CHAR1) + of (CAR L1] + [replace (SELECTION CHLIM) of L + with (ADD1 (OR PARAEND (fetch (LINEDESCRIPTOR CHARLIM) + of (CAR LN] + [replace (SELECTION POINT) of L + with (COND + ((ILEQ (IDIFFERENCE (fetch (LINEDESCRIPTOR CHAR1) + of LINE) + (fetch (SELECTION CH#) of L)) + (IDIFFERENCE (fetch (SELECTION CHLIM) + of L) + (fetch (LINEDESCRIPTOR CHARLIM) + of LINE))) + 'LEFT) + (T 'RIGHT] + (replace (SELECTION DCH) of L + with (IDIFFERENCE (fetch (SELECTION CHLIM) of L) + (fetch (SELECTION CH#) of L))) + (COND + ((fetch (LINEDESCRIPTOR LHASPROT) of LINE) + (* ; +"We have cause to suspect there may be protected text around this para. Fix the sel the hard way.") + (\FIXSEL L TEXTOBJ)) + (T (* ; + "No protected text is evident. DO it the easy way.") + (replace (SELECTION Y0) of L with + (fetch (LINEDESCRIPTOR + YBOT) + of (CAR L1))) + (replace (SELECTION YLIM) of L + with (fetch (LINEDESCRIPTOR YBOT) of (CAR LN))) + (replace (SELECTION X0) of L with + (fetch (LINEDESCRIPTOR + LEFTMARGIN) + of (CAR L1))) + (replace (SELECTION XLIM) of L + with (fetch (LINEDESCRIPTOR LXLIM) + of (CAR LN))) + (replace (SELECTION DX) of L + with (IPLUS 1 (IDIFFERENCE (fetch (SELECTION XLIM) + of L) + (fetch (SELECTION X0) + of L] + (T (* ; + "Select the line we're pointing at.") + (replace (SELECTION SELKIND) of L with 'LINE) + (RPLACA L1 LINE) + (RPLACA LN LINE) + (replace (SELECTION CH#) of L with (fetch + (LINEDESCRIPTOR + CHAR1) of + LINE)) + (replace (SELECTION CHLIM) of L + with (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) of LINE))) + (replace (SELECTION DX) of L + with (IDIFFERENCE (fetch (LINEDESCRIPTOR LXLIM) + of LINE) + (fetch (LINEDESCRIPTOR LEFTMARGIN) + of LINE))) + (replace (SELECTION X0) of L with (fetch + (LINEDESCRIPTOR + LEFTMARGIN) + of LINE)) + (replace (SELECTION XLIM) of L with (fetch + (LINEDESCRIPTOR + LXLIM) + of LINE)) + (replace (SELECTION Y0) of L + with (replace (SELECTION YLIM) of L + with (fetch (LINEDESCRIPTOR YBOT) + of LINE))) + (replace (SELECTION DCH) of L + with (IDIFFERENCE (fetch (SELECTION CHLIM) of L) + (fetch (SELECTION CH#) of L))) + (replace (SELECTION POINT) of L with 'LEFT) + (replace (SELECTION SET) of L with T)))) + (SHOULDNT "Unknown text/line-bar region?")) + (RETURN))) + (SETQ PREVLINE LINE) + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE))) + (RETURN (OR L PREVLINE]) + +(\TEDIT.SELECT.CHARACTER + [LAMBDA (TEXTOBJ SEL PREVCH LINE X Y TXB SELWINDOW SELOPERATION EXTENDING) + (* ; "Edited 29-Mar-94 13:28 by jds") + + (* ;; "We have moved over a particular character. If it's really a character, OK. Otherwise, call in the selection function!") + + (DECLARE (USEDFREE . WORDSELFLG)) + (COND + ((NULL PREVCH) + (replace (SELECTION SELOBJ) of SEL with NIL)) + ((SMALLP PREVCH) + (replace (SELECTION SELOBJ) of SEL with NIL)) + (T (replace (SELECTION SELOBJ) of SEL with PREVCH) + (replace (SELECTION X0) of SEL with TXB) + (replace (SELECTION Y0) of SEL with (fetch (LINEDESCRIPTOR YBOT) + of LINE)) + [PROG ([OBJBOX (OR (IMAGEOBJPROP PREVCH 'BOUNDBOX) + (IMAGEBOX PREVCH SELWINDOW 'DISPLAY] + (DS (WINDOWPROP SELWINDOW 'DSP)) + SELRES) + (RESETLST + (RESETSAVE (DSPXOFFSET (IDIFFERENCE (IPLUS TXB (DSPXOFFSET NIL DS)) + (fetch XKERN of OBJBOX)) + DS) + (LIST (FUNCTION DSPXOFFSET) + (DSPXOFFSET NIL DS) + DS)) + (RESETSAVE (DSPYOFFSET (IDIFFERENCE (IPLUS (fetch (LINEDESCRIPTOR YBASE) + of LINE) + (DSPYOFFSET NIL DS)) + (fetch YDESC of OBJBOX)) + DS) + (LIST (FUNCTION DSPYOFFSET) + (DSPYOFFSET NIL DS) + DS)) + (RESETSAVE (DSPCLIPPINGREGION (create REGION + LEFT _ 0 + BOTTOM _ 0 + WIDTH _ (IMIN (fetch XSIZE of OBJBOX + ) + (IDIFFERENCE + (fetch (TEXTOBJ WRIGHT) + of TEXTOBJ) + TXB)) + HEIGHT _ (fetch YSIZE of OBJBOX)) + DS) + (LIST (FUNCTION DSPCLIPPINGREGION) + (DSPCLIPPINGREGION NIL DS) + DS)) + (SETQ SELRES (ERSETQ (APPLY* (IMAGEOBJPROP PREVCH 'BUTTONEVENTINFN) + PREVCH DS SEL (IDIFFERENCE X TXB) + (IDIFFERENCE Y (fetch (LINEDESCRIPTOR YBASE) + of LINE)) + SELWINDOW + (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) + (COND + (EXTENDING 'RIGHT) + (WORDSELFLG 'MIDDLE) + (T 'LEFT)) + SELOPERATION))) + (* ; + "Go tell him he's being pointed at.") + ) + (COND + ((NULL SELRES) (* ; + "If the event fn returns NIL, do nothing untoward") + ) + ((NULL (CAR SELRES)) (* ; + "If it returns something with a CAR of NIL, then UN-SET the object-ness of the selection") + (replace (SELECTION SELOBJ) of SEL with NIL)) + (T (* ; + "Otherwise, check to see what he wants us to do") + (COND + ((EQ (CAR SELRES) + 'DON'T) (* ; + "The object declines to be selected. Don't permit the select to happen.") + (replace (SELECTION SET) of SEL with NIL)) + ((AND (LISTP (CAR SELRES)) + (FMEMB 'DON'T (CAR SELRES))) (* ; + "The object declines to be selected. Don't permit the select to happen.") + (replace (SELECTION SET) of SEL with NIL))) + (COND + ((EQ (CAR SELRES) + 'CHANGED) (* ; + "If the object claims to have changed, update the screen.") + (TEDIT.OBJECT.CHANGED TEXTOBJ (fetch (SELECTION SELOBJ) of SEL))) + ((AND (LISTP (CAR SELRES)) + (FMEMB 'CHANGED (CAR SELRES)))(* ; + "If the object claims to have changed, update the screen.") + (TEDIT.OBJECT.CHANGED TEXTOBJ (fetch (SELECTION SELOBJ) of SEL] + (SETQ WORDSELFLG NIL]) +) +(DEFINEQ + +(\FIXSEL + [LAMBDA (SEL TEXTOBJ THISWINDOW AVOIDINGTHISW) (* ; "Edited 31-May-91 12:26 by jds") + + (* ;; "Given that the selection SEL contains the correct CH# and CHLIM, reset the Y0 X0, DX, and XLIM values.") + + (PROG* ((CH# (fetch (SELECTION CH#) of SEL)) + (CHLIM (fetch (SELECTION CHLIM) of SEL)) + (THISLINE (fetch (TEXTOBJ THISLINE) of TEXTOBJ)) + (WINDOW (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) + (THISW (OR THISWINDOW (\TEDIT.MAINW TEXTOBJ))) + (WREG (AND THISW (DSPCLIPPINGREGION NIL THISW))) + (STARTFOUND NIL) + (ENDFOUND NIL) + WLIST CHLIST LOOKS LINE PREVLINE L1HCPY LNHCPY) + (COND + ((NOT WINDOW) (* ; + "There is no window to go with this edit; don't bother to try updating the selection") + (RETURN)) + ((NOT THISW) (* ; + "There is no window to go with this edit; don't bother to try updating the selection") + (RETURN))) + [COND + ((AND AVOIDINGTHISW (fetch (SELECTION Y0) of SEL))) + (T (replace (SELECTION Y0) of SEL with (fetch PTOP of WREG] + (COND + ((AND AVOIDINGTHISW (fetch (SELECTION YLIM) of SEL))) + (T (replace (SELECTION YLIM) of SEL with -1))) + (OR (fetch (SELECTION XLIM) of SEL) + (replace (SELECTION XLIM) of SEL with -1)) + (* ; "Initialize it, if need be.") + (for WW inside WINDOW as L1 on (fetch (SELECTION L1) of SEL) + as LN on (fetch (SELECTION LN) of SEL) as LINES + inside (fetch (TEXTOBJ LINES) of TEXTOBJ) + do (COND + ([AND (fetch (SELECTION SET) of SEL) + (OR (NOT THISWINDOW) + (NEQ AVOIDINGTHISW (EQ THISWINDOW WW] + (* ; + "Only if a 'real' SELECTION proceed") + (SETQ WLIST (fetch (THISLINE WIDTHS) of THISLINE)) + (SETQ CHLIST (fetch (THISLINE CHARS) of THISLINE)) + (SETQ LOOKS (fetch (THISLINE LOOKS) of THISLINE)) + (RPLACA L1 NIL) + (RPLACA LN NIL) + (bind (LINE _ (fetch (LINEDESCRIPTOR NEXTLINE) of LINES)) + TX DX while LINE + do (COND + [(AND (IGEQ CH# (fetch (LINEDESCRIPTOR CHAR1) of LINE)) + (ILEQ CH# (fetch (LINEDESCRIPTOR CHARLIM) + of LINE))) + (* ; + "The selection starts in this line. Fix L1, X0, and Y0.") + (SETQ STARTFOUND T) + (replace (SELECTION Y0) of SEL + with (fetch (LINEDESCRIPTOR YBOT) of LINE)) + (SETQ L1HCPY (fetch (FMTSPEC FMTHARDCOPY) + of (fetch (LINEDESCRIPTOR LFMTSPEC) + of LINE))) + (* ; + "Remember that this is a hardcopy-mode line") + (RPLACA L1 LINE) + (SETQ TX (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE)) + (* ; + "Temp. X value for scanning the line from left margin to the right") + (replace (SELECTION X0) of SEL + with (fetch (LINEDESCRIPTOR LEFTMARGIN) + of LINE)) + (COND + ((IGREATERP CH# (fetch (LINEDESCRIPTOR CHAR1) + of LINE)) + (* ; + "Only bother formatting the line if the selection doesn't include the first character.") + (COND + ((NEQ (fetch DESC of THISLINE) + LINE) (* ; + "If this line isn't cached in THISLINE, reformat it.") + (\FORMATLINE TEXTOBJ NIL (fetch (LINEDESCRIPTOR + CHAR1) + of LINE) + LINE))) + (COND + ((IGEQ (fetch LEN of THISLINE) + 0) (* ; + "As long as there's something there on the line...") + (bind (LOOKNO _ 0) for I from 0 + to (fetch LEN of THISLINE) as + CHNO + from (fetch (LINEDESCRIPTOR CHAR1) + of LINE) + do + + (* ;; "Run thru the characters on the line, looking for the first selected one. Keep track of our X position, so we know where the selection starts.") + + (SETQ DX (\EDITELT WLIST I)) + (SETQ TX (IPLUS TX DX)) + (COND + ((IGEQ CHNO CH#) + (* ; + "We've found that first character. Time to bail out.") + (RETURN)) + [(EQ LMInvisibleRun (\EDITELT CHLIST I)) + (* ; + "This is INVISIBLE text. Count the characters as though they were there.") + (add LOOKNO 1) + (add CHNO (SUB1 (\EDITELT LOOKS + LOOKNO] + ((EQ LMLooksChange (\EDITELT CHLIST I)) + (* ; + "This is a format effector--reduce CHNO to ignore it") + (add LOOKNO 1) + (SETQ CHNO (SUB1 CHNO))) + (T + (* ; + "Not yet; update our running X-position in the SEL.") + (replace (SELECTION X0) + of SEL with TX] + ((AND (IEQP CH# (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) + of LINE))) + (IGREATERP CH# (fetch (TEXTOBJ TEXTLEN) of + TEXTOBJ + ))) + + (* ;; "The selection starts after the end of this line, but it's also the end of the text. Go ahead and select there.") + + (COND + ((NEQ (fetch DESC of THISLINE) + LINE) (* ; + "If this line isn't cached in THISLINE, reformat it.") + (\FORMATLINE TEXTOBJ NIL (fetch (LINEDESCRIPTOR CHAR1) + of LINE) + LINE))) + (replace (SELECTION Y0) of SEL + with (fetch (LINEDESCRIPTOR YBOT) of LINE)) + (RPLACA L1 LINE) (* ; + "Make this line be the first in the selection") + (SETQ L1HCPY (fetch (FMTSPEC FMTHARDCOPY) + of (fetch (LINEDESCRIPTOR LFMTSPEC) + of LINE))) + (replace (SELECTION X0) of SEL + with (fetch (LINEDESCRIPTOR LXLIM) of LINE))) + ((AND (NOT STARTFOUND) + (IGREATERP (fetch (LINEDESCRIPTOR CHAR1) of + LINE) + CH#) + (ILESSP (fetch (LINEDESCRIPTOR CHAR1) of LINE) + CHLIM)) (* ; + "The selection starts before this line, so play catch-up") + (replace (SELECTION Y0) of SEL + with (fetch (LINEDESCRIPTOR YBOT) of LINE)) + (RPLACA L1 LINE) (* ; + "Grab this line and make it the apparent first line.") + (SETQ L1HCPY (fetch (FMTSPEC FMTHARDCOPY) + of (fetch (LINEDESCRIPTOR LFMTSPEC) + of LINE))) + (replace (SELECTION X0) of SEL + with (fetch (LINEDESCRIPTOR LEFTMARGIN) + of LINE)) + (SETQ STARTFOUND T))) + [COND + ([AND (ILEQ CH# (fetch (LINEDESCRIPTOR CHARLIM) of + LINE)) + (IGEQ CHLIM (fetch (LINEDESCRIPTOR CHAR1) of + LINE)) + (ILEQ CHLIM (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) + of LINE] + (* ; + "The selection ends in this line. Fix LN, XLIM, and YLIM.") + + (* ;; "NB that it also has to START before the end of this line. This eliminates the case of a 0-wide selection right after the last char on this line.") + + (replace (SELECTION YLIM) of SEL + with (fetch (LINEDESCRIPTOR YBOT) of LINE)) + (* ; + "Set the lowest-Y value for the selection") + (RPLACA LN LINE) (* ; "Remember the final line") + (SETQ LNHCPY (fetch (FMTSPEC FMTHARDCOPY) + of (fetch (LINEDESCRIPTOR LFMTSPEC) + of LINE))) + (SETQ TX (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE)) + (* ; "Temp X position") + (replace (SELECTION XLIM) of SEL + with (fetch (LINEDESCRIPTOR LXLIM) of LINE)) + (* ; + "Start by assuming that the selection extends all the way across the line") + [COND + [(AND (IEQP CHLIM (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) + of LINE))) + (EQ (fetch (SELECTION POINT) of SEL) + 'RIGHT) + (IEQP (fetch (SELECTION DCH) of SEL) + 0) + (fetch (LINEDESCRIPTOR NEXTLINE) of LINE) + (fetch (LINEDESCRIPTOR CR\END) of LINE)) + (* ; + "This selection starts AFTER the CR on a line, and doesn't include it.") + (RPLACA LN (fetch (LINEDESCRIPTOR NEXTLINE) + of LINE)) + (* ; + "Change the selection to start on the next line, at the margin, instead.") + (replace (SELECTION XLIM) of SEL + with (fetch (LINEDESCRIPTOR LEFTMARGIN) + of (CAR LN))) + (replace (SELECTION YLIM) of SEL + with (fetch (LINEDESCRIPTOR YBOT) + of (CAR LN] + ((ILEQ CHLIM (IMIN (fetch (LINEDESCRIPTOR CHARLIM) + of LINE) + (fetch (TEXTOBJ TEXTLEN) of + TEXTOBJ))) + (* ; + "Only bother formatting if the selection doesn't include the last char on the line") + (COND + ((NEQ (fetch DESC of THISLINE) + LINE) (* ; + "If this line isn't cached in THISLINE, then reformat it.") + (\FORMATLINE TEXTOBJ NIL (fetch (LINEDESCRIPTOR + CHAR1) + of LINE) + LINE))) + (COND + ((IGEQ (fetch LEN of THISLINE) + 0) (* ; + "If there are characters on the line, go looking for the one that ends the selection.") + (bind (LOOKNO _ 0) for I from 0 + to (fetch LEN of THISLINE) as CHNO + from (fetch (LINEDESCRIPTOR CHAR1) + of LINE) + do + + (* ;; "Run thru the characters, until we find the final one that is selected. Kep running track of our X position on the line, so we know how wide the final line's hiliting should be.") + + (SETQ DX (\EDITELT WLIST I)) + (* ; "The current character's width") + (SETQ TX (IPLUS TX DX)) + (* ; "Running Temp-X position") + (COND + ((IGEQ CHNO CHLIM) + (* ; + "OK; this character is past the end of the selection. Stop here.") + (RETURN)) + [(EQ LMInvisibleRun (\EDITELT CHLIST I)) + (* ; + "This is a run of INVISIBLE characters. Count them in the character position, though.") + (add LOOKNO 1) + (add CHNO (SUB1 (\EDITELT LOOKS LOOKNO + ] + ((EQ LMLooksChange (\EDITELT CHLIST I)) + (* ; + "This is a format effector--reduce CHNO to ignore it") + (SETQ CHNO (SUB1 CHNO)) + (add LOOKNO 1)) + (T (* ; + "Keep track of how far across we've gotten.") + (replace (SELECTION XLIM) + of SEL with TX] + (RETURN) (* ; + "And stop looking for an ending line--we've obviously found it!") + ) + ((AND (IEQP CHLIM (ADD1 (fetch (LINEDESCRIPTOR CHARLIM) + of LINE))) + (ILEQ CH# (fetch (LINEDESCRIPTOR CHARLIM) of + LINE))) + (* ; + "The selection ends either here or at the start of the next line.") + (* ; + "ANN there is something on this line really selected.") + (replace (SELECTION YLIM) of SEL + with (fetch (LINEDESCRIPTOR YBOT) of LINE)) + (SETQ LNHCPY (fetch (FMTSPEC FMTHARDCOPY) + of (fetch (LINEDESCRIPTOR LFMTSPEC) + of LINE))) + (RPLACA LN LINE) + (replace (SELECTION XLIM) of SEL + with (fetch (LINEDESCRIPTOR LXLIM) of LINE] + (SETQ PREVLINE LINE) + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE))) + [COND + (L1HCPY (* ; + "The first line of the selection is hardcopy-mode. Convert the X0 value to screen units") + (replace (SELECTION X0) of SEL + with (FIXR (FQUOTIENT (fetch (SELECTION X0) + of SEL) + 35.27778] + [COND + (LNHCPY (* ; + "The last line of the selection is hardcopy-mode. Convert the XLIM value to screen units") + (replace (SELECTION XLIM) of SEL + with (FIXR (FQUOTIENT (fetch (SELECTION XLIM) + of SEL) + 35.27778] + (COND + [(IEQP 0 (fetch (SELECTION DCH) of SEL)) + (* ; + "If this is a point selection, put it on the correct side of the character we selected.") + (replace (SELECTION DX) of SEL with 0) + (COND + ((EQ (fetch (SELECTION POINT) of SEL) + 'LEFT) + (replace (SELECTION XLIM) of SEL with + (fetch (SELECTION + X0) + of SEL))) + (T (replace (SELECTION X0) of SEL with + (fetch (SELECTION + XLIM) + of SEL] + (T (* ; + "Otherwise, fix DX for the selection") + (replace (SELECTION DX) of SEL + with (IDIFFERENCE (fetch (SELECTION XLIM) of SEL) + (fetch (SELECTION X0) of SEL]) + +(\TEDIT.FIXDELSEL + [LAMBDA (SELTOFIX TEXTOBJ CH#1 CH#LIM DCH) (* ; "Edited 30-May-91 23:00 by jds") + (* Fix up a SELTOFIX after deletion + inside that textobj) + (* Only if the Selection is set, and + is in THIS textobj) + (COND + ((AND (fetch (SELECTION SET) of SELTOFIX) + (EQ TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SELTOFIX))) + (COND + ((IGEQ (fetch (SELECTION CH#) of SELTOFIX) + CH#LIM) (* The selection is after the + deleted text. Just move it forward) + (replace (SELECTION CH#) of SELTOFIX with (IDIFFERENCE (fetch + (SELECTION CH#) + of SELTOFIX) + DCH)) + (replace (SELECTION CHLIM) of SELTOFIX with (IDIFFERENCE (fetch + (SELECTION CHLIM) + of SELTOFIX) + DCH))) + ((IGREATERP (fetch (SELECTION CHLIM) of SELTOFIX) + CH#1) (* It overlaps, at least partially.) + (COND + ((IGEQ (fetch (SELECTION CH#) of SELTOFIX) + CH#1) + + (* If the start of the selection was inside the deleted area, it now starts + where the deletion left off.) + + (replace (SELECTION CH#) of SELTOFIX with CH#1))) + (replace (SELECTION CHLIM) of SELTOFIX with (IMAX CH#1 + (IDIFFERENCE + (fetch (SELECTION + CHLIM) + of SELTOFIX) + DCH))) + (replace (SELECTION DCH) of SELTOFIX with (COND + ((IEQP (fetch (SELECTION + CHLIM) + of SELTOFIX) + CH#1) + 0) + (T (IDIFFERENCE + (fetch (SELECTION CHLIM) + of SELTOFIX) + (fetch (SELECTION CH#) + of SELTOFIX]) + +(\TEDIT.FIXINSSEL + [LAMBDA (SELTOFIX TEXTOBJ CH#1 DCH) (* ; "Edited 30-May-91 23:00 by jds") + (* Fix up a SELTOFIX after deletion + inside that textobj) + (* Only if the Selection is set, and + is in THIS textobj) + (PROG (CH# CHLIM) + (COND + ((AND (fetch (SELECTION SET) of SELTOFIX) + (EQ TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SELTOFIX))) + [COND + ((IGEQ (SETQ CH# (ffetch (SELECTION CH#) of SELTOFIX)) + CH#1) + + (* Fix up the selection; if we're beyond the insert point, move the whole sel + forward) + + (freplace (SELECTION CH#) of SELTOFIX with (IPLUS CH# DCH] + (COND + ((IGREATERP (SETQ CHLIM (ffetch (SELECTION CHLIM) of SELTOFIX)) + CH#1) (* And the tail end of the sel, too.) + (freplace (SELECTION CHLIM) of SELTOFIX with (IPLUS CHLIM DCH]) + +(\TEDIT.FIXSELS + [LAMBDA (TEXTOBJ EXCEPT) (* ; "Edited 30-May-91 23:03 by jds") + (* Fixes all the sels for a given + textobj.) + (for SELN in (LIST (fetch (TEXTOBJ SEL) of TEXTOBJ) + (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) + (fetch (TEXTOBJ MOVESEL) of TEXTOBJ) + (fetch (TEXTOBJ DELETESEL) of TEXTOBJ)) + when (NEQ SELN EXCEPT) do (AND (fetch (SELECTION SET) of SELN) + (\FIXSEL SELN TEXTOBJ]) +) +(DEFINEQ + +(TEDIT.RESET.EXTEND.PENDING.DELETE + [LAMBDA (SEL) (* ; "Edited 30-May-91 23:03 by jds") + (* Reset the "Extend Pending Delete" + status) + (AND SEL (\TEDIT.SET.SEL.LOOKS SEL 'NORMAL)) + (SETQ TEDIT.PENDINGDEL NIL) + (AND (fetch (SELECTION \TEXTOBJ) of SEL) + (replace (TEXTOBJ BLUEPENDINGDELETE) of (fetch (SELECTION \TEXTOBJ) of + SEL) + with NIL]) + +(\TEDIT.SET.SEL.LOOKS + [LAMBDA (SEL OPERATION) (* ; "Edited 30-May-91 23:00 by jds") + (* Set what the selection should be + displayed like, given what it's for + (NORMAL, COPY, MOVE, etc.)) + (SELECTQ OPERATION + (NORMAL (* Regular selection) + (replace (SELECTION HOW) of SEL with BLACKSHADE) + (replace (SELECTION HOWHEIGHT) of SEL with 1) + (replace (SELECTION HASCARET) of SEL with T)) + (COPY (* Copy source) + (replace (SELECTION HOW) of SEL with COPYSELSHADE) + (replace (SELECTION HOWHEIGHT) of SEL with 1) + (replace (SELECTION HASCARET) of SEL with NIL)) + (COPYLOOKS (* copylooks source) + (replace (SELECTION HOW) of SEL with COPYLOOKSSELSHADE) + (replace (SELECTION HOWHEIGHT) of SEL with 2) + (replace (SELECTION HASCARET) of SEL with NIL)) + (MOVE (* Copy source) + (replace (SELECTION HOW) of SEL with EDITMOVESHADE) + (replace (SELECTION HOWHEIGHT) of SEL with 16384) + (replace (SELECTION HASCARET) of SEL with NIL)) + (DELETE (* To be deleted instantly) + (replace (SELECTION HOW) of SEL with BLACKSHADE) + (replace (SELECTION HOWHEIGHT) of SEL with 16384) + (replace (SELECTION HASCARET) of SEL with NIL) + NIL) + (PENDINGDEL (* Delete at next type-in) + (replace (SELECTION HOW) of SEL with BLACKSHADE) + (replace (SELECTION HOWHEIGHT) of SEL with 16384) + (replace (SELECTION HASCARET) of SEL with T) + NIL) + (INVERTED (* For people who really want to see + what's selected.) + (replace (SELECTION HOW) of SEL with BLACKSHADE) + (replace (SELECTION HOWHEIGHT) of SEL with 16384) + (replace (SELECTION HASCARET) of SEL with T) + NIL) + NIL]) +) +(DEFINEQ + +(\SHOWSEL + [LAMBDA (SEL HOW ON) (* ; "Edited 22-May-92 16:11 by jds") + + (* ;; "Highlight the selection SEL, according to HOW, turning it on or off according to ON") + + (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) + (SHADE (OR (fetch (SELECTION HOW) of SEL) + BLACKSHADE)) + (SHADEHEIGHT (OR (fetch (SELECTION HOWHEIGHT) of SEL) + 1)) + LL SHOWFN) + (COND + ([OR (NOT (fetch (SELECTION SET) of SEL)) + (NOT (fetch (TEXTOBJ \WINDOW) of (fetch (SELECTION \TEXTOBJ) + of SEL] + + (* ;; "This operation only makes sense if there is a selection, it has been set, and there's a window to do the highlighting in.") + + (RETURN)) + ((fetch (TEXTOBJ TXTDON'TUPDATE) of TEXTOBJ) + (* ; + "We're suppressing screen updating, so don't do anything visible.") + (RETURN))) + [for DS inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) as LINES + inside (fetch (TEXTOBJ LINES) of TEXTOBJ) as L1 + in (fetch (SELECTION L1) of SEL) as LN in (fetch (SELECTION + LN) + of SEL) + as CARET inside (fetch (TEXTOBJ CARET) of TEXTOBJ) + do (COND + ((fetch (SELECTION SELOBJ) of SEL) + (* ; + "If it is an object and it has a non-nil showselfn then use it") + (\TEDIT.OBJECT.SHOWSEL TEXTOBJ SEL ON DS) + (RETURN))) + (COND + [(AND ON (NOT (fetch (SELECTION ONFLG) of SEL))) + (* ; + "It's off and we want to turn it on") + (\SHOWSEL.HILIGHT TEXTOBJ SEL LINES L1 LN DS SHADEHEIGHT SHADE) + (COND + [(AND (fetch (SELECTION HASCARET) of SEL) + (ffetch (TEXTOBJ TXTEDITING) of TEXTOBJ)) + + (* ;; + "If the selection has a caret, turn one on. But only if the document is actively being edited.") + + (COND + [(EQ (fetch (SELECTION POINT) of SEL) + 'LEFT) (* ; + "At the LEFT end of the selection") + (COND + ((AND L1 (IGEQ (fetch (LINEDESCRIPTOR YBOT) of L1) + 0)) + (\SETCARET (fetch (SELECTION X0) of SEL) + (fetch (LINEDESCRIPTOR YBASE) of L1) + DS TEXTOBJ CARET)) + (T (MOVETO -10 -10 DS] + ((AND LN (IGEQ (fetch (LINEDESCRIPTOR YBOT) of LN) + 0)) (* ; "Or at the RIGHT end.") + (\SETCARET (fetch (SELECTION XLIM) of SEL) + (fetch (LINEDESCRIPTOR YBASE) of LN) + DS TEXTOBJ CARET)) + (T (* ; + "Neither end is on screen. For self-caret flashers, move the caret location off-screen") + (MOVETO -10 -10 DS] + (T (SELECTQ (fetch (SELECTION POINT) of SEL) + (LEFT (AND L1 (MOVETO (fetch (SELECTION X0) of SEL) + (fetch (LINEDESCRIPTOR YBASE) of L1) + DS))) + (RIGHT (AND LN (MOVETO (fetch (SELECTION XLIM) of SEL) + (fetch (LINEDESCRIPTOR YBASE) of + LN) + DS))) + NIL] + ((AND (NOT ON) + (fetch (SELECTION ONFLG) of SEL)) + (* ; + "The selection is highlighted and we want to turn it off.") + (COND + ((AND (fetch (SELECTION HASCARET) of SEL) + (NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)) + (ffetch (TEXTOBJ TXTEDITING) of TEXTOBJ)) + (* ; + "IF the selection has a caret with it, make sure it's turned off.") + (\EDIT.UPCARET CARET) (* ; + "Pick the caret up off the screen.") + )) + (\SHOWSEL.HILIGHT TEXTOBJ SEL LINES L1 LN DS SHADEHEIGHT SHADE] + (replace (SELECTION ONFLG) of SEL with ON]) + +(\SHOWSEL.HILIGHT + [LAMBDA (TEXTOBJ SEL LINES L1 LN DS SHADEHEIGHT SHADE X0 XLIM) + (* ; "Edited 30-May-91 23:07 by jds") + + (* * Do the actual highlighting and unhighlighting of a selection for \SHOWSEL) + + (PROG (LL LEFT RIGHT) + (COND + ((OR L1 LN) + + (* One end or the other is on-screen, so it makes sense to try displaying + something.) + + (COND + ((AND L1 (EQ L1 LN) + (IGEQ (fetch (LINEDESCRIPTOR YBOT) of L1) + 0)) (* It's all in a single line; + just underline the right section and + beat it) + (BITBLT NIL 0 0 DS (OR X0 (fetch (SELECTION X0) of SEL)) + (fetch (LINEDESCRIPTOR YBOT) of L1) + (IDIFFERENCE (OR XLIM (fetch (SELECTION XLIM) of SEL)) + (OR X0 (fetch (SELECTION X0) of SEL))) + (IMIN SHADEHEIGHT (fetch (LINEDESCRIPTOR LHEIGHT) of L1)) + 'TEXTURE + 'INVERT SHADE)) + (T (* Different lines.) + (COND + ((AND L1 (IGEQ (fetch (LINEDESCRIPTOR YBOT) of L1) + 0)) (* If the first line is known, + underline the right section of it.) + [SETQ RIGHT (COND + ((fetch (FMTSPEC FMTHARDCOPY) of (fetch + (LINEDESCRIPTOR + LFMTSPEC) + of L1)) + (FIXR (FQUOTIENT (fetch (LINEDESCRIPTOR LXLIM) + of L1) + 35.27778))) + (T (fetch (LINEDESCRIPTOR LXLIM) of L1] + (BITBLT NIL 0 0 DS (OR X0 (fetch (SELECTION X0) of SEL)) + (fetch (LINEDESCRIPTOR YBOT) of L1) + (IDIFFERENCE RIGHT (OR X0 (fetch (SELECTION X0) of SEL))) + (IMIN SHADEHEIGHT (fetch (LINEDESCRIPTOR LHEIGHT) of L1)) + 'TEXTURE + 'INVERT SHADE))) + (SETQ LL (OR L1 LINES)) + (AND LL (SETQ LL (fetch (LINEDESCRIPTOR NEXTLINE) of LL))) + + (* The line after the first, or the top line on the screen -- + if we didn't have a first line) + + (while LL until (OR (EQ LL LN) + (ILESSP (fetch (LINEDESCRIPTOR YBOT) of + LL) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ))) + do (* Highlight every line between + first and last) + [COND + [(fetch (FMTSPEC FMTHARDCOPY) of (fetch (LINEDESCRIPTOR + LFMTSPEC) + of LL)) + (* This line is in hardcopy mode. + Scale the margin values) + (SETQ LEFT (\MICASTOPTS (fetch (LINEDESCRIPTOR LEFTMARGIN) + of LL))) + (SETQ RIGHT (\MICASTOPTS (fetch (LINEDESCRIPTOR LXLIM) + of LL] + (T (SETQ LEFT (fetch (LINEDESCRIPTOR LEFTMARGIN) of LL)) + (SETQ RIGHT (fetch (LINEDESCRIPTOR LXLIM) of LL] + (BITBLT NIL 0 0 DS LEFT (fetch (LINEDESCRIPTOR YBOT) of LL) + (IDIFFERENCE RIGHT LEFT) + (IMIN SHADEHEIGHT (fetch (LINEDESCRIPTOR LHEIGHT) + of LL)) + 'TEXTURE + 'INVERT SHADE) + (SETQ LL (fetch (LINEDESCRIPTOR NEXTLINE) of LL))) + (COND + ((AND LL (IGEQ (fetch (LINEDESCRIPTOR YBOT) of LL) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ))) + (* The final line is on-screen. + Hilight it, too.) + [SETQ LEFT (COND + ((fetch (FMTSPEC FMTHARDCOPY) of (fetch + (LINEDESCRIPTOR + LFMTSPEC) + of LL)) + (\MICASTOPTS (fetch (LINEDESCRIPTOR LEFTMARGIN) + of LL))) + (T (fetch (LINEDESCRIPTOR LEFTMARGIN) of LL] + (BITBLT NIL 0 0 DS LEFT (fetch (LINEDESCRIPTOR YBOT) of LN) + (IDIFFERENCE (OR XLIM (fetch (SELECTION XLIM) of SEL)) + LEFT) + (IMIN SHADEHEIGHT (fetch (LINEDESCRIPTOR LHEIGHT) of LL)) + 'TEXTURE + 'INVERT SHADE))) (* Highlight the final line of the + selection) + ]) + +(\TEDIT.UPDATE.SHOWSEL + [LAMBDA (NSEL OSEL TSTFLG) (* ; "Edited 30-May-91 23:03 by jds") + (* Update the selection highlighting + to reflect the differences between + NSEL and OSEL) + (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of OSEL))) + (PROG ((SHADE (OR (fetch (SELECTION HOW) of OSEL) + BLACKSHADE)) + (SHADEHEIGHT (OR (fetch (SELECTION HOWHEIGHT) of OSEL) + 1)) + (EXCHFLG NIL) + TSEL LL) + (replace (SELECTION ONFLG) of NSEL with T) + (* Make the new selection think that + we've really displayed all its new + aspects.) + [COND + ((fetch (SELECTION HASCARET) of OSEL) + (* Turn off the caret, if need be) + (for CARET inside (fetch (TEXTOBJ CARET) of TEXTOBJ) + do (\EDIT.UPCARET CARET] + [COND + ((NEQ (fetch (SELECTION CH#) of NSEL) + (fetch (SELECTION CH#) of OSEL)) + (* The new selection starts earlier; + add hilight at the front) + (COND + ((ILESSP (fetch (SELECTION CH#) of OSEL) + (fetch (SELECTION CH#) of NSEL)) + (* Actually, it starts later; + just exchange the selections) + (swap OSEL NSEL) + (SETQ EXCHFLG T))) + (for NEWL1 inside (fetch (SELECTION L1) of NSEL) as OLDL1 + inside (fetch (SELECTION L1) of OSEL) as LINES + inside (fetch (TEXTOBJ LINES) of TEXTOBJ) as DS + inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + do (\SHOWSEL.HILIGHT TEXTOBJ OSEL LINES NEWL1 OLDL1 DS SHADEHEIGHT + SHADE (fetch (SELECTION X0) of NSEL) + (fetch (SELECTION X0) of OSEL] + (COND + (EXCHFLG (* Put the selections back as they + were.) + (swap OSEL NSEL) + (SETQ EXCHFLG NIL))) + (COND + ((ILESSP (fetch (SELECTION CHLIM) of NSEL) + (fetch (SELECTION CHLIM) of OSEL)) + + (* Arrange for NSEL to be the selection that ends later, so that one set of + code will do both earlier AND later cases.) + + (swap OSEL NSEL) + (SETQ EXCHFLG T))) + (for OLDLN in (fetch (SELECTION LN) of OSEL) as NEWLN + in (fetch (SELECTION LN) of NSEL) as LINES + inside (fetch (TEXTOBJ LINES) of TEXTOBJ) as OLDL1 + in (fetch (SELECTION L1) of OSEL) as DS + inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + do (\SHOWSEL.HILIGHT TEXTOBJ OSEL LINES OLDLN NEWLN DS SHADEHEIGHT SHADE + (fetch (SELECTION XLIM) of OSEL) + (fetch (SELECTION XLIM) of NSEL))) + (COND + (EXCHFLG (* Put the selections back as they + were.) + (SETQ TSEL OSEL) + (SETQ OSEL NSEL) + (SETQ NSEL TSEL))) + (COND + ((fetch (SELECTION HASCARET) of NSEL) + (* Now put the caret back up.) + (for L1 in (fetch (SELECTION L1) of NSEL) as LN + in (fetch (SELECTION LN) of NSEL) as DS + inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) as CARET + inside (fetch (TEXTOBJ CARET) of TEXTOBJ) + do (COND + ((EQ (fetch (SELECTION POINT) of NSEL) + 'LEFT) (* Left end of the selection) + (AND L1 (\SETCARET (fetch (SELECTION X0) of NSEL) + (fetch (LINEDESCRIPTOR YBOT) of L1) + DS TEXTOBJ CARET))) + (LN (* Right end of the selection) + (\SETCARET (fetch (SELECTION XLIM) of NSEL) + (fetch (LINEDESCRIPTOR YBOT) of LN) + DS TEXTOBJ CARET]) + +(\TEDIT.SHOWSELS + [LAMBDA (TEXTOBJ HOW ON) (* ; "Edited 30-May-91 23:03 by jds") + (* Turns all the selections for a + given Textobj on or off) + (for SELN in (LIST (fetch (TEXTOBJ SEL) of TEXTOBJ) + (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) + (fetch (TEXTOBJ MOVESEL) of TEXTOBJ) + (fetch (TEXTOBJ DELETESEL) of TEXTOBJ)) + do (AND (fetch (SELECTION SET) of SELN) + (\SHOWSEL SELN HOW ON]) + +(\TEDIT.REFRESH.SHOWSEL + [LAMBDA (TEXTOBJ NEWSEL OLDSEL OLDOP NEWOP EXTENDING) (* ; "Edited 30-May-91 23:03 by jds") + + (* * Update the screen hilighting to account for the changes that have taken + place between OLDSEL and NEWSEL.) + + (DECLARE (USEDFREE . GLOBALSEL)) + (PROG (NOSEL) + (COND + ((AND EXTENDING (EQ OLDOP NEWOP)) + + (* If we're extending a selection and the looks haven't changed, we can do it + the fast way, to prevent flicker.) + + (\TEDIT.UPDATE.SHOWSEL NEWSEL OLDSEL) + (\COPYSEL NEWSEL OLDSEL) + (replace (SELECTION ONFLG) of OLDSEL with T)) + (T + + (* Otherwise, we have to turn the old one off, change things, and turn the new + one on.) + + (\SHOWSEL OLDSEL NIL NIL) + (COND + ((NEQ OLDOP NEWOP) + + (* He changed his mind about copying, deleting, or whatever -- + change the kind of selection it is.) + + (SELECTQ NEWOP + ((NORMAL PENDINGDEL) + (SETQ GLOBALSEL TEDIT.SELECTION) + (SETQ NOSEL (fetch (TEXTOBJ SEL) of TEXTOBJ))) + (COPY (SETQ GLOBALSEL TEDIT.SHIFTEDSELECTION) + (SETQ NOSEL (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ))) + (MOVE (SETQ GLOBALSEL TEDIT.MOVESELECTION) + (SETQ NOSEL (fetch (TEXTOBJ MOVESEL) of TEXTOBJ))) + (DELETE (SETQ GLOBALSEL TEDIT.DELETESELECTION) + (SETQ NOSEL (fetch (TEXTOBJ DELETESEL) of TEXTOBJ))) + (COPYLOOKS (SETQ GLOBALSEL TEDIT.COPYLOOKSSELECTION) + (SETQ NOSEL (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ))) + NIL) (* Remember the new operation type.) + (replace (SELECTION SET) of OLDSEL with NIL) + (* Turn off the old kind of + selection, so it doesn't reappear to + haunt us.) + (AND (fetch (SELECTION SET) of NOSEL) + (\SHOWSEL NOSEL NIL NIL)) (* If there was a new-type selection + around, turn it off.) + (SETQ OLDSEL NOSEL) (* Now cut over to the new selection) + (\TEDIT.SET.SEL.LOOKS OLDSEL NEWOP) (* And set it up looking right.) + )) + (\COPYSEL NEWSEL OLDSEL) + (replace (SELECTION ONFLG) of OLDSEL with NIL) + (* Make sure we can turn the + highlighting on.) + (\SHOWSEL OLDSEL NIL T))) + (RETURN (OR NOSEL OLDSEL]) +) +(DEFINEQ + +(\COPYSEL + [LAMBDA (FROM TO) (* ; "Edited 31-May-91 12:27 by jds") + (* Copy a SELECTION record from FROM + to TO, without creating any new ones) + (replace (SELECTION Y0) of TO with (fetch (SELECTION Y0) of FROM)) + (replace (SELECTION X0) of TO with (fetch (SELECTION X0) of FROM)) + (replace (SELECTION DX) of TO with (fetch (SELECTION DX) of FROM)) + (replace (SELECTION CH#) of TO with (fetch (SELECTION CH#) of FROM)) + (replace (SELECTION XLIM) of TO with (fetch (SELECTION XLIM) of FROM)) + (replace (SELECTION CHLIM) of TO with (fetch (SELECTION CHLIM) of FROM)) + (replace (SELECTION DCH) of TO with (fetch (SELECTION DCH) of FROM)) + (replace (SELECTION L1) of TO with (COPY (fetch (SELECTION L1) of FROM))) + (replace (SELECTION LN) of TO with (COPY (fetch (SELECTION LN) of FROM))) + (replace (SELECTION YLIM) of TO with (fetch (SELECTION YLIM) of FROM)) + (replace (SELECTION POINT) of TO with (fetch (SELECTION POINT) of FROM)) + (replace (SELECTION SET) of TO with (fetch (SELECTION SET) of FROM)) + (replace (SELECTION \TEXTOBJ) of TO with (fetch (SELECTION \TEXTOBJ) of + FROM)) + (replace (SELECTION SELKIND) of TO with (fetch (SELECTION SELKIND) of FROM)) + (replace (SELECTION HOW) of TO with (fetch (SELECTION HOW) of FROM)) + (replace (SELECTION HOWHEIGHT) of TO with (fetch (SELECTION HOWHEIGHT) + of FROM)) + (replace (SELECTION HASCARET) of TO with (fetch (SELECTION HASCARET) of + FROM)) + (replace (SELECTION SELOBJ) of TO with (fetch (SELECTION SELOBJ) of FROM)) + (replace (SELECTION ONFLG) of TO with (fetch (SELECTION ONFLG) of FROM]) + +(\TEDIT.SEL.CHANGED? + [LAMBDA (NEWSEL OLDSEL OLDSELOP NEWSELOP) (* ; "Edited 30-May-91 23:01 by jds") + + (* Decide whether there has been an interesting change in the selection, so we + can decide whether to refresh its hilighting on the screen.) + + (AND NEWSEL (fetch (SELECTION SET) of NEWSEL) + (NOT (AND (fetch (SELECTION SET) of OLDSEL) + (EQ (fetch (SELECTION SET) of OLDSEL) + (fetch (SELECTION SET) of NEWSEL)) + (EQUAL (fetch (SELECTION CH#) of NEWSEL) + (fetch (SELECTION CH#) of OLDSEL)) + (EQUAL (fetch (SELECTION CHLIM) of NEWSEL) + (fetch (SELECTION CHLIM) of OLDSEL)) + (EQ (fetch (SELECTION \TEXTOBJ) of NEWSEL) + (fetch (SELECTION \TEXTOBJ) of OLDSEL)) + (IEQP (fetch (SELECTION DX) of NEWSEL) + (fetch (SELECTION DX) of OLDSEL)) + (EQ (fetch (SELECTION POINT) of NEWSEL) + (fetch (SELECTION POINT) of OLDSEL)) + (EQ (fetch (SELECTION HOW) of NEWSEL) + (fetch (SELECTION HOW) of OLDSEL)) + (EQ (fetch (SELECTION HOWHEIGHT) of NEWSEL) + (fetch (SELECTION HOWHEIGHT) of OLDSEL)) + (EQ OLDSELOP NEWSELOP]) +) + + + +(* ;; "User entries to the selection code") + +(DEFINEQ + +(TEDIT.GETPOINT + [LAMBDA (STREAM SEL) (* ; "Edited 30-May-91 23:03 by jds") + + (* Given a selection, tell the CH# that type-in would be inserted in front of. + IF SEL is given, use it to decide. Otherwise, use STREAM's current selection.) + + (PROG [(TSEL (OR SEL (fetch (TEXTOBJ SEL) of (TEXTOBJ STREAM] + (RETURN (IMAX 1 (SELECTQ (fetch (SELECTION POINT) of TSEL) + (LEFT (fetch (SELECTION CH#) of TSEL)) + (RIGHT (fetch (SELECTION CHLIM) of TSEL)) + (SHOULDNT "Selection's POINT is neither RIGHT nor LEFT."]) + +(TEDIT.GETSEL + [LAMBDA (STREAM) (* ; "Edited 30-May-91 23:03 by jds") + (create SELECTION using (fetch (TEXTOBJ SEL) of (fetch (TEXTSTREAM TEXTOBJ) + of STREAM]) + +(TEDIT.MAKESEL + [LAMBDA (STREAM CH# LEN POINT) (* ; "Edited 30-May-91 23:03 by jds") + (PROG ((SEL (fetch (TEXTOBJ SEL) of (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) + (TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) + (\SHOWSEL SEL NIL NIL) + (replace (SELECTION CH#) of SEL with CH#) + (replace (SELECTION CHLIM) of SEL with (IMAX CH# (IPLUS CH# LEN))) + (replace (SELECTION DCH) of SEL with LEN) + (replace (SELECTION POINT) of SEL with (OR POINT 'LEFT)) + (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ) + (replace (SELECTION SET) of SEL with T) + (AND (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + (\FIXSEL SEL TEXTOBJ)) + (\SHOWSEL SEL NIL T]) + +(TEDIT.SCANSEL + [LAMBDA (STREAM) (* ; "Edited 30-May-91 23:03 by jds") + + (* Set up to read the selected text; return the sel's length or NIL if nothing + selected.) + + (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) + SEL) + (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (COND + ((fetch (SELECTION SET) of SEL) + (\SETUPGETCH (fetch (SELECTION CH#) of SEL) + TEXTOBJ) + (RETURN (fetch (SELECTION DCH) of SEL))) + (T (RETURN NIL]) + +(TEDIT.SET.SEL.LOOKS + [LAMBDA (SEL OPERATION) (* ; "Edited 30-May-91 23:01 by jds") + (* Set what the selection should be + displayed like, given what it's for + (NORMAL, COPY, MOVE, etc.)) + (PROG ((WASON (fetch (SELECTION ONFLG) of SEL))) + (\SHOWSEL SEL NIL NIL) + (SELECTQ OPERATION + (NORMAL (* Regular selection) + (replace (SELECTION HOW) of SEL with BLACKSHADE) + (replace (SELECTION HOWHEIGHT) of SEL with 1) + (replace (SELECTION HASCARET) of SEL with T)) + (COPY (* Copy source) + (replace (SELECTION HOW) of SEL with COPYSELSHADE) + (replace (SELECTION HOWHEIGHT) of SEL with 1) + (replace (SELECTION HASCARET) of SEL with NIL)) + (COPYLOOKS (* copylooks source) + (replace (SELECTION HOW) of SEL with COPYLOOKSSELSHADE) + (replace (SELECTION HOWHEIGHT) of SEL with 2) + (replace (SELECTION HASCARET) of SEL with NIL)) + (MOVE (* Copy source) + (replace (SELECTION HOW) of SEL with EDITMOVESHADE) + (replace (SELECTION HOWHEIGHT) of SEL with 16384) + (replace (SELECTION HASCARET) of SEL with NIL)) + (DELETE (* To be deleted instantly) + (replace (SELECTION HOW) of SEL with BLACKSHADE) + (replace (SELECTION HOWHEIGHT) of SEL with 16384) + (replace (SELECTION HASCARET) of SEL with NIL) + NIL) + (PENDINGDEL (* Delete at next type-in) + (replace (SELECTION HOW) of SEL with BLACKSHADE) + (replace (SELECTION HOWHEIGHT) of SEL with 16384) + (replace (SELECTION HASCARET) of SEL with T) + NIL) + (INVERTED (* For people who really want to see + what's selected.) + (replace (SELECTION HOW) of SEL with BLACKSHADE) + (replace (SELECTION HOWHEIGHT) of SEL with 16384) + (replace (SELECTION HASCARET) of SEL with T) + NIL) + NIL) + (\SHOWSEL SEL NIL WASON]) + +(TEDIT.SETSEL + [LAMBDA (STREAM CH# LEN POINT PENDINGDELFLG LEAVECARETLOOKS OPERATION) + (* ; "Edited 30-May-91 23:05 by jds") + + (* ;; "Given a text stream or textobj, and a piece of text to select, set the internal selection, and return it.") + (* ; "Make sure we got a stream") + (PROG ((TEXTOBJ (TEXTOBJ STREAM)) + SEL TEXTLEN) + (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (\SHOWSEL SEL NIL NIL) (* ; "First turn the old sel off.") + [COND + ((type? SELECTION CH#) (* ; + "He gave use a selection; just plug it in") + (\COPYSEL CH# SEL) + (replace (SELECTION ONFLG) of SEL with NIL) + (* ; + "And make sure it can be turned on.") + ) + (T (* ; "He fed us numbers; use them") + (replace (SELECTION CH#) of SEL with (IMIN (IMAX 1 CH#) + (ADD1 TEXTLEN))) + (* ; "Starting character") + [replace (SELECTION CHLIM) of SEL with (IMAX 1 CH# + (IMIN (IPLUS CH# LEN) + (ADD1 TEXTLEN] + (* ; "Last selected character") + [replace (SELECTION DCH) of SEL with (IMIN LEN TEXTLEN + (IDIFFERENCE + (fetch (SELECTION CHLIM) + of SEL) + (fetch (SELECTION CH#) + of SEL] + (replace (SELECTION POINT) of SEL with (OR (AND (IGREATERP CH# TEXTLEN) + 'LEFT) + POINT + 'LEFT)) + (* ; + "Which side the caret should go on") + (COND + ((OR (IGREATERP (fetch (SELECTION CH#) of SEL) + TEXTLEN) + (NEQ 1 LEN)) + (replace (SELECTION SELOBJ) of SEL with NIL)) + (T (replace (SELECTION SELOBJ) of SEL + with (fetch (PIECE POBJ) of (\CHTOPC (fetch (SELECTION + CH#) + of SEL) + (fetch (TEXTOBJ PCTB) + of TEXTOBJ] + (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ) + (* ; + "Link it back to the associated textobj") + [COND + (PENDINGDELFLG (* ; + "This selection is to be a pending-deletion sel.") + (replace (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ with T) + (* ; + "Warn TEdit that there's a deletion pending") + (\TEDIT.SET.SEL.LOOKS SEL (OR OPERATION 'PENDINGDEL)) + (* ; + "And make the selection look right.") + ) + (T (* ; + "This selection is to be a pending-deletion sel.") + (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) + (\TEDIT.SET.SEL.LOOKS SEL (OR OPERATION 'NORMAL] + (replace (SELECTION SET) of SEL with T)(* ; + "Mark the selection as valid for others to use") + [COND + ((NOT LEAVECARETLOOKS) (* ; + "And set the insertion looks to follow.") + (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (\TEDIT.GET.INSERT.CHARLOOKS + TEXTOBJ SEL] + (\FIXSEL SEL TEXTOBJ) (* ; + "Update the selection's screen location") + (\SHOWSEL SEL NIL T) (* ; "Highlight it on the screen") + (RETURN SEL]) + +(TEDIT.SHOWSEL + [LAMBDA (STREAM ONFLG SEL) (* ; "Edited 30-May-91 23:04 by jds") + (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) + (COND + (SEL (* He's giving us a selection to + highlight. Connect it to this + textobj.) + (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ) + (\FIXSEL SEL TEXTOBJ))) + (\SHOWSEL (OR SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + NIL ONFLG]) +) +(PUTPROPS TEDITSELECTION COPYRIGHT ("John Sybalsky & Xerox Corporation" 1983 1984 1985 1986 1987 1988 +1990 1991 1992 1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (2782 17597 (TEDIT.SEL.AS.STRING 2792 . 4245) (TEDIT.SELECTED.PIECES 4247 . 7745) ( +\TEDIT.FIND.FIRST.LINE 7747 . 11756) (\TEDIT.FIND.LAST.LINE 11758 . 13039) ( +\TEDIT.FIND.OVERLAPPING.LINE 13041 . 13483) (\TEDIT.FIND.PROTECTED.END 13485 . 15412) ( +\TEDIT.FIND.PROTECTED.START 15414 . 17034) (\TEDIT.WORD.BOUND 17036 . 17595)) (17641 18120 ( +\CREATE.TEDIT.SELECTION 17651 . 17721) (\CREATE.TEDIT.SHIFTEDSELECTION 17723 . 17826) ( +\CREATE.TEDIT.MOVESELECTION 17828 . 17957) (\CREATE.TEDIT.DELETESELECTION 17959 . 18118)) (18864 84316 + (TEDIT.EXTEND.SEL 18874 . 32763) (TEDIT.SELECT 32765 . 38574) (TEDIT.SCAN.LINE 38576 . 59323) ( +TEDIT.SELECT.LINE.SCANNER 59325 . 78264) (\TEDIT.SELECT.CHARACTER 78266 . 84314)) (84317 114722 ( +\FIXSEL 84327 . 108968) (\TEDIT.FIXDELSEL 108970 . 112637) (\TEDIT.FIXINSSEL 112639 . 113957) ( +\TEDIT.FIXSELS 113959 . 114720)) (114723 118260 (TEDIT.RESET.EXTEND.PENDING.DELETE 114733 . 115403) ( +\TEDIT.SET.SEL.LOOKS 115405 . 118258)) (118261 140862 (\SHOWSEL 118271 . 124249) (\SHOWSEL.HILIGHT +124251 . 131073) (\TEDIT.UPDATE.SHOWSEL 131075 . 136880) (\TEDIT.SHOWSELS 136882 . 137605) ( +\TEDIT.REFRESH.SHOWSEL 137607 . 140860)) (140863 144817 (\COPYSEL 140873 . 143265) ( +\TEDIT.SEL.CHANGED? 143267 . 144815)) (144870 157188 (TEDIT.GETPOINT 144880 . 145583) (TEDIT.GETSEL +145585 . 145892) (TEDIT.MAKESEL 145894 . 146787) (TEDIT.SCANSEL 146789 . 147431) (TEDIT.SET.SEL.LOOKS +147433 . 150578) (TEDIT.SETSEL 150580 . 156482) (TEDIT.SHOWSEL 156484 . 157186))))) +STOP diff --git a/library/TEDITWINDOW b/library/TEDITWINDOW new file mode 100644 index 00000000..3156ff58 --- /dev/null +++ b/library/TEDITWINDOW @@ -0,0 +1,2398 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "21-Jun-99 20:00:42" {DSK}medley3.5>library>TEDITWINDOW.;3 185046 changes to%: (FNS \TEDIT.WINDOW.SETUP) previous date%: "25-Aug-94 10:56:22" {DSK}medley3.5>library>TEDITWINDOW.;2) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994, 1999 by John Sybalsky & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEDITWINDOWCOMS) (RPAQQ TEDITWINDOWCOMS [(FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (FILES ATTACHEDWINDOW) (FNS TEDIT.CREATEW \TEDIT.CREATEW.FROM.REGION TEDIT.CURSORMOVEDFN TEDIT.CURSOROUTFN TEDIT.WINDOW.SETUP TEDIT.MINIMAL.WINDOW.SETUP \TEDIT.ACTIVE.WINDOWP \TEDIT.BUTTONEVENTFN \TEDIT.WINDOW.OPS \TEDIT.EXPANDFN \TEDIT.MAINW \TEDIT.PRIMARYW \TEDIT.COPYINSERTFN \TEDIT.NEWREGIONFN \TEDIT.SET.WINDOW.EXTENT \TEDIT.SHRINK.ICONCREATE \TEDIT.SHRINKFN \TEDIT.SPLITW \TEDIT.UNSPLITW \TEDIT.WINDOW.SETUP \SAFE.FIRST) (CURSORS BXCARET BXHICARET TEDIT.LINECURSOR \TEDIT.SPLITCURSOR \TEDIT.MOVESPLITCURSOR \TEDIT.UNSPLITCURSOR \TEDIT.MAKESPLITCURSOR) (INITVARS (TEDIT.DEFAULT.WINDOW NIL)) (GLOBALVARS TEDIT.DEFAULT.WINDOW) (COMS (* ;  "User-level %"is this a TEdit window?%" function.") (FNS TEDITWINDOWP)) (COMS (* ; "User-typein support") (FNS TEDIT.GETINPUT \TEDIT.MAKEFILENAME)) (COMS (* ; "Attached Prompt window support.") (FNS TEDIT.PROMPTPRINT TEDIT.PROMPTFLASH \TEDIT.PROMPT.PAGEFULLFN) (INITVARS (TEDIT.PROMPT.FONT (FONTCREATE 'GACHA 10)) (TEDIT.PROMPTWINDOW.HEIGHT NIL)) (GLOBALVARS TEDIT.PROMPT.FONT TEDIT.PROMPTWINDOW.HEIGHT)) (COMS (* ; "Title creation and update") (FNS TEXTSTREAM.TITLE \TEDIT.ORIGINAL.WINDOW.TITLE \TEDIT.WINDOW.TITLE \TEXTSTREAM.FILENAME)) (COMS (* ; "Screen updating utilities") (FNS TEDIT.DEACTIVATE.WINDOW \TEDIT.REPAINTFN \TEDIT.RESHAPEFN \TEDIT.SCROLLFN)) (COMS (* ; "Process-world interfaces") (FNS \TEDIT.PROCIDLEFN \TEDIT.PROCENTRYFN \TEDIT.PROCEXITFN)) (COMS (INITVARS (\CARETRATE 333)) (* ;  "Caret handler; stolen from CHAT.") (FNS \EDIT.DOWNCARET \EDIT.FLIPCARET TEDIT.FLASHCARET \EDIT.UPCARET TEDIT.NORMALIZECARET \SETCARET \TEDIT.CARET)) [COMS (* ; "Menu interfacing") (FNS TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENUFN TEDIT.REMOVE.MENUITEM \TEDIT.CREATEMENU \TEDIT.MENU.WHENHELDFN \TEDIT.MENU.WHENSELECTEDFN) (GLOBALVARS TEDIT.DEFAULT.MENU) [DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (TEDIT.DEFAULT.MENU (\TEDIT.CREATEMENU '((Put 'Put NIL (SUBITEMS |Put Formatted Document| Plain-Text Old-Format )) (Get 'Get NIL (SUBITEMS |Get Formatted Document| Unformatted% Get )) Include Find Looks Substitute Quit (Expanded% Menu 'Expanded% Menu NIL (SUBITEMS Expanded% Menu Character% Looks Paragraph% Formatting Page% Layout] (DECLARE%: DONTEVAL@LOAD DOCOPY (P [OR (SASSOC 'TEdit BackgroundMenuCommands) (NCONC1 BackgroundMenuCommands '(TEdit '(TEDIT) "Opens a TEdit window for use."] (SETQ BackgroundMenu NIL] (COMS (* ; "titled icon info") (FILES ICONW) (BITMAPS TEDITICON TEDITMASK) (INITVARS (TEDIT.ICON.FONT (FONTCREATE 'HELVETICA 8 'BOLD)) [TEDIT.ICON.TITLE.REGION (CONS 16 (CONS 4 (CONS 64 (CONS 77 NIL] (* ;  "Original was (create REGION BOTTOM _ 4 LEFT _ 16 WIDTH _ 64 HEIGHT _ 77).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") [TEDIT.TITLED.ICON.TEMPLATE (CONS TEDITICON (CONS TEDITMASK (CONS TEDIT.ICON.TITLE.REGION NIL] (* ; "Original was (create TITLEDICON ICON _ TEDITICON MASK _ TEDITMASK TITLEREG _ TEDIT.ICON.TITLE.REGION).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") ]) (FILESLOAD TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SCRATCHLEN 64) (CONSTANTS (\SCRATCHLEN 64)) ) (FILESLOAD (LOADCOMP) TEDITDCL) ) (FILESLOAD ATTACHEDWINDOW) (DEFINEQ (TEDIT.CREATEW + [LAMBDA (PROMPT FILE PROPS) (* jds "23-May-85 15:19") + (CLRPROMPT) + (printout PROMPTWINDOW PROMPT T) + (PROG ((PROMPT (LISTGET PROPS 'PROMPTWINDOW)) + (PHEIGHT 0) + PWINDOW REGION) + [COND + ((EQ PROMPT 'DON'T)) + (PROMPT) + (T (SETQ PHEIGHT (HEIGHTIFWINDOW (ITIMES (OR (LISTGET PROPS 'PROMPTWINDOWHEIGHT) + TEDIT.PROMPTWINDOW.HEIGHT 1) + (FONTPROP TEDIT.PROMPT.FONT 'HEIGHT] + (SETQ REGION (GETREGION 32 (IPLUS PHEIGHT 32))) + (add (fetch HEIGHT of REGION) + (IMINUS PHEIGHT)) + (SETQ TEDIT.DEFAULT.WINDOW (CREATEW REGION (\TEDIT.ORIGINAL.WINDOW.TITLE FILE))) + (CLRPROMPT) + (OR PROMPT (GETPROMPTWINDOW TEDIT.DEFAULT.WINDOW (OR (LISTGET PROPS 'PROMPTWINDOWHEIGHT) + TEDIT.PROMPTWINDOW.HEIGHT 1) + TEDIT.PROMPT.FONT))) + TEDIT.DEFAULT.WINDOW]) (\TEDIT.CREATEW.FROM.REGION + [LAMBDA (REGION FILE PROPS) (* gbn "15-Nov-84 18:04") + (PROG ((PROMPT (LISTGET PROPS 'PROMPTWINDOW)) + (PHEIGHT 0) + PWINDOW) + [COND + ((EQ PROMPT 'DON'T)) + (PROMPT) + (T (SETQ PHEIGHT (HEIGHTIFWINDOW (ITIMES (OR (LISTGET PROPS 'PROMPTWINDOWHEIGHT) + TEDIT.PROMPTWINDOW.HEIGHT 1) + (FONTPROP TEDIT.PROMPT.FONT 'HEIGHT] + (SETQ TEDIT.DEFAULT.WINDOW (CREATEW REGION (\TEDIT.ORIGINAL.WINDOW.TITLE FILE))) + (WINDOWPROP TEDIT.DEFAULT.WINDOW 'TEDITCREATED T) + (OR PROMPT (GETPROMPTWINDOW TEDIT.DEFAULT.WINDOW (OR (LISTGET PROPS 'PROMPTWINDOWHEIGHT) + TEDIT.PROMPTWINDOW.HEIGHT 1) + TEDIT.PROMPT.FONT))) + TEDIT.DEFAULT.WINDOW]) (TEDIT.CURSORMOVEDFN + [LAMBDA (W) (* ; "Edited 30-May-91 23:39 by jds") + + (* Watch the mouse and change the cursor to reflect the region of the window + it's in (line select, window split eventually?)) + + (PROG ((X (LASTMOUSEX W)) + (Y (LASTMOUSEY W)) + (TEXTOBJ (WINDOWPROP W 'TEXTOBJ)) + (CURSORREG (WINDOWPROP W 'TEDIT.CURSORREGION)) + LINE LEFT RIGHT) + (COND + ((INSIDE? CURSORREG X Y) (* Do nothing) + NIL) + (T (SETQ LINE (\TEDIT.FIND.OVERLAPPING.LINE (for LINES + inside (fetch (TEXTOBJ LINES) + of TEXTOBJ) + as WINDOW + inside (fetch (TEXTOBJ \WINDOW) + of TEXTOBJ) + when (EQ W WINDOW) + do (RETURN LINES)) + Y)) + [COND + (LINE (replace BOTTOM of CURSORREG with (fetch (LINEDESCRIPTOR + YBOT) of + LINE)) + (replace HEIGHT of CURSORREG with (fetch (LINEDESCRIPTOR + LHEIGHT) + of LINE] + (SELECTQ (fetch (TEXTOBJ MOUSEREGION) of TEXTOBJ) + (TEXT [COND + ((IGEQ X (SETQ LEFT (IDIFFERENCE (fetch (TEXTOBJ WRIGHT) + of TEXTOBJ) + 8))) + (CURSOR \TEDIT.SPLITCURSOR) + (replace (TEXTOBJ MOUSEREGION) of TEXTOBJ with 'WINDOW) + (replace LEFT of CURSORREG with LEFT) + (replace WIDTH of CURSORREG with 8)) + ([ILESSP X (SETQ LEFT + (OR [AND LINE (COND + ((fetch (FMTSPEC FMTHARDCOPY) + of (fetch (LINEDESCRIPTOR + LFMTSPEC) + of LINE)) + (FIXR (FQUOTIENT (fetch ( + LINEDESCRIPTOR + LEFTMARGIN) + of LINE) + 35.27778))) + (T (fetch (LINEDESCRIPTOR LEFTMARGIN) + of LINE] + (IPLUS (fetch (TEXTOBJ WLEFT) of TEXTOBJ) + 8] (* In left margin; + switch to the line-select cursor) + (CURSOR TEDIT.LINECURSOR) + (replace (TEXTOBJ MOUSEREGION) of TEXTOBJ with 'LINE) + (replace LEFT of CURSORREG with 0) + (replace WIDTH of CURSORREG with LEFT)) + (T (replace LEFT of CURSORREG with LEFT) + (replace WIDTH of CURSORREG with + (IDIFFERENCE (fetch + (TEXTOBJ WRIGHT) + of TEXTOBJ) + (IPLUS LEFT 8]) + (LINE (COND + ((IGEQ X (SETQ LEFT (IDIFFERENCE (fetch (TEXTOBJ WRIGHT) + of TEXTOBJ) + 8))) + (CURSOR \TEDIT.SPLITCURSOR) + (replace (TEXTOBJ MOUSEREGION) of TEXTOBJ with 'WINDOW) + (replace LEFT of CURSORREG with LEFT) + (replace WIDTH of CURSORREG with 8)) + [[IGEQ X (SETQ LEFT (OR [AND LINE (COND + ((fetch (FMTSPEC FMTHARDCOPY) + of (fetch ( + LINEDESCRIPTOR + LFMTSPEC) + of LINE)) + (FIXR (FQUOTIENT + (fetch (LINEDESCRIPTOR + LEFTMARGIN) + of LINE) + 35.27778))) + (T (fetch (LINEDESCRIPTOR + LEFTMARGIN) + of LINE] + (IPLUS (fetch (TEXTOBJ WLEFT) of TEXTOBJ + ) + 8] + (CURSOR T) + (replace (TEXTOBJ MOUSEREGION) of TEXTOBJ with 'TEXT) + (replace LEFT of CURSORREG with LEFT) + (replace WIDTH of CURSORREG with (IDIFFERENCE + (fetch (TEXTOBJ + WRIGHT) + of TEXTOBJ) + (IPLUS LEFT 8] + (T (replace LEFT of CURSORREG with 0) + (replace WIDTH of CURSORREG with LEFT)))) + (WINDOW (COND + ((IGEQ X (SETQ LEFT (IDIFFERENCE (fetch (TEXTOBJ WRIGHT) + of TEXTOBJ) + 8))) + (replace (TEXTOBJ MOUSEREGION) of TEXTOBJ with + 'WINDOW) + (replace LEFT of CURSORREG with LEFT) + (replace WIDTH of CURSORREG with 8)) + ([IGEQ X (SETQ LEFT + (OR [AND LINE (COND + ((fetch (FMTSPEC FMTHARDCOPY) + of (fetch (LINEDESCRIPTOR + LFMTSPEC) + of LINE)) + (FIXR (FQUOTIENT (fetch ( + LINEDESCRIPTOR + LEFTMARGIN) + of LINE) + 35.27778))) + (T (fetch (LINEDESCRIPTOR LEFTMARGIN) + of LINE] + (IPLUS (fetch (TEXTOBJ WLEFT) of TEXTOBJ) + 8] + (CURSOR T) + (replace (TEXTOBJ MOUSEREGION) of TEXTOBJ with + 'TEXT) + (replace LEFT of CURSORREG with LEFT) + (replace WIDTH of CURSORREG with + (IDIFFERENCE (fetch + (TEXTOBJ WRIGHT) + of TEXTOBJ) + LEFT))) + (T (CURSOR TEDIT.LINECURSOR) + (replace LEFT of CURSORREG with 0) + (replace WIDTH of CURSORREG with LEFT)))) + NIL]) (TEDIT.CURSOROUTFN + [LAMBDA (W) (* ; "Edited 30-May-91 23:32 by jds") + (* Cursor leaves edit window; + make sure we think we're in the text + region.) + (PROG [(TEXTOBJ (WINDOWPROP W 'TEXTOBJ] + (CURSOR T) + (replace (TEXTOBJ MOUSEREGION) of TEXTOBJ with 'TEXT]) (TEDIT.WINDOW.SETUP + [LAMBDA (WINDOW TEXTOBJ TEXTSTREAM PROPS AFTERWINDOW) (* ; "Edited 30-May-91 23:32 by jds") + + (* ;; "Set up the window and TEXTOBJ so they correspond, and the window is a TEDIT window.") + + (* ;; "Do the minimal, everyone-wants-it style of setup. Leave more specialized setup for other functions.") + + (PROG ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + TEDITPROMPTWINDOW DS PROP TWIDTH THEIGHT) + (OR WINDOW (\ILLEGAL.ARG WINDOW)) + (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION \TEDIT.BUTTONEVENTFN)) + (* ; + "Set the window up with the right mouse interfaces for TEDIT.") + (WINDOWPROP WINDOW 'RIGHTBUTTONFN (FUNCTION \TEDIT.BUTTONEVENTFN)) + (WINDOWPROP WINDOW 'HARDCOPYFN (FUNCTION TEDIT.HARDCOPYFN)) + (* ; + "Hook into the system standard hardcopy interface") + (SETQ PROP (LISTGET PROPS 'MENU)) (* ; + "The Command menu, or list of items for it") + (COND + ((type? MENU PROP) (* ; "It's a menu. just use it.") + (WINDOWPROP WINDOW 'TEDIT.MENU PROP)) + (PROP (* ; + "It's a list of menu items. Force a new menu on next middle button.") + (WINDOWPROP WINDOW 'TEDIT.MENU.COMMANDS PROP) + (WINDOWPROP WINDOW 'TEDIT.MENU NIL))) + (TEDIT.MINIMAL.WINDOW.SETUP WINDOW TEXTOBJ TEXTSTREAM PROPS AFTERWINDOW]) (TEDIT.MINIMAL.WINDOW.SETUP + [LAMBDA (WINDOW TEXTOBJ TEXTSTREAM PROPS AFTERWINDOW) (* ; "Edited 30-May-91 23:33 by jds") + + (* ;; "Do the absolute minimum setup so that TEXTOBJ and WINDOW know about each other. Does NOT include mouse interface or scrolling.") + + (* ;; "If AFTERWINDOW is non-NIL, the new window will be placed after AFTERWINDOW in the TEXTOBJ's list. This lists us maintain an ordering of windows, for splitting and unsplitting.") + + (PROG ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + TEDITPROMPTWINDOW DS PROP TWIDTH THEIGHT LINES OLDWINDOWS) + (OR WINDOW (\ILLEGAL.ARG WINDOW)) + (replace (TEDITCARET TCCARETDS) of (COND + [(LISTP (fetch (TEXTOBJ CARET) + of TEXTOBJ)) + (CAR (FLAST (fetch (TEXTOBJ CARET) + of TEXTOBJ] + (T (fetch (TEXTOBJ CARET) of TEXTOBJ) + )) with (WINDOWPROP WINDOW + 'DSP)) + (* ; + "The displaystream for flashing the caret") + (replace (TEXTOBJ SELWINDOW) of TEXTOBJ with WINDOW) + (WINDOWPROP WINDOW 'PROCESS NIL) (* ; + "For the moment, this window has no process") + (WINDOWPROP WINDOW 'TEDIT.PROPS PROPS) (* ; + "Put the props on the window for others ... **this should go**") + (WINDOWPROP WINDOW 'TEXTSTREAM TEXTSTREAM) (* ; + "Save the text stream for the user to get at via the window.") + (WINDOWPROP WINDOW 'TEXTOBJ TEXTOBJ) (* ; + "Give a handle on the TEXTOBJ for the text being edited.") + (WINDOWPROP WINDOW 'TEDIT.CURSORREGION (LIST 0 0 0 0)) + (* ; "Used by CursorMovedFn") + (WINDOWPROP WINDOW 'CURSORMOVEDFN (FUNCTION TEDIT.CURSORMOVEDFN)) + (WINDOWPROP WINDOW 'CURSOROUTFN (FUNCTION TEDIT.CURSOROUTFN)) + (SETQ DS (WINDOWPROP WINDOW 'DSP)) + (DSPRIGHTMARGIN 32767 DS) (* ; + "So we don't get spurious RETURNs printed out by the system") + (SETQ OLDWINDOWS (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) + [replace (TEXTOBJ \WINDOW) of TEXTOBJ + with (COND + [(LISTP OLDWINDOWS) (* ; + "There are windows already. Add this to the list.") + (COND + (AFTERWINDOW (* ; + "We know which window to put it after. Put it there") + [RPLACD (FMEMB AFTERWINDOW OLDWINDOWS) + (CONS WINDOW (CDR (FMEMB AFTERWINDOW OLDWINDOWS] + OLDWINDOWS) + (T (* ; + "Otherwise, just add it at the end of the list") + (NCONC1 OLDWINDOWS WINDOW] + (WINDOW (LIST WINDOW] + (replace (TEXTOBJ DISPLAYCACHE) of TEXTOBJ with (CAR (\TEDIT.CREATE.LINECACHE + 1))) + (* ; + "and a CACHE for creating line images for display") + [replace (TEXTOBJ DISPLAYCACHEDS) of TEXTOBJ + with (DSPCREATE (fetch LCBITMAP of (fetch (TEXTOBJ DISPLAYCACHE) + of TEXTOBJ] + (* ; + "A displaystream for changeing the image caches") + (DSPOPERATION 'PAINT (fetch (TEXTOBJ DISPLAYCACHEDS) of TEXTOBJ)) + (DSPCLIPPINGREGION (create REGION + LEFT _ 0 + BOTTOM _ 0 + WIDTH _ 100 + HEIGHT _ 15) + (fetch (TEXTOBJ DISPLAYCACHEDS) of TEXTOBJ)) + (* ; "Remember its size, too.") + [COND + ((SETQ PROP (LISTGET PROPS 'REGION)) (* ; + "The caller wants to set a region. Use his") + (replace (TEXTOBJ WTOP) of TEXTOBJ with (fetch PTOP of PROP)) + (replace (TEXTOBJ WRIGHT) of TEXTOBJ with (fetch RIGHT of PROP)) + (replace (TEXTOBJ WBOTTOM) of TEXTOBJ with (fetch BOTTOM of PROP)) + (replace (TEXTOBJ WLEFT) of TEXTOBJ with (fetch LEFT of PROP))) + (T (* ; + "Otherwise, default to the whole window") + (replace (TEXTOBJ WLEFT) of TEXTOBJ with 0) + (replace (TEXTOBJ WBOTTOM) of TEXTOBJ with 0) + (replace (TEXTOBJ WTOP) of TEXTOBJ with (fetch HEIGHT + of (DSPCLIPPINGREGION + NIL DS))) + (replace (TEXTOBJ WRIGHT) of TEXTOBJ with (fetch WIDTH + of (DSPCLIPPINGREGION + NIL DS] + (SETQ LINES (\SHOWTEXT TEXTOBJ NIL WINDOW)) + (WINDOWPROP WINDOW 'LINES LINES) (* ; + "Display the text in the window, for later use.") + [replace (TEXTOBJ LINES) of TEXTOBJ + with (COND + [AFTERWINDOW (for LINE in (fetch (TEXTOBJ LINES) of TEXTOBJ) + as WINDOW in OLDWINDOWS + join (COND + ((EQ WINDOW AFTERWINDOW) + (LIST LINE LINES)) + (T (LIST LINE] + ((LISTP (fetch (TEXTOBJ LINES) of TEXTOBJ)) + (NCONC1 (fetch (TEXTOBJ LINES) of TEXTOBJ) + LINES)) + (LINES (LIST LINES] + (\FIXSEL SEL TEXTOBJ) + (TEDIT.NORMALIZECARET TEXTOBJ SEL) + (\SHOWSEL SEL NIL T) + (\TEDIT.SET.WINDOW.EXTENT TEXTOBJ WINDOW) + (\COPYSEL SEL TEDIT.SELECTION]) (\TEDIT.ACTIVE.WINDOWP + [LAMBDA (W) (* ; "Edited 30-May-91 23:33 by jds") + + (* Decides whether a TEdit window is really in use. + The function TEDIT will set the TEXTOBJ prop of the window to T pro tem, to + reserve a window. Once the TEdit has really started, the TEXTOBJ property will + be a real textobj.) + + (PROG [(TEXTOBJ (OR (WINDOWPROP W 'TEXTOBJ) + (AND (WINDOWPROP W 'TEXTSTREAM) + (TEXTOBJ (WINDOWPROP W 'TEXTSTREAM] + (RETURN (COND + ((EQ TEXTOBJ T) (* Can have a TEXTOBJ of T as a + placeholder during creation...) + T) + (TEXTOBJ (AND (NOT (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ)) + (PROCESSP (WINDOWPROP W 'PROCESS]) (\TEDIT.BUTTONEVENTFN + [LAMBDA (W STREAM) (* ; "Edited 5-Sep-91 18:52 by jds") + + (* ;; "Handle button events for a TEdit window") + + (AND STREAM (SETQ STREAM (TEXTOBJ STREAM))) + (PROG* ((OSEL NIL) + (SEL NIL) + [TEXTOBJ (OR STREAM (WINDOWPROP W 'TEXTOBJ] + (DS (WINDOWPROP W 'DSP)) + USERFN + (GLOBALSEL TEDIT.SELECTION) + (X (LASTMOUSEX W)) + (Y (LASTMOUSEY W)) + (CLIPREGION (DSPCLIPPINGREGION NIL W)) + (SELOPERATION 'NORMAL) + (SELFN (TEXTPROP TEXTOBJ 'SELFN)) + (EXTENDFLG NIL) + (OLDX -32000) + (OLDY -32000) + SELFINALFN PROC NOSEL) + (COND + ((NOT (MOUSESTATE (OR LEFT MIDDLE RIGHT))) (* ; + "No button is down -- we got control on button-up transition, so ignore it.") + (RETURN)) + (TEDIT.SELPENDING (* ; + "There is already a selection in progress. Don't allow another to interfere.") + (RETURN))) + (replace (SELECTION CH#) of TEDIT.SCRATCHSELECTION with 0) + (* ; + "Mark the user-visible scratch selection fresh, so changes can be detected...") + (COND + [[OR (NOT TEXTOBJ) + (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ) + (AND (NOT (WINDOWPROP W 'PROCESS)) + (NOT (TEXTPROP TEXTOBJ 'READONLY)) + (NOT (SHIFTDOWNP 'SHIFT)) + (NOT (SHIFTDOWNP 'CTRL)) + (NOT (SHIFTDOWNP 'META)) + (NOT (KEYDOWNP 'MOVE)) + (NOT (KEYDOWNP 'COPY] (* ; "There's no edit session behind this window. You can only do window ops, or re-establish a session.") + (TOTOPW W) + (COND + ((\TEDIT.MOUSESTATE RIGHT) (* ; + "Right button gets the window command menu") + (DOWINDOWCOM W)) + ((AND TEXTOBJ (NOT (TEXTPROP TEXTOBJ 'READONLY)) + (NOT (TEXTPROP TEXTOBJ 'SELECTONLY)) + [NOT (PROCESSP (WINDOWPROP W 'PROCESS] + (\TEDIT.MOUSESTATE MIDDLE)) (* ; + "Middle button on a dead window gives a menu for re-starting TEDIT") + (COND + ((EQ (MENU TEDIT.RESTART.MENU) + 'NewEditProcess) + (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with NIL) + (TEDIT (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) + W] + [(IGREATERP Y (fetch TOP of CLIPREGION)) + (* ; + "It's not inside the window's REAL region, so call on a menu.") + (TOTOPW W) + (COND + ((\TEDIT.MOUSESTATE RIGHT) + (DOWINDOWCOM W)) + ((MOUSESTATE (OR LEFT MIDDLE)) + (AND TEXTOBJ (SETQ USERFN (WINDOWPROP W 'TEDIT.TITLEMENUFN)) + (NEQ USERFN 'DON'T) (* ; "HAD BEEN: (COND ((AND (SETQ PROC (WINDOWPROP W 'PROCESS)) (PROCESSP PROC)) ; This window has a live process behind it; go evaluate the button fn there. (PROCESS.APPLY PROC USERFN (LIST W))) (T ; Otherwise, create a new process to handle the menu. (ADD.PROCESS (LIST USERFN (KWOTE W)))))") + (ADD.PROCESS (LIST USERFN (KWOTE W] + ((AND TEXTOBJ (EQ (fetch (TEXTOBJ MOUSEREGION) of TEXTOBJ) + 'WINDOW)) (* ; + "We're in the window-ops region of the window. Do a window split or something") + (\TEDIT.WINDOW.OPS TEXTOBJ W)) + ((AND TEXTOBJ (NOT (fetch (TEXTOBJ EDITOPACTIVE) of TEXTOBJ))) + (* ; + "Usual case -- he's really selecting something. And there's nothing else going on now.") + (TOTOPW W) (* ; + "Move the editing window to the top, so he can select wherever he wants.") + (\CARET.DOWN) (* ; + "Make sure the caret isn't being displayed.") + (RESETLST + (RESETSAVE TEDIT.SELPENDING TEXTOBJ) + + (* ;; "Tell all TEdits not to run, since there is a selection in progress. This is reset to NIL on return from here, to re-enable TEdit runs.") + + (RESETSAVE (for CARET inside (fetch (TEXTOBJ CARET) of TEXTOBJ) + do (replace TCCARET of CARET with (\CARET.CREATE + BXHICARET))) + (LIST '\TEDIT.CARET (fetch (TEXTOBJ CARET) of TEXTOBJ))) + (* ; + "Then make the caret be the special, tall one so he can see it.") + (COND + ((KEYDOWNP 'COPY) (* ; + "In a read-only document, you can only copy.") + (SETQ GLOBALSEL TEDIT.SHIFTEDSELECTION) + (SETQ OSEL (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ)) + (SETQ SELOPERATION 'COPY)) + ((AND (KEYDOWNP 'MOVE) + (NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ))) + (* ; + "The MOVE key is down, so set MOVE mode.") + (SETQ GLOBALSEL TEDIT.MOVESELECTION) + (SETQ OSEL (fetch (TEXTOBJ MOVESEL) of TEXTOBJ)) + (SETQ SELOPERATION 'MOVE)) + [(SHIFTDOWNP 'SHIFT) (* ; + "the SHIFT key is down; mark this selection for COPY or MOVE.") + (COND + ((AND (SHIFTDOWNP 'CTRL) + (NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ))) + (* ; "CTRL-SHIFT select means MOVE.") + (SETQ GLOBALSEL TEDIT.MOVESELECTION) + (SETQ OSEL (fetch (TEXTOBJ MOVESEL) of TEXTOBJ)) + (SETQ SELOPERATION 'MOVE)) + (T (SETQ GLOBALSEL TEDIT.SHIFTEDSELECTION) + (SETQ OSEL (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ)) + (SETQ SELOPERATION 'COPY] + ((SHIFTDOWNP 'META) (* ; + "He's holding the meta key down , do a copylooks selection") + (SETQ GLOBALSEL TEDIT.COPYLOOKSSELECTION) + (SETQ OSEL (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ)) + (SETQ SELOPERATION 'COPYLOOKS)) + ((AND (SHIFTDOWNP 'CTRL) + (NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ))) + (* ; + "He's holding the control key down; note the fact.") + (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) + NIL NIL) + (SETQ GLOBALSEL TEDIT.DELETESELECTION) + [COND + ((fetch (SELECTION SET) of (fetch (TEXTOBJ DELETESEL) + of TEXTOBJ)) + (* ; + "There's a pending delete selection. Use it, and turn off the existing normal selection.") + ) + (T (* ; + "No existing delete selection. Use the normal selection as a starting point.") + (\COPYSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) + (fetch (TEXTOBJ DELETESEL) of TEXTOBJ] + (replace (SELECTION SET) of (fetch (TEXTOBJ SEL) of TEXTOBJ) + with NIL) + + (* ;; "Remember to turn off the normal selection, since we'll be moving it to a new spot after the deletion.") + + (SETQ OSEL (fetch (TEXTOBJ DELETESEL) of TEXTOBJ)) + (SETQ SELOPERATION 'DELETE) + (TEDIT.SET.SEL.LOOKS OSEL 'DELETE) + (replace (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ with NIL)) + (T (SETQ OSEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (replace (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ with NIL) + (* ; "Reset the pending-delete flag.") + )) + (\COPYSEL OSEL GLOBALSEL) + (bind (OSELOP _ SELOPERATION) + while [OR (SHIFTDOWNP 'SHIFT) + (SHIFTDOWNP 'CTRL) + (SHIFTDOWNP 'META) + (KEYDOWNP 'MOVE) + (KEYDOWNP 'COPY) + (NOT (ZEROP (LOGAND LASTMOUSEBUTTONS 7] + do (* ; + "Poll the selection & display its current state") + [COND + ((ZEROP (LOGAND LASTMOUSEBUTTONS 7)) + (* ; + "No mouse buttons are down; don't try anything.") + (SETQ OLDX -32000) (* ; + "However, remember that pushing a mouse button is a change of status that we should notice.") + ) + ((KEYDOWNP 'MOVE) (* ; + "the MOVE key is down; mark this selection for MOVE.") + (SETQ SELOPERATION 'MOVE)) + [(OR (SHIFTDOWNP 'SHIFT) + (KEYDOWNP 'COPY)) (* ; + "the SHIFT key is down; mark this selection for COPY or MOVE.") + (COND + ((SHIFTDOWNP 'CTRL) (* ; + "He's holding down both ctrl and shift -- do a move.") + (SETQ SELOPERATION 'MOVE)) + (T (* ; + "Just the SHIFT key. It's a COPY") + (SETQ SELOPERATION 'COPY] + ((SHIFTDOWNP 'META) (* ; + "He's holding the meta key down; note the fact.") + (SETQ SELOPERATION 'COPYLOOKS)) + ((SHIFTDOWNP 'CTRL) (* ; + "He's holding only the CTRL key -- mark the selection for deletion.") + (SETQ SELOPERATION 'DELETE)) + (T (* ; + "No key being held down; revert to normal selection.") + (SETQ SELOPERATION 'NORMAL] + (COND + [(AND (OR [NOT (IEQP OLDX (SETQ X (LASTMOUSEX DS] + [NOT (IEQP OLDY (SETQ Y (LASTMOUSEY DS] + (NEQ OSELOP SELOPERATION)) + (INSIDEP CLIPREGION X Y)) + + (* ;; "Only do selection if (1) the mouse is inside the window proper and (2) the mouse has moved, or the kind of selection has changed") + + (* ;; "Must precede the scroll-region test, so that we don't try to scroll while the mouse is inside the main window, even if the scroll bar overlaps the window (at left edge of screen, say)") + + (SETQ OLDX X) + (SETQ OLDY Y) + [COND + ((\TEDIT.MOUSESTATE LEFT) (* ; + "Left button is character selection") + (SETQ SEL (TEDIT.SELECT X Y TEXTOBJ (fetch (TEXTOBJ + MOUSEREGION + ) + of TEXTOBJ) + NIL SELOPERATION W)) + (SETQ EXTENDFLG NIL)) + ((\TEDIT.MOUSESTATE MIDDLE) + (* ; "Middle button is word selection") + (SETQ SEL (TEDIT.SELECT X Y TEXTOBJ (fetch (TEXTOBJ + MOUSEREGION + ) + of TEXTOBJ) + T SELOPERATION W)) + (SETQ EXTENDFLG NIL)) + [(\TEDIT.MOUSESTATE RIGHT)(* ; "RIght button extends selections") + (COND + ((NEQ SELOPERATION OSELOP) + + (* ;; "Things changed since the last selection. Grab the prior selection info, so that the extension is taken from the selection NOW being made, rather than the last existing old-type selection.") + + (\COPYSEL OSEL GLOBALSEL))) + (COND + ((fetch (SELECTION SET) of GLOBALSEL) + (AND TEDIT.EXTEND.PENDING.DELETE (EQ SELOPERATION + 'NORMAL) + (SETQ SELOPERATION 'PENDINGDEL) + (replace (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ + with T)) (* ; + "If TeditBluePendingDelete flag is set, then simulate Laurel's blue-pending-delete feature.") + (SETQ SEL (TEDIT.EXTEND.SEL X Y GLOBALSEL TEXTOBJ + SELOPERATION W)) + (SETQ EXTENDFLG T] + (T (* ; + "The mouse buttons are up, leaving us with a pro-tem 'permanent' selection") + (\COPYSEL OSEL GLOBALSEL) + (* ; + "And SEL is NOT SET ANY LONGER, so it won't get copied into OSEL down below") + (AND SEL (replace (SELECTION SET) of SEL with + NIL] + [COND + ((AND SEL (fetch (SELECTION SET) of SEL) + SELFN) (* ; + "The selection was set, but there's a SELFN that has veto authority") + (COND + ((EQ (APPLY* SELFN TEXTOBJ SEL SELOPERATION 'TENTATIVE) + 'DON'T) (* ; + "The selfn vetoed this selection, so mark it un-set.") + (replace (SELECTION SET) of SEL with NIL] + (COND + ((\TEDIT.SEL.CHANGED? SEL OSEL OSELOP SELOPERATION) + (* ; + "Something interesting about the selection changed. We have to re-display its image.") + (COND + ((OR (EQ SELOPERATION 'NORMAL) + (EQ SELOPERATION 'PENDINGDEL)) + (* ; + "For a normal selection, set the 'window last selected in' for the TEXTOBJ") + (replace (TEXTOBJ SELWINDOW) of TEXTOBJ with + W))) + (SETQ OSEL (\TEDIT.REFRESH.SHOWSEL TEXTOBJ SEL OSEL OSELOP + SELOPERATION EXTENDFLG)) + (SETQ OSELOP SELOPERATION)) + ([AND OSEL (fetch (SELECTION SET) of OSEL) + (EQ (fetch (SELECTION SELKIND) of OSEL) + 'VOLATILE) + (OR (NOT SEL) + (NOT (fetch (SELECTION SET) of SEL] + + (* ;; "There is an old selection around, but it is VOLATILE -- i.e., it shouldn't last longer than something is pointing at it. Turn it off.") + + (\SHOWSEL OSEL NIL NIL) + (replace (SELECTION SET) of OSEL with NIL] + ((IN/SCROLL/BAR? W LASTMOUSEX LASTMOUSEY) + (* ; + "If he moves to the scroll bar, let him scroll without trouble") + (SCROLL.HANDLER W))) + (BLOCK) (* ; "Give other processes a chance") + (GETMOUSESTATE) (* ; "And get the new mouse info") + (TEDIT.CURSORMOVEDFN W)) + (\COPYSEL OSEL GLOBALSEL) + (COND + ((fetch (SELECTION SET) of OSEL) + (* ; + "Only if a selection REALLY got made should we do this....") + (SELECTQ SELOPERATION + (COPY (* ; + "A COPY selection -- set the copy flag, and see if this is a copy to a non-TEdit window") + (SETQ TEDIT.COPY.PENDING T) + (replace (SELECTION SET) of OSEL with NIL) + (* ; + "And turn off OSEL, to avoid spurious highlighting") + (\TEDIT.FOREIGN.COPY? GLOBALSEL) + (* ; + "Maybe copy into the SYSBUF, if the recipient isn't a TEdit window.") + ) + (COPYLOOKS (* ; "A COPYLOOKS selection") + (SETQ TEDIT.COPYLOOKS.PENDING T) + (* ; + "And turn off OSEL, to avoid spurious highlighting") + (replace (SELECTION SET) of OSEL with NIL)) + (MOVE (* ; + "A MOVE selection -- set the flag to signal the TEdit command loop,") + (SETQ TEDIT.MOVE.PENDING T) (* ; + "And turn off OSEL, to avoid spurious highlighting") + (replace (SELECTION SET) of OSEL with NIL)) + (DELETE (SETQ TEDIT.DEL.PENDING T) + (replace (SELECTION SET) of OSEL with NIL) + (* ; + "And turn off OSEL, to avoid spurious highlighting") + ) + (NORMAL (* ; + "This is a normal selection; set the caret looks") + (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ + with (\TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ OSEL))) + NIL))) + (AND SELFN (APPLY* SELFN TEXTOBJ GLOBALSEL SELOPERATION 'FINAL)) + (* ; + "Give a user exit routine control, perhaps for logging of selections.") + (for CARET inside (fetch (TEXTOBJ CARET) of TEXTOBJ) + do (OR (fetch TCUP of CARET) + (\EDIT.FLIPCARET CARET T)))) + (AND OSEL (fetch (SELECTION SET) of OSEL) + (fetch (SELECTION SELOBJ) of OSEL) + (SETQ SELFINALFN (IMAGEOBJPROP (fetch (SELECTION SELOBJ) of OSEL) + 'WHENOPERATEDONFN)) + (APPLY* SELFINALFN (fetch (SELECTION SELOBJ) of OSEL) + (WINDOWPROP W 'DSP) + 'SELECTED OSEL (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ]) (\TEDIT.WINDOW.OPS + [LAMBDA (TEXTOBJ WINDOWTOSPLIT) (* ; "Edited 30-May-91 23:33 by jds") + +(* ;;; "Do window operations for TEdit, e.g., splitting a window, moving the split location, or unsplitting.") + + (PROG ([WINDOWOPREGION (create REGION + LEFT _ (DIFFERENCE (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) + 8) + BOTTOM _ 0 + WIDTH _ 8 + HEIGHT _ (fetch HEIGHT of (WINDOWPROP WINDOWTOSPLIT + 'REGION] + Y OPERATION) + [while [AND (MOUSESTATE (OR LEFT MIDDLE RIGHT)) + (INSIDE? WINDOWOPREGION (LASTMOUSEX WINDOWTOSPLIT) + (SETQ Y (LASTMOUSEY WINDOWTOSPLIT] do + + (* ;; + "Wait until he lets up on a button, and signal which button was last pushed.") + + (BLOCK) + (COND + ((MOUSESTATE MIDDLE) + (CURSOR + \TEDIT.MAKESPLITCURSOR + ) + (SETQ OPERATION + 'SPLIT)) + ((MOUSESTATE LEFT) + (CURSOR + \TEDIT.MOVESPLITCURSOR + ) + (SETQ OPERATION + 'MOVE)) + ((MOUSESTATE RIGHT) + (CURSOR + \TEDIT.UNSPLITCURSOR + ) + (SETQ OPERATION + 'UNSPLIT] + (COND + ((INSIDE? WINDOWOPREGION (LASTMOUSEX WINDOWTOSPLIT) + (SETQ Y (LASTMOUSEY WINDOWTOSPLIT))) + (CURSOR \TEDIT.SPLITCURSOR) + (SELECTQ OPERATION + (SPLIT (* ; "Splitting the window") + (\TEDIT.SPLITW WINDOWTOSPLIT Y)) + (UNSPLIT (* ; "Rejoining two panes") + (\TEDIT.UNSPLITW WINDOWTOSPLIT)) + (MOVE (* ; + "Moving the divider between two panes.") + (TEDIT.PROMPTPRINT TEXTOBJ "Can't move the split point yet." T)) + (SHOULDNT))) + (T (CURSOR T]) (\TEDIT.EXPANDFN + [LAMBDA (W) (* jds " 7-May-85 15:56") + + (* steals back the tty for us when the TEdit window is expanded.) + + (COND + ((WINDOWPROP W 'PROCESS) + + (* There's a process to go with this edit window. + Give it the TTY.) + + (TTY.PROCESS (WINDOWPROP W 'PROCESS]) (\TEDIT.MAINW + [LAMBDA (TEXTSTREAM) (* ; "Edited 30-May-91 23:33 by jds") + + (* ;; "Get the MAIN edit window for this edit session (i.e., the one with the title, and all the props & stuff)") + + (LET ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) + WINDOWS WINDOW) + (SETQ WINDOWS (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ TEXTSTREAM))) + (COND + (WINDOWS (* ; + "This question only makes sense if there ARE windows for this editor.") + (SETQ WINDOW (COND + ((LISTP WINDOWS) (* ; + "how do we know we can just take the first window as the main one?") + (CAR WINDOWS)) + (T WINDOWS))) + (COND + ((AND (fetch (TEXTOBJ MENUFLG) of TEXTOBJ) + (WINDOWPROP WINDOW 'MAINWINDOW)) + + (* ;; "If this is a menu window, and it's attached to a main TEdit window, then look to the main TEdit window.") + + (WINDOWPROP WINDOW 'MAINWINDOW)) + (T WINDOW]) (\TEDIT.PRIMARYW + [LAMBDA (TEXTSTREAM) (* ; "Edited 30-May-91 23:33 by jds") + + (* Given an edit session with possibly several PANES on the same document, give + me the PRINCIPAL one of them--i.e., the original edit window that has all the + back pointers, props &c on it.) + + (PROG ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) + WINDOWS WINDOW) + (SETQ WINDOWS (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ TEXTSTREAM))) + (* The edit window + (s) associated with this edit + session) + (SETQ WINDOW (COND + ((LISTP WINDOWS) + + (* If there are several panes, the first one in the list is the original window) + + (CAR WINDOWS)) + (T (* If there's only the one window, + that's the guy.) + WINDOWS))) + (RETURN WINDOW]) (\TEDIT.COPYINSERTFN + [LAMBDA (INSERTIONS WW) (* ; "Edited 30-May-91 23:33 by jds") + + (* Given a string, an imageobj, or a list of any of them, insert it in the + tedit window WW.) + + (PROG [[TEXTSTREAM (TEXTSTREAM (WINDOWPROP WW 'MAINWINDOW] + (SEL (fetch (TEXTOBJ SEL) of (TEXTOBJ (WINDOWPROP WW 'MAINWINDOW] + (for INSERTION inside INSERTIONS do (COND + ((STRINGP INSERTION) + (TEDIT.INSERT TEXTSTREAM INSERTION SEL) + ) + ((IMAGEOBJP INSERTION) + (TEDIT.INSERT.OBJECT INSERTION + TEXTSTREAM SEL]) (\TEDIT.NEWREGIONFN + [LAMBDA (FIXEDPOINT MOVINGPOINT WINDOW) (* jds "24-FEB-83 17:43") + + (* This function is called whenever a new region for the window is needed. + It constrains the size of the window so that the menu and/or titles will fit) + + (COND + ((NULL MOVINGPOINT) + + (* This is true only the first time the function is called) + + FIXEDPOINT) + (T (PROG (%#OFMENUITEMS MENUWIDTH XDELTA YDELTA) + + (* The NEWREGIONFNARG can be either a window or a list consisting of the number + of items in the menu and the minimum width of the window neede to hold the menu + an titles) + + (SETQ XDELTA (IDIFFERENCE (fetch (POSITION XCOORD) of MOVINGPOINT) + (fetch (POSITION XCOORD) of FIXEDPOINT))) + (SETQ YDELTA (IDIFFERENCE (fetch (POSITION YCOORD) of MOVINGPOINT) + (fetch (POSITION YCOORD) of FIXEDPOINT))) + [COND + [(IGEQ XDELTA 0) + (replace (POSITION XCOORD) of MOVINGPOINT with (IPLUS (fetch (POSITION XCOORD) + of FIXEDPOINT) + (IMAX 32 XDELTA] + (T (replace (POSITION XCOORD) of MOVINGPOINT with (IPLUS (fetch (POSITION XCOORD) + of FIXEDPOINT) + (IMIN -32 XDELTA] + [COND + [(IGEQ YDELTA 0) + (replace (POSITION YCOORD) of MOVINGPOINT with (IPLUS (fetch (POSITION YCOORD) + of FIXEDPOINT) + (IMAX 32 YDELTA] + (T (replace (POSITION YCOORD) of MOVINGPOINT with (IPLUS (fetch (POSITION YCOORD) + of FIXEDPOINT) + (IMIN -32 YDELTA] + (RETURN MOVINGPOINT]) (\TEDIT.SET.WINDOW.EXTENT + [LAMBDA (TEXTOBJ WINDOWS) (* ; "Edited 30-May-91 23:33 by jds") + (* Set the window's EXTENT property + according to 1st and last char on + screen.) + (for WINDOW inside WINDOWS + do (PROG* ((REGION (DSPCLIPPINGREGION NIL WINDOW)) + (WHEIGHT (fetch HEIGHT of REGION)) + (LINES (WINDOWPROP WINDOW 'LINES)) + (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + TOPCHAR BOTCHAR PREVLINE EXTHEIGHT EXTBOT YBOT) + (COND + ((TEXTPROP TEXTOBJ 'NOEXTENT) (* If he doesn't want the extent + set, don't bother him.) + (RETURN))) + (OR WINDOW (RETURN)) (* Do nothing if there's no window + to do it in.) + (while (AND LINES (IGEQ (fetch (LINEDESCRIPTOR YBOT) of LINES) + WHEIGHT)) do + (* Run thru the lines looking for + the first one on the screen.) + (SETQ LINES (fetch ( + LINEDESCRIPTOR + NEXTLINE) + of LINES))) + (COND + (LINES + + (* IF there are lines on the screen, then get the CH# of the start of the first + line -- notionally, the CH at the top of the screen.) + + (SETQ TOPCHAR (fetch (LINEDESCRIPTOR CHAR1) of LINES))) + (T (* Otherwise, everything is scrolled + off the top, so we're at the end.) + (SETQ TOPCHAR TEXTLEN))) + (while (AND LINES (IGEQ (fetch (LINEDESCRIPTOR YBOT) of LINES) + (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ))) + do (* Then go looking for the last line + on the screen) + (SETQ PREVLINE LINES) + (SETQ LINES (fetch (LINEDESCRIPTOR NEXTLINE) of LINES))) + (COND + (PREVLINE + + (* There IS a last line on the screen. Grab its last character as the bottom + character on the screen, and set the lowest-Y position to the bottom of that + line) + + (SETQ BOTCHAR (IMIN TEXTLEN (fetch (LINEDESCRIPTOR CHARLIM) + of PREVLINE))) + (SETQ YBOT (fetch (LINEDESCRIPTOR YBOT) of PREVLINE))) + (T + + (* Everything is off the top of the screen. + Bottom character is also the last char in the document, and the lowest Y we + encountered is the top of the edit window.) + + (SETQ BOTCHAR TEXTLEN) + (SETQ YBOT WHEIGHT))) + [COND + ((AND (IEQP BOTCHAR TEXTLEN) + (IEQP TOPCHAR TEXTLEN)) (* If we're really at the bottom of + the document) + (SETQ EXTBOT (SUB1 YBOT)) (* Set up the extent bottom and + height fields to account for that.) + (SETQ EXTHEIGHT WHEIGHT)) + (T + + (* Otherwise, set the bottom in proportion to what is left below the bottom of + the screen, and the extent height in proportion to how much text appears in the + window) + + [SETQ EXTHEIGHT (FIXR (FQUOTIENT (ITIMES (IDIFFERENCE WHEIGHT YBOT) + TEXTLEN) + (IMAX (IDIFFERENCE BOTCHAR TOPCHAR) + 1] + (SETQ EXTBOT (IDIFFERENCE YBOT (FIXR (FQUOTIENT (ITIMES (IDIFFERENCE + WHEIGHT YBOT) + (IDIFFERENCE + TEXTLEN + BOTCHAR)) + (IMAX (IDIFFERENCE BOTCHAR + TOPCHAR) + 1] + (WINDOWPROP WINDOW 'EXTENT (create REGION + BOTTOM _ EXTBOT + HEIGHT _ (IMAX 1 EXTHEIGHT) + WIDTH _ (fetch WIDTH of REGION) + LEFT _ 0]) (\TEDIT.SHRINK.ICONCREATE + [LAMBDA (W ICON ICON-POSITION) (* ; "Edited 25-Apr-88 23:53 by jds") + (* ;; "Create the icon that represents this window.") + + [PROG [(ICON (WINDOWPROP W 'ICON)) + (ICONTITLE (WINDOWPROP W 'TEDIT.ICON.TITLE)) + (SHRINKFN (WINDOWPROP W 'SHRINKFN] + (COND + ((NOT (WINDOWPROP W 'TEXTOBJ)) (* ; + "This isn't really a TEdit window any more. Don't do anything") + NIL) + ((WINDOWPROP W 'TEDITMENU) (* ; + "This is a text menu, and shrinks without trace.") + NIL) + ((OR (IGREATERP (FLENGTH SHRINKFN) + 3) + (AND (NOT (FMEMB '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 'TEDIT.ICON.TITLE (SETQ ICONTITLE (TEXTSTREAM.TITLE (TEXTSTREAM + W] + (ICONTITLE ICONTITLE NIL NIL ICON)) + (T (* ; "install a new icon") + [WINDOWPROP W 'TEDIT.ICON.TITLE (SETQ ICONTITLE (TEXTSTREAM.TITLE (TEXTSTREAM + W] + (WINDOWPROP W 'ICON (TITLEDICONW TEDIT.TITLED.ICON.TEMPLATE ICONTITLE TEDIT.ICON.FONT + ICON-POSITION T NIL 'FILE] + (WINDOWPROP W 'ICON]) (\TEDIT.SHRINKFN + [LAMBDA (W ICON ICONW) (* jds "14-Dec-84 08:56") + (* hands off the tty to the exec + process) + (COND + ((AND (EQ (WINDOWPROP W 'PROCESS) + (TTY.PROCESS))) + (TTY.PROCESS T) + + (* per bvm, this means "Hand the TTY to some other process" %. + It tries EXEC first; if that's not found, it hands it to MOUSE.) + + ]) (\TEDIT.SPLITW + [LAMBDA (WINDOW Y) (* ; "Edited 30-May-91 23:38 by jds") + + (* ;; "SPLIT WINDOW W AT W-RELATIVE Y into 2 %"panes%" that can scroll independently.") + + (PROG* ((WREG (WINDOWPROP WINDOW 'REGION)) + (TEXTOBJ (WINDOWPROP WINDOW 'TEXTOBJ)) + (OLDWINDOWS (COPY (fetch (TEXTOBJ \WINDOW) of TEXTOBJ))) + (SUBWINDOW (WINDOWPROP WINDOW 'TEDIT-NEXT-PANE-DOWN)) + ATTACHEDWINDOWS NEWW OLDW OTITLE OLDCARET NEWCARET OLINES) + (SETQ Y (OR Y (LASTMOUSEY WINDOW))) (* ; "Get the Y-position where we're to make the split--it's either supplied or we use the mouse's Y position.") + (COND + (SUBWINDOW (* ; + "If there's already a pane below this one, detach it for the moment.") + (DETACHWINDOW SUBWINDOW))) + (SHAPEW WINDOW (create REGION using WREG BOTTOM _ (IPLUS (fetch BOTTOM + of WREG) + Y) + HEIGHT _ (IDIFFERENCE (fetch HEIGHT + of WREG) + Y))) + (* ; + "Reshape the original window to form the upper %"pane%".") + + (* ;; "Attach the new window, without disturbing the pre-existing attached windows") + + (SETQ ATTACHEDWINDOWS (WINDOWPROP WINDOW 'ATTACHEDWINDOWS NIL)) + (ATTACHWINDOW (SETQ NEWW (CREATEW (create REGION using WREG HEIGHT _ Y) + NIL NIL NIL)) + WINDOW + 'BOTTOM + 'JUSTIFY + 'MAIN) (* ; "and attach a lower %"pane%".") + [WINDOWPROP WINDOW 'ATTACHEDWINDOWS (APPEND ATTACHEDWINDOWS (WINDOWPROP WINDOW + 'ATTACHEDWINDOWS] + + (* ;; "[end of attached-window hackery to prevent disturbance]") + + (WINDOWPROP NEWW 'TEDITCREATED T) + (DSPFONT (fetch (CHARLOOKS CLFONT) of (fetch (TEXTOBJ CARETLOOKS) of + TEXTOBJ)) + NEWW) (* ; + "Set the font on the display stream to be the current one from CARETLOOKS") + (SETQ OLDW (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) + (SETQ OTITLE (\TEDIT.WINDOW.TITLE TEXTOBJ)) + (SETQ OLDCARET (fetch (TEXTOBJ CARET) of TEXTOBJ)) + (SETQ NEWCARET (create TEDITCARET + TCCARETDS _ (WINDOWPROP NEWW 'DSP) + TCFORCEUP _ T)) + [replace (TEXTOBJ CARET) of TEXTOBJ with (COND + ((LISTP OLDCARET) + (NCONC1 OLDCARET NEWCARET)) + (T (LIST OLDCARET NEWCARET] + (for SEL in (LIST (fetch (TEXTOBJ SEL) of TEXTOBJ) + (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ) + (fetch (TEXTOBJ MOVESEL) of TEXTOBJ) + (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) + (fetch (TEXTOBJ DELETESEL) of TEXTOBJ)) + do (replace (SELECTION L1) of SEL with (NCONC1 (fetch (SELECTION + L1) + of SEL) + NIL)) + (replace (SELECTION LN) of SEL with (NCONC1 (fetch (SELECTION + LN) + of SEL) + NIL))) + (SETQ OLINES (fetch (TEXTOBJ LINES) of TEXTOBJ)) + (\TEDIT.WINDOW.SETUP NEWW TEXTOBJ (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) + (APPEND '(NOTITLE T PROMPTWINDOW DON'T) + (fetch (TEXTOBJ EDITPROPS) of TEXTOBJ)) + WINDOW) + [for CARET in (fetch (TEXTOBJ CARET) of TEXTOBJ) as WINDOW + in (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + do (replace TCCARETDS of CARET with (WINDOWPROP WINDOW 'DSP] + (replace (TEXTOBJ WINDOWTITLE) of TEXTOBJ with OTITLE) + (WINDOWPROP NEWW 'PROCESS (WINDOWPROP WINDOW 'PROCESS)) + (WINDOWPROP WINDOW 'TEDIT-NEXT-PANE-DOWN NEWW) (* ; + "Tell the main window about its new lower pane.") + (COND + (SUBWINDOW (* ; + "There was already a pane below this one. Attach it to the new lower pane.") + (ATTACHWINDOW SUBWINDOW NEWW 'BOTTOM 'JUSTIFY 'MAIN) + (WINDOWPROP NEWW 'TEDIT-NEXT-PANE-DOWN SUBWINDOW) + (* ; + "Tell the lower pane about its lower, lower pane..") + ]) (\TEDIT.UNSPLITW + [LAMBDA (WINDOW Y) (* ; "Edited 30-May-91 23:34 by jds") + +(* ;;; "Re-attach two panes of a split editing window, to make a single larger pane.") + + (PROG* ([WREG (COPY (WINDOWPROP WINDOW 'REGION] + (TEXTOBJ (WINDOWPROP WINDOW 'TEXTOBJ)) + (WINDOWS (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) + (MAINW (WINDOWPROP WINDOW 'MAINWINDOW)) + (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + (MOVESEL (fetch (TEXTOBJ MOVESEL) of TEXTOBJ)) + (SHIFTEDSEL (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ)) + (DELETESEL (fetch (TEXTOBJ DELETESEL) of TEXTOBJ)) + (SUBWINDOW (WINDOWPROP WINDOW 'TEDIT-NEXT-PANE-DOWN)) + NEWW OLDW OTITLE ATTACHEDWINDOWS LINES CARETS) + (COND + ((NOT MAINW) + (TEDIT.PROMPTPRINT TEXTOBJ "Can't UNSPLIT the main window." T) + (RETURN))) + (\TEDIT.SHOWSELS TEXTOBJ NIL NIL) (* ; + "Turn off selections during the unsplit.") + (DETACHWINDOW WINDOW) (* ; "Detach the pane") + (COND + (SUBWINDOW (* ; "The pane that's going away had a yet lower pane attached to it. Detach it from here, so we can reattach it to the unsplit part later.") + (DETACHWINDOW SUBWINDOW) + (WINDOWPROP WINDOW 'TEDIT-NEXT-PANE-DOWN NIL))) + (WINDOWPROP MAINW 'TEDIT-NEXT-PANE-DOWN NIL) + (for CARET in (SETQ CARETS (fetch (TEXTOBJ CARET) of TEXTOBJ)) + as LINE in (SETQ LINES (fetch (TEXTOBJ LINES) of TEXTOBJ)) as + OLDW + in WINDOWS when (EQ WINDOW OLDW) do + (* ; + "Remove the caret from our list, and the starting line") + (replace (TEXTOBJ CARET) + of TEXTOBJ + with (DREMOVE CARET CARETS)) + (replace (TEXTOBJ LINES) + of TEXTOBJ + with (DREMOVE LINE LINES))) + (* ; "Close the pane") + (replace (TEXTOBJ SELWINDOW) of TEXTOBJ with MAINW) + (* ; + "Forget that we ever selected in the alternate window") + (replace (TEXTOBJ \WINDOW) of TEXTOBJ with (SETQ WINDOWS (DREMOVE WINDOW + WINDOWS))) + (* ; + "Have TEdit forget the window as well") + (replace (SELECTION L1) of SEL with (CDR (fetch (SELECTION L1) + of SEL))) + (replace (SELECTION LN) of SEL with (CDR (fetch (SELECTION LN) + of SEL))) + (replace (SELECTION L1) of SCRATCHSEL with (CDR (fetch (SELECTION L1) + of SCRATCHSEL))) + (replace (SELECTION LN) of SCRATCHSEL with (CDR (fetch (SELECTION LN) + of SCRATCHSEL))) + (for REMAININGWINDOW inside WINDOWS do + (* ; + "Run thru the remaining panes for this edit, fixing things up in the selections") + (\FIXSEL (fetch (TEXTOBJ SEL) + of TEXTOBJ) + TEXTOBJ REMAININGWINDOW)) + (TEDIT.DEACTIVATE.WINDOW WINDOW T T) (* ; + "Disable all the TEdit-related stuff on the window") + (CLOSEW WINDOW) + + (* ;; "Reshape the window, without affecting the placement of attached windows") + + (SETQ ATTACHEDWINDOWS (WINDOWPROP MAINW 'ATTACHEDWINDOWS NIL)) + [SHAPEW MAINW (UNIONREGIONS WREG (WINDOWPROP MAINW 'REGION] + (WINDOWPROP MAINW 'ATTACHEDWINDOWS ATTACHEDWINDOWS) + + (* ;; "[end of attached window hackery]") + + (COND + (SUBWINDOW (* ; "The pane that's going away had a yet lower pane attached to it. Detach it from here, so we can reattach it to the unsplit part later.") + (ATTACHWINDOW SUBWINDOW MAINW 'BOTTOM 'JUSTIFY 'MAIN) + (WINDOWPROP MAINW 'TEDIT-NEXT-PANE-DOWN SUBWINDOW))) + (\TEDIT.SHOWSELS TEXTOBJ NIL T]) (\TEDIT.WINDOW.SETUP [LAMBDA (WINDOW TEXTOBJ TEXTSTREAM PROPS AFTERWINDOW) (* ; "Edited 11-Jun-99 15:48 by rmk:") (* ; "Edited 11-Jun-99 15:44 by rmk:") (* ; "Edited 11-Jun-99 15:31 by rmk:") (* ; "Edited 30-May-91 23:34 by jds") (* ;; "Set up the window and TEXTOBJ so they correspond, and the window is a TEDIT window.") (PROG ((ICONFN (WINDOWPROP WINDOW 'ICONFN)) TEDITPROMPTWINDOW) (OR WINDOW (\ILLEGAL.ARG WINDOW)) (TEDIT.WINDOW.SETUP WINDOW TEXTOBJ TEXTSTREAM PROPS AFTERWINDOW) (* ;; "Do the general-purpose window setting up--the kind that every user will want.") (* ;; "Then do the stuff that a TEdit session needs as well.") (WINDOWADDPROP WINDOW 'RESHAPEFN (FUNCTION \TEDIT.RESHAPEFN)) (WINDOWADDPROP WINDOW 'NEWREGIONFN (FUNCTION \TEDIT.NEWREGIONFN)) (OR (WINDOWPROP WINDOW 'SCROLLFN) (WINDOWPROP WINDOW 'SCROLLFN (FUNCTION \TEDIT.SCROLLFN))) (WINDOWPROP WINDOW 'REPAINTFN (FUNCTION \TEDIT.REPAINTFN)) [OR (WINDOWPROP WINDOW 'TEDIT.TITLEMENUFN) (WINDOWPROP WINDOW 'TEDIT.TITLEMENUFN (OR (LISTGET PROPS 'TITLEMENUFN) (FUNCTION TEDIT.DEFAULT.MENUFN] (* ;  "Only put our menu function on the window if the originator didn't supply one.") (WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION TEDIT.DEACTIVATE.WINDOW) T) (* ;  "To clean up when the window is closed") (WINDOWPROP WINDOW 'WINDOWENTRYFN (FUNCTION \TEDIT.PROCIDLEFN)) (* ;  "For grabbing the TTY when the mouse clicks in the window") (OR ICONFN (WINDOWPROP WINDOW 'ICONFN (FUNCTION \TEDIT.SHRINK.ICONCREATE))) (* ;  "Only set up to create a shrink icon if nobody else has.") (WINDOWADDPROP WINDOW 'SHRINKFN (FUNCTION \TEDIT.SHRINKFN)) (* ;  "But always give up control of the keyboard on shrinking.") (WINDOWADDPROP WINDOW 'EXPANDFN (FUNCTION \TEDIT.EXPANDFN)) (* ; "And grab it back on expansion") (WINDOWPROP WINDOW 'TEDIT.CURSORREGION (LIST 0 0 0 0)) [WINDOWPROP WINDOW 'HARDCOPYFILEFN (FUNCTION (LAMBDA (W EXT) (LET [(STRM (FETCH (TEXTOBJ TXTFILE) OF (SETQ W (TEXTOBJ W] (CL:WHEN STRM (PACKFILENAME 'VERSION NIL 'EXTENSION (OR EXT 'IMAGEFILE) 'BODY (FULLNAME STRM)))] (* ; "Used by CursorMovedFn") (COND ((NOT AFTERWINDOW) (* ;  "Only set the window's title if we aren't splitting windows.") (\TEDIT.WINDOW.TITLE TEXTOBJ (\TEDIT.ORIGINAL.WINDOW.TITLE WINDOW (fetch (TEXTOBJ \DIRTY) of TEXTOBJ))) (COND ((EQ 'DON'T (LISTGET PROPS 'PROMPTWINDOW)) (* ;  "He said not to provide a feedback region, so don't.") ) ((AND (NOT (LISTGET PROPS 'READONLY)) [NOT (replace (TEXTOBJ PROMPTWINDOW) of TEXTOBJ with (LISTGET PROPS 'PROMPTWINDOW] (NOT (fetch (TEXTOBJ MENUFLG) of TEXTOBJ))) (* ;  "The window is read-write, so give it a feedback region") (SETQ TEDITPROMPTWINDOW (GETPROMPTWINDOW WINDOW (OR (LISTGET PROPS 'PROMPTWINDOWHEIGHT) TEDIT.PROMPTWINDOW.HEIGHT 1) TEDIT.PROMPT.FONT)) (replace (TEXTOBJ PROMPTWINDOW) of TEXTOBJ with TEDITPROMPTWINDOW) (WINDOWPROP TEDITPROMPTWINDOW 'TEDIT.PROMPTWINDOW T) (* ;  "And remember that this is a TEdit-supplied prompt window") (WINDOWPROP TEDITPROMPTWINDOW 'PAGEFULLFN (FUNCTION \TEDIT.PROMPT.PAGEFULLFN]) (\SAFE.FIRST + [LAMBDA (LIST.OR.ATOM) (* ; "Edited 26-Apr-91 13:00 by jds") + (* ; + "gives the first element whether the arg is a list or an atom. Should be a macro eventually") + (COND + ((LISTP LIST.OR.ATOM) + (CAR LIST.OR.ATOM)) + (T LIST.OR.ATOM]) ) (RPAQ BXCARET (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@CH@@CH@@FL@@FL@@LF@@ ) (QUOTE NIL) 3 4)) (RPAQ BXHICARET (CURSORCREATE (QUOTE #*(16 16)A@@@A@@@A@@@A@@@A@@@A@@@A@@@A@@@CH@@GL@@FL@@LF@@HB@@@@@@@@@@@@@@ ) (QUOTE NIL) 4 7)) (RPAQ TEDIT.LINECURSOR (CURSORCREATE (QUOTE #*(16 16)@@@A@@@C@@@G@@@O@@AO@@CO@@GO@@@O@@AK@@AI@@C@@@C@@@F@@@F@@@L@@@L@ ) (QUOTE NIL) 15 15)) (RPAQ \TEDIT.SPLITCURSOR (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OO@@HA@@HA@@HA@@HA@@HA@@HA@@OO@@ ) (QUOTE NIL) 4 4)) (RPAQ \TEDIT.MOVESPLITCURSOR (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OO@@HA@@HA@@OO@@OO@@HA@@HA@@OO@@ ) (QUOTE NIL) 4 4)) (RPAQ \TEDIT.UNSPLITCURSOR (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OO@@HA@@JE@@II@@II@@JE@@HA@@OO@@ ) (QUOTE NIL) 4 4)) (RPAQ \TEDIT.MAKESPLITCURSOR (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OO@@HA@@HA@@MK@@MK@@HA@@HA@@OO@@ ) (QUOTE NIL) 4 4)) (RPAQ? TEDIT.DEFAULT.WINDOW NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.DEFAULT.WINDOW) ) (* ; "User-level %"is this a TEdit window?%" function.") (DEFINEQ (TEDITWINDOWP + [LAMBDA (WINDOW) (* ; "Edited 16-Jan-89 10:28 by jds") + + (* ;; "Returns non-NIL if WINDOW is a legal TEdit window: I.e., if it has a TEXTOBJ property, and the TEXTOBJ thinks this is its window.") + + (COND + ((WINDOWP WINDOW)) + ((DISPLAYSTREAMP WINDOW) + (SETQ WINDOW (WFROMDS WINDOW))) + (T (SETQ WINDOW NIL))) + (LET* [(CHECKED-WINDOW (COND + ((WINDOWP WINDOW) + WINDOW) + ((DISPLAYSTREAMP WINDOW) + (WFROMDS WINDOW)) + (T NIL))) + (TEXTOBJ (AND CHECKED-WINDOW (WINDOWPROP CHECKED-WINDOW 'TEXTOBJ] + (AND (type? TEXTOBJ TEXTOBJ) + (MEMBER CHECKED-WINDOW (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) + T]) ) (* ; "User-typein support") (DEFINEQ (TEDIT.GETINPUT + [LAMBDA (STREAM PROMPTSTRING DEFAULTSTRING DELIMITER.LIST) + (* ; "Edited 30-May-91 23:34 by jds") + + (* ;; "Ask for input (file names, &c) for TEdit, perhaps with a default.") + + (PROG* ((TEXTOBJ (TEXTOBJ STREAM)) + (TPROMPT (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ))) + (SETQ TPROMPT (SELECTQ TPROMPT + (DON'T [COND + ((TEXTPROP TEXTOBJ 'PWINDOW.ON.DEMAND) + (GETPROMPTWINDOW (\TEDIT.MAINW STREAM]) + (NIL [GETPROMPTWINDOW (\TEDIT.MAINW STREAM) + NIL NIL (NOT (TEXTPROP TEXTOBJ 'PWINDOW.ON.DEMAND]) + TPROMPT)) + (COND + (TPROMPT (* ; + "If it's our own promptwindow, just clear it.") + (CLEARW TPROMPT)) + (T (* ; + "If it's the system's window, just move to a new line.") + (FRESHLINE PROMPTWINDOW))) + (RETURN (PROG1 (PROMPTFORWORD PROMPTSTRING DEFAULTSTRING NIL (OR TPROMPT PROMPTWINDOW) + NIL + 'TTY + (OR DELIMITER.LIST (CHARCODE (EOL LF TAB ESCAPE))) + NIL) (* ; + "Get what the guy wants to tell us") + (WINDOWPROP (OR TPROMPT PROMPTWINDOW) + 'PROCESS NIL) (* ; + "Now detach the prompt window from its process, to avoid a circularity.") + )]) (\TEDIT.MAKEFILENAME + [LAMBDA (STRING) (* jds " 8-Feb-85 11:25") + + (* Takes a string, removes leading and trailing spaces, and converts it to an + ATOM.) + + (PROG ((FIRSTNONSPACE (STRPOSL '(% ) STRING NIL T)) + (LASTNONSPACE (STRPOSL '(% ) STRING NIL T T))) + (COND + ((AND FIRSTNONSPACE LASTNONSPACE) + (RETURN (MKATOM (SUBSTRING STRING FIRSTNONSPACE LASTNONSPACE]) ) (* ; "Attached Prompt window support.") (DEFINEQ (TEDIT.PROMPTPRINT + [LAMBDA (TEXTSTREAM MSG CLEAR?) (* ; + "Edited 4-Jun-93 12:04 by sybalsky:mv:envos") + + (* ;; "Print a message in the editor's prompt window (if none, use the global promptwindow). Optionally clear the window first.") + + (PROG (WINDOW PWINDOW (TEXTOBJ (AND TEXTSTREAM (TEXTOBJ TEXTSTREAM))) + MAINTEXTOBJ) + (COND + [(AND TEXTOBJ (fetch (TEXTOBJ MENUFLG) of TEXTOBJ)) + (* ; + "There is a known textobj, and it's a menu. Go use the main editor's promptwindow.") + (SETQ MAINTEXTOBJ (WINDOWPROP (\TEDIT.MAINW TEXTOBJ) + 'TEXTOBJ)) (* ; + "Find the TEXTOBJ for the main edit window, and use ITS prompting window.") + (SETQ WINDOW (AND MAINTEXTOBJ (fetch (TEXTOBJ PROMPTWINDOW) of MAINTEXTOBJ] + (TEXTOBJ (SETQ WINDOW (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ)) + (* ; + "There IS an editor window to get to; use its prompt window") + )) + [SETQ WINDOW (CAR (NLSETQ (SELECTQ WINDOW + (DON'T [COND + ((TEXTPROP TEXTOBJ 'PWINDOW.ON.DEMAND) + (GETPROMPTWINDOW (\TEDIT.MAINW STREAM]) + (NIL [AND TEXTSTREAM (GETPROMPTWINDOW + (\TEDIT.MAINW TEXTSTREAM) + NIL NIL (NOT (TEXTPROP TEXTOBJ + 'PWINDOW.ON.DEMAND]) + WINDOW] (* ; + "Try to find an editor's prompt window for our message") + (COND + (WINDOW (* ; + "We found a window to use. Print the message.") + + (* ;; "WAS (RESETLST (RESETSAVE (TTYDISPLAYSTREAM WINDOW)) (COND (CLEAR? (CLEARW WINDOW))) (PRIN1 MSG WINDOW))") + + (COND + ((AND CLEAR? (WINDOWP WINDOW)) + (CLEARW WINDOW))) + (PRIN1 MSG WINDOW)) + (T (* ; + "Failing all else, use PROMPTWINDOW.") + (FRESHLINE PROMPTWINDOW) + (printout PROMPTWINDOW MSG]) (TEDIT.PROMPTFLASH + [LAMBDA (TEXTSTREAM) (* ; "Edited 30-May-91 23:34 by jds") + (* Flash the TEdit prompt window, or + the global promptwindow, if TEdit + has none.) + (PROG (WINDOW PWINDOW (TEXTOBJ (TEXTOBJ TEXTSTREAM)) + MAINTEXTOBJ) + (COND + [(AND TEXTOBJ (fetch (TEXTOBJ MENUFLG) of TEXTOBJ)) + + (* There is a known textobj, and it's a menu. + Go use the main editor's promptwindow.) + + (SETQ MAINTEXTOBJ (WINDOWPROP (\TEDIT.MAINW TEXTOBJ) + 'TEXTOBJ)) (* Find the TEXTOBJ for the main + edit window, and use ITS prompting + window.) + (SETQ WINDOW (AND MAINTEXTOBJ (fetch (TEXTOBJ PROMPTWINDOW) of MAINTEXTOBJ] + ((AND TEXTOBJ (SETQ WINDOW (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ))) + (* There IS an editor window to get + to; use its prompt window) + ) + ((SETQ WINDOW (GETPROMPTWINDOW (\TEDIT.MAINW TEXTSTREAM) + NIL NIL T)) (* Failing that, try any prompt + window attached to the edit window.) + )) (* Try to find an editor's prompt + window for our message) + (FLASHWINDOW (OR WINDOW PROMPTWINDOW) + 2]) (\TEDIT.PROMPT.PAGEFULLFN + [LAMBDA (PROMPT-DISPLAY-STREAM) (* ; "Edited 18-Nov-87 14:44 by jds") + + (* ;; "Given a TEdit promptwindow, expand it to be a line taller--called when a message overflows the window.") + + (LET* [(PROMPT-WINDOW (WFROMDS PROMPT-DISPLAY-STREAM)) + (%#LINES (ADD1 (OR (WINDOWPROP PROMPT-WINDOW 'TEDIT.NLINES) + 1))) + (OLDREGION (WINDOWPROP PROMPT-WINDOW 'REGION)) + (OLDTOP (fetch (REGION TOP) of OLDREGION)) + (OLDBOTTOM (fetch (REGION BOTTOM) of OLDREGION)) + (MAINWINDOW (WINDOWPROP PROMPT-WINDOW 'MAINWINDOW)) + (ATTACHEDMENUS (REMOVE PROMPT-WINDOW (ATTACHEDWINDOWS MAINWINDOW] + (GETPROMPTWINDOW MAINWINDOW %#LINES) (* ; "Get the new window") + + (SETQ \CURRENTDISPLAYLINE (CL:1- %#LINES)) (* ; "Set this so the page-full code will fire again at the end of THIS line, rather than waiting for another screen-ful. There ought to be an interface to this.") + + [SETQ NEWTOP (fetch (REGION TOP) of (WINDOWPROP PROMPT-WINDOW 'REGION] + [for WINDOW in (REVERSE ATTACHEDMENUS) + when (>= (fetch (REGION BOTTOM) of (WINDOWPROP WINDOW 'REGION)) + OLDBOTTOM) do (RELMOVEW WINDOW (CREATEPOSITION 0 (IDIFFERENCE NEWTOP + OLDTOP] + (WINDOWPROP PROMPT-WINDOW 'TEDIT.NLINES %#LINES]) ) (RPAQ? TEDIT.PROMPT.FONT (FONTCREATE 'GACHA 10)) (RPAQ? TEDIT.PROMPTWINDOW.HEIGHT NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.PROMPT.FONT TEDIT.PROMPTWINDOW.HEIGHT) ) (* ; "Title creation and update") (DEFINEQ (TEXTSTREAM.TITLE + [LAMBDA (STREAM) (* ; "Edited 30-May-91 23:34 by jds") + + (* ;; "returns a string with which you can talk to the user about this stream") + + (PROG ((TEXTOBJ (TEXTOBJ STREAM)) + TXTFILE) + (SETQ TXTFILE (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) + (RETURN (OR (CL:TYPECASE TXTFILE + (STRINGP TXTFILE) + (STREAM (fetch FULLNAME of TXTFILE)) + (LITATOM TXTFILE) + (T TXTFILE)) + ""]) (\TEDIT.ORIGINAL.WINDOW.TITLE + [LAMBDA (FILE DIRTY?) (* ; "Edited 26-Apr-91 13:05 by jds") + + (* ;; "Given a file name, derive a title for the TEdit window that is editing it.") + + (PROG (TITLE) + (RETURN (COND + ((NULL FILE) (* ; + "Just calling (TEDIT) should give a 'Text Editor Window'") + (CONCAT (COND + (DIRTY? "* ") + (T "")) + "Text Editor Window")) + ((AND (STRINGP FILE) + (ZEROP (NCHARS FILE))) (* ; + "So should editing an empty string") + (CONCAT (COND + (DIRTY? "* ") + (T "")) + "Text Editor Window")) + ((WINDOWP FILE) + (COND + ((SETQ TITLE (WINDOWPROP FILE 'TITLE)) + (* ; + "if \TEDIT.WINDOW.SETUP has assigned a title, use it") + TITLE) + (T "Text Editor Window"))) + (T (* ; + "Strings use the string itself, otherwise grab the full file name.") + (CONCAT (COND + (DIRTY? "* ") + (T "")) + "Edit Window for: " + (CL:TYPECASE FILE + (STRINGP FILE) + (STREAM (fetch FULLNAME of FILE)) + (LITATOM FILE) + (T FILE))]) (\TEDIT.WINDOW.TITLE + [LAMBDA (TEXTSTREAM NEW.TITLE) (* jds "23-May-85 15:20") + (PROG ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) + W) + (RETURN (COND + ((AND (SETQ W (\TEDIT.PRIMARYW TEXTOBJ)) + (NOT (TEXTPROP TEXTOBJ 'NOTITLE)) + (TEXTPROP TEXTOBJ 'TEDITCREATEDWINDOW)) + + (* Only change the title if there IS a window, and he isn't suppressing title + changes.) + + (COND + (NEW.TITLE (WINDOWPROP W 'TITLE NEW.TITLE)) + (T (WINDOWPROP W 'TITLE]) (\TEXTSTREAM.FILENAME + [LAMBDA (TEXTSTREAM) (* ; "Edited 30-May-91 23:34 by jds") + + (* ;; "returns the name of the file associated with this stream if there is one. NIL otherwise. Version numbers suppressed") + + (PROG ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) + OFILE) + [COND + ((type? STREAM (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) + (SETQ OFILE (PACKFILENAME 'VERSION NIL 'BODY (fetch FULLFILENAME + (fetch (TEXTOBJ TXTFILE) + of TEXTOBJ] + (RETURN OFILE]) ) (* ; "Screen updating utilities") (DEFINEQ (TEDIT.DEACTIVATE.WINDOW + [LAMBDA (W FORCEFLG DISCONNECTONLYFLG) (* ; "Edited 30-May-91 23:34 by jds") + + (* ;; "Deactivate the various button fns for this window") + + (PROG [(TEXTOBJ (WINDOWPROP W 'TEXTOBJ] (* ; + "Can't be a call to TEXTOBJ, since window may NOT have a textobj on it.") + [COND + ((AND TEXTOBJ (fetch (TEXTOBJ EDITOPACTIVE) of TEXTOBJ)) + + (* ;; "If something is going on, DON'T CLOSE THE WINDOW") + + (TEDIT.PROMPTPRINT TEXTOBJ "Not closed; edit operation in progress" T) + (RETURN 'DON'T)) + ((AND TEXTOBJ (PROCESSP (WINDOWPROP W 'PROCESS)) + (NOT (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ)) + (NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)) + (NOT FORCEFLG)) (* ; + "This is an un-quit TEdit window. Try to QUIT out of TEdit.") + (COND + ((\TEDIT.QUIT W T)) + (T + (* ;; "Always return DON'T: If we didn't quit, we don't want to close the window; if we did quit, the window is closed already, and will be reopened to reclose it.") + + (RETURN 'DON'T] + (COND + ([AND TEXTOBJ (OR FORCEFLG (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ) + (NOT (PROCESSP (WINDOWPROP W 'PROCESS] + (* ; + "Only do this if it's a TEdit window, and has been QUIT out of.") + [COND + ((AND (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ) + (OPENWP (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ))) + (CLEARW (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ] + (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) + NIL NIL) (* ; + "Before the window is closed, make SURE that the caret is down, or the window will reappear.") + (COND + ((AND (\TEDIT.WINDOW.TITLE TEXTOBJ) + (OPENWP (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ)) + (OPENWP W) + (EQ W (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ))) + (NOT DISCONNECTONLYFLG)) + (\TEDIT.WINDOW.TITLE TEXTOBJ "Edit Window [Inactive]") + (* ; + "Reset the window's title to a known 'inactive' value") + )) + [COND + ((NOT DISCONNECTONLYFLG) + (for PANE in (REVERSE (CDR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ))) + do + + (* ;; "Run thru any split-off sub-panes, and reattach them, so we get a whole window back before the end of the world.") + + (\TEDIT.UNSPLITW PANE)) + (replace (TEXTOBJ \WINDOW) of TEXTOBJ with NIL) + (COND + ((type? STREAM (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) + (* ; + "Close the file that this window was open on.") + (COND + ((NOT (WINDOWPROP W 'TEDIT-CLOSING-FILE T)) + (CLOSEF? (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)) + (WINDOWPROP W 'TEDIT-CLOSING-FILE NIL] + (WINDOWPROP W 'TEXTOBJ NIL) (* ; + "Detach the edit data structures from the window") + (WINDOWPROP W 'TEXTSTREAM NIL) + (WINDOWPROP W 'LINES NIL) + (WINDOWPROP W 'THISLINE NIL) + (WINDOWPROP W 'PROCESS.EXITFN NIL) + (WINDOWPROP W 'PROCESS.IDLEFN NIL) + (WINDOWPROP W 'CURSOROUTFN NIL) + (WINDOWPROP W 'CURSORMOVEDFN NIL) + (WINDOWPROP W 'BUTTONEVENTFN 'TOTOPW) (* ; "And the button functions") + (WINDOWPROP W 'RIGHTBUTTONFN 'DOWINDOWCOM) + (WINDOWDELPROP W 'CLOSEFN 'TEDIT.DEACTIVATE.WINDOW) + (WINDOWPROP W 'SCROLLFN NIL) + (WINDOWDELPROP W 'RESHAPEFN '\EDITRESHAPEFN) + (AND (NOT DISCONNECTONLYFLG) + (WINDOWPROP W 'PROCESS) + (\TEDIT.INTERRUPT.SETUP (WINDOWPROP W 'PROCESS) + T)) (* ; + "Make sure any disarmed interrupts are restored.") + (for MENUW in (ATTACHEDWINDOWS W) when (AND (WINDOWPROP MENUW 'TEDITMENU) + (WINDOWPROP MENUW 'TEXTOBJ)) + do (* ; + "Detach all the TEDITMENU windows that belong to this window.") + (replace (TEXTOBJ EDITFINISHEDFLG) of (TEXTOBJ MENUW) with T) + (* ; "Mark it finished") + (WINDOWPROP MENUW 'TEDITMENU NIL) (* ; + "And mark it no longer a menu window") + (GIVE.TTY.PROCESS MENUW) (* ; + "Then give it a chance to kill itself off") + (DISMISS 300)) + (COND + ((NOT DISCONNECTONLYFLG) + (GIVE.TTY.PROCESS W) + (DISMISS 300))) + [replace (TEXTOBJ \WINDOW) of TEXTOBJ with (COND + ((LISTP (fetch + (TEXTOBJ \WINDOW) + of TEXTOBJ)) + (* ; + "It's a list; remove this window") + (DREMOVE W + (fetch + (TEXTOBJ \WINDOW) + of TEXTOBJ] + (* ; + "Disconnect the window from the edit data structures as well.") + ]) (\TEDIT.REPAINTFN + [LAMBDA (W) (* ; "Edited 30-May-91 23:34 by jds") + + (* Will eventually do the right thing w/r/t text margins. + For now, it's a place holder.) + + (PROG ((TEXTOBJ (WINDOWPROP W 'TEXTOBJ)) + (TEXTSTREAM (WINDOWPROP W 'TEXTSTREAM)) + (WREG (DSPCLIPPINGREGION NIL W)) + (CH# 0) + WHEIGHT FIRSTCH# LINES LINE WWIDTH) + (OR TEXTOBJ (RETURN)) (* If this window has no TEXTOBJ on + it yet, just leave.) + (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) + NIL NIL) (* Turn off the selection while we + make changes) + (SETQ WHEIGHT (fetch PTOP of WREG)) (* Old window height) + (OR (SETQ LINES (WINDOWPROP W 'LINES)) + (RETURN)) (* If no text has been displayed + yet, just leave) + (SETQ LINE LINES) + (while LINE do + + (* Now hunt for the first line that had been visible, so we can find the CH# + that has to appear at the top of the window.) + + (COND + ((ILESSP (fetch (LINEDESCRIPTOR YBOT) of LINE) + WHEIGHT) (* This line was visible) + (SETQ FIRSTCH# (fetch (LINEDESCRIPTOR CHAR1) of LINE)) + (* Note its first character %#) + (RETURN))) + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE))) + (COND + (LINE + + (* You can only do this if there IS text on the screen to start with.) + + (\DISPLAYLINE TEXTOBJ LINE W) (* Actually display it) + (\FILLWINDOW (fetch (LINEDESCRIPTOR YBOT) of LINE) + LINE TEXTOBJ NIL W) (* Fill out the window with more + lines, to fill or to EOF) + )) + (\FIXSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) + TEXTOBJ) (* Fix up the selection to account + for the line shuffling) + (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) + NIL T) (* And highlight it) + ]) (\TEDIT.RESHAPEFN + [LAMBDA (W BITS OLDREGION) (* ; "Edited 30-May-91 23:34 by jds") + + (* Will eventually do the right thing w/r/t text margins. + For now, it's a place holder.) + + (PROG ((TEXTOBJ (WINDOWPROP W 'TEXTOBJ)) + (TEXTSTREAM (WINDOWPROP W 'TEXTSTREAM)) + (NEWWHEIGHT (fetch HEIGHT of (DSPCLIPPINGREGION NIL W))) + (NEWWWIDTH (fetch WIDTH of (DSPCLIPPINGREGION NIL W))) + (NEWLEFT 0) + (NEWBOTTOM 0) + (CH# 0) + WHEIGHT FIRSTCH# LINES LINE WWIDTH) + (OR TEXTOBJ (RETURN)) (* If this window has no TEXTOBJ on + it yet, just leave.) + (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) + NIL NIL) (* Turn off the selection while we + make changes) + (SETQ WHEIGHT (fetch HEIGHT of OLDREGION)) (* Old window height) + (replace (TEXTOBJ WTOP) of TEXTOBJ with NEWWHEIGHT) + (* Save new height/width for later + use) + (replace (TEXTOBJ WRIGHT) of TEXTOBJ with NEWWWIDTH) + (replace (TEXTOBJ WBOTTOM) of TEXTOBJ with NEWBOTTOM) + (replace (TEXTOBJ WLEFT) of TEXTOBJ with NEWLEFT) + (OR (SETQ LINES (WINDOWPROP W 'LINES)) + (RETURN)) (* If no text has been displayed + yet, just leave) + (SETQ LINE LINES) + (while LINE do + + (* Now hunt for the first line that had been visible, so we can find the CH# + that has to appear at the top of the window.) + + (COND + ((ILESSP (fetch (LINEDESCRIPTOR YBOT) of LINE) + WHEIGHT) (* This line was visible) + (SETQ FIRSTCH# (fetch (LINEDESCRIPTOR CHAR1) of LINE)) + (* Note its first character %#) + (RETURN)) + (T (replace (LINEDESCRIPTOR YBOT) of LINE with + NEWWHEIGHT + ))) + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE))) + (AND FIRSTCH# (SETQ LINE (\TEDIT.FIND.FIRST.LINE TEXTOBJ NEWWHEIGHT FIRSTCH# W))) + (COND + (LINE + + (* You can only do this if there IS text on the screen to start with.) + + (COND + ((NEQ LINE LINES) + (replace (LINEDESCRIPTOR NEXTLINE) of LINES with LINE) + (replace (LINEDESCRIPTOR PREVLINE) of LINE with LINES))) + (* Forget the old chain of line + descriptors) + (replace (LINEDESCRIPTOR YBOT) of LINE with (IDIFFERENCE + NEWWHEIGHT + (fetch ( + LINEDESCRIPTOR + LHEIGHT) + of LINE))) + (* Fix the line to appear at the top + of the window) + (replace (LINEDESCRIPTOR YBASE) of LINE with + (IPLUS (fetch (LINEDESCRIPTOR + YBOT) + of LINE) + (fetch (LINEDESCRIPTOR + DESCENT) + of LINE))) + (\DISPLAYLINE TEXTOBJ LINE W) (* Actually display it) + (\FILLWINDOW (fetch (LINEDESCRIPTOR YBOT) of LINE) + LINE TEXTOBJ NIL W) (* Fill out the window with more + lines, to fill or to EOF) + )) + (\FIXSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) + TEXTOBJ) (* Fix up the selection to account + for the line shuffling) + (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) + NIL T) (* And highlight it) + ]) (\TEDIT.SCROLLFN + [LAMBDA (W DX DY) (* ; "Edited 31-May-91 13:32 by jds") + (* Handle scrolling of the edit + window) + (PROG* (WHEIGHT (TEXTOBJ (WINDOWPROP W 'TEXTOBJ)) + (PRIORCR 0) + SELWASON SHIFTEDSELWASON MOVESELWASON DELETESELWASON (WREG (DSPCLIPPINGREGION + NIL W)) + LINES TRUEY TRUEX WWIDTH SEL (PREVLINE NIL) + (PRESCROLLFN (TEXTPROP TEXTOBJ 'PRESCROLLFN)) + (POSTSCROLLFN (TEXTPROP TEXTOBJ 'POSTSCROLLFN)) + TEXTLEN THEIGHT TOPLINE RHEIGHT LOWESTY YBOT LINE CH# CHNO CH) + (COND + ((ZEROP (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) + (* Don't scroll a zero-length file) + (RETURN)) + ((fetch (TEXTOBJ EDITOPACTIVE) of TEXTOBJ) + (* Don't scroll while something + interesting is happening!) + (TEDIT.PROMPTPRINT TEXTOBJ "Edit operation in progress." T) + (RETURN))) (* Displaystream for the window) + (SETQ WHEIGHT (fetch HEIGHT of WREG)) (* Height of the window) + (SETQ LOWESTY WHEIGHT) (* Lowest Y of a line-bottom yet + seet) + (SETQ WWIDTH (fetch WIDTH of WREG)) (* Width of the window) + (SETQ LINES (WINDOWPROP W 'LINES)) (* List of formatted lines) + (AND PRESCROLLFN (DOUSERFNS PRESCROLLFN W)) (* If there's a pre-scroll fn, + execute it now.) + (COND + ((fetch (SELECTION SET) of (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))) + (* Turn off the selection during the + scroll.) + (SETQ SELWASON (fetch (SELECTION ONFLG) of SEL)) + (\SHOWSEL SEL NIL NIL))) + (SETQ SHIFTEDSELWASON (fetch (SELECTION ONFLG) of (fetch (TEXTOBJ SHIFTEDSEL) + of TEXTOBJ))) + (\SHOWSEL (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) + NIL NIL) + (SETQ MOVESELWASON (fetch (SELECTION ONFLG) of (fetch (TEXTOBJ MOVESEL) + of TEXTOBJ))) + (\SHOWSEL (fetch (TEXTOBJ MOVESEL) of TEXTOBJ) + NIL NIL) + (SETQ DELETESELWASON (fetch (SELECTION ONFLG) of (fetch (TEXTOBJ DELETESEL) + of TEXTOBJ))) + (\SHOWSEL (fetch (TEXTOBJ DELETESEL) of TEXTOBJ) + NIL NIL) + (COND + [(AND (FIXP DY) + (NOT (ZEROP DY))) (* Regular up/down scrolling) + (SETQ TRUEY (IDIFFERENCE WHEIGHT (IABS DY))) + (COND + [(ILESSP 0 DY) (* Scroll text up) + (SETQ LINE LINES) + (while (AND LINE (IGEQ (fetch (LINEDESCRIPTOR YBOT) of LINE) + WHEIGHT)) do (SETQ LINE (fetch (LINEDESCRIPTOR + NEXTLINE) + of LINE))) + (first [COND + ((AND LINE (ILESSP (fetch (LINEDESCRIPTOR YBOT) of LINE) + TRUEY)) (* Make sure we scroll up at least + one line.) + (replace (LINEDESCRIPTOR YBASE) of LINE + with (IPLUS (fetch (LINEDESCRIPTOR DESCENT) of + LINE) + (replace (LINEDESCRIPTOR YBOT) of LINE + with WHEIGHT))) + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE] + while LINE do (* Find the line whose top is to + move to the top of the window) + [COND + ((ILESSP (fetch (LINEDESCRIPTOR YBOT) of LINE) + TRUEY) + (RETURN)) + (T (replace (LINEDESCRIPTOR YBASE) of LINE + with (IPLUS (fetch (LINEDESCRIPTOR + DESCENT) + of LINE) + (replace (LINEDESCRIPTOR + YBOT) of LINE + with WHEIGHT] + (SETQ PREVLINE LINE) + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) + of LINE))) + [COND + (LINE (* There is a line to go to the top) + (SETQ RHEIGHT (IPLUS (fetch (LINEDESCRIPTOR YBASE) of LINE) + (fetch (LINEDESCRIPTOR ASCENT) of LINE))) + (* Find the Ypos of the top of the + line's image) + (BITBLT W 0 0 W 0 (IDIFFERENCE WHEIGHT RHEIGHT) + WWIDTH RHEIGHT 'INPUT 'REPLACE) + (BITBLT NIL 0 0 W 0 0 WWIDTH (IDIFFERENCE WHEIGHT RHEIGHT) + 'TEXTURE + 'REPLACE WHITESHADE) + [bind NL (PL _ PREVLINE) for I from 1 to 50 while + PL + do (* Let him keep 50 lines above what + he can see on the screen) + (SETQ PL (fetch (LINEDESCRIPTOR PREVLINE) of PL)) + finally (COND + ((AND PL (NEQ PL LINES)) + (* There were more than 50 lines + (and we aren't pointing at the root) + %, so lop the spare ones off.) + (SETQ NL (fetch (LINEDESCRIPTOR NEXTLINE) + of LINES)) + (UNINTERRUPTABLY + (replace (LINEDESCRIPTOR NEXTLINE) + of LINES with PL) + (replace (LINEDESCRIPTOR PREVLINE) + of PL with LINES)) + (bind NNL while (AND NL (NEQ NL PL)) + do (SETQ NNL NL) + (SETQ NL (fetch (LINEDESCRIPTOR NEXTLINE) + of NL)) + (replace (LINEDESCRIPTOR NEXTLINE) + of NNL with NIL] + (while (AND LINE (IGEQ (fetch (LINEDESCRIPTOR YBOT) of LINE) + (fetch BOTTOM of WREG))) + do (* Update the bottom and baseline) + (replace (LINEDESCRIPTOR YBOT) of LINE + with (IPLUS (fetch (LINEDESCRIPTOR YBOT) of + LINE) + (IDIFFERENCE WHEIGHT RHEIGHT))) + (replace (LINEDESCRIPTOR YBASE) of LINE + with (IPLUS (fetch (LINEDESCRIPTOR YBOT) of + LINE) + (fetch (LINEDESCRIPTOR DESCENT) + of LINE))) + (SETQ PREVLINE LINE) + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE] + (COND + ((AND LINE (IGEQ (fetch (LINEDESCRIPTOR YBOT) of LINE) + (fetch BOTTOM of WREG))) + (* Fill the rest of the window) + (\FILLWINDOW (fetch (LINEDESCRIPTOR YBOT) of LINE) + LINE TEXTOBJ NIL W)) + (PREVLINE (\FILLWINDOW (fetch (LINEDESCRIPTOR YBOT) of PREVLINE) + PREVLINE TEXTOBJ NIL W] + (T (* Scroll text down in window, + adding lines at top to fill.) + (SETQ PREVLINE (SETQ TOPLINE LINES)) (* Find the top line on the screen%:) + [while TOPLINE do + + (* Run thru the lines, until we hit the first one that is below the top of the + edit window) + + (COND + ((ILESSP (fetch (LINEDESCRIPTOR YBOT) + of TOPLINE) + WHEIGHT) + (RETURN)) + (T (SETQ PREVLINE TOPLINE) + (SETQ TOPLINE (fetch (LINEDESCRIPTOR NEXTLINE + ) of TOPLINE] + [COND + ((AND (EQ PREVLINE LINES) + (OR (NOT (fetch (LINEDESCRIPTOR NEXTLINE) of PREVLINE)) + (IGREATERP (fetch (LINEDESCRIPTOR CHAR1) + of (fetch (LINEDESCRIPTOR NEXTLINE) + of PREVLINE)) + 1))) (* There's nothing between us and + start of file that's formatted; + start by making some.) + (SETQ PREVLINE (\BACKFORMAT LINES TEXTOBJ WHEIGHT] + (SETQ THEIGHT 0) + + (* Accumulates the heights of the lines we've backed over. + When this exceeds the scrolling distance, we've found the line.) + + (bind (FIRSTTIME _ T) while (OR FIRSTTIME + (AND (ILESSP THEIGHT (IABS DY)) + (IGEQ (fetch (LINEDESCRIPTOR + CHAR1) + of PREVLINE) + 1))) + do + + (* Starting with PREVLINE, accumulate LHEIGHTs until we hit top of text or have + accumulated enough lines to fill the screen) + + (add THEIGHT (fetch (LINEDESCRIPTOR LHEIGHT) of PREVLINE)) + (SETQ PREVLINE (fetch (LINEDESCRIPTOR PREVLINE) of PREVLINE)) + [COND + ((OR (NOT PREVLINE) + (ILESSP (fetch (LINEDESCRIPTOR CHAR1) of PREVLINE) + 1)) (* We need to format some lines + above where we are -- + go do it.) + (SETQ PREVLINE (\BACKFORMAT LINES TEXTOBJ WHEIGHT] + (SETQ FIRSTTIME NIL)) + [COND + ([OR (EQ TOPLINE (fetch (LINEDESCRIPTOR NEXTLINE) of PREVLINE)) + (EQ TOPLINE (fetch (LINEDESCRIPTOR NEXTLINE) + of (fetch (LINEDESCRIPTOR NEXTLINE) of + PREVLINE + ] + + (* Always move at least one line backward. + So if we're about to move no lines, force a single line.) + + ) + ((ILESSP (IABS DY) + THEIGHT) (* BACK UP ONE LINE TO GET TO THE + ONE WHICH PUSHED US OVER TOP) + (SETQ PREVLINE (fetch (LINEDESCRIPTOR NEXTLINE) of PREVLINE)) + (SETQ THEIGHT (IDIFFERENCE THEIGHT (fetch (LINEDESCRIPTOR LHEIGHT) + of PREVLINE] + [COND + ((NEQ TOPLINE (fetch (LINEDESCRIPTOR NEXTLINE) of PREVLINE)) + (SETQ PREVLINE (fetch (LINEDESCRIPTOR NEXTLINE) of PREVLINE] + (* Move to the first line to be + formatted.-) + (BITBLT W 0 THEIGHT W 0 0 WWIDTH (IDIFFERENCE WHEIGHT THEIGHT) + 'INPUT + 'REPLACE) + (BITBLT NIL 0 0 W 0 (IDIFFERENCE WHEIGHT THEIGHT) + WWIDTH THEIGHT 'TEXTURE 'REPLACE WHITESHADE) + (bind (LINE _ TOPLINE) while LINE + do (COND + ((IGEQ (fetch (LINEDESCRIPTOR YBOT) of LINE) + (IPLUS (fetch BOTTOM of WREG) + THEIGHT)) (* This line will be on screen. + Adjust its YBOT/YBASE) + (replace (LINEDESCRIPTOR YBOT) of LINE + with (IDIFFERENCE (fetch (LINEDESCRIPTOR YBOT) + of LINE) + THEIGHT)) + (replace (LINEDESCRIPTOR YBASE) of LINE + with (IDIFFERENCE (fetch (LINEDESCRIPTOR YBASE) + of LINE) + THEIGHT)) + (SETQ LOWESTY (fetch (LINEDESCRIPTOR YBOT) of LINE))) + (T (replace (LINEDESCRIPTOR YBOT) of LINE + with (SUB1 (fetch BOTTOM of WREG))) + (replace (LINEDESCRIPTOR NEXTLINE) + of (fetch (LINEDESCRIPTOR PREVLINE) of LINE) + with NIL) + (SETQ LINE (fetch (LINEDESCRIPTOR PREVLINE) of LINE)) + (RETURN))) + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE)) + (* Clear anything below us)) + (BITBLT NIL 0 0 W 0 (fetch BOTTOM of WREG) + WWIDTH + (IDIFFERENCE LOWESTY (fetch BOTTOM of WREG)) + 'TEXTURE + 'REPLACE WHITESHADE) + (SETQ YBOT WHEIGHT) + (while (AND PREVLINE (NEQ PREVLINE TOPLINE)) + do + + (* Move down lines to be added, adjusting YBOT/YBASE and DISPALYLINE-ing them, + until the next line to do EQ TOPLINE) + + [replace (LINEDESCRIPTOR YBOT) of PREVLINE + with (COND + [(AND (fetch (LINEDESCRIPTOR PREVLINE) of + PREVLINE + ) + (IGREATERP (fetch (LINEDESCRIPTOR CHAR1) + of PREVLINE) + 0) + (fetch (FMTSPEC FMTBASETOBASE) + of (fetch (LINEDESCRIPTOR LFMTSPEC) + of PREVLINE))) + (SETQ YBOT (IDIFFERENCE + (IPLUS YBOT (fetch (LINEDESCRIPTOR + DESCENT) + of (fetch + (LINEDESCRIPTOR + PREVLINE) + of PREVLINE))) + (IPLUS (fetch (FMTSPEC FMTBASETOBASE) + of (fetch (LINEDESCRIPTOR + LFMTSPEC) + of PREVLINE)) + (fetch (LINEDESCRIPTOR DESCENT) + of PREVLINE] + (T (SETQ YBOT (IDIFFERENCE YBOT (fetch ( + LINEDESCRIPTOR + LHEIGHT) + of PREVLINE] + (replace (LINEDESCRIPTOR YBASE) of PREVLINE + with (IPLUS (fetch (LINEDESCRIPTOR YBOT) of PREVLINE) + (fetch (LINEDESCRIPTOR DESCENT) of PREVLINE) + )) + (\DISPLAYLINE TEXTOBJ PREVLINE W) + (SETQ PREVLINE (fetch (LINEDESCRIPTOR NEXTLINE) of PREVLINE] + ((FLOATP DY) (* Do a thumbing-type scroll) + (SETQ CH# (IMAX (IMIN (SUB1 TEXTLEN) + (FIXR (FTIMES TEXTLEN DY))) + 1)) + (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINES)) + [while (AND LINE (ILESSP (fetch (LINEDESCRIPTOR CHARLIM) of LINE) + CH#)) do (SETQ LINE (fetch (LINEDESCRIPTOR + NEXTLINE) + of LINE)) + finally (COND + ((AND LINE (IGREATERP (fetch (LINEDESCRIPTOR CHAR1) of + LINE) + CH#)) + (SETQ LINE NIL] (* find out if any line currently + formatted includes the target char) + (COND + ((AND LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE) + (IGEQ (fetch (LINEDESCRIPTOR CHAR1) of LINE) + 1)) + + (* If so, let's do this as a fast scroll, rather than a complete repaint of the + screen) + + [SETQ DY (COND + [(ILEQ WHEIGHT (fetch (LINEDESCRIPTOR YBOT) of LINE)) + (* this line is off the top of the + window) + (IMINUS (for (DESCENDLINE _ (fetch (LINEDESCRIPTOR NEXTLINE) + of LINE)) + by (fetch (LINEDESCRIPTOR NEXTLINE) of + DESCENDLINE + ) + while (AND DESCENDLINE (ILEQ WHEIGHT + (fetch ( + LINEDESCRIPTOR + YBOT) + of DESCENDLINE))) + sum + + (* sum the heights of all the lines in between the new top line and the present + top line) + + (fetch (LINEDESCRIPTOR LHEIGHT) of + DESCENDLINE + ] + (T (IDIFFERENCE (IDIFFERENCE WHEIGHT (fetch (LINEDESCRIPTOR YBOT) + of LINE)) + (fetch (LINEDESCRIPTOR LHEIGHT) of LINE] + (\TEDIT.SCROLLFN W 0 DY) + + (* recurse telling to normally scroll instead of thumb scroll so that the + screen is not blanked and reformatted unnecessarily) + + ) + (T [for LINE inside (fetch (SELECTION L1) of SEL) when LINE + do (replace (LINEDESCRIPTOR YBOT) of LINE + with (SUB1 (fetch BOTTOM of WREG] + (* Make sure it thinks the old + selection is off-screen for now) + [for LINE inside (fetch (SELECTION LN) of SEL) when LINE + do (replace (LINEDESCRIPTOR YBOT) of LINE + with (SUB1 (fetch BOTTOM of WREG] + (BITBLT NIL 0 0 W 0 (fetch BOTTOM of WREG) + WWIDTH + (IDIFFERENCE WHEIGHT (fetch BOTTOM of WREG)) + 'TEXTURE + 'REPLACE WHITESHADE) + (SETQ LINE (\TEDIT.FIND.FIRST.LINE TEXTOBJ WHEIGHT CH# W)) + (* Find the first line to go in the + window) + (replace (LINEDESCRIPTOR YBOT) of LINE with + (IDIFFERENCE WHEIGHT + (fetch (LINEDESCRIPTOR + LHEIGHT) + of LINE))) + (* Set it up as the top line.) + (replace (LINEDESCRIPTOR YBASE) of LINE + with (IPLUS (fetch (LINEDESCRIPTOR YBOT) of LINE) + (fetch (LINEDESCRIPTOR DESCENT) of LINE))) + (\DISPLAYLINE TEXTOBJ LINE W) + (\FILLWINDOW (fetch (LINEDESCRIPTOR YBOT) of LINE) + LINE TEXTOBJ NIL W))) (* And fill out the window from + there.) + )) + (AND POSTSCROLLFN (DOUSERFNS POSTSCROLLFN W)) (* For user subsystem cleanup) + [COND + ((fetch (SELECTION SET) of SEL) + (\FIXSEL SEL TEXTOBJ) + (AND SELWASON (\SHOWSEL SEL NIL T] + [COND + ((fetch (SELECTION SET) of (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ)) + (\FIXSEL (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) + TEXTOBJ) + (AND SHIFTEDSELWASON (\SHOWSEL (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) + NIL T] + [COND + ((fetch (SELECTION SET) of (fetch (TEXTOBJ MOVESEL) of TEXTOBJ)) + (\FIXSEL (fetch (TEXTOBJ MOVESEL) of TEXTOBJ) + TEXTOBJ) + (AND MOVESELWASON (\SHOWSEL (fetch (TEXTOBJ MOVESEL) of TEXTOBJ) + NIL T] + [COND + ((fetch (SELECTION SET) of (fetch (TEXTOBJ DELETESEL) of TEXTOBJ)) + (\FIXSEL (fetch (TEXTOBJ DELETESEL) of TEXTOBJ) + TEXTOBJ) + (AND DELETESELWASON (\SHOWSEL (fetch (TEXTOBJ DELETESEL) of TEXTOBJ) + NIL T] + (\TEDIT.SET.WINDOW.EXTENT TEXTOBJ W]) ) (* ; "Process-world interfaces") (DEFINEQ (\TEDIT.PROCIDLEFN + [LAMBDA (WINDOW) (* ; "Edited 30-May-91 23:35 by jds") + + (* TEDIT's PROC.IDLEFN for regaining control. + If the shift key is down, we're not trying to restart this window, just to copy + from it.) + + (GETMOUSESTATE) + (COND + [[AND (INSIDE? (DSPCLIPPINGREGION NIL WINDOW) + (LASTMOUSEX WINDOW) + (LASTMOUSEY WINDOW)) + [NOT (OR (SHIFTDOWNP 'SHIFT) + (SHIFTDOWNP 'META) + (KEYDOWNP 'MOVE) + (KEYDOWNP 'COPY] + (PROCESSP (WINDOWPROP WINDOW 'PROCESS] (* No SHIFT key down; + let's regain control.) + (TTY.PROCESS (WINDOWPROP WINDOW 'PROCESS)) + (COND + ((fetch (TEXTOBJ MENUFLG) of (WINDOWPROP (WHICHW) + 'TEXTOBJ)) + (* This is a MENU -- + always select.) + (\TEDIT.BUTTONEVENTFN WINDOW] + (T (* Otherwise, let him select.) + (\TEDIT.BUTTONEVENTFN WINDOW]) (\TEDIT.PROCENTRYFN + [LAMBDA (NEWPROCESS OLDPROCESS) (* jds "15-Feb-84 16:59") + + (* TEDIT's PROCESS.ENTRYFN, which disarms any dangerous interrupts within the + editing world) + + (\TEDIT.INTERRUPT.SETUP NEWPROCESS]) (\TEDIT.PROCEXITFN + [LAMBDA (THISP NEWP) (* jds " 5-Apr-84 10:40") + + (* Re-arm any interrupts that TEdit turned off, so the poor user has them + available in other parts of the system.) + + (AND (WINDOWPROP (PROCESSPROP THISP 'WINDOW) + 'TEXTOBJ) + (\TEDIT.INTERRUPT.SETUP THISP T]) ) (RPAQ? \CARETRATE 333) (* ; "Caret handler; stolen from CHAT.") (DEFINEQ (\EDIT.DOWNCARET + [LAMBDA (CARET) (* ; "Edited 13-Nov-87 08:25 by jds") + + (* ;; "Put the caret down -- i.e., MAKE IT VISIBLE -- as fast as possible") + + (LET* ((DS (fetch (TEDITCARET TCCARETDS) of CARET)) + (X (DSPXPOSITION NIL DS)) + (Y (DSPYPOSITION NIL DS))) + (replace (TEDITCARET TCCARETX) of CARET with X) + (replace (TEDITCARET TCCARETY) of CARET with Y) + (replace (TEDITCARET TCFORCEUP) of CARET with NIL) + (\CARET.FLASH? DS (fetch (TEDITCARET TCCARET) of CARET) + 10 NIL X Y]) (\EDIT.FLIPCARET + [LAMBDA (CARET FORCE) (* ; "Edited 30-Mar-87 16:50 by jds") + (* ; + "changes the caret from on to off or off to on.") + + (* ;; "(COND ((OR FORCE (fetch TCFORCEDDOWN of CARET) (AND (IGREATERP (CLOCK0 (fetch TCNOWTIME of CARET)) (fetch TCTHENTIME of CARET)) (NOT (fetch TCFORCEUP of CARET)))) (UNINTERRUPTABLY (* note the time of the next change.) (* must be done without creating boxes because happens during keyboard wait.) (\BOXIPLUS (CLOCK0 (fetch TCTHENTIME of CARET)) (fetch TCCARETRATE of CARET)) (* Set the time for the next caret transition) (replace TCUP of CARET with (NOT (fetch TCUP of CARET))) (* Invert the sense of the caret's UPness) (replace TCFORCEDDOWN of CARET with NIL) (* Turn off the force-down & Force-up flags) (replace TCFORCEUP of CARET with NIL) (PROG ((DS (fetch TCCARETDS of CARET)) (CURS (fetch TCCURSORBM of CARET))) (COND ((fetch TCUP of CARET)) (T (* We're putting the caret down -- set the new X,Y position) (replace TCCARETX of CARET with (DSPXPOSITION NIL DS)) (replace TCCARETY of CARET with (DSPYPOSITION NIL DS)))) (BITBLT (fetch (CURSOR CUIMAGE) of CURS) 0 0 DS (IDIFFERENCE (fetch TCCARETX of CARET) (fetch (CURSOR CUHOTSPOTX) of CURS)) (IDIFFERENCE (fetch TCCARETY of CARET) (fetch (CURSOR CUHOTSPOTY) of CURS)) CURSORWIDTH CURSORHEIGHT (QUOTE INPUT) (QUOTE INVERT))))))") + + NIL]) (TEDIT.FLASHCARET + [LAMBDA (CARETS) (* jds "16-Jul-85 12:35") + + (* Unless the caret is constrained to be INVISIBLE, give it a chance to flash.) + + (bind (FIRSTTIME _ T) for CARET inside CARETS + do (COND + ((NOT (fetch TCFORCEUP of CARET)) (* The caret need not stay invisible.) + (* (\EDIT.FLIPCARET CARET)) + (COND + (FIRSTTIME (SETQ FIRSTTIME NIL) + (\CARET.FLASH? (fetch TCCARETDS of CARET) + (fetch TCCARET of CARET) + NIL NIL (fetch TCCARETX of CARET) + (fetch TCCARETY of CARET))) + (T (\CARET.FLASH.AGAIN (fetch TCCARET of CARET) + (fetch TCCARETDS of CARET) + (fetch TCCARETX of CARET) + (fetch TCCARETY of CARET]) (\EDIT.UPCARET + [LAMBDA (CARET) (* ; "Edited 13-Nov-87 08:27 by jds") + + (* ;; "Take the caret up -- i.e., MAKE IT INVISIBLE -- and keep it up") + + (\CARET.DOWN (fetch (TEDITCARET TCCARETDS) of CARET)) + + (* ;; "The TCFORCEUP field is set so that the caret will stay off-screen:") + + (replace (TEDITCARET TCFORCEUP) of CARET with T]) (TEDIT.NORMALIZECARET + [LAMBDA (TEXTOBJ SEL) (* ; "Edited 30-May-91 23:35 by jds") + + (* ;; "Scroll the text window so that the caret is visible in it.") + + (SETQ TEXTOBJ (TEXTOBJ TEXTOBJ)) + (PROG* ((SEL (OR SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))) + [WINDOW (OR (fetch (TEXTOBJ SELWINDOW) of TEXTOBJ) + (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ] + (WREG (AND WINDOW (DSPCLIPPINGREGION NIL WINDOW))) + (WHEIGHT (AND WREG (fetch PTOP of WREG))) + (WBOTTOM (AND WREG (fetch BOTTOM of WREG))) + (SELWASON (fetch (SELECTION ONFLG) of SEL)) + CH# Y LINE) + (OR WINDOW (RETURN)) + (OR (fetch (SELECTION SET) of SEL) + (RETURN)) (* ; + "If there is no selection set, don't bother.") + (COND + (SELWASON (* ; + "The selection is hilited, so turn it off.") + (\SHOWSEL SEL NIL NIL))) + (for WW inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) as L1 + inside (fetch (SELECTION L1) of SEL) as LN + inside (fetch (SELECTION LN) of SEL) when (EQ WW WINDOW) + do + + (* ;; "Get to the line info for the SELWINDOW. (failing that, the main/only edit window) Use that info to decide where the caret is.") + + (SELECTQ (fetch (SELECTION POINT) of SEL) + (LEFT (* ; + "The caret is at the left end of the selection; hunt for the first selected character") + (SETQ CH# (fetch (SELECTION CH#) of SEL)) + (SETQ Y (OR (AND L1 (fetch (LINEDESCRIPTOR YBOT) of L1)) + (fetch (SELECTION Y0) of SEL)))) + (RIGHT (* ; + "The caret is at the right end of the selection; hunt for the last selected character") + (SETQ CH# (SUB1 (fetch (SELECTION CHLIM) of SEL))) + (SETQ Y (OR (AND LN (fetch (LINEDESCRIPTOR YBOT) of LN)) + (fetch (SELECTION YLIM) of SEL)))) + NIL)) + (COND + ((AND (OR (IGEQ Y WHEIGHT) + (ILESSP Y WBOTTOM)) + (NOT (fetch (TEXTOBJ TXTNEEDSUPDATE) of TEXTOBJ))) + (* ; + "The caret is off-screen. Scroll to get it on") + (for LINE inside (fetch (SELECTION L1) of SEL) when LINE + do (replace (LINEDESCRIPTOR YBOT) of LINE with (SUB1 WBOTTOM))) + (* ; + "Make sure it thinks the old selection is off-screen for now") + (for LINE inside (fetch (SELECTION LN) of SEL) when LINE + do (replace (LINEDESCRIPTOR YBOT) of LINE with (SUB1 WBOTTOM))) + (SETQ LINE (\TEDIT.FIND.FIRST.LINE TEXTOBJ WHEIGHT (IMAX 1 (IMIN CH# + (fetch + (TEXTOBJ TEXTLEN) + of TEXTOBJ))) + WINDOW)) (* ; + "Find the first line to go in the window") + (replace (LINEDESCRIPTOR YBOT) of LINE with (IDIFFERENCE + WHEIGHT + (fetch (LINEDESCRIPTOR + LHEIGHT) + of LINE))) + (* ; "Set it up as the top line.") + (replace (LINEDESCRIPTOR YBASE) of LINE with (IPLUS (fetch + (LINEDESCRIPTOR + YBOT) of LINE) + (fetch + (LINEDESCRIPTOR + DESCENT) + of LINE))) + (\DISPLAYLINE TEXTOBJ LINE WINDOW) + (\FILLWINDOW (fetch (LINEDESCRIPTOR YBOT) of LINE) + LINE TEXTOBJ NIL WINDOW) (* ; + "And fill out the window from there.") + (\FIXSEL SEL TEXTOBJ) + (\TEDIT.SET.WINDOW.EXTENT TEXTOBJ WINDOW))) + (COND + (SELWASON (* ; + "The selection is hilited, so turn it back on.") + (\SHOWSEL SEL NIL T]) (\SETCARET + [LAMBDA (X Y DS TEXTOBJ CARET) (* ; "Edited 30-May-91 23:35 by jds") + (PROG ((CLIPREGION (DSPCLIPPINGREGION NIL DS))) + (COND + [(AND (ILESSP Y (fetch PTOP of CLIPREGION)) + (IGEQ Y (fetch BOTTOM of CLIPREGION))) + (MOVETO X Y DS) + (COND + ((NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)) + (\EDIT.DOWNCARET CARET] + (T + + (* The caret is off screen. Do a MOVETO so the system carets don't appear at + odd times.) + + (MOVETO (IPLUS (fetch PTOP of CLIPREGION) + 12) + 0 DS))) (* Only put down the caret the line + it points to is on-screen) + ]) (\TEDIT.CARET + [LAMBDA (CARETS) (* jds "12-Jul-85 11:18") + + (* Reset the caret to its normal state state, from the selection caret) + + (for CARET inside CARETS do (replace TCCARET of CARET with (\CARET.CREATE BXCARET]) ) (* ; "Menu interfacing") (DEFINEQ (TEDIT.ADD.MENUITEM + [LAMBDA (MENU ITEM) (* jds " 9-AUG-83 09:55") + + (* Adds ITEM to the MENU, and updates all the stuff.) + + (PROG (OLDITM) + (COND + ((MEMBER ITEM (fetch ITEMS of MENU)) (* Do nothing--it's already in the + menu) + ) + ([AND (LISTP ITEM) + (SETQ OLDITM (SASSOC (CAR ITEM) + (fetch ITEMS of MENU] + + (* The menu item exists. Make sure the thing behind it is right.) + + (RPLACD OLDITM (CDR ITEM))) + (T + + (* It isn't in the menu, so go ahead and add it.) + + (replace ITEMS of MENU with (NCONC1 (fetch ITEMS of MENU) + ITEM)) + (COND + ((EQ (fetch MENUCOLUMNS of MENU) + 1) + + (* If there is only one column, force a re-figuring of the number of rows) + + (replace MENUROWS of MENU with NIL)) + ((EQ (fetch MENUROWS of MENU) + 1) (* There's only one row, so recompute + %# of columns.) + (replace MENUCOLUMNS of MENU with NIL))) + (replace ITEMWIDTH of MENU with 10000) + (replace ITEMHEIGHT of MENU with 10000) + (replace IMAGE of MENU with NIL) (* Force it to create a new menu + image.) + (UPDATE/MENU/IMAGE MENU]) (TEDIT.DEFAULT.MENUFN + [LAMBDA (W) (* ; "Edited 30-May-91 23:35 by jds") + + (* ;; + "Default MENU Fn for editor windows--displays a menu of items & acts on the commands received.") + + (PROG ((TEXTOBJ (WINDOWPROP W 'TEXTOBJ)) + (WMENU (WINDOWPROP W 'TEDIT.MENU)) + THISMENU CH OFILE OCURSOR PCTB LINES SEL ITEM) + (COND + ((EQ (fetch (TEXTOBJ EDITOPACTIVE) of TEXTOBJ) + T) + + (* ;; + "We're busy doing something, but not sure what. Give a general 'please wait' msg:") + + (TEDIT.PROMPTPRINT TEXTOBJ "Edit operation in progress; please wait." T) + (RETURN)) + ((fetch (TEXTOBJ EDITOPACTIVE) of TEXTOBJ) + + (* ;; "We know specifically what's happening. Tell him:") + + (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT (fetch (TEXTOBJ EDITOPACTIVE) of TEXTOBJ + ) + " in progress; please wait.") + T) + (RETURN))) + (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + (SETQ THISMENU (COND + (WMENU) + ((SETQ WMENU (WINDOWPROP W 'TEDIT.MENU.COMMANDS)) + (PROG1 (SETQ WMENU (\TEDIT.CREATEMENU WMENU)) + (WINDOWPROP W 'TEDIT.MENU WMENU))) + (TEDIT.DEFAULT.MENU))) + (SETQ ITEM (MENU THISMENU)) + (ERSETQ (RESETLST + [RESETSAVE (\TEDIT.MARKACTIVE TEXTOBJ) + '(AND (\TEDIT.MARKINACTIVE OLDVALUE] + (replace (TEXTOBJ EDITOPACTIVE) of TEXTOBJ with (OR (CAR ITEM) + T)) + (* ; + "So we ca ntell the guy WHAT op is active.") + [SELECTQ (CAR ITEM) + ((Put |Put Formatted Document|) + (TEDIT.PUT TEXTOBJ NIL NIL (TEXTPROP TEXTOBJ 'CLEARPUT))) + (Plain-Text (TEDIT.PUT TEXTOBJ NIL NIL T)) + (Old-Format (* ; + "Write out the file in the OLD TEdit format.") + (TEDIT.PUT TEXTOBJ NIL NIL NIL T)) + ((Get |Get Formatted Document|) (* ; + "Get a new file (overwriting the one being edited.)") + (TEDIT.GET TEXTOBJ NIL (TEXTPROP TEXTOBJ 'CLEARGET))) + (Unformatted% Get + (TEDIT.GET TEXTOBJ NIL T)) + (Include (* ; + "Insert a file where the caret is") + (TEDIT.INCLUDE TEXTOBJ)) + (Quit (* ; "Stop this session.") + (\TEDIT.QUIT W)) + (Substitute (* ; "Search-and-replace") + (RESETLST + (RESETSAVE (CURSOR WAITINGCURSOR)) + (TEDIT.SUBSTITUTE (fetch (TEXTOBJ STREAMHINT) + of TEXTOBJ)))) + (Find (* ; + "Case sensitive search, with * and # wildcards") + [SETQ OFILE (TEDIT.GETINPUT TEXTOBJ "Text to find: " + (WINDOWPROP W 'TEDIT.LAST.FIND.STRING) + (CHARCODE (EOL LF ESC] + [COND + (OFILE (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (\SHOWSEL SEL NIL NIL) + (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) + (SETQ CH (TEDIT.FIND TEXTOBJ (MKSTRING OFILE) + NIL NIL T)) + (COND + (CH (* ; "We found the target text.") + (TEDIT.PROMPTPRINT TEXTOBJ "Done.") + (replace (SELECTION CH#) of SEL + with (CAR CH)) + (* ; + "Set up SELECTION to be the found text") + (replace (SELECTION CHLIM) of SEL + with (ADD1 (CADR CH))) + [replace (SELECTION DCH) of SEL + with (ADD1 (IDIFFERENCE (CADR CH) + (CAR CH] + (replace (SELECTION POINT) of SEL + with 'RIGHT) + (replace (TEXTOBJ 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 OFILE) + (* ; "And get it into the window") + ) + (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found)") + (\SHOWSEL SEL NIL T] + (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) + (* ; + "Doing a FIND invalidates the insertion-piece cahce? I don't understand this. Check it.") + ) + (Looks (* ; + "He wants to set the font for the current selection") + (\TEDIT.LOOKS TEXTOBJ)) + (Hardcopy (* ; "Print this document") + (TEDIT.HARDCOPY TEXTOBJ)) + (Press% File (* ; + "Make a hardcopy file with this document in it.") + (TEDIT.HCPYFILE TEXTOBJ)) + (Expanded% Menu (* ; + "Open the expanded operations menu.") + (\TEDIT.EXPANDED.MENU TEXTOBJ)) + (Character% Looks (* ; + "Open the menu for setting character looks") + (\TEDIT.EXPANDEDCHARLOOKS.MENU TEXTOBJ)) + (Paragraph% Formatting (* ; + "Open the paragraph formatting menu") + (\TEDIT.EXPANDEDPARA.MENU TEXTOBJ)) + (Page% Layout (* ; "Open the page-layout menu") + (\TEXTMENU.START (COPYTEXTSTREAM TEDIT.EXPANDED.PAGEMENU T) + (\TEDIT.PRIMARYW TEXTOBJ) + "Page Layout Menu" 150)) + (COND + ((CAR ITEM) (* ; + "This is a user-supplied entry. Get the function, and apply it to the TEXTSTREAM for him") + (APPLY* (CAR ITEM) + (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ])]) (TEDIT.REMOVE.MENUITEM + [LAMBDA (MENU ITEM) (* gbn "26-Apr-84 04:06") + (PROG (ITEMLIST) + [COND + ((OR (LITATOM ITEM) + (STRINGP ITEM)) + (for X in (fetch ITEMS of MENU) do (COND + ((AND (LISTP X) + (EQUAL (CAR X) + ITEM)) + (RETURN (SETQ ITEM X] + (RETURN (COND + ((MEMBER ITEM (SETQ ITEMLIST (fetch ITEMS of MENU))) + (replace ITEMS of MENU with (REMOVE ITEM ITEMLIST)) + (replace MENUCOLUMNS of MENU with NIL) + (replace MENUROWS of MENU with NIL) + (UPDATE/MENU/IMAGE MENU)) + (T NIL]) (\TEDIT.CREATEMENU + [LAMBDA (ITEMS) (* ; "Edited 16-Oct-87 14:21 by jds") + + (* ;; "Create a TEdit command menu, given a list of menu items.") + + (create MENU + ITEMS _ ITEMS + CENTERFLG _ T + MENUFONT _ (FONTCREATE 'HELVETICA 10 'BOLD) + WHENHELDFN _ '\TEDIT.MENU.WHENHELDFN + WHENSELECTEDFN _ '\TEDIT.MENU.WHENSELECTEDFN]) (\TEDIT.MENU.WHENHELDFN + [LAMBDA (ITEM MENU BUTTON) (* jds "10-Apr-84 15:14") + (COND + ((ATOM ITEM) + (CLRPROMPT) + (PROMPTPRINT (SELECTQ ITEM + (Put "Sends the document to a file") + (Get "Gets a new file as the document to edit.") + (Looks "Changes the font/size/etc. of characters") + (Find "Searches for a string") + (Quit "Ends the edit session") + (Hardcopy "Formats and sends the file to a printer.") + (Press% File "Creates a PRESS or INTERPRESS file of the document.") + ""))) + (T (DEFAULTMENUHELDFN ITEM]) (\TEDIT.MENU.WHENSELECTEDFN + [LAMBDA (ITEM MENU BUTTON) (* ; "Edited 16-Oct-87 14:21 by jds") + + (* ;; "A Selection fn for preserving the button pressed, for special handling in PUT, e.g.") + + (CONS (DEFAULTWHENSELECTEDFN ITEM MENU BUTTON) + BUTTON]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.DEFAULT.MENU) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ TEDIT.DEFAULT.MENU [\TEDIT.CREATEMENU '((Put 'Put NIL (SUBITEMS |Put Formatted Document| Plain-Text Old-Format)) (Get 'Get NIL (SUBITEMS |Get Formatted Document| Unformatted% Get)) Include Find Looks Substitute Quit (Expanded% Menu 'Expanded% Menu NIL (SUBITEMS Expanded% Menu Character% Looks Paragraph% Formatting Page% Layout]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY [OR (SASSOC 'TEdit BackgroundMenuCommands) (NCONC1 BackgroundMenuCommands '(TEdit '(TEDIT) "Opens a TEdit window for use."] (SETQ BackgroundMenu NIL) ) (* ; "titled icon info") (FILESLOAD ICONW) (RPAQQ TEDITICON #*(87 95)OOOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOON@@@@@@O@AA@@CH@@@H@H@@@G@@@@@@OOOOOOOOOOOOOOOOOOH@@@@@OH@MJH@@F@@@@@@@B@N@@@@@OOOOOOOOOOOHGOOOOOOH@@@@MO@@@@@F@@@OL@@C@@@OH@@@LOOOOOOOOOOOOOOOOOOOON@@LGOOOOOOOOOOOOOOOOOOON@@LAOOOOOOOOOOOOOOOOOOON@@L@CN@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@LD@N@@@@@@@@@@@@@@@@@N@@MLDN@@@@@@@@@@@@@@@@@N@@LGBN@@@@@@@@@@@@@@@@@N@@LDNN@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@M@@N@@@@@@@@@@@@@@@@@N@@LGBN@@@@@@@@@@@@@@@@@N@@LDNN@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@MH@N@@@@@@@@@@@@@@@@@N@@MFBN@@@@@@@@@@@@@@@@@N@@LELN@@@@@@@@@@@@@@@@@N@@LDBN@@@@@@@@@@@@@@@@@N@@LBBN@@@@@@@@@@@@@@@@@N@@LALN@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@MH@N@@@@@@@@@@@@@@@@@N@@M@DN@@@@@@@@@@@@@@@@@N@@MDBN@@@@@@@@@@@@@@@@@N@@MCBN@@@@@@@@@@@@@@@@@N@@MNBN@@@@@@@@@@@@@@@@@N@@MCJN@@@@@@@@@@@@@@@@@N@@L@FN@@@@@@@@@@@@@@@@@N@@L@BN@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@MH@N@@@@@@@@@@@@@@@@@N@@M@@N@@@@@@@@@@@@@@@@@N@@M@@N@@@@@@@@@@@@@@@@@N@@ML@N@@@@@@@@@@@@@@@@@N@@MCJN@@@@@@@@@@@@@@@@@N@@M@FN@@@@@@@@@@@@@@@@@N@@MHBN@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@L@@N@@@@@@@@@@@@@@@@@N@@N@@N@@@@@@@@@@@@@@@@@N@@G@@N@@@@@@@@@@@@@@@@@N@@GH@N@@@@@@@@@@@@@@@@@N@@CN@N@@@@@@@@@@@@@@@@@N@@AOHN@@@@@@@@@@@@@@@@@N@@@GOOOOOOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOOOOON@@@@COOOOOOOOOOOOOOOOOON@@ ) (RPAQQ TEDITMASK #*(87 95)OOOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOON@@@@@@OOOOOOOOOOOOOOOOOO@@@@@@OOOOOOOOOOOOOOOOOOH@@@@@OOOOOOOOOOOOOOOOOON@@@@@OOOOOOOOOOOOOOOOOOOH@@@@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@@OOOOOOOOOOOOOOOOOOOOON@@OOOOOOOOOOOOOOOOOOOOON@@OOOOOOOOOOOOOOOOOOOOON@@OOOOOOOOOOOOOOOOOOOOON@@OOOOOOOOOOOOOOOOOOOOON@@GOOOOOOOOOOOOOOOOOOOON@@GOOOOOOOOOOOOOOOOOOOON@@COOOOOOOOOOOOOOOOOOOON@@AOOOOOOOOOOOOOOOOOOOON@@@GOOOOOOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOOOOON@@@@COOOOOOOOOOOOOOOOOON@@ ) (RPAQ? TEDIT.ICON.FONT (FONTCREATE 'HELVETICA 8 'BOLD)) (RPAQ? TEDIT.ICON.TITLE.REGION [CONS 16 (CONS 4 (CONS 64 (CONS 77 NIL]) (RPAQ? TEDIT.TITLED.ICON.TEMPLATE (CONS TEDITICON (CONS TEDITMASK (CONS TEDIT.ICON.TITLE.REGION NIL)))) (PUTPROPS TEDITWINDOW COPYRIGHT ("John Sybalsky & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1993 1994 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7130 91759 (TEDIT.CREATEW 7140 . 8276) (\TEDIT.CREATEW.FROM.REGION 8278 . 9262) ( TEDIT.CURSORMOVEDFN 9264 . 19916) (TEDIT.CURSOROUTFN 19918 . 20453) (TEDIT.WINDOW.SETUP 20455 . 22264) (TEDIT.MINIMAL.WINDOW.SETUP 22266 . 30055) (\TEDIT.ACTIVE.WINDOWP 30057 . 31038) ( \TEDIT.BUTTONEVENTFN 31040 . 54735) (\TEDIT.WINDOW.OPS 54737 . 58540) (\TEDIT.EXPANDFN 58542 . 58945) (\TEDIT.MAINW 58947 . 60236) (\TEDIT.PRIMARYW 60238 . 61450) (\TEDIT.COPYINSERTFN 61452 . 62423) ( \TEDIT.NEWREGIONFN 62425 . 64892) (\TEDIT.SET.WINDOW.EXTENT 64894 . 70996) (\TEDIT.SHRINK.ICONCREATE 70998 . 73270) (\TEDIT.SHRINKFN 73272 . 73847) (\TEDIT.SPLITW 73849 . 79950) (\TEDIT.UNSPLITW 79952 . 85646) (\TEDIT.WINDOW.SETUP 85648 . 91368) (\SAFE.FIRST 91370 . 91757)) (92905 93812 (TEDITWINDOWP 92915 . 93810)) (93849 96345 (TEDIT.GETINPUT 93859 . 95842) (\TEDIT.MAKEFILENAME 95844 . 96343)) ( 96394 102845 (TEDIT.PROMPTPRINT 96404 . 99308) (TEDIT.PROMPTFLASH 99310 . 101265) ( \TEDIT.PROMPT.PAGEFULLFN 101267 . 102843)) (103080 107120 (TEXTSTREAM.TITLE 103090 . 103700) ( \TEDIT.ORIGINAL.WINDOW.TITLE 103702 . 105736) (\TEDIT.WINDOW.TITLE 105738 . 106408) ( \TEXTSTREAM.FILENAME 106410 . 107118)) (107163 151887 (TEDIT.DEACTIVATE.WINDOW 107173 . 114322) ( \TEDIT.REPAINTFN 114324 . 117181) (\TEDIT.RESHAPEFN 117183 . 122803) (\TEDIT.SCROLLFN 122805 . 151885) ) (151929 153978 (\TEDIT.PROCIDLEFN 151939 . 153288) (\TEDIT.PROCENTRYFN 153290 . 153583) ( \TEDIT.PROCEXITFN 153585 . 153976)) (154057 165057 (\EDIT.DOWNCARET 154067 . 154748) (\EDIT.FLIPCARET 154750 . 156285) (TEDIT.FLASHCARET 156287 . 157401) (\EDIT.UPCARET 157403 . 157856) ( TEDIT.NORMALIZECARET 157858 . 163809) (\SETCARET 163811 . 164731) (\TEDIT.CARET 164733 . 165055)) ( 165091 178846 (TEDIT.ADD.MENUITEM 165101 . 167016) (TEDIT.DEFAULT.MENUFN 167018 . 176285) ( TEDIT.REMOVE.MENUITEM 176287 . 177288) (\TEDIT.CREATEMENU 177290 . 177743) (\TEDIT.MENU.WHENHELDFN 177745 . 178515) (\TEDIT.MENU.WHENSELECTEDFN 178517 . 178844))))) STOP \ No newline at end of file diff --git a/library/TELERAID b/library/TELERAID new file mode 100644 index 00000000..f43a0aa9 --- /dev/null +++ b/library/TELERAID @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "13-Jun-90 00:14:27" {DSK}local>lde>lispcore>library>TELERAID.;2 616 changes to%: (VARS TELERAIDCOMS) previous date%: " 4-Oct-84 15:52:04" {DSK}local>lde>lispcore>library>TELERAID.;1) (* ; " Copyright (c) 1984, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TELERAIDCOMS) (RPAQQ TELERAIDCOMS ((FILES REMOTEVMEM READSYS RDSYS VMEM))) (FILESLOAD REMOTEVMEM READSYS RDSYS VMEM) (PUTPROPS TELERAID COPYRIGHT ("Venue & Xerox Corporation" 1984 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/library/TEXEC b/library/TEXEC new file mode 100644 index 00000000..27a98013 --- /dev/null +++ b/library/TEXEC @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "30-May-91 19:21:21" |{PELE:MV:ENVOS}LIBRARY>TEXEC.;5| 197129 |changes| |to:| (FNS TEXEC.GET TEXEC.INCLUDE TEXEC.FIND.FORWARD TEXEC.FIND.BACKWARD TEDIT.FIND.BACKWARD TEDIT.BASICFIND.BACKWARD TEXEC.FILLBUFFER TEXEC.FILLBUFFER.TCLASS TEXEC.CHSELPENDING TEXEC.FILLBUFFER.WORDDELETE TEXEC.FILLBUFFER.LINEDELETE TEXEC.FLASHCARET TEXEC.NTHBACKCHNUM TEXEC.EOTP TEXEC.INSERTCHAR TEXEC.\\CHDEL1 TEDIT.SCROLL? TEXEC.DISPLAYTEXT \\TEXEC.TEXTBOUT \\TEXEC.TEXTBOUT1 \\TEXEC.TEXTBOUT2 \\TEXEC.TEXTBOUT4 \\TEXEC.SELFN) (VARS TEXECCOMS) |previous| |date:| "13-Jun-90 00:19:00" |{PELE:MV:ENVOS}LIBRARY>TEXEC.;2|) ; Copyright (c) 1985, 1900, 1986, 1987, 1988, 1989, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT TEXECCOMS) (RPAQQ TEXECCOMS ((COMS (* \;  "To support development and compilation") (DECLARE\: DONTCOPY EVAL@COMPILE (FILES (LOADCOMP) ATERM TEDITDECLS))) (COMS (* |;;| "THE FILLBUFFER REPLACEMENT CODE") (FNS TEXEC.BACKSKREAD TEXEC.OPENTEXTSTREAM TEXEC.DEFAULT.MENUFN TEXEC.DO?CMD TEXEC.CREATEMENU TEXEC.GET TEXEC.INCLUDE TEXEC.FIND.FORWARD TEXEC.FIND.BACKWARD TEDIT.FIND.BACKWARD TEDIT.BASICFIND.BACKWARD TEXEC.MENU.WHENHELDFN TEXEC.SHRINK.ICONCREATE TEXEC.FILLBUFFER TEXEC.FILLBUFFER.TCLASS TEXEC.CHSELPENDING TEXEC.FILLBUFFER.CHARDELETE TEXEC.FILLBUFFER.WORDDELETE TEXEC.FILLBUFFER.LINEDELETE TEXEC.PARENCOUNT TEXEC.PARENMATCH TEXEC.FLASHCARET TEXEC.TEXTSTREAM.TO.LINEBUF TEXEC.FIX TEXEC.NTHBUFCHARBACK TEXEC.NTHBACKCHNUM TEXEC.EOTP TEXEC.GETKEY TEXEC.INSERTCHAR TEXEC.DELETE TEXEC.\\CHDEL1 TEXEC.?EQUAL TEDIT.SCROLL? TEXEC.DISPLAYTEXT \\TEXEC.TEXTBOUT \\TEXEC.TEXTBOUT1 \\TEXEC.TEXTBOUT2 \\TEXEC.TEXTBOUT3 \\TEXEC.TEXTBOUT4 \\TEXEC.SELFN TEXEC.PRINTARGS TEXEC.PROCENTRYFN TEXEC.PROCEXITFN)) (COMS (* |;;| "Code to support a TEXEC lisp 'listener'") (FNS TEXEC TTEXEC) (APPENDVARS (|BackgroundMenuCommands| (TEXEC '(TEXEC) "Starts TEXEC in a new window.")))) (HORRIBLEVARS TEXEC.ICON TEXEC.ICON.MASK TEXEC.TITLED.ICON.TEMPLATE) (VARS (TEXEC.ICON.TITLE.REGION (CREATE REGION BOTTOM _ 55 LEFT _ 6 WIDTH _ 77 HEIGHT _ 16)) (TEXEC.ICON.FONT (FONTCREATE 'HELVETICA 8 'BOLD)) (TEXEC.DEFAULT.MENU (TEXEC.CREATEMENU '((|Put| '|Put| NIL (SUBITEMS |Plain-Text| |Old-Format|)) (|Include| '|Include|) ("Forward Find" '|ForwardFind|) ("Backward Find" '|BackwardFind|) (|Limit| '|Limit|)))) (|BackgroundMenu| NIL)) (INITVARS (TEXEC.BUFFERLIMIT 10000)))) (* \; "To support development and compilation") (DECLARE\: DONTCOPY EVAL@COMPILE (FILESLOAD (LOADCOMP) ATERM TEDITDECLS) ) (* |;;| "THE FILLBUFFER REPLACEMENT CODE") (DEFINEQ (TEXEC.BACKSKREAD (LAMBDA (BUFFER BUF NOTIFQUOTED) (* \; "Edited 1-Dec-87 13:20 by jds") (* |;;| "Returns buffer position of start of list containing cursor position BUF, or start of buffer. If NOTIFQUOTED is true, then returns NIL if the paren/bracket at BUF is quoted with the escape char or is inside a string. Strategy: start at beginning of buffer and TTSKREAD forward (much easier); if read ends at BUF, we win; if ends before BUF, then resume reading there (we skipped an internal list); otherwise if read did not end, BUF must be inside a list, so scan ahead for start of an inner list, and repeat") (PROG ((B BUFFER) (INNERMOSTLIST BUFFER) ESCAPED BRACKETFLG X) LP (COND ((EQ B BUF) (* \; "No list in buffer at all") (RETURN (AND (OR (NOT NOTIFQUOTED) (NOT ESCAPED)) INNERMOSTLIST)))) (SELECTC (\\SYNCODE \\RDTBLSA (FIRSTCHAR B)) ((LIST LEFTPAREN.RC LEFTBRACKET.RC) (* \;  "open paren or bracket. Try scanning this new internal list") (COND (ESCAPED (* \; "Inside a multiple escape") ) ((EQ (SETQ X (TTSKREAD (CDR B) BUF)) BUF) (RETURN (OR BRACKETFLG B))) (X (* \;  "Skip over internal list just scanned") (SETQ B X)) (T (* |;;| "The TTSKREAD failed, so BUF must be at least this deeply nested. Save pointer here in case we abort inside a string or such") (SETQ INNERMOSTLIST B) (COND ((AND (EQ (CAR B) (CHARCODE [)) (EQ (CAR BUF) (CHARCODE ]))) (* |;;| "Brackets may match; save position of this open bracket. Otherwise we'll return the innermost list, rather than the start of the bracket expression") (SETQ BRACKETFLG B)))))) (ESCAPE.RC (* \; " to quote the next char") (COND ((EQ (CDR B) BUF) (* |;;| "The char at BUF is quoted. This is why TTSKREAD failed here. Just return the list we're now inside") (RETURN (AND (NOT NOTIFQUOTED) INNERMOSTLIST))) (T (* \; "skip over escape char") (SETQ B (CDR B))))) (STRINGDELIM.RC (* \; "double-quote") (COND ((AND (NOT ESCAPED) (NOT (SETQ B (FIND.MATCHING.QUOTE (CDR B) BUF)))) (* \;  "Termination analogous to previous case") (RETURN (AND (NOT NOTIFQUOTED) INNERMOSTLIST))))) (MULTIPLE-ESCAPE.RC (SETQ ESCAPED (NOT ESCAPED))) (OTHER.RC NIL) (PROGN (COND ((AND (EQ (CAR B) (CHARCODE \;)) (READTABLEPROP RDTBL 'COMMONLISP)) (* \; "Handle semicolon special") (COND ((|do| (SETQ B (CDR B)) (COND ((EQ B BUF) (RETURN T)) ((EQ (FIRSTCHAR B) (CHARCODE EOL)) (RETURN)))) (* \; "Done inside a comment") (RETURN (AND (NOT NOTIFQUOTED) INNERMOSTLIST)))))))) (SETQ B (CDR B)) (GO LP)))) (TEXEC.OPENTEXTSTREAM (LAMBDA (WINDOW MENUFN) (* \; "Edited 13-Jun-90 00:17 by mitani") (* |;;| "Initialize and return TEDIT TEXTSTREAM") (LET* ((TEXSTREAM (OPENTEXTSTREAM NIL WINDOW NIL NIL (LIST 'TERMTABLE \\PRIMTERMTABLE 'PROMPTWINDOW 'DON\'T))) (TEXTOBJ (TEXTOBJ TEXSTREAM)) (TEXLEN (|fetch| (TEXTOBJ TEXTLEN) TEXTOBJ))) (* \;  "force shift select typein to be put in keyboard buffer ") (|replace| (TEXTOBJ TXTEDITING) |of| TEXTOBJ |with| T) (TEXTPROP TEXSTREAM 'STARTINGEOF TEXLEN) (TEXTPROP TEXSTREAM 'COPYBYBKSYSBUF T) (* \;  "forces COPY-SELECT to unread chars into TTY buffer") (TEXTPROP TEXSTREAM 'SELFN (FUNCTION \\TEXEC.SELFN)) (* \;  "Limits selection to current input") (|replace| (STREAM STRMBOUTFN) |of| TEXSTREAM |with| '\\TEXEC.TEXTBOUT) (|replace| (SELECTION SET) |of| (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ) |with| T) (|replace| (SELECTION L1) |of| (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ) |with| (LIST (|fetch| DESC |of| (|fetch| (TEXTOBJ THISLINE) |of| TEXTOBJ)))) (* \;  "hookup middle button menu instead of TEDIT menu") (WINDOWPROP WINDOW 'TEDIT.TITLEMENUFN MENUFN) (CHANGEFONT (|fetch| (CHARLOOKS CLFONT) |of| (|fetch| (TEXTOBJ CARETLOOKS) |of| TEXTOBJ)) TEXSTREAM) TEXSTREAM))) (TEXEC.DEFAULT.MENUFN (LAMBDA (W) (* \; "Edited 13-Jun-90 00:16 by mitani") (* |Default| |User| F\n |for| TEXEC |windows--displays| \a |menu| |of| |items|  & |acts| |on| |the| |commands| |received.|) (PROG ((TEXTOBJ (WINDOWPROP W 'TEXTOBJ)) (WMENU (WINDOWPROP W 'TEDIT.MENU)) THISMENU CH OFILE OCURSOR PCTB LINES SEL ITEM) (COND ((EQ (|fetch| (TEXTOBJ EDITOPACTIVE) |of| TEXTOBJ) T) (* |We're| |busy| |doing|  |something,| |but| |not| |sure|  |what.| |Give| \a |general|  "please wait" |msg|) (TEDIT.PROMPTPRINT TEXTOBJ "Edit operation in progress; please wait." T) (RETURN)) ((|fetch| (TEXTOBJ EDITOPACTIVE) |of| TEXTOBJ) (* W\e |know| |specifically|  |what's| |happening.|  |Tell| |him|) (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT (|fetch| (TEXTOBJ EDITOPACTIVE) |of| TEXTOBJ ) " in progress; please wait.") T) (RETURN))) (SETQ PCTB (|fetch| (TEXTOBJ PCTB) |of| TEXTOBJ)) (SETQ THISMENU (COND (WMENU) ((SETQ WMENU (WINDOWPROP W 'TEDIT.MENU.COMMANDS)) (PROG1 (SETQ WMENU (TEXEC.CREATEMENU WMENU)) (WINDOWPROP W 'TEDIT.MENU WMENU))) (TEXEC.DEFAULT.MENU))) (SETQ ITEM (MENU THISMENU)) (ERSETQ (RESETLST (RESETSAVE (\\TEDIT.MARKACTIVE TEXTOBJ) '(AND (\\TEDIT.MARKINACTIVE OLDVALUE))) (|replace| (TEXTOBJ EDITOPACTIVE) |of| TEXTOBJ |with| (OR (CAR ITEM) T)) (* S\o |we| |ca| |ntell| |the| |guy|  WHAT |op| |is| |active.|) (SELECTQ (CAR ITEM) (|Put| (TEDIT.PUT TEXTOBJ NIL NIL (TEXTPROP TEXTOBJ 'CLEARPUT))) (|Plain-Text| (TEDIT.PUT TEXTOBJ NIL NIL T)) (|Old-Format| (* |Write| |out| |the| |file| |in|  |the| OLD |TEdit| |format.|) (TEDIT.PUT TEXTOBJ NIL NIL NIL T)) (|Get| (* |Get| \a |new| |file|  (|overwriting| |the| |one| |being|  |edited.|)) (TEXEC.GET TEXTOBJ NIL (TEXTPROP TEXTOBJ 'CLEARGET))) (|Unformatted Get| (TEXEC.GET TEXTOBJ NIL T)) (|Include| (* |Insert| \a |file| |where| |the|  |caret| |is|) (TEXEC.INCLUDE TEXTOBJ)) (|ForwardFind| (* |Normal| |forward| |search|  |Find|) (TEXEC.FIND.FORWARD TEXTOBJ)) (|BackwardFind| (* |Backward| |search| |Find|) (TEXEC.FIND.BACKWARD TEXTOBJ)) (|Limit| (SETQ TEXEC.BUFFERLIMIT (RNUMBER))) (COND ((CAR ITEM) (* |This| |is| \a |user-supplied| |entry.|  |Get| |the| |function,| |and| |apply| |it| |to| |the| TEXTSTREAM |for| |him|) (APPLY* (CAR ITEM) (|fetch| (TEXTOBJ STREAMHINT) |of| TEXTOBJ)))))))))) (TEXEC.DO?CMD (LAMBDA (TEXTOBJ) (* \; "Edited 13-Jun-90 00:16 by mitani") (* |;;;| "Handles 'read macros' ? and ?=. CMD is one of those. Returns NIL if thinks it isn't. Saves current cursor location for later restoration") (DECLARE (SPECVARS \\?TAIL \\?PARAMS \\BUFFER)) (* (\\CARET.DOWN)) (PROG ((START (TEXTPROP TEXOBJ 'STARTINGEOF)) (STREAM (TEXTSTREAM TEXTOBJ)) \\BUFFER START-BUFFER FN FNSTART FNEND SPTAIL SAVE) (SETFILEPTR STREAM START) (SETQ \\BUFFER (FOR I FROM 0 TO (IDIFFERENCE (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ) START) COLLECT (BIN STREAM))) (SETQ START-BUFFER (BACKSKREAD (FLAST \\BUFFER))) (SELECTC (\\SYNCODE \\RDTBLSA (FIRSTCHAR START-BUFFER)) ((LIST LEFTPAREN.RC LEFTBRACKET.RC) (COND ((AND (EQ (SCANFORWARD (CAR START-BUFFER) (SETQ FNSTART TTYIN-BUFFER)) START) (PROGN (* \;  "START is the first paren in buffer, so check and see if there's an atom before it") (SETQ FN (TTRATOM)) (* |;;;| "") (* |;;;| "removed: (COND ((OR (EQ FN 'E) (AND (EQ \\\\PROMPT1 '*) (FMEMB FN EDITCOMSL))) ; What looks like a fn in apply format is really a command, either E or an editor command (SETQ FNSTART \\\\BUFFER) (SETQ FN (TTRATOM))))") (SETQ FNEND \\BUFFER) (EQ (TTSKIPSEPR) START))) (* \;  "This is first list on line, preceded by FN in evalqt format") ) (T (SETQ FNSTART (SETQ \\BUFFER (CDR START))) (* \; "EVAL form: read fn") (COND ((EQ (SETQ FN (TTRATOM)) CMD) (* \; "Hasn't typed the fn name yet!") (RETURN))) (SETQ FNEND \\BUFFER)))) (PROGN (* \;  "Not inside a list now, so no macro") (RETURN))) (SAVE.CURSOR) (COND ((NLSETQ (PROG ((\\?PARAMS |null|) STUFF) (COND ((EQ CMD '?) (XHELPSYS FN)) (T (GO.TO.FREELINE) (COND ((EQ \\BUFFER START) (* \; "Apply format, skip over paren") (SETQ \\BUFFER (CDR START)))) (COND ((OR (NOT TTYIN?=FN) (NOT (SETQ STUFF (APPLY* TTYIN?=FN FN)))) (SETQ STUFF (SMARTARGLIST FN T (SETQ SPTAIL (CONS FN)))) (COND ((NEQ FN (SETQ FN (CAR SPTAIL))) (* \;  "Fn was spelling corrected, so There was an extra crlf involved in printing the correction") (TTCRLF.ACCOUNT)) (T (SETQ SPTAIL NIL))) (TTYIN.PRINTARGS FN STUFF T)) ((EQ (CAR (LISTP STUFF)) 'ARGS) (TTYIN.PRINTARGS FN (CDR STUFF) T)) ((LISTP STUFF) (TTPRIN2 STUFF)) ((NEQ STUFF T) (TTPRIN1 STUFF)))))))) ((BEEP) (* \;  "error occurred, probably undefined fn.") )) (SELECTQ CMD (? (* \; "now delete the ?") (TTRUBOUT)) (?= (RESTORE.CURSOR) (BACKWARD.DELETE.TO \\?TAIL) (COND (SPTAIL (* |;;| "Fn was spelling corrected, so replace it. There was also an extra crlf involved in printing the correction") (SETQ SAVE \\CURSOR) (MOVE.TO.WHEREVER FNEND) (BACKWARD.DELETE.TO FNSTART) (READFROMBUF (CHCON FN T RDTBL)) (MOVE.TO.WHEREVER SAVE)))) NIL) (RETURN T)))) (TEXEC.CREATEMENU (LAMBDA (ITEMS) (* AJB " 2-Jan-86 15:23") (* |Create| \a |TEdit| |command| |menu,| |given| \a |list| |of| |menu| |items.|) (|create| MENU ITEMS _ ITEMS CENTERFLG _ T MENUFONT _ (FONTCREATE 'HELVETICA 10 'BOLD) WHENHELDFN _ 'TEXEC.MENU.WHENHELDFN WHENSELECTEDFN _ '\\TEDIT.MENU.WHENSELECTEDFN))) (TEXEC.GET (LAMBDA (TEXTOBJ FILE UNFORMATTED?) (* \; "Edited 30-May-91 19:17 by jds") (* \;  "Get a file (overwriting the current textstream data)") (PROG (OFILE OCURSOR LINES USER.CMFILE RESP TITLE FILENAME MENUSTREAM (GETFN (TEXTPROP TEXTOBJ 'GETFN)) (SEL (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ)) (PCTB (|fetch| (TEXTOBJ PCTB) |of| TEXTOBJ)) (TEDIT.GET.FINISHEDFORMS NIL)) (COND ((AND (|fetch| (TEXTOBJ \\DIRTY) |of| TEXTOBJ) (PROGN (AND (|fetch| (TEXTOBJ PROMPTWINDOW) |of| TEXTOBJ) (FRESHLINE (|fetch| (TEXTOBJ PROMPTWINDOW) |of| TEXTOBJ))) (NOT (MOUSECONFIRM "Not saved yet; LEFT go Get anyway." T (|fetch| (TEXTOBJ PROMPTWINDOW) |of| TEXTOBJ))))) (* \;  "Only do the GET if he knows he'll zorch himself.") (RETURN))) (SETQ OFILE (OR FILE (\\TEDIT.MAKEFILENAME (TEDIT.GETINPUT TEXTOBJ "File to GET: ")))) (COND ((AND OFILE (INFILEP OFILE)) (* \;  "Only if there's a file to load and the file exists.") (COND ((AND GETFN (EQ (APPLY* GETFN (|fetch| (TEXTOBJ STREAMHINT) |of| TEXTOBJ) (FULLNAME OFILE) 'BEFORE) 'DON\'T)) (* \;  "He doesn't want this document put. Bail out.") (RETURN))) (RESETLST (RESETSAVE (TTYDISPLAYSTREAM (OR (|fetch| (TEXTOBJ PROMPTWINDOW) |of| TEXTOBJ) PROMPTWINDOW))) (RESETSAVE (CURSOR WAITINGCURSOR)) (\\SHOWSEL (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ) NIL NIL) (\\TEXTCLOSEF (|fetch| (TEXTOBJ STREAMHINT) |of| TEXTOBJ)) (* \; "CLOSE the old files") (SETQ OFILE (OPENSTREAM OFILE 'INPUT)) (* \; "And open the new one.") (SETQ PCTB (|replace| (TEXTOBJ PCTB) |of| TEXTOBJ |with| (TEDIT.BUILD.PCTB OFILE TEXTOBJ NIL NIL (|fetch| (TEXTOBJ DEFAULTCHARLOOKS) |of| TEXTOBJ) (|fetch| (TEXTOBJ FMTSPEC) |of| TEXTOBJ) UNFORMATTED?))) (|for| FORM |in| TEDIT.GET.FINISHEDFORMS |do| (EVAL FORM)) (* \;  "Do any necessary cleanup for outside packages") (SETQ LINES (|fetch| (TEXTOBJ LINES) |of| TEXTOBJ)) (|replace| (TEXTOBJ \\DIRTY) |of| TEXTOBJ |with| NIL) (|for| FIRSTLINE |inside| LINES |do| (|replace| (LINEDESCRIPTOR NEXTLINE) |of| FIRSTLINE |with| NIL)) (|replace| (TEXTOBJ \\INSERTPCVALID) |of| TEXTOBJ |with| NIL) (* |;;| "The old cached piece is no longer valid--keep people from stepping on it, to prevent lost type-in and smashing other docuemnts to which it has been moved...") (TEXTPROP TEXTOBJ 'STARTINGEOF (|replace| (TEXTOBJ TEXTLEN) |of| TEXTOBJ |with| (SUB1 (\\EDITELT PCTB (SUB1 (\\EDITELT PCTB |\\PCTBLastPieceOffset| )))))) (|replace| (SELECTION CH#) |of| SEL |with| (|replace| (SELECTION CHLIM) |of| SEL |with| TEXTLEN)) (|replace| (SELECTION DCH) |of| SEL |with| 0) (|replace| (SELECTION POINT) |of| SEL |with| 'LEFT) (|replace| (SELECTION SET) |of| SEL |with| T) (|replace| (SELECTION SET) |of| (|fetch| (TEXTOBJ SCRATCHSEL) |of| TEXTOBJ) |with| NIL) (|replace| (SELECTION SET) |of| (|fetch| (TEXTOBJ SHIFTEDSEL) |of| TEXTOBJ) |with| NIL) (|replace| (SELECTION SET) |of| (|fetch| (TEXTOBJ MOVESEL) |of| TEXTOBJ) |with| NIL) (|replace| (SELECTION SET) |of| TEDIT.SELECTION |with| NIL) (|replace| (SELECTION SET) |of| TEDIT.SHIFTEDSELECTION |with| NIL) (|replace| (TEXTOBJ CARETLOOKS) |of| TEXTOBJ |with| ( \\TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ SEL)) (|for| WINDOW |inside| (|fetch| (TEXTOBJ \\WINDOW) |of| TEXTOBJ) |as| LINE |inside| LINES |do| (* \;  "Fill the edit window (s) with the new text") (\\FILLWINDOW (|fetch| ( LINEDESCRIPTOR YBOT) |of| LINE) LINE TEXTOBJ NIL WINDOW)) (\\FIXSEL SEL TEXTOBJ) (\\SHOWSEL SEL NIL T) (SETQ TITLE (TEXTSTREAM.TITLE TEXTOBJ)) (* \; "find and set the title") (\\TEDIT.WINDOW.TITLE TEXTOBJ (\\TEDIT.ORIGINAL.WINDOW.TITLE TITLE NIL)) (SETQ MENUSTREAM (TEDITMENU.STREAM TEXTOBJ)) (COND ((AND MENUSTREAM (|type?| LITATOM TITLE)) (* \;  "if we have a filename then put it in the GET and PUT fields of the menu") (SETQ FILENAME (PACKFILENAME 'VERSION NIL 'BODY TITLE)) (MBUTTON.SET.FIELD MENUSTREAM '|Get| FILENAME) (MBUTTON.SET.FIELD MENUSTREAM '|Put| FILENAME))) (\\TEDIT.SET.WINDOW.EXTENT TEXTOBJ (\\TEDIT.PRIMARYW TEXTOBJ)) (\\TEDIT.HISTORYADD TEXTOBJ (|create| TEDITHISTORYEVENT THACTION _ '|Get|))) (AND GETFN (APPLY* GETFN (|fetch| (TEXTOBJ STREAMHINT) |of| TEXTOBJ) (FULLNAME (|fetch| (TEXTOBJ TXTFILE) |of| TEXTOBJ)) 'AFTER))) (OFILE (TEDIT.PROMPTPRINT TEXTOBJ "[File not found.]")) (T (TEDIT.PROMPTPRINT TEXTOBJ "[Get aborted.]" T)))))) (TEXEC.INCLUDE (LAMBDA (STREAM FILE START END) (* \; "Edited 30-May-91 19:17 by jds") (* |Obtain| \a |file| |name,| |and| |include| |that| |file's| |contents| |at|  |the| |place| |where| |the| |caret| |is.|) (* |Returns| T |if| |the| |insertion| |happened,| NIL |if| |there| |was| |no|  |place| |to| |put| |it.|) (SETQ STREAM (TEXTOBJ STREAM)) (PROG ((SEL (|fetch| (TEXTOBJ SEL) |of| STREAM)) PCTB TEXTLEN NFILE NNFILE INSERTCH# INSPC LEN INSPC# PCLST NPC WASOPEN PCCOUNT NSTREAM) (COND ((|fetch| (SELECTION SET) |of| SEL) (* |There| |is| \a |place| |to| |do|  |the| |include.|) (SETQ NFILE (OR FILE (\\TEDIT.MAKEFILENAME (TEDIT.GETINPUT STREAM "Name of the file to load: ")))) (COND ((NOT NFILE) (* I\f |no| |file| |was| |given,|  |don't| |bother| |INCLUDEing.|) (TEDIT.PROMPTPRINT STREAM "[Include aborted.]" T) (RETURN)) ((STREAMP NFILE)) ((NOT (INFILEP NFILE)) (* |Can't| |find| |the| |file.|  |Put| |out| \a |message.|) (TEDIT.PROMPTPRINT STREAM "[File not found.]") (RETURN))) (SETQ NNFILE (OPENSTREAM '{NODIRCORE} 'OUTPUT 'NEW)) (* |Create| |the| |holding| |file|) (SETQ NFILE (COND ((OPENP NFILE) (SETQ WASOPEN T) NFILE) (T (* |Wasn't| |open| --  |need| |to| |open| |it| |for|  |input...|) (OPENFILE NFILE 'INPUT)))) (* |And| |copy| |the| |file-section|  |into| |it.|) (COPYBYTES NFILE NNFILE (OR START 0) (OR END (GETEOFPTR NFILE))) (* |Have| |to| |explicitly| |fill| |in| 0 |and| EOFPTR\, |because| |if| |the|  |file| |was| |open| |already,| NIL\s |would| |only| |copy| |from| |current|  |fileptr| |to| EOF.) (OR WASOPEN (CLOSEF NFILE)) (* I\f |the| |file| |didn't| |come|  |to| |use| |open,| |close| |it.|) (CLOSEF NNFILE) (SETQ NFILE NNFILE) (SETQ START (SETQ END NIL)) (* |Then| |pretend| |nothing|  |happened.|) (TEDIT.DO.BLUEPENDINGDELETE SEL STREAM) (* |Delete| |any| |text,| |if|  |need| |be|) (SETQ TEXTLEN (|fetch| (TEXTOBJ TEXTLEN) |of| STREAM)) (* W\e |need| |the| |POST-deletion| |text| |length| |for| |later,| |so| |this|  |must| |come| |after| |the| |b-p-d.|) (\\SHOWSEL SEL NIL NIL) (* |Turn| |off| SEL\s |before| |we|  |go| |any| |further|) (SETQ NFILE (TEXTOBJ (SETQ NSTREAM (OPENTEXTSTREAM (OPENSTREAM NFILE 'INPUT) NIL NIL NIL (LIST 'FONT ( \\TEDIT.GET.INSERT.CHARLOOKS STREAM SEL) 'PARALOOKS (|fetch| (TEXTOBJ FMTSPEC) |of| STREAM)))))) (* |Get| \a |textobj| |to|  |describe| |the| |include| |source|  |file| (|need| NSTREAM |so| |that|  |if| |we| |have| |to| |convert| |it|  |to| |formatted,| |we| |won't|  |have| |lost| |the|  |textstream--and| |thus| |smash|  |the| |free| |list.|)) (COND ((AND (|fetch| (TEXTOBJ FORMATTEDP) |of| NFILE) (NOT (|fetch| (TEXTOBJ FORMATTEDP) |of| STREAM))) (* I\f |the| |includED| |text| |is|  |formatted| |but| |this| |file|  |isn't,| |let's| |format| |it!|) (\\TEDIT.CONVERT.TO.FORMATTED STREAM)) ((AND (|fetch| (TEXTOBJ FORMATTEDP) |of| STREAM) (NOT (|fetch| (TEXTOBJ FORMATTEDP) |of| NFILE))) (* |The| TARGET |document| |is| |formatted,| |but| |the| INCLUDE\d |text|  |isn't.| |Better| |format| |it| |before| |completing| |the| |include.|) (\\TEDIT.CONVERT.TO.FORMATTED NFILE))) (SETQ PCTB (|fetch| (TEXTOBJ PCTB) |of| STREAM)) (* HERE\, |because| |the|  |conversion| |to| |formatted| |will|  |lengthen| |the| |pctb|) (SETQ INSERTCH# (COND ((EQ (|fetch| (SELECTION POINT) |of| SEL) 'LEFT) (|fetch| (SELECTION CH#) |of| SEL)) (T (|fetch| (SELECTION CHLIM) |of| SEL)))) (* |Find| |the| |place| |to| |make|  |the| |insertion.|) (SETQ INSPC# (OR (\\CHTOPCNO INSERTCH# PCTB) (\\EDITELT PCTB |\\PCTBLastPieceOffset|))) (* |Likewise,| |this| |is|  |affected| |by| |the|  |convert-to-formatted|) (SETQ INSPC (\\EDITELT (|fetch| (TEXTOBJ PCTB) |of| STREAM) (ADD1 INSPC#))) (* |The| |piece| |to| |make| |the|  |insertion| |in|) (COND ((NEQ INSPC 'LASTPIECE) (COND ((IGREATERP INSERTCH# (\\EDITELT PCTB INSPC#)) (* |Must| |split| |the| |piece.|) (SETQ INSPC (\\SPLITPIECE INSPC INSERTCH# STREAM INSPC#)) (|add| INSPC# |\\EltsPerPiece|) (SETQ PCTB (|fetch| (TEXTOBJ PCTB) |of| STREAM)) (* |Refresh| |the| PCTB |in| |case|  |it| |grew.|) )))) (SETQ PCLST (|fetch| (TEXTOBJ PCTB) |of| NFILE)) (* A |temporary| |pctb,| |holding|  |the| |pieces| |which| |describe|  |the| INCLUDE\d |text|) (SETQ LEN (SUB1 (\\EDITELT PCLST (SUB1 (\\EDITELT PCLST |\\PCTBLastPieceOffset|))))) (SETQ PCCOUNT (IDIFFERENCE (SUB1 (\\EDITELT PCLST |\\PCTBLastPieceOffset|)) |\\FirstPieceOffset|)) (* |Remember| |how| |many| |slots|  |in| |the| PCTB |we| |took| |up|  (|i.e.| 2 \x \# |of| |pieces|)) (\\TEDIT.INSERT.PIECES STREAM INSERTCH# (SETQ PCLST (\\EDITELT PCLST (ADD1 |\\FirstPieceOffset| ))) LEN INSPC INSPC# NIL) (COND ((AND (|fetch| (TEXTOBJ FORMATTEDP) |of| STREAM) (NOT (|fetch| (TEXTOBJ FORMATTEDP) |of| NFILE))) (* I\f |the| |includED| |text| |is|  |formatted| |but| |this| |file|  |isn't,| |let's| |format| |it!|) (\\TEDIT.CONVERT.TO.FORMATTED STREAM INSERTCH# (IPLUS INSERTCH# LEN)))) (\\TEDIT.HISTORYADD STREAM (|create| TEDITHISTORYEVENT THACTION _ '|Include| THCH# _ INSERTCH# THLEN _ LEN THFIRSTPIECE _ PCLST)) (* |Remember| |that| |we| |did|  |this,| |so| |it| |can| |be|  |undone.|) (|replace| (TEXTOBJ TEXTLEN) |of| STREAM |with| (IPLUS TEXTLEN LEN)) (* |Inserting| |the| |pieces| |didn't| |fix| |up| |things| |like| |the|  |length| |of| |the| |document,| |so| |do| |it| |now.|) (AND (|fetch| (TEXTOBJ \\WINDOW) |of| STREAM) (\\FIXILINES STREAM SEL INSERTCH# LEN TEXTLEN)) (* |Mark| |any| |changed| |lines|  |dirty.|) (|replace| (SELECTION CHLIM) |of| SEL |with| (|replace| (SELECTION CH#) |of| SEL |with| (IPLUS INSERTCH# LEN))) (* |Now| |fix| |up| |the| |selection| |to| |be| |at| |the| |end| |of| |the|  |included| |text,| |point_left,| |character| |selection| |grain.|) (|replace| (SELECTION DCH) |of| SEL |with| 0) (|replace| (SELECTION DX) |of| SEL |with| 0) (|replace| (SELECTION POINT) |of| SEL |with| 'LEFT) (* S\o |that| |several| |things|  INCLUDED |in| |sequence| |fall| |in|  |sequence.|) (|replace| (SELECTION SELKIND) |of| SEL |with| 'CHAR) (|replace| (SELECTION SELOBJ) |of| SEL |with| NIL) (COND ((|fetch| (TEXTOBJ \\WINDOW) |of| STREAM) (* |We're| |displaying;|  |update| |the| |display| |and| |the|  |selection's| |line| |references|) (TEDIT.UPDATE.SCREEN STREAM) (\\FIXSEL SEL STREAM) (\\SHOWSEL SEL NIL T))) (|replace| (TEXTOBJ \\DIRTY) |of| STREAM |with| T) (* |Mark| |the| |document| |changed|) (\\SETUPGETCH (|create| EDITMARK PC _ INSPC PCOFF _ 0 PCNO _ (IPLUS INSPC# PCCOUNT)) STREAM) (* |Set| |the| |fileptr| |to| |the|  |end| |of| |the| |insertion.|) (TEDIT.SCROLL? STREAM) (* |Scroll| |the| |end| |into|  |view| |if| |necessary|) T) (T (TEDIT.PROMPTPRINT STREAM "Please choose the place for the INCLUDE first." T)))))) (TEXEC.FIND.FORWARD (LAMBDA (TEXTOBJ) (* \; "Edited 30-May-91 19:17 by jds") (* |Case| |sensitive| |search,|  |with| * |and| \# |wildcards|) (PROG* (FTEXT CHL (SEL (|fetch| (TEXTOBJ SCRATCHSEL) |of| TEXTOBJ)) (SHIFTEDSELWASON (|fetch| (SELECTION ONFLG) |of| (|fetch| (TEXTOBJ SHIFTEDSEL) |of| TEXTOBJ))) (MOVESELWASON (|fetch| (SELECTION ONFLG) |of| (|fetch| (TEXTOBJ MOVESEL ) |of| TEXTOBJ))) (DELETESELWASON (|fetch| (SELECTION ONFLG) |of| (|fetch| (TEXTOBJ DELETESEL) |of| TEXTOBJ))) (W (|fetch| (TEXTOBJ SELWINDOW) |of| TEXTOBJ)) (LINES (WINDOWPROP W 'LINES)) (LINE (|fetch| (LINEDESCRIPTOR NEXTLINE) |of| LINES)) (WREG (DSPCLIPPINGREGION NIL W)) (WHEIGHT (|fetch| (REGION HEIGHT) |of| WREG)) (WWIDTH (|fetch| (REGION WIDTH) |of| WREG))) (SETQ FTEXT (TEDIT.GETINPUT TEXTOBJ "Text to find: " (WINDOWPROP W 'TEDIT.LAST.FIND.STRING) (CHARCODE (EOL LF ESC)))) (COND (FTEXT (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) (* I\f |the| |selection| |is| |at| |the| |caret,| |then| |always| |start|  |there.| |Otherwise| |check| |if| \a |previous| |find| |is| |in| |view,| |and|  |if| |not| |just| |start| |at| |the| |caret|) (SETQ CHL (TEDIT.FIND TEXTOBJ (MKSTRING FTEXT) (COND ((|fetch| (SELECTION SET) |of| (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ)) 1) ((WINDOWPROP W 'TEDIT.LAST.FIND.POSITION) (IPLUS (WINDOWPROP W 'TEDIT.LAST.FIND.POSITION) 2)) (T 1)) NIL T)) (COND (CHL (* W\e |found| |the| |target|  |text.|) (TEDIT.PROMPTPRINT TEXTOBJ "Done.") (COND ((|fetch| (SELECTION SET) |of| SEL) (* |Turn| |any| |selections| |off|) (\\SHOWSEL SEL NIL NIL))) (|replace| (SELECTION SET) |of| SEL |with| T) (|for| CARET |inside| (|fetch| (TEXTOBJ CARET) |of| TEXTOBJ) |do| (\\EDIT.UPCARET CARET)) (* |Remove| |any| |visible| |carets|) (\\SHOWSEL (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ) NIL NIL) (|replace| (SELECTION CH#) |of| SEL |with| (CAR CHL)) (* |Set| |up| SELECTION |to| |be|  |the| |found| |text|) (|replace| (SELECTION CHLIM) |of| SEL |with| (ADD1 (CADR CHL))) (|replace| (SELECTION DCH) |of| SEL |with| (ADD1 (IDIFFERENCE (CADR CHL) (CAR CHL)))) (|replace| (SELECTION POINT) |of| SEL |with| 'RIGHT) (|replace| (SELECTION SET) |of| (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ) |with| NIL) (|replace| (SELECTION SELKIND) |of| SEL |with| 'CHAR) (|replace| (SELECTION \\TEXTOBJ) |of| SEL |with| TEXTOBJ) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* |And| |never| |pending| \a  |deletion.|) (|for| LINE |inside| (|fetch| (SELECTION L1) |of| (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ)) |when| LINE |do| (|replace| (LINEDESCRIPTOR YBOT) |of| LINE |with| (SUB1 (|fetch| (REGION BOTTOM) |of| WREG)))) (* |Make| |sure| |it| |thinks| |the|  |old| |selection| |is| |off-screen|  |for| |now|) (|for| LINE |inside| (|fetch| (SELECTION LN) |of| (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ)) |when| LINE |do| (|replace| (LINEDESCRIPTOR YBOT) |of| LINE |with| (SUB1 (|fetch| (REGION BOTTOM) |of| WREG)))) (BITBLT NIL 0 0 W 0 (|fetch| (REGION BOTTOM) |of| WREG) WWIDTH (IDIFFERENCE WHEIGHT (|fetch| (REGION BOTTOM) |of| WREG)) 'TEXTURE 'REPLACE WHITESHADE) (SETQ LINE (\\TEDIT.FIND.FIRST.LINE TEXTOBJ WHEIGHT (CAR CHL) W)) (* |Find| |the| |first| |line| |to|  |go| |in| |the| |window|) (|replace| (LINEDESCRIPTOR YBOT) |of| LINE |with| (IDIFFERENCE WHEIGHT (|fetch| (LINEDESCRIPTOR LHEIGHT) |of| LINE))) (|replace| (LINEDESCRIPTOR YBASE) |of| LINE |with| (IPLUS (|fetch| (LINEDESCRIPTOR YBOT) |of| LINE) (|fetch| (LINEDESCRIPTOR DESCENT) |of| LINE))) (\\DISPLAYLINE TEXTOBJ LINE W) (\\FILLWINDOW (|fetch| (LINEDESCRIPTOR YBOT) |of| LINE) LINE TEXTOBJ NIL W) (|replace| (SELECTION HASCARET) |of| (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ) |with| NIL) (|replace| (SELECTION HASCARET) |of| SEL |with| NIL) (* |Make| |sure| |selection| |has|  |no| |caret|) (|replace| (SELECTION HOWHEIGHT) |of| SEL |with| 16384) (* |Full| |height| |for|  |highlighting|) (COND ((|fetch| (SELECTION SET) |of| SEL) (\\FIXSEL SEL TEXTOBJ) (\\SHOWSEL SEL NIL T))) (COND ((|fetch| (SELECTION SET) |of| (|fetch| (TEXTOBJ SHIFTEDSEL ) |of| TEXTOBJ)) (\\FIXSEL (|fetch| (TEXTOBJ SHIFTEDSEL) |of| TEXTOBJ) TEXTOBJ) (AND SHIFTEDSELWASON (\\SHOWSEL (|fetch| (TEXTOBJ SHIFTEDSEL) |of| TEXTOBJ) NIL T)))) (COND ((|fetch| (SELECTION SET) |of| (|fetch| (TEXTOBJ MOVESEL) |of| TEXTOBJ)) (\\FIXSEL (|fetch| (TEXTOBJ MOVESEL) |of| TEXTOBJ) TEXTOBJ) (AND MOVESELWASON (\\SHOWSEL (|fetch| (TEXTOBJ MOVESEL) |of| TEXTOBJ) NIL T)))) (COND ((|fetch| (SELECTION SET) |of| (|fetch| (TEXTOBJ DELETESEL) |of| TEXTOBJ)) (\\FIXSEL (|fetch| (TEXTOBJ DELETESEL) |of| TEXTOBJ) TEXTOBJ) (AND DELETESELWASON (\\SHOWSEL (|fetch| (TEXTOBJ DELETESEL) |of| TEXTOBJ) NIL T)))) (\\TEDIT.SET.WINDOW.EXTENT TEXTOBJ W) (WINDOWPROP W 'TEDIT.LAST.FIND.STRING FTEXT) (* |And| |get| |it| |into| |the|  |window|) (WINDOWPROP W 'TEDIT.LAST.FIND.POSITION (CAR CHL)) (* |Store| |last| |found| |position|) ) (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found)") (WINDOWPROP W 'TEDIT.LAST.FIND.POSITION NIL) (* |reset| |last| |position| |found|) (\\SHOWSEL (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ) NIL T)))))))) (TEXEC.FIND.BACKWARD (LAMBDA (TEXTOBJ) (* \; "Edited 30-May-91 19:17 by jds") (* |Case| |sensitive| |search,|  |with| * |and| \# |wildcards|) (PROG* (FTEXT CHL (SEL (|fetch| (TEXTOBJ SCRATCHSEL) |of| TEXTOBJ)) (SHIFTEDSELWASON (|fetch| (SELECTION ONFLG) |of| (|fetch| (TEXTOBJ SHIFTEDSEL) |of| TEXTOBJ))) (MOVESELWASON (|fetch| (SELECTION ONFLG) |of| (|fetch| (TEXTOBJ MOVESEL ) |of| TEXTOBJ))) (DELETESELWASON (|fetch| (SELECTION ONFLG) |of| (|fetch| (TEXTOBJ DELETESEL) |of| TEXTOBJ))) (W (|fetch| (TEXTOBJ SELWINDOW) |of| TEXTOBJ)) (LINES (WINDOWPROP W 'LINES)) (LINE (|fetch| (LINEDESCRIPTOR NEXTLINE) |of| LINES)) (WREG (DSPCLIPPINGREGION NIL W)) (WHEIGHT (|fetch| (REGION HEIGHT) |of| WREG)) (WWIDTH (|fetch| (REGION WIDTH) |of| WREG))) (SETQ FTEXT (TEDIT.GETINPUT TEXTOBJ "Text to find: " (WINDOWPROP W 'TEDIT.LAST.FIND.STRING) (CHARCODE (EOL LF ESC)))) (COND (FTEXT (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) (* I\f |the| |selection| |is| |at| |the| |caret,| |then| |always| |start|  |there.| |Otherwise| |check| |if| \a |previous| |find| |is| |in| |view,| |and|  |if| |not| |just| |start| |at| |the| |caret|) (SETQ CHL (TEDIT.FIND.BACKWARD TEXTOBJ (MKSTRING FTEXT) (COND ((|fetch| (SELECTION SET) |of| (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ)) (|fetch| (SELECTION CH#) |of| (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ)) ) (T (OR (AND (|fetch| (SELECTION SET) |of| SEL) (WINDOWPROP W 'TEDIT.LAST.FIND.POSITION)) (|fetch| (SELECTION CH#) |of| (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ))))) 1 T)) (COND (CHL (* W\e |found| |the| |target|  |text.|) (TEDIT.PROMPTPRINT TEXTOBJ "Done.") (COND ((|fetch| (SELECTION SET) |of| SEL) (* |Turn| |any| |selections| |off|) (\\SHOWSEL SEL NIL NIL))) (|replace| (SELECTION SET) |of| SEL |with| T) (|for| CARET |inside| (|fetch| (TEXTOBJ CARET) |of| TEXTOBJ) |do| (\\EDIT.UPCARET CARET)) (* |Remove| |any| |visible| |carets|) (\\SHOWSEL (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ) NIL NIL) (|replace| (SELECTION CH#) |of| SEL |with| (SUB1 (IDIFFERENCE (CAR CHL) (IDIFFERENCE (CADR CHL) (CAR CHL))))) (* |Set| |up| SELECTION |to| |be|  |the| |found| |text|) (|replace| (SELECTION CHLIM) |of| SEL |with| (CAR CHL)) (|replace| (SELECTION DCH) |of| SEL |with| (ADD1 (IDIFFERENCE (CADR CHL) (CAR CHL)))) (|replace| (SELECTION POINT) |of| SEL |with| 'LEFT) (|replace| (SELECTION SET) |of| (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ) |with| NIL) (|replace| (SELECTION SELKIND) |of| SEL |with| 'CHAR) (|replace| (SELECTION \\TEXTOBJ) |of| SEL |with| TEXTOBJ) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* |And| |never| |pending| \a  |deletion.|) (|for| LINE |inside| (|fetch| (SELECTION L1) |of| (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ)) |when| LINE |do| (|replace| (LINEDESCRIPTOR YBOT) |of| LINE |with| (SUB1 (|fetch| (REGION BOTTOM) |of| WREG)))) (* |Make| |sure| |it| |thinks| |the|  |old| |selection| |is| |off-screen|  |for| |now|) (|for| LINE |inside| (|fetch| (SELECTION LN) |of| (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ)) |when| LINE |do| (|replace| (LINEDESCRIPTOR YBOT) |of| LINE |with| (SUB1 (|fetch| (REGION BOTTOM) |of| WREG)))) (BITBLT NIL 0 0 W 0 (|fetch| (REGION BOTTOM) |of| WREG) WWIDTH (IDIFFERENCE WHEIGHT (|fetch| (REGION BOTTOM) |of| WREG)) 'TEXTURE 'REPLACE WHITESHADE) (SETQ LINE (\\TEDIT.FIND.FIRST.LINE TEXTOBJ WHEIGHT (CAR CHL) W)) (* |Find| |the| |first| |line| |to|  |go| |in| |the| |window|) (|replace| (LINEDESCRIPTOR YBOT) |of| LINE |with| (IDIFFERENCE WHEIGHT (|fetch| (LINEDESCRIPTOR LHEIGHT) |of| LINE))) (|replace| (LINEDESCRIPTOR YBASE) |of| LINE |with| (IPLUS (|fetch| (LINEDESCRIPTOR YBOT) |of| LINE) (|fetch| (LINEDESCRIPTOR DESCENT) |of| LINE))) (\\DISPLAYLINE TEXTOBJ LINE W) (\\FILLWINDOW (|fetch| (LINEDESCRIPTOR YBOT) |of| LINE) LINE TEXTOBJ NIL W) (|replace| (SELECTION HASCARET) |of| (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ) |with| NIL) (|replace| (SELECTION HASCARET) |of| SEL |with| NIL) (* |Make| |sure| |selection| |has|  |no| |caret|) (|replace| (SELECTION HOWHEIGHT) |of| SEL |with| 16384) (* |Full| |height| |for|  |highlighting|) (COND ((|fetch| (SELECTION SET) |of| SEL) (\\FIXSEL SEL TEXTOBJ) (\\SHOWSEL SEL NIL T))) (COND ((|fetch| (SELECTION SET) |of| (|fetch| (TEXTOBJ SHIFTEDSEL ) |of| TEXTOBJ)) (\\FIXSEL (|fetch| (TEXTOBJ SHIFTEDSEL) |of| TEXTOBJ) TEXTOBJ) (AND SHIFTEDSELWASON (\\SHOWSEL (|fetch| (TEXTOBJ SHIFTEDSEL) |of| TEXTOBJ) NIL T)))) (COND ((|fetch| (SELECTION SET) |of| (|fetch| (TEXTOBJ MOVESEL) |of| TEXTOBJ)) (\\FIXSEL (|fetch| (TEXTOBJ MOVESEL) |of| TEXTOBJ) TEXTOBJ) (AND MOVESELWASON (\\SHOWSEL (|fetch| (TEXTOBJ MOVESEL) |of| TEXTOBJ) NIL T)))) (COND ((|fetch| (SELECTION SET) |of| (|fetch| (TEXTOBJ DELETESEL) |of| TEXTOBJ)) (\\FIXSEL (|fetch| (TEXTOBJ DELETESEL) |of| TEXTOBJ) TEXTOBJ) (AND DELETESELWASON (\\SHOWSEL (|fetch| (TEXTOBJ DELETESEL) |of| TEXTOBJ) NIL T)))) (\\TEDIT.SET.WINDOW.EXTENT TEXTOBJ W) (WINDOWPROP W 'TEDIT.LAST.FIND.STRING FTEXT) (* |And| |get| |it| |into| |the|  |window|) (WINDOWPROP W 'TEDIT.LAST.FIND.POSITION (CAR CHL)) (* |Store| |last| |found| |position|) ) (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found)") (WINDOWPROP W 'TEDIT.LAST.FIND.POSITION NIL) (* |reset| |last| |position| |found|) (\\SHOWSEL (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ) NIL T)))))))) (TEDIT.FIND.BACKWARD (LAMBDA (TEXTOBJ TARGETSTRING START# END# WILDCARDS?) (* \; "Edited 30-May-91 19:17 by jds") (* I\f WILDCARDS? |is| NIL |then| TEDIT.FIND.BACKWARD |is| |the| |old|  TEDIT.FIND. |Else,| |it| |returns| \a |list| |of|  (SEL.START# SEL.END#) |which| |is| |the| |start| |and| |end| |char| |positions|  |of| |the| |selection|) (PROG ((TEDIT.WILDCARD.CHARACTERS '("#" "*"))) (AND TARGETSTRING (NOT (STRINGP TARGETSTRING)) (SETQ TARGETSTRING (MKSTRING TARGETSTRING))) (SETQ TEXTOBJ (TEXTOBJ TEXTOBJ)) (\\TEDIT.HISTORYADD TEXTOBJ (|create| TEDITHISTORYEVENT THACTION _ '|Find| THAUXINFO _ TARGETSTRING)) (|replace| (TEXTOBJ \\INSERTPCVALID) |of| TEXTOBJ |with| NIL) (* |Any| FIND |invalidates| |the|  |type-in| |cache.|) (RETURN (COND (WILDCARDS? (* |will| |return| \a |list| |of| |start| |and| |end| |of| |selection| |or|  |nil| |if| |not| |found|) (PROG (TARGETLIST SEL RESULT RESULT1) (RETURN (COND ((OR START# (AND (|fetch| (SELECTION SET) |of| (SETQ SEL (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ))) (LEQ (SETQ START# (SELECTQ (|fetch| (SELECTION POINT) |of| SEL) (LEFT (|fetch| (SELECTION CH#) |of| SEL)) (RIGHT (|fetch| (SELECTION CHLIM) |of| SEL)) NIL)) (OR END# (SETQ END# 1))))) (* |Backwards| |search|) (COND ((AND (|for| X |in| (SETQ TARGETLIST (\\TEDIT.PARSE.SEARCHSTRING (|for| X |in| (UNPACK (MKATOM TARGETSTRING )) |collect| (MKSTRING X)))) |collect| X |when| (LITATOM X)) (SETQ RESULT1 (\\TEDIT.SUBST.FN1 TEXTOBJ TARGETLIST END# START#))) (* I\f |there| |are| |atoms,| |they|  |are| |tedit| |wildcard| |chars|) (\\TEDIT.FIND.WC TEXTOBJ TARGETLIST RESULT1 START#)) (T (* |no| |wildcards| |but| |bounded|  |search|) (COND ((SETQ RESULT (TEDIT.FIND.BACKWARD TEXTOBJ (CAR TARGETLIST ) START# END# NIL)) (LIST RESULT (SUB1 (IPLUS RESULT (NCHARS (CAR TARGETLIST)) )))))))))))) (T (* |will| |return| |just| |the|  |number| |of| |the| |start| |char|  |or| |nil| |if| |not| |found|) (PROG (RESULT) (SETQ RESULT (TEDIT.BASICFIND.BACKWARD TEXTOBJ TARGETSTRING START# 1)) (RETURN (COND ((NULL END#) RESULT) ((OR (NULL RESULT)) NIL) (T RESULT)))))))))) (TEDIT.BASICFIND.BACKWARD (LAMBDA (TEXTOBJ STRING CH# CHLIM) (* \; "Edited 30-May-91 19:17 by jds") (* |Search| |thru| TEXTOBJ\, |starting| |where| |the| |caret| |is,| |for| |the|  |string| STRING\, |exact| |match| |only| |for| |now.|  (|Optionally,| |start| |the| |search| |at| |character| |ch#.|)) (PROG ((SEL (|fetch| (TEXTOBJ SEL) |of| TEXTOBJ)) (TEXTLEN (|fetch| (TEXTOBJ TEXTLEN) |of| TEXTOBJ)) (TEXTLIM (OR CHLIM (ADD1 (IDIFFERENCE (|fetch| (TEXTOBJ TEXTLEN) |of| TEXTOBJ) (NCHARS STRING))))) (TEXTSTREAM (|fetch| (TEXTOBJ STREAMHINT) |of| TEXTOBJ)) (FOUND NIL) CH1 CH CH#1 (RSTRING "") (TSTRING (CONCAT STRING)) ANCHOR PCH# OANCHOR CH) (* |Reverse| |the| |string|) (|while| (SETQ CH (GLC TSTRING)) |do| (SETQ RSTRING (CONCAT RSTRING (MKSTRING CH)))) (SETQ CH#1 (NTHCHARCODE RSTRING 1)) (|replace| (TEXTOBJ \\INSERTPCVALID) |of| TEXTOBJ |with| NIL) (* |2/12/85| JDS\: I |don't| |understand| WHY |this| |is| |here,| |but| |I'll|  |assume| |it's| |right| |for| |now.|) (* |Prohibit| |future| |insertions|  |in| |the| |current| |piece.|) (COND ((OR CH# (|fetch| (SELECTION SET) |of| SEL)) (* |There| |must| |be| \a  |well-defined| |starting| |point.|) (RETURN (PROG NIL (SETQ CH1 (SUB1 (OR CH# (SELECTQ (|fetch| (SELECTION POINT) |of| SEL) (LEFT (|fetch| (SELECTION CH#) |of| SEL)) (RIGHT (|fetch| (SELECTION CHLIM) |of| SEL)) NIL)))) (* |Find| |the| |starting| |point|  |for| |the| |search|) (* DO THE SEARCH) (COND ((ILESSP CH1 2) (* |Starting| |the| |search| |past|  |the| |last| |possible| |starting|  |point.| |Just| |punt.|) (RETURN NIL))) RETRY (SETQ ANCHOR CH1) (\\SETUPGETCH ANCHOR TEXTOBJ) (|for| |old| ANCHOR |from| CH1 |by| -1 |to| 2 |do| (SETQ CH (\\BACKBIN TEXTSTREAM)) (COND ((EQ CH CH#1) (RETURN)))) (COND ((ILEQ ANCHOR 2) (RETURN NIL))) (* N\o |starting| |character|  |found| |before| |end| |of| |string|) (SETQ OANCHOR ANCHOR) (SETQ FOUND T) (|for| |old| CH1 |from| (SUB1 ANCHOR) |to| 2 |by| -1 |as| PCH# |from| 2 |to| (NCHARS STRING) |do| (SETQ CH (\\BACKBIN TEXTSTREAM)) (COND ((NEQ CH (NTHCHARCODE RSTRING PCH#)) (SETQ FOUND NIL) (RETURN)))) (COND (FOUND (RETURN ANCHOR)) (T (GO RETRY)))))))))) (TEXEC.MENU.WHENHELDFN (LAMBDA (ITEM MENU BUTTON) (* AJB "30-Jan-86 13:09") (PROMPTPRINT (SELECTQ (CAR ITEM) (|Put| "Sends the document to a file") (|Get| "Gets a new file as the document to edit.") (|Include| "Includes a file at the cursor") (|ForwardFind| "Searches forward for a string of text") (|BackwardFind| "Searches backward for a string of text") (|Limit| "Limits the number of characters in the textstream in memory") "")))) (TEXEC.SHRINK.ICONCREATE (LAMBDA (W ICON ICONW) (* AJB " 7-Jan-86 16:37") (* |Create| |the| |icon| |that|  |represents| |this| |window.|) (PROG ((ICON (WINDOWPROP W 'ICON)) (ICONTITLE (WINDOWPROP W 'TEDIT.ICON.TITLE)) (SHRINKFN (WINDOWPROP W 'SHRINKFN))) (COND ((NOT (WINDOWPROP W 'TEXTOBJ)) (* |This| |isn't| |really| \a |TEdit| |window| |any| |more.|  |Don't| |do| |anything|) NIL) ((WINDOWPROP W 'TEDITMENU) (* |This| |is| \a |text| |menu,| |and|  |shrinks| |without| |trace.|) NIL) ((OR (IGREATERP (FLENGTH SHRINKFN) 3) (AND (NOT (FMEMB 'SHRINKATTACHEDWINDOWS SHRINKFN)) (IGREATERP (FLENGTH SHRINKFN) 2))) (* |There| |are| |other| |functions| |that| |expect| |to| |handle| |this.|  |Don't| |bother.|) NIL) ((OR (AND ICONTITLE (EQUAL ICONTITLE (PROCESSPROP (WINDOWPROP W 'PROCESS) 'NAME))) (AND (NOT ICONTITLE) ICON)) (* |we| |built| |this| |and| |the| |title| |is| |the| |same,| |or| |he| |has|  |already| |put| |an| |icon| |on| |this.|  D\o |nothing|) NIL) (ICON (* |There's| |an| |existing| |icon| |window;|  |change| |the| |title| |in| |it|) (WINDOWPROP W 'TEDIT.ICON.TITLE (SETQ ICONTITLE (PROCESSPROP (WINDOWPROP W 'PROCESS) 'NAME))) (ICONTITLE ICONTITLE NIL NIL ICON)) (T (* |install| \a |new| |icon|) (WINDOWPROP W 'TEDIT.ICON.TITLE (SETQ ICONTITLE (PROCESSPROP (WINDOWPROP W 'PROCESS) 'NAME))) (WINDOWPROP W 'ICON (TITLEDICONW TEXEC.TITLED.ICON.TEMPLATE ICONTITLE TEXEC.ICON.FONT NIL T '(BOTTOM LEFT)))))) (WINDOWPROP W 'ICON))) (TEXEC.FILLBUFFER (LAMBDA (FILLTYPE) (* \; "Edited 30-May-91 19:18 by jds") (* |;;;| "While filling the line, the current file pointer is the end of the line. When the line is closed, this is made the eof. --- #CURRENTRDTBL# is used for syntactic delimiters and paren counting on READ and RATOM calls but isn't referenced (or bound) for READC") (DECLARE (USEDFREE \#CURRENTRDTBL# \\PRIMTERMTABLE *READ-NEWLINE-SUPPRESS* \\TERM.OFD) (SPECVARS RSNX TCLASS RTBLSA RAISEDCHAR FILLTYPE RAISEDCHAR PEEKEDECHOED C)) (\\RESETLINE) (* |;;;| "If ERROR or RESET, move STARTINGEOF to end of text (TEXTLEN)") (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA NIL (COND (RESETSTATE (* \;  "Point to end of text and clearout linebuffer on RESET or ERROR") (PROG* ((TEXOBJ (|fetch| (TEXTSTREAM TEXTOBJ) |of| \\TERM.OFD)) (SEL (|fetch| (TEXTOBJ SEL) |of| TEXOBJ))) (TEXTPROP TEXOBJ 'STARTINGEOF (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ)) (|replace| (STREAM REVALIDATEFLG) |of| \\LINEBUF.OFD |with| NIL) (\\RESETTERMINAL) (\\SHOWSEL SEL) (|replace| (SELECTION CH#) |of| SEL |with| (ADD1 (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ))) (|replace| (SELECTION CHLIM) |of| SEL |with| (ADD1 (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ))) (|replace| (SELECTION POINT) |of| SEL |with| 'LEFT) (|replace| (SELECTION DCH) |of| SEL |with| 0) (|replace| (SELECTION SET) |of| SEL |with| T) (\\FIXSEL SEL TEXOBJ)))))))) (PROG* ((RTBLSA (|fetch| READSA |of| \#CURRENTRDTBL#)) (CONTROLTON (|fetch| CONTROLFLG |of| \\PRIMTERMTABLE)) (TEXOBJ (|fetch| (TEXTSTREAM TEXTOBJ) |of| \\TERM.OFD)) (SEL (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)) (WINDOW (|fetch| (TEXTOBJ \\WINDOW) |of| TEXOBJ)) (LINES (|fetch| (TEXTOBJ LINES) |of| TEXOBJ)) RSNX TCLASS C RAISEDCHAR PEEKEDECHOED TTYWINDOW FN TCH INSCH# CHNO ADDEDEOL) (* |;;;| "STARTINGEOF is the beginning of the current text being entered which gets returned to READ so that \\TEXEC.TEXTBOUT knows where to output any text including ^T") (* |;;;| "TCLASS is terminal syntax class, RSNX is read-table code") (TEXTPROP TEXOBJ 'STARTINGEOF (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ)) (* \; "Keep STARTINGEOF in sync") (COND ((SETQ C (|fetch| (LINEBUFFER PEEKEDCHAR) |of| \\LINEBUF.OFD)) (* \; "Account for peeked character") (SETQ C (IABS C)) (* \;  "The peeked char may be negative because it was BIN'ed earlier. Make sure it is positive.") (|replace| (LINEBUFFER PEEKEDCHAR) |of| \\LINEBUF.OFD |with| NIL) (SETQ PEEKEDECHOED T) (SETQ RAISEDCHAR (\\RAISECHAR C)) (COND ((EQ FILLTYPE READ.FT) (TEXTPROP TEXOBJ 'STARTINGEOF (SUB1 (TEXTPROP TEXOBJ 'STARTINGEOF))))) (* \; "Backup one in textstream to start the input before the peeked and echoed character if doing a READ") )) (COND ((AND CONTROLTON (EQ FILLTYPE READC.FT)) (TEXEC.INSERTCHAR TEXOBJ C) (* \;  "Read single char and check for echoing") (GO EXIT))) (* \;  "If in CONTROL T mode and reading a single char") (COND (C (* |;;| "Working on the previously-peeked char, so skip the keyboard read. Since the peeked char has been inserted in the TEdit buffer already, back up the starting-eof counter to include it.") (TEXTPROP TEXOBJ 'STARTINGEOF (SUB1 (TEXTPROP TEXOBJ 'STARTINGEOF))) (* |;;| "Then go skip the kbd read.") (GO NEXTTCLASS))) (* |;;| "- - -") (* |;;| "Top of the next-character loop") (* |;;| "- - -") (\\SHOWSEL SEL NIL NIL) (\\SHOWSEL SEL NIL T) NEXT (SETQ C (TEXEC.GETKEY TEXOBJ)) (* \;  "read next character from keyboard") NEXTTCLASS (SETQ TCLASS (|fetch| TERMCLASS |of| (\\SYNCODE \\PRIMTERMSA (SETQ RAISEDCHAR (\\RAISECHAR C))))) REDO (* |;;;| "Handle Terminal Class characters") (SELECTQ (TEXEC.FILLBUFFER.TCLASS TEXOBJ SEL) (NEXT (GO NEXT)) (EXIT (GO EXIT)) NIL) (* |;;;| "Here if it isn't a terminal class.") (COND (PEEKEDECHOED (SETQ PEEKEDECHOED NIL)) (T (TEXEC.INSERTCHAR TEXOBJ C))) (AND (EQ FILLTYPE READC.FT) (GO NEXT)) (COND ((EQ ESCAPE.RC (SETQ RSNX (\\SYNCODE RTBLSA RAISEDCHAR))) (COND ((EQ CTRLV.TC (SETQ TCLASS (|fetch| TERMCLASS |of| (\\SYNCODE \\PRIMTERMSA (SETQ RAISEDCHAR (TEXEC.INSERTCHAR TEXOBJ)))))) (GO REDO))) (GO NEXT))) (SELECTC FILLTYPE (RATOM/RSTRING.FT (COND ((AND CONTROLTON (|fetch| STOPATOM |of| RSNX)) (GO EXIT)))) (READ.FT (SELECTC RSNX ((LIST RIGHTPAREN.RC RIGHTBRACKET.RC LEFTPAREN.RC LEFTBRACKET.RC STRINGDELIM.RC) (COND ((NOT (TEXEC.EOTP TEXOBJ)) (|replace| (STREAM REVALIDATEFLG) |of| \\LINEBUF.OFD |with| T) (* \;  "Inserting a paren/bracket in the middle of the input, invalidate paren/bracket count") )) (SELECTC RSNX ((LIST RIGHTPAREN.RC RIGHTBRACKET.RC) (TEXEC.FLASHCARET TEXOBJ (TEXEC.PARENMATCH TEXOBJ RSNX))) NIL)) NIL) (COND ((AND CONTROLTON (ZEROP (|fetch| (LINEBUFFER LBRKCOUNT) |of| \\LINEBUF.OFD)) (ZEROP (|fetch| (LINEBUFFER LPARCOUNT) |of| \\LINEBUF.OFD)) (|fetch| STOPATOM |of| RSNX) (SELECTC RSNX ((LIST LEFTPAREN.RC LEFTBRACKET.RC RIGHTBRACKET.RC RIGHTPAREN.RC) NIL) (STRINGDELIM.RC (COND ((|fetch| (LINEBUFFER INSTRINGP) |of| \\LINEBUF.OFD ) (|replace| (LINEBUFFER INSTRINGP) |of| \\LINEBUF.OFD |with| NIL) T))) (NOT (|fetch| (LINEBUFFER INSTRINGP) |of| \\LINEBUF.OFD )))) (* |;;| "READ is reading an atom. Return when atom ends, but also obey bracket/paren exception noted on page 14.33 of manual.") (GO EXIT))) (COND ((TEXEC.EOTP TEXOBJ) (COND ((|fetch| (STREAM REVALIDATEFLG) |of| \\LINEBUF.OFD) (TEXEC.PARENCOUNT TEXOBJ) (* \;  "text needs recount of parens/brackets") )) (COND ((\\INCPARENCOUNT RSNX) (COND ((STREAMPROP \\TERM.OFD 'FIXFLG) (STREAMPROP \\TERM.OFD 'FIXFLG NIL) (* \;  "Expression is being FIXed by user, reset FIXFLG and go for more input") (GO NEXT))) (* |;;| "Parens balance--throw the carriage if the closing paren or bracket character was not a CR, and if FLG argument of READ is NIL. (We know we are under a READ call because of FILLTYPE)") (* \;  "copy the chars from the textstream into the linebuffer") (TEXEC.TEXTSTREAM.TO.LINEBUF TEXOBJ (TEXTPROP TEXOBJ 'STARTINGEOF) \\LINEBUF.OFD FILLTYPE) (* \;  "AND (EQ FILLTYPE READ.FT) (TEXEC.FIX? TEXOBJ \\LINEBUF.OFD) (GO NEXT)") (* \;  "If it was a PA FIX command handle it, and allow editing") (* \;  "now reset the new STARTINGEOF to start at the end of the text") (TEXTPROP TEXOBJ 'STARTINGEOF (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ)) (\\CLOSELINE) (AND (NEQ RAISEDCHAR (CHARCODE EOL)) (NOT *READ-NEWLINE-SUPPRESS*) (\\OUTCHAR \\TERM.OFD (CHARCODE EOL))) (* \;  "\\CLOSELINE first so dribble happens before EOL") (RETURN)) ((EQ IMMEDIATE.RMW (|fetch| WAKEUP |of| RSNX)) (* \; "Immediate read-macro") (RETURN)))))) (SHOULDNT)) (GO NEXT) EXIT (COND ((STREAMPROP \\TERM.OFD 'FIXFLG) (STREAMPROP \\TERM.OFD 'FIXFLG NIL) (COND ((NEQ RAISEDCHAR (CHARCODE EOL)) (* \;  "Expression is being FIXed by user, reset FIXFLG and go for more input") (GO NEXT))))) (COND ((AND (EQ FILLTYPE READ.FT) (EQ RAISEDCHAR (CHARCODE EOL)) (EQ (SUB1 (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ)) (TEXTPROP TEXOBJ 'STARTINGEOF))) (\\LINEBUFBOUT \\LINEBUF.OFD (CAR (GETSYNTAX 'RIGHTBRACKET \#CURRENTRDTBL#))) (* |;;| "If doing a READ, force a lone CR to terminate the READ by handing back a RIGHTBRACKET into the LINEBUFFER") ) (T (TEXEC.TEXTSTREAM.TO.LINEBUF TEXOBJ (TEXTPROP TEXOBJ 'STARTINGEOF) \\LINEBUF.OFD FILLTYPE))) (TEXTPROP TEXOBJ 'STARTINGEOF (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ)) (* \;  "AND (EQ FILLTYPE READ.FT) (TEXEC.FIX? TEXOBJ \\LINEBUF.OFD) (GO NEXT)") (* \;  "If it was a PA FIX command handle it, and allow editing") (\\CLOSELINE) (AND (NEQ RAISEDCHAR (CHARCODE EOL)) (NOT CONTROLTON) (NOT *READ-NEWLINE-SUPPRESS*) (\\OUTCHAR \\TERM.OFD (CHARCODE EOL))))))) (TEXEC.FILLBUFFER.TCLASS (LAMBDA (TEXOBJ SEL) (* \; "Edited 30-May-91 19:18 by jds") (* |;;| "Handle special terminal class characters") (DECLARE (USEDFREE \\LINEBUF.OFD PEEKEDECHOED C FILLTYPE TCLASS)) (PROG NIL (SELECTC TCLASS (RETYPE.TC (RETURN 'NEXT) (* \;  "Ignore ^R since the user can rescroll the line") ) (CHARDELETE.TC (TEXEC.FILLBUFFER.CHARDELETE TEXOBJ) (RETURN 'NEXT)) (WORDDELETE.TC (TEXEC.FILLBUFFER.WORDDELETE TEXOBJ) (RETURN 'NEXT)) (LINEDELETE.TC (TEXEC.FILLBUFFER.LINEDELETE TEXOBJ) (RETURN 'NEXT)) (CTRLV.TC (COND (PEEKEDECHOED (SETQ PEEKEDECHOED NIL))) (TEXEC.INSERTCHAR TEXOBJ C) (COND ((NEQ FILLTYPE READC.FT) (SETQ C (TEXEC.GETKEY TEXOBJ)))) (SETQQ TCLASS NONE.TC)) (EOL.TC (AND (EQ FILLTYPE READ.FT) (TEXEC.?EQUAL TEXOBJ) (TRUE (TEXEC.INSERTCHAR TEXOBJ (CHARCODE EOL))) (RETURN 'EXIT) (* \; "Let READ handle ? and ?=") ) (TEXEC.INSERTCHAR TEXOBJ C) (COND ((EQ FILLTYPE READ.FT) (* \; "If we are doing a 'READ'") (* |;;| "If we are at the end of the input now, update parencount if invalid, and test for matching paren/bracket count") (AND (TEXEC.EOTP TEXOBJ) (COND ((|fetch| (STREAM REVALIDATEFLG) |of| \\LINEBUF.OFD) (TEXEC.PARENCOUNT TEXOBJ)) (T T)) (ZEROP (|fetch| (LINEBUFFER LBRKCOUNT) |of| \\LINEBUF.OFD)) (ZEROP (|fetch| (LINEBUFFER LPARCOUNT) |of| \\LINEBUF.OFD)) (NOT (|fetch| (LINEBUFFER INSTRINGP) |of| \\LINEBUF.OFD)) (RETURN 'EXIT) (* \; "Proper termination of READ") ) (RETURN 'NEXT) (* \; "Else go for more input") ) (T (RETURN 'EXIT) (* \;  "Exit always if not in 'READ' mode") ))) NIL) (COND ((EQ C 127) (* \; "DELETE") (COND ((AND (|fetch| (TEXTOBJ BLUEPENDINGDELETE) |of| TEXOBJ) (IGREATERP (|fetch| (SELECTION CH#) |of| SEL) (TEXTPROP TEXOBJ 'STARTINGEOF))) (* \;  "Only allow deletion of selection if left side of selection is after start of current input") (\\TEDIT.DELETE SEL TEXOBJ) (* \;  "Erase characters from the screen") (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* \;  "Make it a normal selection again.") (|replace| (STREAM REVALIDATEFLG) |of| \\LINEBUF.OFD |with| T))) (* \; "invalidate paren/bracket count") (RETURN 'NEXT))) (COND ((FMEMB C (LIST (CHARCODE ^U) (CHARCODE ^Q))) (* \; "Delete a line") (TEXEC.FILLBUFFER.LINEDELETE TEXOBJ) (RETURN 'NEXT))) (COND ((EQ C (CHARCODE ^X)) (* \; "^X positions to end of text") (\\SETUPGETCH (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ) TEXOBJ) (|replace| (SELECTION CH#) |of| SEL |with| (ADD1 (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ))) (|replace| (SELECTION CHLIM) |of| SEL |with| (|fetch| (SELECTION CH#) |of| SEL)) (|replace| (SELECTION POINT) |of| SEL |with| 'LEFT) (|replace| (SELECTION DCH) |of| SEL |with| 0) (|replace| (SELECTION SET) |of| SEL |with| T) (|replace| (SELECTION HASCARET) |of| SEL |with| T) (UNINTERRUPTABLY (\\CHECKCARET) (|for| CARET |inside| (|fetch| (TEXTOBJ CARET) |of| TEXOBJ) |as| WIN |inside| (|fetch| (TEXTOBJ \\WINDOW) |of| TEXOBJ) |do| (\\FIXSEL SEL TEXOBJ WIN) (MOVETO (|fetch| (SELECTION X0) |of| SEL) (|fetch| (SELECTION Y0) |of| SEL) WIN) (|replace| TCCARETX |of| CARET |with| (|fetch| (SELECTION X0) |of| SEL)) (|replace| TCCARETY |of| CARET |with| (|fetch| (SELECTION Y0) |of| SEL)))) (RETURN 'NEXT)))))) (TEXEC.CHSELPENDING (LAMBDA (TEXOBJ) (* \; "Edited 30-May-91 19:18 by jds") (ERSETQ (PROGN (|replace| (TEXTOBJ EDITOPACTIVE) |of| TEXOBJ |with| T) (* |Before| |starting| |to| |work,|  |note| |that| |we| |are| |doing|  |something|) (COND (TEDIT.COPY.PENDING (* |Have| |to| |copy| |the|  |shifted| SEL |to| |caret.|) (SETQ TEDIT.COPY.PENDING NIL) (\\COPYSEL TEDIT.SHIFTEDSELECTION (|fetch| (TEXTOBJ SHIFTEDSEL) |of| TEXOBJ)) (TEDIT.COPY (|fetch| (TEXTOBJ SHIFTEDSEL) |of| TEXOBJ) (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)) (|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| TEXOBJ))) (TEDIT.COPYLOOKS.PENDING (* |Have| |to| |copy| |the|  |shifted| SEL |to| |caret.|) (SETQ TEDIT.COPYLOOKS.PENDING NIL) (\\COPYSEL TEDIT.COPYLOOKSSELECTION (|fetch| (TEXTOBJ SHIFTEDSEL) |of| TEXOBJ)) (COND ((EQ 'PARA (|fetch| (SELECTION SELKIND) |of| (|fetch| (TEXTOBJ SHIFTEDSEL) |of| TEXOBJ))) (* |copy| |the| |paragraph| |looks,|  |since| |the| |source| |selection|  |type| |was| |paragraph|) (TEDIT.COPY.PARALOOKS TEXOBJ (|fetch| (TEXTOBJ SHIFTEDSEL) |of| TEXOBJ) (|fetch| (TEXTOBJ SEL) |of| TEXOBJ))) (T (* |copy| |the| |character| |looks|) (TEDIT.COPY.LOOKS TEXOBJ (|fetch| (TEXTOBJ SHIFTEDSEL) |of| TEXOBJ) (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)))) (\\SHOWSEL (|fetch| (TEXTOBJ SHIFTEDSEL) |of| TEXOBJ) 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| TEXOBJ))) (TEDIT.MOVE.PENDING (* |Have| |to| |move| |the|  |ctrl-shift| SEL |to| |caret.|) (SETQ TEDIT.MOVE.PENDING NIL) (\\COPYSEL TEDIT.MOVESELECTION (|fetch| (TEXTOBJ MOVESEL) |of| TEXOBJ)) (TEDIT.DO.BLUEPENDINGDELETE SEL TEXOBJ) (TEDIT.MOVE (|fetch| (TEXTOBJ MOVESEL) |of| TEXOBJ) (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)) (|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| TEXOBJ))) (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| TEXOBJ) NIL NIL) (* |Turn| |off| |the| |selection|  |highlights|) (\\SHOWSEL (|fetch| (TEXTOBJ SEL) |of| TEXOBJ) NIL NIL) (|replace| (SELECTION SET) |of| (|fetch| (TEXTOBJ DELETESEL ) |of| TEXOBJ) |with| NIL) (\\COPYSEL TEDIT.DELETESELECTION (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)) (\\TEDIT.SET.SEL.LOOKS (|fetch| (TEXTOBJ SEL) |of| TEXOBJ) 'NORMAL) (* |Grab| |the| |selection| |we're|  |to| |use|) (\\TEDIT.DELETE (|fetch| (TEXTOBJ SEL) |of| TEXOBJ) (|fetch| (SELECTION \\TEXTOBJ) |of| (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)) NIL) (|replace| (SELECTION L1) |of| TEDIT.DELETESELECTION |with| NIL) (|replace| (SELECTION LN) |of| TEDIT.DELETESELECTION |with| NIL))))) (|replace| (TEXTOBJ EDITOPACTIVE) |of| TEXOBJ |with| NIL))))) (TEXEC.FILLBUFFER.CHARDELETE (LAMBDA (TEXOBJ) (* AJB " 7-Jan-86 15:03") (DECLARE (USEDFREE FILLTYPE RSNX TCLASS RTBLSA RAISEDCHAR \#CURRENTRDTBL#)) (PROG (C) (COND ((NULL (SETQ C (TEXEC.\\CHDEL1 TEXOBJ))) (* |Try| |deleting| \a |character| (|put| |the| |deleted| |char| |in| C |and|  RETURN C)\. I\f |there| |was| |no| |character| |to| |delete|  (|ie,| |we're| |at| |start| |of| |line|)\,  (RETURN NIL)) (FLASHWINDOW) (RETURN))) (PROG (C1 (ESCAPE? (AND (NEQ FILLTYPE READC.FT) (|fetch| ESCAPEFLG |of| \#CURRENTRDTBL#) ESCAPE.RC))) (COND ((NEQ FILLTYPE READC.FT) (* |Don't| |process| |escapes| |if|  READC) (SETQ RSNX (\\SYNCODE RTBLSA C)) (COND ((SETQ C1 (TEXEC.NTHBUFCHARBACK TEXOBJ 0)) (* |Check| |preceding| |char| C1 |for|  |escape|) (COND ((EQ ESCAPE? (\\SYNCODE RTBLSA C1)) (SETQ RSNX OTHER.RC) (SETQ C (TEXEC.\\CHDEL1 TEXOBJ)) (* |Delete| |the| ESCAPE |char| |also|) )))) (COND ((NULL (|fetch| (STREAM REVALIDATEFLG) |of| \\LINEBUF.OFD)) (\\DECPARENCOUNT RSNX) (* |no| |need| |to| |update| |parencount| |if| |deleting| |chars| |in| |the|  |middle| |of| |the| |text|) ))))) (RETURN C) (* |Successful| |delete|) ))) (TEXEC.FILLBUFFER.WORDDELETE (LAMBDA (TEXOBJ) (* \; "Edited 30-May-91 19:18 by jds") (* |Delete| |chars| |until| |first| |non-sepr/non-other,| |or| |first|  |non-other| |after| |sepr| |string| |and| |other| |string.|  |Note| |that| \a |terminal| |wordsepr| |is| |treated| |as| |if| |it| |were| \a  |read-sepr|) (DECLARE (USEDFREE RSNX RTBLSA \\PRIMTERMSA TCLASS FILLTYPE \#CURRENTRDTBL# \\LINEBUF.OFD)) (PROG* (C (STARTINGEOF (TEXTPROP TEXOBJ 'STARTINGEOF)) (SEL (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)) (ENDCH# (SUB1 (SELECTQ (|fetch| (SELECTION POINT) |of| SEL) (LEFT (COND ((ZEROP (|fetch| (SELECTION DCH) |of| SEL)) (|fetch| (SELECTION CHLIM) |of| SEL)) (T (SUB1 (|fetch| (SELECTION CHLIM) |of| SEL))))) (RIGHT (|fetch| (SELECTION CHLIM) |of| SEL)) NIL))) (CH# ENDCH#)) (COND ((ILEQ CH# (TEXTPROP (CAR (|fetch| (TEXTOBJ \\WINDOW) |of| TEXOBJ)) 'STARTINGEOF)) (FLASHWINDOW) (RETURN))) AGAIN (COND ((SETQ C (PROGN (\\SETUPGETCH CH# TEXOBJ) (\\BIN (|fetch| (TEXTOBJ STREAMHINT) |of| TEXOBJ)))) (SETQ RSNX (\\SYNCODE RTBLSA C)) (SELECTC RSNX (SEPRCHAR.RC (|add| CH# -1) (GO AGAIN) (* |cont| |until| |first| |non-sepr|) ) (OTHER.RC (COND ((EQ WORDSEPR.TC (\\SYNCODE \\PRIMTERMSA C)) (|add| CH# -1) (GO AGAIN) (* |cont| |until| |first| |non-sepr|) )) (PROG (C1 (ESCAPE? (AND (NEQ FILLTYPE READC.FT) (|fetch| ESCAPEFLG |of| \#CURRENTRDTBL#) ESCAPE.RC))) (* |The| |first| OTHER) TRY (COND ((SETQ C (PROGN (\\SETUPGETCH CH# TEXOBJ) (\\BIN (|fetch| (TEXTOBJ STREAMHINT) |of| TEXOBJ)))) (* |look| |at| |previous| |char|) (SETQ RSNX (\\SYNCODE RTBLSA C)) (SETQ TCLASS (\\SYNCODE \\PRIMTERMSA C)) (COND ((SETQ C1 (PROGN (\\SETUPGETCH (SUB1 CH#) TEXOBJ) (\\BIN (|fetch| (TEXTOBJ STREAMHINT) |of| TEXOBJ)))) (COND ((EQ ESCAPE? (\\SYNCODE RTBLSA C1)) (SETQ RSNX OTHER.RC) (SETQ TCLASS NONE.TC))))) (COND ((AND (NEQ TCLASS WORDSEPR.TC) (EQ OTHER.RC RSNX)) (|add| CH# -1)(* |Erase| |it|) (GO TRY))))))) (PROGN (|add| CH# -1) (COND ((EQ FILLTYPE READ.FT) (* |For| READ |filltype| |only,| |Fix| |up| |paren| |count| |if| |we| |still|  |have| \a |valid| |paren| |count| |since| |this| |can| |be| \a |paren| |or|  |bracket| |or| |stringdelimiter|) (COND ((NOT (|fetch| (STREAM REVALIDATEFLG) |of| \\LINEBUF.OFD)) (\\DECPARENCOUNT RSNX))))))))) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* |Make| |it| \a |normal|  |selection| |again.|) (|replace| (SELECTION CH#) |of| SEL |with| (ADD1 CH#)) (|replace| (SELECTION CHLIM) |of| SEL |with| (ADD1 ENDCH#)) (|replace| (SELECTION DCH) |of| SEL |with| (ADD1 (IDIFFERENCE ENDCH# CH#))) (\\TEDIT.DELETE SEL TEXOBJ) (* |Now| |delete| |the| |characters|) ))) (TEXEC.FILLBUFFER.LINEDELETE (LAMBDA (TEXOBJ) (* \; "Edited 30-May-91 19:18 by jds") (* |Delete| |last| |line| |entered|  |by| |user| (^U\, ^Q)) (DECLARE (USEDFREE RSNX RTBLSA \\PRIMTERMSA TCLASS FILLTYPE \#CURRENTRDTBL# \\LINEBUF.OFD)) (PROG* (C (STARTINGEOF (TEXTPROP TEXOBJ 'STARTINGEOF)) (SEL (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)) (ENDCH# (SUB1 (SELECTQ (|fetch| (SELECTION POINT) |of| SEL) (LEFT (COND ((ZEROP (|fetch| (SELECTION DCH) |of| SEL)) (|fetch| (SELECTION CHLIM) |of| SEL)) (T (SUB1 (|fetch| (SELECTION CHLIM) |of| SEL))))) (RIGHT (|fetch| (SELECTION CHLIM) |of| SEL)) NIL))) (CH# ENDCH#)) (COND ((ILEQ CH# (TEXTPROP (CAR (|fetch| (TEXTOBJ \\WINDOW) |of| TEXOBJ)) 'STARTINGEOF)) (FLASHWINDOW) (RETURN))) (|while| (AND (SETQ C (PROGN (\\SETUPGETCH CH# TEXOBJ) (\\BIN (|fetch| (TEXTOBJ STREAMHINT) |of| TEXOBJ) ))) (NEQ C (CHARCODE EOL)) (IGREATERP CH# (TEXTPROP (CAR (|fetch| (TEXTOBJ \\WINDOW) |of| TEXOBJ)) 'STARTINGEOF))) |do| (SETQ RSNX (\\SYNCODE RTBLSA C)) (|add| CH# -1) (COND ((EQ FILLTYPE READ.FT) (* |Invalidate| |paren| |count| |to|  |force| |recalculation|) (|replace| (STREAM REVALIDATEFLG) |of| \\LINEBUF.OFD |with| T)))) (TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* |Make| |it| \a |normal|  |selection| |again.|) (|replace| (SELECTION CH#) |of| SEL |with| (ADD1 CH#)) (|replace| (SELECTION CHLIM) |of| SEL |with| (ADD1 ENDCH#)) (|replace| (SELECTION DCH) |of| SEL |with| (ADD1 (IDIFFERENCE ENDCH# CH#))) (\\TEDIT.DELETE SEL TEXOBJ) (* |Now| |delete| |the| |characters|) ))) (TEXEC.PARENCOUNT (LAMBDA (TEXOBJ) (* \; "Edited 13-Jun-90 00:17 by mitani") (DECLARE (USEDFREE \\LINEBUF.OFD)) (PROG ((STREAM (|fetch| (TEXTOBJ STREAMHINT) |of| TEXOBJ))) (|replace| (LINEBUFFER LPARCOUNT) |of| \\LINEBUF.OFD |with| 0) (|replace| (LINEBUFFER LBRKCOUNT) |of| \\LINEBUF.OFD |with| 0) (|replace| (LINEBUFFER LPARCOUNT) |of| \\LINEBUF.OFD |with| 0) (|replace| (LINEBUFFER INSTRINGP) |of| \\LINEBUF.OFD |with| NIL) (\\SETUPGETCH (TEXTPROP TEXOBJ 'STARTINGEOF) TEXOBJ) (* |Don't| |include| |last|  |character| |otherwise| |it| |will|  |get| |counted| |twice|) (|for| I |from| (TEXTPROP TEXOBJ 'STARTINGEOF) |to| (SUB1 (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ)) |do| (\\INCPARENCOUNT (\\SYNCODE RTBLSA (\\BIN STREAM)))) (|replace| (STREAM REVALIDATEFLG) |of| \\LINEBUF.OFD |with| NIL) (* |Last| |thing| |is| |to| |reset| |the| |validation| |flag,| |and| |always|  RETURN T |for| |AND's| |to| |work|) (RETURN T)))) (TEXEC.PARENMATCH (LAMBDA (TEXOBJ RSNX) (* \; "Edited 13-Jun-90 00:17 by mitani") (* |;;| "Returns CH# if matching left paren/bracket is found, else NIL") (DECLARE (USEDFREE \#CURRENTRDTBL# \\TERM.OFD)) (PROG (MATCH? N CH CH1 CH2 (PCOUNT 0)) (SELECTC RSNX (RIGHTPAREN.RC (SETQ CH (CAR (GETSYNTAX 'LEFTPAREN \#CURRENTRDTBL#))) (SETQ CH1 (CAR (GETSYNTAX 'RIGHTPAREN \#CURRENTRDTBL#)))) (RIGHTBRACKET.RC (SETQ CH (CAR (GETSYNTAX 'LEFTBRACKET \#CURRENTRDTBL#))) (SETQ CH1 (CAR (GETSYNTAX 'RIGHTBRACKET \#CURRENTRDTBL#)))) 0) (|for| I |from| 0 |to| (IDIFFERENCE (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ) (TEXTPROP TEXOBJ 'STARTINGEOF)) |do| (SETQ CH2 (TEXEC.NTHBUFCHARBACK TEXOBJ I)) (COND ((EQ CH2 CH1) (SETQ PCOUNT (ADD1 PCOUNT))) ((EQ CH2 CH) (SETQ PCOUNT (SUB1 PCOUNT)))) |repeatuntil| (SETQ MATCH? (EQ PCOUNT 0)) |finally| (COND (MATCH? (* \; "\\CARET.DOWN \\TERM.OFD") (SETQ N (TEXEC.NTHBACKCHNUM TEXOBJ I))))) (RETURN N)))) (TEXEC.FLASHCARET (LAMBDA (TEXOBJ N) (* \; "Edited 30-May-91 19:18 by jds") (* * |Flashes| |caret| |at| |char#| N\, |used| |for| |flashing| |caret| |at|  |matching| |paren/bracket| I\f N |is| NIL\, |simply| |returns|) (PROG (TSEL (WINDOW (|fetch| (TEXTOBJ \\WINDOW) |of| TEXOBJ))) (COND ((NOT N) (RETURN))) (SETQ TSEL (|create| SELECTION |using| (|fetch| (TEXTOBJ SEL) |of| TEXOBJ) CH# _ N CHLIM _ N DCH _ 0 POINT _ 'LEFT \\TEXTOBJ _ TEXOBJ SET _ T)) (UNINTERRUPTABLY (|bind| (FIRSTTIME _ T) |for| CARET |inside| (|fetch| (TEXTOBJ CARET) |of| TEXOBJ) |as| WIN |inside| WINDOW |as| L1 |inside| (|fetch| (SELECTION L1) |of| TSEL) |do| (COND (L1 (\\EDIT.UPCARET CARET) (\\FIXSEL TSEL TEXOBJ WIN) (COND (FIRSTTIME (SETQ FIRSTTIME NIL) (\\CARET.FLASH? (|fetch| TCCARETDS |of| CARET) (|fetch| TCCARET |of| CARET) NIL NIL (|fetch| (SELECTION X0) |of| TSEL) (|fetch| (SELECTION Y0) |of| TSEL))) (T (\\CARET.FLASH.AGAIN (|fetch| TCCARET |of| CARET) (|fetch| TCCARETDS |of| CARET) (|fetch| (SELECTION X0) |of| TSEL) (|fetch| (SELECTION Y0) |of| TSEL))))))) (DISMISS 500) (|for| WIN |inside| WINDOW |as| CARET |inside| (|fetch| (TEXTOBJ CARET) |of| TEXOBJ) |do| (\\EDIT.DOWNCARET CARET) (* |Display| |the| |caret| |at|  |the| |typein| |point|)))))) (TEXEC.TEXTSTREAM.TO.LINEBUF (LAMBDA (TEXOBJ STARTINGEOF LINEBUF FILLTYPE) (* \; "Edited 13-Jun-90 00:17 by mitani") (* |;;|  "Copy the contents of the current edit line into the line buffer, for transmission to the system.") (\\SETUPGETCH (IMIN (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ) (ADD1 STARTINGEOF)) TEXOBJ) (* \;  "Move to where the user's typed input starts in the edit buffer,") (SETFILEPTR LINEBUF 0) (* \; "and clear out the line buffer.") (\\SETEOFPTR LINEBUF 0) (LET* ((TEXTSTREAM (|fetch| (TEXTOBJ STREAMHINT) |of| TEXOBJ)) (DRIBBLE (STREAMPROP TEXTSTREAM 'DRIBBLESTREAM))) (|while| (NOT (EOFP TEXTSTREAM)) |do| (\\LINEBUFBOUT LINEBUF (PROG ((C (\\BIN TEXTSTREAM))) (COND ((AND (NEQ FILLTYPE READC.FT) (EQ (CHARCODE ^V) C)) (* \;  "convert ^Vx to real CONTROL char") (SETQ C (COND ((OR (AND (IGEQ (SETQ C (\\BIN TEXTSTREAM) ) (CHARCODE A)) (ILEQ C (CHARCODE Z))) (AND (IGEQ C (CHARCODE \a)) (ILEQ C (CHARCODE \z)))) (* \; "CONVERT TO CONTROL CHAR") (LOGAND C 31)) (T C))))) (COND (DRIBBLE (* \; "Dribble output") (\\OUTCHAR DRIBBLE C))) (RETURN C))))) T)) (TEXEC.FIX (LAMBDA (STREAM LISPY TAIL) (* \; "Edited 13-Jun-90 00:17 by mitani") (* * |Inserts| |the| |text| |into| |the| |textstream| |and| |then| |positions|  |to| |the| |end| |for| |user| |editing|) (DECLARE (USEDFREE \#CURRENTRDTBL#)) (PROG ((TEXOBJ (TEXTOBJ STREAM)) (RDTBL (COPYREADTABLE \#CURRENTRDTBL#)) APPLYFLG (NCHARS 1)) (SETSYNTAX (CHARCODE \") 'OTHER RDTBL) (SETQ LISPY (REMOVE HISTSTR0 LISPY)) (* |Remove| "") (COND (LISPY (TEXTPROP TEXOBJ 'STARTINGEOF (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ)) (* |Set| |the| |new| STARTINGEOF  |to| |the| |beginning| |of| |the|  |text| |to| |insert|) (SETQ LISPY (CHCON (COND ((LISTP (CAR LISPY)) (* EVAL |format|) (CAR LISPY)) (T (* APPLY |format|) (SETQ APPLYFLG LISPY) LISPY)) T RDTBL)) (COND (APPLYFLG (SETQ LISPY (REVERSE (CDR (REVERSE (CDR LISPY))))) (* |Remove| |surrounding|  |parens/brackets|) )) (|for| CH |inside| LISPY |do| (|add| NCHARS 1) (COND ((AND APPLYFLG (EQ CH (CHARCODE \ )) (OR (EQ (CAR (NTH LISPY NCHARS)) (CHARCODE \()) (EQ (CHARCODE [) (CAR (NTH LISPY NCHARS))))) (SETQ APPLYFLG NIL) (* |Remove| |space| |before| \a  |left| |paren/bracket| |to| |put|  |back| |in| APPLY |mode|) ) (T (BKSYSBUF (CHARACTER CH))))) (* |Unread| |the| |characters|  |back| |into| |the| |main|  |keyboard| |buffer|) (STREAMPROP STREAM 'FIXFLG T) (* |Indicate| |to| TEXEC.FILLBUFFER  |we| |are| |in| |fix| |mode|) (RETURN)))))) (TEXEC.NTHBUFCHARBACK (LAMBDA (TEXOBJ N) (* \; "Edited 13-Jun-90 00:17 by mitani") (* |Return| |the| |Nth| |character| |back| |from| |the| |current| |end| |of|  |text.| |Puts| |the| |pointer| |back| |at| |the| |end| |of| |the| |buffer|) (PROG ((CHPOS (TEXEC.NTHBACKCHNUM TEXOBJ N))) (* CHPOS |is| |the| |actual| |char|  |position| |in| |the| |text.|) (COND ((OR (ILEQ CHPOS (TEXTPROP TEXOBJ 'STARTINGEOF)) (ILEQ CHPOS 1)) (* |returns| NIL |if| |there| |is|  |no| |char| |at| |that| |position|) (RETURN))) (\\SETUPGETCH CHPOS TEXOBJ) (* |Setup| |position| |to| BIN  |character|) (RETURN (\\BIN (|fetch| (TEXTOBJ STREAMHINT) |of| TEXOBJ)))))) (TEXEC.NTHBACKCHNUM (LAMBDA (TEXOBJ N) (* \; "Edited 30-May-91 19:18 by jds") (* |Converts| N |chars| |back|  |from| |the| |end| |of| |the|  |selection| |to| \a CH#) (IDIFFERENCE (IMIN (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ) (SELECTQ (|fetch| (SELECTION POINT) |of| (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)) (LEFT (SUB1 (|fetch| (SELECTION CH#) |of| (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)))) (RIGHT (|fetch| (SELECTION CHLIM) |of| (|fetch| (TEXTOBJ SEL) |of| TEXOBJ))) NIL)) N))) (TEXEC.EOTP (LAMBDA (TEXOBJ) (* \; "Edited 30-May-91 19:18 by jds") (* |Test| |if| |the| |caret| |is|  |at| |the| |end| |of| |the| |text|) (PROG ((SEL (|fetch| (TEXTOBJ SEL) |of| TEXOBJ))) (RETURN (ILESSP (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ) (SELECTQ (|fetch| (SELECTION POINT) |of| SEL) (LEFT (|fetch| (SELECTION CH#) |of| SEL)) (RIGHT (|fetch| (SELECTION CHLIM) |of| SEL)) NIL)))))) (TEXEC.GETKEY (LAMBDA (TEXOBJ) (* \; "Edited 13-Jun-90 00:17 by mitani") (* |;;;| "Return a character from the keyboard without echoing. If no key has been typed, update the screen if prior input-output didn't want to do it, flash the caret in all of the attached windows if the keyboard is attached to this process, ie, is the TTYDISPLAYSTREAM. Blocks until a key is typed with the keyboard attached to this process") (PROG ((SEL (|fetch| (TEXTOBJ SEL) |of| TEXOBJ))) (|until| (\\WAITFORSYSBUFP 100) |do| (OR (|fetch| (TEXTOBJ EDITFINISHEDFLG) |of| TEXOBJ) (|while| (OR TEDIT.SELPENDING (|fetch| (TEXTOBJ EDITOPACTIVE) |of| TEXOBJ)) |do| (* \;  "Don't anything while he's selecting or one of the lock-out ops is active.") (AND (OR (EQ TEDIT.SELPENDING TEXOBJ)) (TEDIT.FLASHCARET (|fetch| (TEXTOBJ CARET) |of| TEXOBJ))) (BLOCK))) (* \;  "Flash carets in all windows until a key is entered unless process is being terminated") (OR (|fetch| (TEXTOBJ EDITFINISHEDFLG) |of| TEXOBJ) (COND ((|fetch| (TEXTOBJ TXTNEEDSUPDATE) |of| TEXOBJ) (* \; "Screen needs updating") (\\SHOWSEL SEL NIL NIL) (PRINTOUT PROMPTWINDOW "Needed updating." T) (TEDIT.UPDATE.SCREEN TEXOBJ) (* \;  "Turn highlighting off of selection") (\\FIXSEL SEL TEXOBJ) (* \; "Fix up the selection fields") (TEDIT.SCROLL? TEXOBJ) (* \; "Scroll windows if necessary") (\\SHOWSEL SEL NIL T) (* \; "Turn any selection back on") ))) (OR (|fetch| (TEXTOBJ EDITFINISHEDFLG) |of| TEXOBJ) (PROGN (TEDIT.FLASHCARET (|fetch| (TEXTOBJ CARET) |of| TEXOBJ)) (* \;  "Check for SHIFT/COPY/MOVE active") (TEXEC.CHSELPENDING TEXOBJ)))) (RETURN (AND (NOT (|fetch| (TEXTOBJ EDITFINISHEDFLG) |of| TEXOBJ)) (\\GETKEY)))))) (TEXEC.INSERTCHAR (LAMBDA (TEXOBJ C) (* \; "Edited 30-May-91 19:18 by jds") (* * |Inserts| \a |character| |into| |the| |textstream.|  I\f |the| |character| |is| |being| |inserted| |prior| |to| |the| |current|  |input| |then| |the| |start| |of| |the| |current| |input| |pointer,|  STARTINGEOF |is| |incremented.| I\f |echoing| |is| |off,| |then| |the|  |character| |is| |inserted| |as| "invisible") (DECLARE (USEDFREE \\PRIMTERMTABLE \\TERM.OFD)) (PROG ((SEL (|fetch| (TEXTOBJ SEL) |of| TEXOBJ))) (COND ((ILEQ (SELECTQ (|fetch| (SELECTION POINT) |of| SEL) (LEFT (|fetch| (SELECTION CH#) |of| SEL)) (RIGHT (|fetch| (SELECTION CHLIM) |of| SEL)) NIL) (TEXTPROP TEXOBJ 'STARTINGEOF)) (TEXTPROP TEXOBJ 'STARTINGEOF (ADD1 (TEXTPROP TEXOBJ 'STARTINGEOF))) (* I\f |inserting| |text| |prior| |to| |current| |input| |move| |the| |start|  |of| |input| |down| 1 |to| |compensate|) ) (T (AND (IGREATERP (IMIN (|fetch| (SELECTION CH#) |of| SEL) (|fetch| (SELECTION CHLIM) |of| SEL)) (TEXTPROP TEXOBJ 'STARTINGEOF)) (TEDIT.DO.BLUEPENDINGDELETE SEL TEXOBJ)))) (* |Only| |allow| |deletion| |of|  |seletected| |text| |if| |after|  |start| |of| |current| |input|) (COND ((|fetch| ECHOFLG |of| \\PRIMTERMTABLE) (TEDIT.\\INSERT (OR C (SETQ C (TEXEC.GETKEY TEXOBJ))) SEL \\TERM.OFD)) (T (TEDIT.CARETLOOKS TEXOBJ '(INVISIBLE ON)) (TEDIT.\\INSERT (OR C (SETQ C (TEXEC.GETKEY TEXOBJ))) SEL \\TERM.OFD) (TEDIT.CARETLOOKS TEXOBJ '(INVISIBLE OFF)))) (RETURN C) (* |Return| |character| |inserted|) ))) (TEXEC.DELETE (LAMBDA (TEXOBJ START END) (* \; "Edited 13-Jun-90 00:17 by mitani") (* |Deletes| |the| |chars| |in|  |the| |textstream| |from| START |to|  END) (LET ((TSEL (|create| SELECTION |using| (|fetch| (TEXTOBJ SEL) |of| TEXOBJ) CH# _ START CHLIM _ (ADD1 END) POINT _ 'LEFT DCH _ (ADD1 (IDIFFERENCE END START)))) (STREAM (|fetch| (TEXTOBJ STREAMHINT) |of| TEXOBJ))) (\\TEDIT.DELETE TSEL STREAM T)))) (TEXEC.\\CHDEL1 (LAMBDA (TEXOBJ) (* \; "Edited 30-May-91 19:19 by jds") (* |Delete| |the| |last| |character| |in| |the| |text| |stream,| |and| |return|  |it,| |so| |we| |can| |decide| |what| |to| |do| |with| |it.|) (DECLARE (USEDFREE \\LINEBUF.OFD)) (LET* ((SEL (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)) (TEXTLEN (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ)) (CH (COND ((SELECTQ (|fetch| (SELECTION POINT) |of| SEL) (LEFT (IDIFFERENCE (|fetch| (SELECTION CH#) |of| SEL) 1)) (RIGHT (|fetch| (SELECTION CH#) |of| SEL)) NIL))))) (* CH = |character| |position| |at|  |current| |location| |of| |caret|) (COND ((NEQ CH (TEXTPROP TEXOBJ 'STARTINGEOF)) (* |don't| |allow| |deletion| |of|  |text| |if| |at| |beginning| |of|  |current| |input|) (COND ((ILEQ (SELECTQ (|fetch| (SELECTION POINT) |of| (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)) (LEFT (|fetch| (SELECTION CH#) |of| (|fetch| (TEXTOBJ SEL) |of| TEXOBJ))) (RIGHT (SUB1 (|fetch| (SELECTION CHLIM) |of| (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)) )) NIL) (TEXTPROP TEXOBJ 'STARTINGEOF)) (TEXTPROP TEXOBJ 'STARTINGEOF (SUB1 (TEXTPROP TEXOBJ 'STARTINGEOF))) (* I\f |deleting| |text| |prior| |to| |current| |input| |move| |the| |start|  |of| |input| |up| 1 |to| |compensate|) )) (COND ((TEXEC.EOTP TEXOBJ)) (T (|replace| (STREAM REVALIDATEFLG) |of| \\LINEBUF.OFD |with| T) (* |Invalidate| |paren/bracket|  |count| |since| |we| |are| |no|  |longer| |at| |the| |end| |of| |the|  |text|) )) (PROG1 (PROGN (\\SETUPGETCH CH TEXOBJ) (\\BIN (|fetch| (TEXTOBJ STREAMHINT) |of| TEXOBJ))) (\\TEDIT.CHARDELETE TEXOBJ "" (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)))))))) (TEXEC.?EQUAL (LAMBDA (TEXOBJ) (* \; "Edited 13-Jun-90 00:17 by mitani") (* * |Test| |for| ? |or| ?= |and| |if| |so| RETURN T |else| RETURN NIL) (DECLARE (USEDFREE \#CURRENTRDTBL#)) (PROG ((CH# 0) CH FLG (TS (|fetch| (TEXTOBJ STREAMHINT) |of| TEXOBJ)) LST PTR FNAME TAIL TEMPFILE (STARTINGEOF (TEXTPROP TEXOBJ 'STARTINGEOF))) (COND ((OR (AND (EQ (TEXEC.NTHBUFCHARBACK TEXOBJ 0) (CHARCODE =)) (EQ (TEXEC.NTHBUFCHARBACK TEXOBJ 1) (CHARCODE ?)) (FMEMB (TEXEC.NTHBUFCHARBACK TEXOBJ 2) (CHCON '| '(| '[))) (AND (EQ (TEXEC.NTHBUFCHARBACK TEXOBJ 0) (CHARCODE ?)) (FMEMB (TEXEC.NTHBUFCHARBACK TEXOBJ 1) (CHCON '| '(| '[)))) (RETURN T)) (T (RETURN)))))) (TEDIT.SCROLL? (LAMBDA (TEXOBJ) (* \; "Edited 30-May-91 19:19 by jds") (* * |This| |function| |scrolls| |all| |of| |the| |windows| |if| |the| |caret|  |is| |off-window| |in| |the| |selection| |window|) (PROG ((SEL (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)) SELINE) (|for| WIN |inside| (|fetch| (TEXTOBJ \\WINDOW) |of| TEXOBJ) |as| L1 |on| (|fetch| (SELECTION L1) |of| SEL) |as| LN |on| (|fetch| (SELECTION LN) |of| SEL) |do| (COND ((AND (EQ WIN (|fetch| (TEXTOBJ SELWINDOW) |of| TEXOBJ)) (OR (NOT (SELECTQ (|fetch| (SELECTION POINT) |of| SEL) (LEFT (CAR L1)) (RIGHT (CAR LN)) NIL)) (ILEQ (SELECTQ (|fetch| (SELECTION POINT) |of| SEL) (LEFT (|fetch| (LINEDESCRIPTOR YBOT) |of| (CAR L1))) (RIGHT (|fetch| (LINEDESCRIPTOR YBOT) |of| (CAR LN))) 0) (|fetch| (REGION BOTTOM) |of| (DSPCLIPPINGREGION NIL WIN))))) (* |The| |caret| |is| |off-window| |in| |the| |selection| |window.|  |Need| |to| |scroll| |it| |up| |so| |the| |caret| |is| |visible.|) (|while| (OR (COND ((SETQ SELINE (SELECTQ (|fetch| (SELECTION POINT) |of| SEL) (LEFT (CAR L1)) (RIGHT (CAR LN)) NIL)) (ILESSP (|fetch| (LINEDESCRIPTOR YBOT) |of| SELINE) (|fetch| (TEXTOBJ WBOTTOM) |of| TEXOBJ) )) (T (ILESSP (|fetch| (SELECTION Y0) |of| SEL) (|fetch| (TEXTOBJ WBOTTOM) |of| TEXOBJ)))) (AND (IGEQ (|fetch| (SELECTION Y0) |of| SEL) (|fetch| (TEXTOBJ WTOP) |of| TEXOBJ)) (NULL SELINE))) |do| (* |The| |caret| |just| |went|  |off-screen.| |Move| |it| |up|  |some.|) (|replace| (TEXTOBJ EDITOPACTIVE) |of| TEXOBJ |with| NIL) (SCROLLW WIN 0 (LLSH (COND ((SELECTQ (|fetch| (SELECTION POINT) |of| SEL) (LEFT (CAR L1)) (RIGHT (CAR LN)) NIL) (|fetch| (LINEDESCRIPTOR LHEIGHT) |of| (SELECTQ (|fetch| (SELECTION POINT) |of| SEL) (LEFT (CAR L1)) (RIGHT (CAR LN)) (SHOULDNT)))) (T 12)) 1))))))))) (TEXEC.DISPLAYTEXT (LAMBDA (TEXTOBJ CH FONT LINE XPOINT DS SEL) (* \; "Edited 30-May-91 19:16 by jds") (* |This| |function| |does| |the|  |actual| |displaying| |of|  |typed-in| |text| |on| |the| |edit|  |window.|) (PROG ((TERMSA (|fetch| (TEXTOBJ TXTTERMSA) |of| TEXTOBJ)) DY) (DSPXPOSITION XPOINT DS) (* |Set| |the| |display| |stream| X  |position|) (COND (TERMSA (* |Special| |terminal| |table|  |for| |controlling| |character|  |display.| |Use| |it.|) (COND ((STRINGP CH) (|for| CHAR |instring| CH |do| (SELCHARQ CHAR (TAB (* |Put| |down| |white|) (BITBLT NIL 0 0 DS XPOINT (|fetch| (LINEDESCRIPTOR YBOT) |of| LINE) 36 (|fetch| (LINEDESCRIPTOR LHEIGHT) |of| LINE) 'TEXTURE 'REPLACE WHITESHADE) (RELMOVETO 36 0 DS)) (CR (BITBLT NIL 0 0 DS XPOINT (|fetch| (LINEDESCRIPTOR YBOT) |of| LINE) (IMAX 6 (CHARWIDTH CHAR FONT)) (|fetch| (LINEDESCRIPTOR LHEIGHT) |of| LINE) 'TEXTURE 'REPLACE WHITESHADE)) (\\DSPPRINTCHAR DS CHAR)))) (T (SELCHARQ CH (TAB (* |Put| |down| |white|) (BITBLT NIL 0 0 DS XPOINT (|fetch| (LINEDESCRIPTOR YBOT) |of| LINE) 36 (|fetch| (LINEDESCRIPTOR LHEIGHT) |of| LINE) 'TEXTURE 'REPLACE WHITESHADE) (RELMOVETO 36 0 DS)) (CR (BITBLT NIL 0 0 DS XPOINT (|fetch| (LINEDESCRIPTOR YBOT) |of| LINE) (IMAX 6 (CHARWIDTH CH FONT)) (|fetch| (LINEDESCRIPTOR LHEIGHT) |of| LINE) 'TEXTURE 'REPLACE WHITESHADE)) (\\DSPPRINTCHAR DS CH))))) (T (* N\o |special| |handling;|  |just| |use| |native| |character|  |codes|) (COND ((STRINGP CH) (|for| CHAR |instring| CH |do| (SELCHARQ CHAR (TAB (* |Put| |down| |white|) (BITBLT NIL 0 0 DS (DSPXPOSITION NIL DS) (|fetch| (LINEDESCRIPTOR YBOT) |of| LINE) 36 (|fetch| (LINEDESCRIPTOR LHEIGHT) |of| LINE) 'TEXTURE 'REPLACE WHITESHADE) (RELMOVETO 36 0 DS)) (CR (BITBLT NIL 0 0 DS (DSPXPOSITION NIL DS) (|fetch| (LINEDESCRIPTOR YBOT) |of| LINE) (IMAX 6 (CHARWIDTH CHAR FONT)) (|fetch| (LINEDESCRIPTOR LHEIGHT) |of| LINE) 'TEXTURE 'REPLACE WHITESHADE)) (BLTCHAR CHAR DS)))) (T (SELCHARQ CH (TAB (* |Put| |down| |white|) (BITBLT NIL 0 0 DS (DSPXPOSITION NIL DS) (|fetch| (LINEDESCRIPTOR YBOT) |of| LINE) 36 (|fetch| (LINEDESCRIPTOR LHEIGHT) |of| LINE) 'TEXTURE 'REPLACE WHITESHADE) (RELMOVETO 36 0 DS)) (CR (* |Blank| |out| |the| |CR's|  |width.|) (BITBLT NIL 0 0 DS (DSPXPOSITION NIL DS) (|fetch| (LINEDESCRIPTOR YBOT) |of| LINE) (IMAX 6 (CHARWIDTH CH FONT)) (|fetch| (LINEDESCRIPTOR LHEIGHT) |of| LINE) 'TEXTURE 'REPLACE WHITESHADE)) (BLTCHAR CH DS))))))))) (\\TEXEC.TEXTBOUT (LAMBDA (STREAM BYTE) (* \; "Edited 30-May-91 19:19 by jds") (* * D\o BOUT |to| \a |text| |stream,| |which| |is| |an| |insertion| |at| |the|  |end| |of| |text| |pointer|) (UNINTERRUPTABLY (PROG ((TEXOBJ (|fetch| (TEXTSTREAM TEXTOBJ) |of| STREAM)) CH# WINDOW TEXTLEN SEL STARTINGEOF) (SETQ STARTINGEOF (ADD1 (TEXTPROP TEXOBJ 'STARTINGEOF))) (* |Insertion| |point| |for| |output| -  |is| |actually| |the| |beginning| |of| |the| |next/current| |text| |being|  |entered| |to| |return| |to| READ) (TEXTPROP TEXOBJ 'STARTINGEOF STARTINGEOF) (* |This| |adds| 1 |to| |the|  |previous| |value| |on| |the|  |property| |list|) (SETQ TEXTLEN (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ)) (* |The| |length| |of| |the| |total|  |text| |in| |chars|) (SETQ WINDOW (|fetch| (TEXTOBJ \\WINDOW) |of| TEXOBJ)) (SETQ SEL (|fetch| (TEXTOBJ SEL) |of| TEXOBJ)) (* |The| |current| |selection|) (* COND ((NOT (LDIFFERENCE  (|fetch| (SELECTION L1) |of| SEL)  (QUOTE (NIL)))) (RETURN))) (* |Return| |if| |caret| |out| |of|  |bounds,| |ie,| |user| |scrolls|  |past| |end| |of| |text|) (SETQ CH# (OR STARTINGEOF (|fetch| (SELECTION CH#) |of| SEL))) (AND WINDOW (|for| L1 |in| (|fetch| (SELECTION L1) |of| SEL) |as| LN |in| (|fetch| (SELECTION LN) |of| SEL) |do| (* |Mark| |changed| |lines| |as|  DIRTY.) (COND (L1 (|replace| (LINEDESCRIPTOR DIRTY) |of| L1 |with| T)) (LN (|replace| (LINEDESCRIPTOR DIRTY) |of| LN |with| T))))) (\\INSERTCH BYTE CH# TEXOBJ) (|replace| (TEXTOBJ TXTNEEDSUPDATE) |of| TEXOBJ |with| T) (AND WINDOW (\\TEXEC.TEXTBOUT1 TEXOBJ STREAM BYTE CH# SEL)))))) (\\TEXEC.TEXTBOUT1 (LAMBDA (TEXOBJ STREAM BYTE CH# SEL) (* \; "Edited 30-May-91 19:19 by jds") (PROG ((THISLINE (|fetch| (TEXTOBJ THISLINE) |of| TEXOBJ)) PS PC OFFST) (* |;;;| "Update stream CHARPOSITION for calls to POSITION ie, GAINSPACE") (|add| (|fetch| (SELECTION CH#) |of| SEL) 1) (* \;  "These must be here, since SELs are valid even without a window.") (|replace| (SELECTION CHLIM) |of| SEL |with| (|fetch| (SELECTION CH#) |of| SEL)) (|replace| (SELECTION POINT) |of| SEL |with| 'LEFT) (|replace| (SELECTION DCH) |of| SEL |with| 0) (|replace| (SELECTION SELKIND) |of| SEL |with| 'CHAR) (|for| CARET |inside| (|fetch| (TEXTOBJ CARET) |of| TEXOBJ) |do| (\\EDIT.UPCARET CARET)) (\\TEXEC.TEXTBOUT2 TEXOBJ STREAM BYTE CH# SEL) (|for| CARET |inside| (|fetch| (TEXTOBJ CARET) |of| TEXOBJ) |do| (* |;;| "Allow carets to flash again.") (|replace| (TEDITCARET TCFORCEUP) |of| CARET |with| NIL)) (|replace| (SELECTION ONFLG) |of| SEL |with| T) (|replace| DESC |of| THISLINE |with| NIL) (* |;;| "SO that this line of text is run thru the formatter again before anything interesting that depends on it being right (like scrolling the window)") (* |;;;| "Fix up the TEXTSTREAM so that the FILEPTR looks like it ought to after the BOUT, even though we've been updating the screen (which usually moves the fileptr....)") (SETQ PS (|ffetch| (PIECE PSTR) |of| (SETQ PC (|fetch| (TEXTOBJ \\INSERTPC) |of| TEXOBJ)))) (* \;  "This piece resides in a STRING. Because it's newly 'typed' material.") (|replace| (TEXTSTREAM PIECE) |of| STREAM |with| PC) (* \;  "Remember the current piece for others.") (|replace| (TEXTSTREAM PCNO) |of| STREAM |with| (|fetch| (TEXTOBJ \\INSERTPCNO ) |of| TEXOBJ)) (* \;  "And which number piece this is.") (|freplace| (STREAM CPPTR) |of| STREAM |with| (ADDBASE (|ffetch| (STRINGP BASE) |of| PS) (LRSH (SETQ OFFST (|ffetch| (STRINGP OFFST) |of| PS)) 1))) (* \;  "Pointer to the actual characters in the string (allowing for substrings.)") (|freplace| (STREAM CPAGE) |of| STREAM |with| 0) (|freplace| (STREAM COFFSET) |of| STREAM |with| (IPLUS (|freplace| (TEXTSTREAM PCSTARTCH) |of| STREAM |with| (LOGAND 1 OFFST)) (|fetch| (TEXTOBJ \\INSERTLEN) |of| TEXOBJ))) (|freplace| (TEXTSTREAM PCSTARTPG) |of| STREAM |with| 0) (* \;  "Page # within the 'file' where this piece starts") (|freplace| (STREAM CBUFSIZE) |of| STREAM |with| (|fetch| (STREAM COFFSET) |of| STREAM)) (|freplace| (STREAM EPAGE) |of| STREAM |with| 1) (|freplace| (TEXTSTREAM CHARSLEFT) |of| STREAM |with| 0) (* \;  "We're, perforce, at the end of the piece.") (|freplace| (TEXTSTREAM REALFILE) |of| STREAM |with| NIL) (* \; "We're not on a file....") ))) (\\TEXEC.TEXTBOUT2 (LAMBDA (TEXOBJ STREAM BYTE CH# SEL) (* \; "Edited 30-May-91 19:19 by jds") (PROG (YFLG) (|for| WIN |in| (|fetch| (TEXTOBJ \\WINDOW) |of| TEXOBJ) |as| L1 |on| (|fetch| (SELECTION L1) |of| SEL) |as| LN |on| (|fetch| (SELECTION LN) |of| SEL) |do| (COND ((CAR L1) (|add| (|fetch| (LINEDESCRIPTOR CHARLIM) |of| (CAR L1)) 1) (|add| (|fetch| (LINEDESCRIPTOR CHARTOP) |of| (CAR L1)) 1) (COND ((EQ WIN (|fetch| (TEXTOBJ SELWINDOW) |of| TEXOBJ)) (SETQ YFLG (ILESSP (|fetch| (LINEDESCRIPTOR YBASE) |of| (CAR L1)) 0))))))) (COND ((OR (IGREATERP (PLUS (|fetch| (SELECTION X0) |of| SEL) (CHARWIDTH BYTE (|fetch| CLFONT |of| (|fetch| (TEXTOBJ CARETLOOKS) |of| TEXOBJ))) ) (IDIFFERENCE (|fetch| (TEXTOBJ WRIGHT) |of| TEXOBJ) 16)) (IEQP BYTE (CHARCODE EOL)) (IEQP BYTE (CHARCODE CR)) (ILESSP CH# (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ)) YFLG) (* |gone| |off| |the| |edge| |of| |the| |line,| O\r |not| |at| |end| |of|  |text| |reformat| |and| |add| |new| |line|) (\\TEXEC.TEXTBOUT3 TEXOBJ STREAM BYTE CH# SEL)) (T (* |Display| |text| |on| |same|  |line| |without| |updating| |entire|  |screen|) (\\TEXEC.TEXTBOUT4 TEXOBJ STREAM BYTE CH# SEL)))))) (\\TEXEC.TEXTBOUT3 (LAMBDA (TEXOBJ STREAM BYTE CH# SEL) (* \; "Edited 13-Jun-90 00:17 by mitani") (* * |Updates| |the| |screen| |if| |necessary| |and| |checks| |for| |exceeding|  |bufferlimit| |size|) (PROG (OCHLIM) (COND ((IGEQ CH# (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ)) (\\SHOWSEL SEL NIL NIL) (TEDIT.UPDATE.SCREEN TEXOBJ) (* |Only| |update| |screen| |if|  |at| |end| |of| |text|) (\\FIXSEL SEL TEXOBJ NIL) (TEDIT.SCROLL? TEXOBJ) (\\SHOWSEL SEL NIL T) (COND ((AND (NEQ TEXEC.BUFFERLIMIT 0) (IGREATERP (SETQ OCHLIM (IDIFFERENCE (GETEOFPTR STREAM) TEXEC.BUFFERLIMIT)) 0)) (|replace| (TEXTOBJ \\INSERTPCVALID) |of| TEXOBJ |with| NIL) (TEXEC.DELETE TEXOBJ 1 (IMAX OCHLIM (LRSH TEXEC.BUFFERLIMIT 3))) (* |Remove| |the| |top| |1/8| |or| |at| |least| |the| |number| |of| |chars|  |exceeding| TEXEC.BUFFERLIMIT. I\f TEXEC.BUFFERLIMIT |is| 0\, |allow|  |infinite| |size|) (\\FIXSEL SEL TEXOBJ)))))))) (\\TEXEC.TEXTBOUT4 (LAMBDA (TEXOBJ STREAM BYTE CH# SEL) (* \; "Edited 30-May-91 19:19 by jds") (* * |Display| |character| |on| |same| |line| |with| |no| |reformatting|  |screen|) (COND ((IGEQ CH# (|fetch| (TEXTOBJ TEXTLEN) |of| TEXOBJ)) (* |Don't| |display| |character| |unless| |the| |output| |is| |at| |the| |end,|  \\TEXEC.GETKEY |will| |update| |the| |screen| |when| |the| |next| |input| |is|  |called| |for.|) (|for| WIN |in| (|fetch| (TEXTOBJ \\WINDOW) |of| TEXOBJ) |as| L1 |on| (|fetch| (SELECTION L1) |of| SEL) |as| LN |on| (|fetch| (SELECTION LN) |of| SEL) |do| (COND ((AND (CAR L1) (IGEQ (|fetch| (LINEDESCRIPTOR YBASE) |of| (CAR L1)) 0)) (TEXEC.DISPLAYTEXT TEXOBJ BYTE (|fetch| CLFONT |of| (|fetch| (TEXTOBJ CARETLOOKS ) |of| TEXOBJ)) (CAR L1) (DSPXPOSITION NIL WIN) (WINDOWPROP WIN 'DSP) SEL) (* |Print| |out| |the| |character|  |on| |the| |screen|) (|replace| (SELECTION X0) |of| SEL |with| (DSPXPOSITION NIL WIN)) (|replace| (SELECTION XLIM) |of| SEL |with| (DSPXPOSITION NIL WIN ))))))))) (\\TEXEC.SELFN (LAMBDA (TEXOBJ SEL SELMODE CONTROL) (* \; "Edited 30-May-91 19:19 by jds") (* * |This| |function| |gets| |called| |via| |the| SELFN |property| |on| |the|  TEXTOBJ\, |and| |restricts| |the| |selection| |to| |the| |current| |input|) (PROG NIL (* |Make| |sure| |there| |is|  |really| \a |selection|) (COND ((AND (FMEMB SELMODE '(NORMAL PENDINGDEL MOVE DELETE)) (|fetch| (SELECTION SET) |of| SEL) (ILESSP (SELECTQ (|fetch| (SELECTION POINT) |of| SEL) (LEFT (|fetch| (SELECTION CH#) |of| SEL)) (RIGHT (|fetch| (SELECTION CHLIM) |of| SEL)) NIL) (ADD1 (TEXTPROP TEXOBJ 'STARTINGEOF)))) (RETURN 'DON\'T) (* |Don't| |allow| |selection| |if|  |selecting| |text| |prior| |to|  |current| |input|) ) (T (RETURN T))) (* |else| |return| T) ))) (TEXEC.PRINTARGS (LAMBDA (FN ARGS ACTUALS ARGTYPE) (* \; "Edited 3-Mar-87 15:06 by raf") (PROG (TYPE REMARGS) (\\CARET.DOWN) (* |;;| "Prints args to fn, matching up with ACTUALS, if supplied. Do this in a way that lets us keep track of where we are.") (TTPRIN1 "(") (TTPRIN2 FN) (COND ((NOT ARGS)) (T (COND ((COND ((EQ ACTUALS T) (SETQ ACTUALS (TTYIN.READ?=ARGS))) (T ACTUALS)) (COND ((CDR ACTUALS) (TTCRLF)) (T (TTPRIN1 " "))) (|bind| MODE |while| ACTUALS |do| (COND ((EQ MODE '&KEY) (TTPRIN1COMMENT " = ") (TTPRIN2 (|pop| ACTUALS)) (TTPRIN1 " ") (TTPRIN2 (|pop| ACTUALS)) (TTCRLF) (GO $$ITERATE)) ((NULL ARGS) (TTPRIN1COMMENT "+ ")) ((NLISTP ARGS) (TTPRIN1COMMENT (CONCAT " . " ARGS " = ")) (|while| ACTUALS |do| (TTPRIN2 (|pop| ACTUALS)) (TTPRIN1 " ")) (TTCRLF) (SETQ ARGS) (RETURN)) (T (SELECTQ (CAR ARGS) ((&REST &BODY) (TTPRIN1COMMENT (CL:FORMAT NIL " ~A ~A =" (|pop| ARGS) (|pop| ARGS))) (|while| ACTUALS |do| (TTPRIN2 (|pop| ACTUALS)) (TTPRIN1 " ")) (TTCRLF) (RETURN)) (&ALLOW-OTHER-KEYS (TTPRIN1COMMENT (|pop| ARGS)) (TTCRLF) (GO $$ITERATE)) (&OPTIONAL (TTPRIN1COMMENT (CL:FORMAT NIL "~A ~A" (SETQ MODE (|pop| ARGS)) (|pop| ARGS)))) (&KEY (SETQ MODE (CAR ARGS)) (|while| (AND ARGS (NOT (FMEMB (CAR ARGS) CL:LAMBDA-LIST-KEYWORDS ))) |do| (TTPRIN1 " ") (TTPRIN1COMMENT (|pop| ARGS))) (TTCRLF) (GO $$ITERATE)) (TTPRIN1COMMENT (|pop| ARGS))))) (TTPRIN1COMMENT " = ") (TTPRIN2 (CAR ACTUALS) 2 4) (SETQ ACTUALS (CDR ACTUALS)) (TTCRLF)))) (|while| ARGS |do| (|if| (NLISTP ARGS) |then| (TTPRIN1COMMENT (CONCAT " . " ARGS)) (TTCRLF) (SETQ ARGS) (RETURN)) (TTPRIN1 " ") (TTPRIN1COMMENT (|pop| ARGS))))) (TTPRIN1 ")") (COND ((SETQ TYPE (SELECTQ (OR ARGTYPE (ARGTYPE FN)) (1 'NL) (3 'NL*) NIL)) (* \; "indicate arg type") (TTPRIN1COMMENT (CONCAT " {" TYPE "}"))))))) (TEXEC.PROCENTRYFN (LAMBDA (NEWPROCESS OLDPROCESS) (* \; "Edited 12-Dec-88 15:18 by jds") (* |;;| "TEXEC'S PROCESS.ENTRYFN which disarms the DELELTE key interrupt so it can use it as a linedelete key") (COND ((NOT (PROCESSPROP NEWPROCESS 'INTERRUPTS)) (PROCESSPROP NEWPROCESS 'INTERRUPTS (RESET.INTERRUPTS (REMOVE '(127 RUBOUT T) (LISPINTERRUPTS)) T)))))) (TEXEC.PROCEXITFN (LAMBDA (THISP NEWP) (* AJB " 6-Feb-86 15:25") (* |Re-arm| DELETE |key| |to|  |whatever| |it| |was| |before|) (RESET.INTERRUPTS (PROCESSPROP THISP 'INTERRUPTS)) (PROCESSPROP THISP 'INTERRUPTS NIL))) ) (* |;;| "Code to support a TEXEC lisp 'listener'") (DEFINEQ (TEXEC (LAMBDA (REGION PROMPT MENUFN) (* \; "Edited 8-Feb-89 16:55 by jds") (* |;;| "Create an Interlisp executive window with TEdit as the editor behind it.") (PROG (HANDLE WINDOW TEDITSTREAM LINEBUFFER) (SETQ WINDOW (CREATEW REGION "TEXEC (Version 20.2)")) (* \;  "Create a window for the TEdit-based listener") (SETQ TEDITSTREAM (TEXEC.OPENTEXTSTREAM WINDOW (OR MENUFN 'TEXEC.DEFAULT.MENUFN))) (* \;  "Create a TEdit stream for the TEXEC and fill in our non-standard fields") (|replace| (STREAM LINELENGTH) |of| TEDITSTREAM |with| (|fetch| (STREAM LINELENGTH) |of| (|fetch| (WINDOW DSP) |of| WINDOW))) (* \;  "set the linelength of the teditstream to be the same as the one for the display stream") (STREAMPROP TEDITSTREAM 'FIXFN (FUNCTION TEXEC.FIX)) (* \;  "This stream has its own P.A. FIX command") (SETQ LINEBUFFER (\\CREATELINEBUFFER)) (* \;  "Create our LINEBUFFER so we can attach a READREFILL function to it") (STREAMPROP LINEBUFFER 'REFILLBUFFERFN (FUNCTION TEXEC.FILLBUFFER)) (* \;  "Attach the READREFILL function to the newly created LINEBUFFER") (WINDOWPROP WINDOW '\\LINEBUF.OFD LINEBUFFER) (* \;  "attach the linebuffer to the window for TTYDISPLAYSTREAM") (SETQ HANDLE (ADD.PROCESS `(PROGN (TTYDISPLAYSTREAM (QUOTE \, TEDITSTREAM)) (EVALQT (QUOTE \, (OR PROMPT '\#)))) 'NAME 'TEXEC 'RESTARTABLE T)) (* \; "Create the TEXEC process") (|replace| PROCTTYENTRYFN |of| HANDLE |with| (FUNCTION TEXEC.PROCENTRYFN)) (|replace| PROCTTYEXITFN |of| HANDLE |with| (FUNCTION TEXEC.PROCEXITFN)) (WINDOWPROP WINDOW 'ICONFN (FUNCTION TEXEC.SHRINK.ICONCREATE)) (WINDOWPROP WINDOW 'TITLE (PROCESSPROP HANDLE 'NAME)) (WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW) (PROG ((|proc| (WINDOWPROP WINDOW 'PROCESS))) (RETURN (COND ((EQ (THIS.PROCESS) |proc|) (ADD.PROCESS (LIST 'CLOSEW (KWOTE WINDOW)) ) 'DON\'T) ((PROCESSP |proc|) (INTERRUPTCHAR 127 (PROCESSPROP |proc| 'INTERRUPTS)) (* \; "Restore interruptchar 127") (DEL.PROCESS |proc|) NIL))))))) (TTY.PROCESS HANDLE)))) (TTEXEC (LAMBDA NIL (* AJB " 6-Feb-86 15:09") (* * |This| |function| |replaces| |the| |Top| |Level| |Interlisp-D| |Executive|  |with| TEXEC\, |but| |only| |if| |this| |function| |is| |being| |run| |from|  |the| |Top| |Level| |Exec| |window.|) (DECLARE\: (USEDFREE \\TERM.OFD \\LINEBUF.OFD)) (PROG ((WINDOW (WFROMDS \\TERM.OFD))) (COND ((EQ (|fetch| PROCNAME |of| (THIS.PROCESS)) 'EXEC) (SETREADFN 'READ) (TTYDISPLAYSTREAM (TEXEC.OPENTEXTSTREAM WINDOW 'TEXEC.DEFAULT.MENUFN)) (STREAMPROP \\TERM.OFD 'FIXFN (FUNCTION TEXEC.FIX)) (* |Put| FIX |function| |on| |stream|) (STREAMPROP \\LINEBUF.OFD 'REFILLBUFFERFN (FUNCTION TEXEC.FILLBUFFER)) (* |Attach| |the| READREFILL  |function| |to| |the| |newly|  |created| LINEBUFFER) (WHENCLOSE \\TERM.OFD 'BEFORE 'DON\'T) (WINDOWPROP WINDOW 'CLOSEFN NIL) (WINDOWPROP WINDOW 'ICONFN (FUNCTION TEXEC.SHRINK.ICONCREATE)) (WINDOWPROP WINDOW 'ICON NIL) (WINDOWPROP WINDOW 'TEDIT.ICON.TITLE NIL) (WINDOWPROP WINDOW 'ICONWINDOW NIL) (WINDOWPROP WINDOW 'ICONPOSITION NIL) (|replace| PROCTTYENTRYFN |of| (THIS.PROCESS) |with| (FUNCTION TEXEC.PROCENTRYFN)) (|replace| PROCTTYEXITFN |of| (THIS.PROCESS) |with| (FUNCTION TEXEC.PROCEXITFN)) (SETREADFN 'TTYINREAD)) (T (PROMPTPRINT "Switching EXEC to TEXEC must be done from EXEC window")))))) ) (APPENDTOVAR |BackgroundMenuCommands| (TEXEC '(TEXEC) "Starts TEXEC in a new window.")) (READVARS-FROM-STRINGS '(TEXEC.ICON TEXEC.ICON.MASK TEXEC.TITLED.ICON.TEMPLATE) " ( {(READBITMAP)(64 77 \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@OH@@@@@@@@@\" \"@@@@COL@@@@@@@@@\" \"@@@@CON@@@@@@@@@\" \"@@@@GHC@@@@@@@@@\" \"@@@@O@AH@@@@@@@@\" \"@@@AKBEL@@@@@@@@\" \"@@@AC@BD@@@@@@@@\" \"@@@AAHBD@@@@@@@@\" \"@@@A@LBD@@@@@@@@\" \"@@@A@NDD@@@@@@@@\" \"@@@AGOOL@@@@@@@@\" \"@@@AHFDF@@@@@@@@\" \"@@@AHBDB@@@@@@@@\" \"@@@A@BDC@@@@@@@@\" \"@@@A@AHA@@@@@@@@\" \"@@@A@AIAH@@@@@@@\" \"@@@AA@I@H@@@@@@@\" \"@@@CA@HHH@@@@@@@\" \"@@@BA@HHHC@@@@@@\" \"@@@CA@I@DB@@@@@@\" \"@@@AAH@HBF@@@@@@\" \"@@@AHF@HNL@@@@@@\" \"@@@ALC@GIL@@@@@@\" \"@@@ADNLC@H@@@@@@\" \"OOOOOHGOMOOOH@@@\" \"O@@@@HDDGH@@O@@@\" \"ON@@@GHC@F@@AN@@\" \"LOL@@@@AOOH@@CL@\" \"LAOH@@@@@@@@@@GH\" \"L@COOOOOOOOOOOOO\" \"L@@GOOOOOOOOOOOO\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"O@@CH@@@@@@@@@@C\" \"ON@CH@@@@@@@@@@C\" \"LOLCH@@@@@@@@@@C\" \"LAOKH@@@@@@@@@@C\" \"@@COOOOOOOOOOOOO\" \"@@@GH@@@@@@@@@@C\" \"@@@CH@@@@@@@@@@C\" \"@@@CH@@@@@@@@@@C\" \"@@@AH@@@@@@@@@@C\")} {(READBITMAP)(64 77 \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"@@@@@@@@@@@@@@@@\" \"@@@@@OH@@@@@@@@@\" \"@@@@COL@@@@@@@@@\" \"@@@@CON@@@@@@@@@\" \"@@@@GOO@@@@@@@@@\" \"@@@@OOOH@@@@@@@@\" \"@@@AOOOL@@@@@@@@\" \"@@@AOOOL@@@@@@@@\" \"@@@AOOOL@@@@@@@@\" \"@@@AOOOL@@@@@@@@\" \"@@@AOOOL@@@@@@@@\" \"@@@AOOOL@@@@@@@@\" \"@@@AOOON@@@@@@@@\" \"@@@AOOON@@@@@@@@\" \"@@@AOOOO@@@@@@@@\" \"@@@AOOOO@@@@@@@@\" \"@@@AOOOOH@@@@@@@\" \"@@@AOOOOH@@@@@@@\" \"@@@COOOOH@@@@@@@\" \"@@@COOOOHC@@@@@@\" \"@@@COOOOLB@@@@@@\" \"@@@AOOOONF@@@@@@\" \"@@@AOOOONL@@@@@@\" \"@@@AOOOOOL@@@@@@\" \"@@@AOOOOOH@@@@@@\" \"OOOOOOOOOOOOH@@@\" \"OOOOOOOOOOOOO@@@\" \"OOOOOOOOOOOOON@@\" \"OOOOOOOOOOOOOOL@\" \"OOOOOOOOOOOOOOOH\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"LOOOOOOOOOOOOOOO\" \"LAOOOOOOOOOOOOOO\" \"@@COOOOOOOOOOOOO\" \"@@@GH@@@@@@@@@@C\" \"@@@CH@@@@@@@@@@C\" \"@@@CH@@@@@@@@@@C\" \"@@@AH@@@@@@@@@@C\")} ( {(READBITMAP)(64 77 \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@@@@@@@@@@@@\" \"@@@@@OH@@@@@@@@@\" \"@@@@COL@@@@@@@@@\" \"@@@@CON@@@@@@@@@\" \"@@@@GHC@@@@@@@@@\" \"@@@@O@AH@@@@@@@@\" \"@@@AKBEL@@@@@@@@\" \"@@@AC@BD@@@@@@@@\" \"@@@AAHBD@@@@@@@@\" \"@@@A@LBD@@@@@@@@\" \"@@@A@NDD@@@@@@@@\" \"@@@AGOOL@@@@@@@@\" \"@@@AHFDF@@@@@@@@\" \"@@@AHBDB@@@@@@@@\" \"@@@A@BDC@@@@@@@@\" \"@@@A@AHA@@@@@@@@\" \"@@@A@AIAH@@@@@@@\" \"@@@AA@I@H@@@@@@@\" \"@@@CA@HHH@@@@@@@\" \"@@@BA@HHHC@@@@@@\" \"@@@CA@I@DB@@@@@@\" \"@@@AAH@HBF@@@@@@\" \"@@@AHF@HNL@@@@@@\" \"@@@ALC@GIL@@@@@@\" \"@@@ADNLC@H@@@@@@\" \"OOOOOHGOMOOOH@@@\" \"O@@@@HDDGH@@O@@@\" \"ON@@@GHC@F@@AN@@\" \"LOL@@@@AOOH@@CL@\" \"LAOH@@@@@@@@@@GH\" \"L@COOOOOOOOOOOOO\" \"L@@GOOOOOOOOOOOO\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"L@@CH@@@@@@@@@@C\" \"O@@CH@@@@@@@@@@C\" \"ON@CH@@@@@@@@@@C\" \"LOLCH@@@@@@@@@@C\" \"LAOKH@@@@@@@@@@C\" \"@@COOOOOOOOOOOOO\" \"@@@GH@@@@@@@@@@C\" \"@@@CH@@@@@@@@@@C\" \"@@@CH@@@@@@@@@@C\" \"@@@AH@@@@@@@@@@C\")} {(READBITMAP)(64 77 \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"@@@@@@@@@@@@@@@@\" \"@@@@@OH@@@@@@@@@\" \"@@@@COL@@@@@@@@@\" \"@@@@CON@@@@@@@@@\" \"@@@@GOO@@@@@@@@@\" \"@@@@OOOH@@@@@@@@\" \"@@@AOOOL@@@@@@@@\" \"@@@AOOOL@@@@@@@@\" \"@@@AOOOL@@@@@@@@\" \"@@@AOOOL@@@@@@@@\" \"@@@AOOOL@@@@@@@@\" \"@@@AOOOL@@@@@@@@\" \"@@@AOOON@@@@@@@@\" \"@@@AOOON@@@@@@@@\" \"@@@AOOOO@@@@@@@@\" \"@@@AOOOO@@@@@@@@\" \"@@@AOOOOH@@@@@@@\" \"@@@AOOOOH@@@@@@@\" \"@@@COOOOH@@@@@@@\" \"@@@COOOOHC@@@@@@\" \"@@@COOOOLB@@@@@@\" \"@@@AOOOONF@@@@@@\" \"@@@AOOOONL@@@@@@\" \"@@@AOOOOOL@@@@@@\" \"@@@AOOOOOH@@@@@@\" \"OOOOOOOOOOOOH@@@\" \"OOOOOOOOOOOOO@@@\" \"OOOOOOOOOOOOON@@\" \"OOOOOOOOOOOOOOL@\" \"OOOOOOOOOOOOOOOH\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"OOOOOOOOOOOOOOOO\" \"LOOOOOOOOOOOOOOO\" \"LAOOOOOOOOOOOOOO\" \"@@COOOOOOOOOOOOO\" \"@@@GH@@@@@@@@@@C\" \"@@@CH@@@@@@@@@@C\" \"@@@CH@@@@@@@@@@C\" \"@@@AH@@@@@@@@@@C\")} (8 30 60 60))) ") (RPAQ TEXEC.ICON.TITLE.REGION (CREATE REGION BOTTOM _ 55 LEFT _ 6 WIDTH _ 77 HEIGHT _ 16)) (RPAQ TEXEC.ICON.FONT (FONTCREATE 'HELVETICA 8 'BOLD)) (RPAQ TEXEC.DEFAULT.MENU (TEXEC.CREATEMENU '((|Put| '|Put| NIL (SUBITEMS |Plain-Text| |Old-Format|)) (|Include| '|Include|) ("Forward Find" '|ForwardFind|) ("Backward Find" '|BackwardFind|) (|Limit| '|Limit|)))) (RPAQQ |BackgroundMenu| NIL) (RPAQ? TEXEC.BUFFERLIMIT 10000) (PUTPROPS TEXEC COPYRIGHT ("Venue & Xerox Corporation" 1985 1900 1986 1987 1988 1989 1990 1991)) (DECLARE\: DONTCOPY (FILEMAP (NIL (3793 183206 (TEXEC.BACKSKREAD 3803 . 8427) (TEXEC.OPENTEXTSTREAM 8429 . 10643) ( TEXEC.DEFAULT.MENUFN 10645 . 15199) (TEXEC.DO?CMD 15201 . 20519) (TEXEC.CREATEMENU 20521 . 20979) ( TEXEC.GET 20981 . 29816) (TEXEC.INCLUDE 29818 . 43700) (TEXEC.FIND.FORWARD 43702 . 56590) ( TEXEC.FIND.BACKWARD 56592 . 70094) (TEDIT.FIND.BACKWARD 70096 . 75573) (TEDIT.BASICFIND.BACKWARD 75575 . 80229) (TEXEC.MENU.WHENHELDFN 80231 . 80890) (TEXEC.SHRINK.ICONCREATE 80892 . 83695) ( TEXEC.FILLBUFFER 83697 . 100131) (TEXEC.FILLBUFFER.TCLASS 100133 . 106473) (TEXEC.CHSELPENDING 106475 . 114965) (TEXEC.FILLBUFFER.CHARDELETE 114967 . 117022) (TEXEC.FILLBUFFER.WORDDELETE 117024 . 122152) (TEXEC.FILLBUFFER.LINEDELETE 122154 . 125036) (TEXEC.PARENCOUNT 125038 . 126427) (TEXEC.PARENMATCH 126429 . 127969) (TEXEC.FLASHCARET 127971 . 130630) (TEXEC.TEXTSTREAM.TO.LINEBUF 130632 . 133319) ( TEXEC.FIX 133321 . 136490) (TEXEC.NTHBUFCHARBACK 136492 . 137555) (TEXEC.NTHBACKCHNUM 137557 . 138842) (TEXEC.EOTP 138844 . 139577) (TEXEC.GETKEY 139579 . 142495) (TEXEC.INSERTCHAR 142497 . 144798) ( TEXEC.DELETE 144800 . 145575) (TEXEC.\\CHDEL1 145577 . 148702) (TEXEC.?EQUAL 148704 . 149753) ( TEDIT.SCROLL? 149755 . 154718) (TEXEC.DISPLAYTEXT 154720 . 161495) (\\TEXEC.TEXTBOUT 161497 . 164505) (\\TEXEC.TEXTBOUT1 164507 . 170141) (\\TEXEC.TEXTBOUT2 170143 . 172474) (\\TEXEC.TEXTBOUT3 172476 . 173866) (\\TEXEC.TEXTBOUT4 173868 . 175911) (\\TEXEC.SELFN 175913 . 177288) (TEXEC.PRINTARGS 177290 . 182253) (TEXEC.PROCENTRYFN 182255 . 182796) (TEXEC.PROCEXITFN 182798 . 183204)) (183266 189641 (TEXEC 183276 . 187698) (TTEXEC 187700 . 189639))))) STOP \ No newline at end of file diff --git a/library/TEXTMODULES b/library/TEXTMODULES new file mode 100644 index 00000000..79b69377 --- /dev/null +++ b/library/TEXTMODULES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (CLIN-PACKAGE (DEFPACKAGE "TEXTMODULES" (USE "LISP" "XCL") (PREFIX-NAME "TM") (EXPORT "LOAD-TEXTMODULE" "MAKE-TEXTMODULE" "*SPECIFIERS*" "MAKE-SPECIFIER" "INSTALL-FORM" "FORM-SPECIFIER" "FILECOM-SPECIFIER" "ADD-FORM" "INSTALL-FORM" "PRINT-FILECOM" "*UPGRADE-COMMENT-LENGTH*" "*JOIN-COMMENTS*" "*CONVERT-LOADED-FILES*" "*DEFDEFINER-MACROS*"))) (FILESLOAD SEDIT-COMMONLISP) *PACKAGE*) BASE 10) (IL:FILECREATED " 7-Jan-91 17:36:04" IL:|{DSK}bane>LISP>TEXTMODULES.;3| 52006 IL:|changes| IL:|to:| (IL:FUNCTIONS INSTALL-READ-MACRO DEFPRESENTATION PRINT-HASH-BASED-NUMBER READ-HASH-BASED-NUMBER TRANSLATE-HASH-BASED-NUMBER HANDLE-READ-MACROS PRINT-HASH-STAR READ-HASH-STAR TRANSLATE-HASH-STAR PRINT-READABLE-READ-TIME-CONDITIONAL PRINT-UNREADABLE-READ-TIME-CONDITIONAL TRANSLATE-READ-TIME-CONDITIONAL READ-READ-TIME-CONDITIONAL) (IL:PRESENTATIONS HASH-BASED-NUMBER HASH-STAR HASH-IL-READABLE HASH-IL-UNREADABLE) (IL:VARS IL:TEXTMODULESCOMS) (IL:VARIABLES *SEDIT-READ-MACROS* *CONDITIONAL-KEYWORDS*) (IL:STRUCTURES READ-TIME-CONDITIONAL) IL:|previous| IL:|date:| " 4-Dec-90 00:36:08" IL:|{DSK}bane>LISP>TEXTMODULES.;2|) ; Copyright (c) 1987, 1988, 1989, 1990, 1991 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:|;;| "Top-level and top-level internal functions") (IL:FUNCTIONS ADD-FORM BEFORE-MAKE-TEXTMODULE-FUNCTIONS CONVERT-LOADED-FILES DEFINER-FILECOM DEFPRESENTATION EXPORT-DEFINERS FILECOM-SPECIFIER FORM-SPECIFIER HANDLE-READ-MACROS IMPORT-DEFINERS INSTALL-FORM INSTALL-READ-MACRO LOAD-TEXTMODULE MAKE-LISP-FILE-READTABLE MAKE-TEXTMODULE NAME-OF PARSE-ENVIRONMENT-SETUP-FILECOMS PRINT-ENVIRONMENT-FORMS PRINT-FILECOM PROCESS-COMS-AFTER-LOAD REMOVE-PRESENTATION SYMBOLS-TRANSLATE TOP-LEVEL-FORM TOP-LEVEL-FORM-FORM TOP-LEVEL-FORM-P TRANSLATE-FORM) (IL:* IL:|;;| "Support for semi-colon comments. Semicolon comments are special cased in this code, because rewriting the SEdit support for that presentation would be hard.") (IL:FUNCTIONS ADJOIN-COMMENTS MAYBE-ADJOIN-COMMENTS MAYBE-UPGRADE-COMMENTS PRINT-COMMENT-LINE PRINT-COPYRIGHT-COMMENTS PRINT-SEMICOLON-COMMENT READ-HASH-BAR-COMMENT READ-SEMICOLON-COMMENT SEMICOLON-COMMENT-P UPGRADE-COMMENTS) (IL:* IL:|;;| "Support for #b #o #x #r") (IL:FUNCTIONS PRINT-HASH-BASED-NUMBER READ-HASH-BASED-NUMBER TRANSLATE-HASH-BASED-NUMBER) (IL:* IL:|;;| "Support for #*") (IL:FUNCTIONS PRINT-HASH-STAR READ-HASH-STAR TRANSLATE-HASH-STAR) (IL:* IL:|;;| "Support for #+ #-") (IL:FUNCTIONS PRINT-READABLE-READ-TIME-CONDITIONAL PRINT-UNREADABLE-READ-TIME-CONDITIONAL READ-READ-TIME-CONDITIONAL TRANSLATE-READABLE-RTC TRANSLATE-UNREADABLE-RTC KEYWORDIZE NON-KEYWORD?) (IL:* IL:|;;| "Support for #, #,") (IL:* IL:|;;| "TRANSLATE-PREFIX-QUOTE is believed unnecessary now; check this...") (IL:FUNCTIONS PRINT-PREFIX-QUOTE READ-PREFIX-QUOTE TRANSLATE-PREFIX-QUOTE TRANSLATE-HASH-COMMA TRANSLATE-HASH-DOT) (IL:* IL:|;;| "Some functions used in the old implementation of #+/#-") (IL:FUNCTIONS PRINT-READ-TIME-CONDITIONAL) (IL:STRUCTURES PRESENTATION PREFIX-QUOTE PRESENTATION-OPS READ-TIME-CONDITIONAL SEMICOLON-COMMENT SPECIFIER UNKNOWN-FORM UNKNOWN-SPECIFIER) (IL:VARIABLES *CONDITIONAL-KEYWORDS* *CONVERT-LOADED-FILES* *UPGRADE-COMMENT-LENGTH* *JOIN-COMMENTS* *DEFDEFINER-MACROS* *DELETE-FORM* COMMENT-LEVEL-MARKERS EOF-MARKER *SEDIT-READ-MACROS* *SPECIFIERS*) (IL:P (UNLESS (FIND-PACKAGE "EMPTY") (MAKE-PACKAGE "EMPTY" :USE NIL)) (MAKE-LISP-FILE-READTABLE)) (IL:* IL:|;;| "PRESENTATIONS handing reading and printing of CL constructs") (IL:DEFINE-TYPES IL:PRESENTATIONS) (IL:PRESENTATIONS HASH-BASED-NUMBER HASH-COMMA HASH-DOT HASH-IL-READABLE HASH-IL-UNREADABLE HASH-STAR) (IL:ADVISE REMOVE-COMMENTS (IL:EVAL :IN IL:\\DO-DEFINE-FILE-INFO)) (IL:* IL:|;;| "(IL:FILES IL:SEDIT-COMMONLISP)") (IL:PROP IL:ARGNAMES LOAD-TEXTMODULE MAKE-TEXTMODULE MAKE-SPECIFIER INSTALL-FORM FILECOM-SPECIFIER FORM-SPECIFIER ADD-FORM PRINT-FILECOM) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:TEXTMODULES))) (IL:* IL:|;;;| "TEXTMODULES, a text file to file manager conversion utility.") (IL:* IL:|;;| "Top-level and top-level internal functions") (DEFUN ADD-FORM (FORM FILECOMS &OPTIONAL (SPECIFIER (FORM-SPECIFIER FORM))) "Call appropriate functions to make definition editable, return new filecoms." (FUNCALL (SPECIFIER-ADD-FORM SPECIFIER) FORM FILECOMS)) (DEFUN BEFORE-MAKE-TEXTMODULE-FUNCTIONS (FILE STREAM) "Things to do before the main body of the textmodule is printed." (PRINT-COMMENT-LINE (GET FILE (QUOTE IL:MAKEFILE-ENVIRONMENT)) STREAM) (PRINT-COPYRIGHT-COMMENTS FILE STREAM) (TERPRI STREAM) (PRINT-ENVIRONMENT-FORMS (GET FILE (QUOTE IL:MAKEFILE-ENVIRONMENT)) STREAM) (TERPRI STREAM)) (DEFUN CONVERT-LOADED-FILES (FORM) "Looks for loaded files to convert in top-level forms." (DECLARE (SPECIAL *CONVERT-LOADED-FILES*)) (WHEN (AND *CONVERT-LOADED-FILES* (MEMBER (CAR FORM) (QUOTE (LOAD REQUIRE)) :TEST (QUOTE EQ)) (IF (EQ *CONVERT-LOADED-FILES* :QUERY) (Y-OR-N-P "Convert file loaded by ~s too?" FORM) T)) (CASE (CAR FORM) (LOAD (LOAD-TEXTMODULE (EVAL (SECOND FORM)))) (REQUIRE (LOAD-TEXTMODULE (EVAL (THIRD FORM)))))) FORM) (DEFUN DEFINER-FILECOM (FORM) "Examines a form and returns its specifier (file command)." (GET (CAR FORM) (QUOTE :DEFINER-FOR))) (DEFDEFINER DEFPRESENTATION IL:PRESENTATIONS (NAME &KEY FIELDS INCLUDE PRINT-FUNCTION (READ-MACRO NIL) (TRANSLATOR (FUNCTION (LAMBDA (PRESENTATION) (CERROR "Ignore the presentation" "Untranslatable presentation ~s" 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 (HANDLE-READ-MACROS (QUOTE (IL:\\\, READ-MACRO))))))) (QUOTE (IL:\\\, NAME))))) (DEFUN EXPORT-DEFINERS (FORM) "Turn definers into macros." (IF (EQ (CAR FORM) (QUOTE DEFDEFINER)) (LET* ((CLEANED-FORM (REMOVE-COMMENTS FORM)) (NAME (SECOND CLEANED-FORM)) (DEFINER-FOR (THIRD CLEANED-FORM)) (BODY (CDR (MEMBER DEFINER-FOR FORM)))) (IL:BQUOTE (DEFMACRO (IL:\\\, (IF (CONSP NAME) (CAR NAME) NAME)) (IL:\\\,@ BODY)))) FORM)) (DEFUN FILECOM-SPECIFIER (FILECOM) "Return the specifier for the filecom, otherwise warn." (OR (SOME (FUNCTION (LAMBDA (SPECIFIER) (AND (FUNCALL (SPECIFIER-FILECOM-P SPECIFIER) FILECOM) SPECIFIER))) *SPECIFIERS*) (IL:NILL (WARN (QUOTE UNKNOWN-SPECIFIER) :SPECIFIER FILECOM)))) (DEFUN FORM-SPECIFIER (FORM) "Return the specifier for the form, otherwise warn." (OR (SOME (FUNCTION (LAMBDA (SPECIFIER) (AND (FUNCALL (SPECIFIER-FORM-P SPECIFIER) FORM) SPECIFIER))) *SPECIFIERS*) (IL:NILL (WARN (QUOTE UNKNOWN-FORM) :FORM FORM)))) (DEFUN HANDLE-READ-MACROS (MAC) (IL:* IL:|;;| "Read macros defined by presentations need to be installed in the \"LISP-FILE\" readtable. In addition those marked :SEDIT need to be on the *SEDIT-READ-MACROS* list. MAC can be a list of the form:") (IL:* IL:|;;| "( [] [:SEDIT]") (IL:* IL:|;;| "or it can be a list of such lists.") (IF (CONSP (FIRST MAC)) (IL:* IL:\; "Handle nested macro specs") (DOLIST (RM MAC) (HANDLE-READ-MACROS RM)) (PROGN (INSTALL-READ-MACRO MAC (IL:FIND-READTABLE "LISP-FILE")) (WHEN (EQ :SEDIT (CAR (LAST MAC))) (LET* ((KEY (IF (AND (CHARACTERP (FIRST MAC)) (CHARACTERP (SECOND MAC))) (CONS (FIRST MAC) (SECOND MAC)) (FIRST MAC))) (DATA (IF (CHARACTERP KEY) (SECOND MAC) (THIRD MAC)))) (SETF (GETHASH KEY *SEDIT-READ-MACROS*) DATA)))))) (DEFUN IMPORT-DEFINERS (FORM) "Change a macro to a definer if we've been told its OK." (DECLARE (SPECIAL *DEFDEFINER-MACROS*)) (IF (AND (EQ (CAR FORM) (QUOTE DEFMACRO)) (MEMBER (CADR FORM) *DEFDEFINER-MACROS* :TEST (QUOTE EQ))) (IL:BQUOTE (DEFDEFINER (IL:\\\, (CADR FORM)) IL:FUNCTIONS (IL:\\\,@ (CDDR FORM)))) FORM)) (DEFUN INSTALL-FORM (FORM &OPTIONAL (SPECIFIER (FORM-SPECIFIER FORM))) "Install a definition as current and executable." (WHEN (NOT (MEMBER IL:DFNFLG (QUOTE (IL:PROP IL:ALLPROP)))) (FUNCALL (SPECIFIER-INSTALL-FORM SPECIFIER) 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 (STRING-UPCASE (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.") (UPGRADE-COMMENT-LENGTH *UPGRADE-COMMENT-LENGTH*) (IL:* IL:\; "Change single to double semi at this length.") (JOIN-COMMENTS *JOIN-COMMENTS*) (IL:* IL:\; "Smash together adjacent comments?") (CONVERT-LOADED-FILES *CONVERT-LOADED-FILES*) (DEFDEFINER-MACROS *DEFDEFINER-MACROS*) (IL:* IL:\; "Names of macros that should become definers.")) "Load a text file, creating a content description." (SETQ PATHNAME (MERGE-PATHNAMES PATHNAME ".LISP")) (ETYPECASE MODULE (STRING T) (SYMBOL (SETQ MODULE (SYMBOL-NAME MODULE)))) (LET ((IL:DFNFLG (IF (NULL INSTALL) (QUOTE IL:PROP) INSTALL)) (*PACKAGE* (IF (PACKAGEP PACKAGE) PACKAGE (FIND-PACKAGE PACKAGE))) (*READTABLE* (IL:FIND-READTABLE "LISP-FILE")) (*JOIN-COMMENTS* JOIN-COMMENTS) (*UPGRADE-COMMENT-LENGTH* UPGRADE-COMMENT-LENGTH) (*CONVERT-LOADED-FILES* CONVERT-LOADED-FILES) (*DEFDEFINER-MACROS* DEFDEFINER-MACROS) (FILECOMS NIL)) (DECLARE (SPECIAL *PACKAGE* *READTABLE* *JOIN-COMMENTS* *UPGRADE-COMMENT-LENGTH* *CONVERT-LOADED-FILES* *DEFDEFINER-MACROS*)) (WITH-OPEN-FILE (STREAM PATHNAME :DIRECTION :INPUT) (LET (FORM) (LOOP (SETQ FORM (READ STREAM NIL EOF-MARKER)) (MAYBE-ADJOIN-COMMENTS FORM) (MAYBE-UPGRADE-COMMENTS FORM) (WHEN (EQ FORM EOF-MARKER) (RETURN NIL)) (IL:* IL:|;;| "JRB - This used to be ADD-FORM and then INSTALL-FORM; I believe it needs to be the other way around. Consider:") (IL:* IL:|;;| "(EVAL-WHEN (EVAL COMPILE LOAD)") (IL:* IL:|;;| " (DEFMACRO MUMBLE (...))") (IL:* IL:|;;| " (MUMBLE ...)") (IL:* IL:|;;| "where MUMBLE is on *DEFDEFINER-MACROS*. The whole EVAL-WHEN goes on the coms before any of it gets installed, so the sub-mumbles don't get made into (FUNCTIONS ...) coms entries.") (LET ((SPECIFIER (FORM-SPECIFIER FORM))) (INSTALL-FORM FORM SPECIFIER) (SETQ FILECOMS (ADD-FORM FORM FILECOMS SPECIFIER)))))) (MULTIPLE-VALUE-BIND (FILECOMS ENVIRONMENT) (PARSE-ENVIRONMENT-SETUP-FILECOMS FILECOMS) (MAYBE-ADJOIN-COMMENTS FILECOMS) (MAYBE-UPGRADE-COMMENTS FILECOMS) (IL:* IL:\; "Must be done AFTER the environment setup is parsed out, lest the env comment be joined to the rest of the initial comments and stripped.") (SETQ FILECOMS (PROCESS-COMS-AFTER-LOAD FILECOMS)) (LET* ((NAME (INTERN MODULE "INTERLISP")) (FILEVAR (IL:FILECOMS NAME))) (SETF (SYMBOL-VALUE FILEVAR) FILECOMS) (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) NAME)))) (DEFUN MAKE-LISP-FILE-READTABLE NIL "Build and name the LISP-FILE readtable." (LET ((TABLE (OR (IL:FIND-READTABLE "LISP-FILE") (IL:* IL:\; "If this is removed, the file cannot be loaded prop and continue to work. The LISP-FILE readtable will be initialized, but the defpresentation forms not re-evaluated.") (COPY-READTABLE (IL:FIND-READTABLE "XCL")))) (IL:* IL:\; "This has to be copied from XCL so that XAIE FIle Manager can read and write the imported files!")) (SET-MACRO-CHARACTER #\; (FUNCTION READ-SEMICOLON-COMMENT) NIL 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))) (FILECOMS (SYMBOL-VALUE (IL:FILECOMS MODULE))) (WIDTH 80)) "Write a text file based on the file manager file." (SETQ MODULE (ETYPECASE MODULE (STRING MODULE) (SYMBOL (SYMBOL-NAME MODULE)))) (LET ((*PACKAGE* (FIND-PACKAGE "USER")) (*READTABLE* (IL:FIND-READTABLE "LISP-FILE")) (*PRINT-BASE* *PRINT-BASE*) (*PRINT-CASE* :DOWNCASE) (*PRINT-ARRAY* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) (*PRINT-STRUCTURE* T) (*PRINT-PRETTY* T) (IL:*PRINT-SEMICOLON-COMMENTS* T) (IL:FONTCHANGEFLG NIL) (IL:\#RPARS NIL) (IL:**COMMENT**FLG NIL) (FILE (IL:MKATOM MODULE))) (DECLARE (SPECIAL IL:*PRINT-SEMICOLON-COMMENTS* FILE)) (WITH-OPEN-FILE (STREAM PATHNAME :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) (IL:LINELENGTH WIDTH STREAM) (IL:* IL:\; "For Interlisp prettyprinter.") (BEFORE-MAKE-TEXTMODULE-FUNCTIONS (INTERN MODULE "INTERLISP") STREAM) (DOLIST (FILECOM FILECOMS) (FRESH-LINE STREAM) (LET ((TYPE (FILECOM-SPECIFIER FILECOM))) (WHEN TYPE (PRINT-FILECOM FILECOM STREAM TYPE)))))) PATHNAME) (DEFUN NAME-OF (FORM) (FUNCALL (GET (CAR FORM) (QUOTE :DEFINITION-NAME)) (REMOVE-COMMENTS FORM))) (DEFUN PARSE-ENVIRONMENT-SETUP-FILECOMS (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.") (COMMENT-FORMS NIL) (IL:* IL:\; "Comments to be pushed onto the front of the coms.")) (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 COMMENT-FORMS, others 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)) (WHEN (NOT (READ-TIME-CONDITIONAL-P FORM)) (RETURN NIL))) ((SEMICOLON-COMMENT-P HEAD) NIL) (T (RETURN-FROM PARSE-COMPLETE NIL)))) (POP NEXT-TAIL))) (POP-FORMS NIL (IL:* IL:|;;| "Comments between CONTENTS and (not including) NEXT-TAIL are popped onto COMMENT-FORMs. The form in NEXT-TAIL is discarded and CONTENTS is updated.") (LOOP (WHEN (EQ CONTENTS NEXT-TAIL) (RETURN NIL)) (PUSH (POP CONTENTS) COMMENT-FORMS)))) (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 (SYMBOLS-TRANSLATE FORM) PACKAGE-FORM)) (WHEN-RECOGNIZED (EQ (FIRST FORM) (QUOTE EXPORT)) (PUSH (SYMBOLS-TRANSLATE 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 (SYMBOLS-TRANSLATE FORM) PACKAGE-FORM)) (WHEN-RECOGNIZED (EQ (FIRST FORM) (QUOTE SHADOWING-IMPORT)) (PUSH (SYMBOLS-TRANSLATE 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 (APPEND (NREVERSE COMMENT-FORMS) CONTENTS) (IL:BQUOTE (:READTABLE "LISP-FILE" :PACKAGE (IL:\\\, (IF PACKAGE-FORM (IL:BQUOTE (LET ((*PACKAGE* *PACKAGE*)) (IL:\\\,@ (NREVERSE PACKAGE-FORM)) *PACKAGE*)) "USER")) :BASE (IL:\\\, BASE)))))) (DEFUN PRINT-ENVIRONMENT-FORMS (ENVIRONMENT STREAM) "Print the environment initializing forms from ENVIRONMENT onto STREAM." (MACROLET ((PRINT-AND-EVAL (FORM STREAM) (IL:BQUOTE (LET ((FORM (IL:\\\, FORM))) (LET ((*PACKAGE* (FIND-PACKAGE "EMPTY"))) (IL:* IL:\; "This allows IMPORT, SHADOW, etc. statements to work, although it increases verbosity...") (PPRINT FORM (IL:\\\, STREAM))) (EVAL FORM))))) (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 (QUOTE (IL:\\\, NICKNAMES))))))))) STREAM) (MAPC (FUNCTION (LAMBDA (OPTION FUNCTION) (LET ((VALUE (CDR (ASSOC OPTION (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-FILECOM (FILECOM STREAM &OPTIONAL (SPECIFIER (FILECOM-SPECIFIER FILECOM))) "Gets the print form of a specifier." (FUNCALL (SPECIFIER-PRINT-FILECOM SPECIFIER) FILECOM STREAM)) (DEFUN PROCESS-COMS-AFTER-LOAD (CONTENTS) "Destructively optimize COMS; compress adjacent definers, p, files, evert redundant COMS." (DO ((TAIL CONTENTS)) ((NULL TAIL) CONTENTS) (LET ((ONE (FIRST TAIL))) (COND ((AND (CDR TAIL) (OR (GET (FIRST ONE) (QUOTE :DEFINED-BY)) (MEMBER (FIRST ONE) (QUOTE (IL:FILES IL:P)))) (EQ (FIRST ONE) (FIRST (SECOND TAIL)))) (IL:* IL:\; "Adjacent coms of same type.") (LET ((END-OF-ONE (LAST ONE)) (IL:* IL:\; "Last cell in first com.") (HEAD-OF-TWO (CDR (SECOND TAIL)))) (IL:* IL:\; "The tail of the next com.") (RPLACD END-OF-ONE HEAD-OF-TWO) (IL:* IL:\; "Append next tail onto current.") (RPLACD TAIL (CDDR TAIL)) (IL:* IL:\; "Splice OUT second com."))) ((EQ (QUOTE IL:COMS) (FIRST ONE)) (IL:* IL:\; "Descend into IL:COMS") (RPLACD ONE (PROCESS-COMS-AFTER-LOAD (CDR ONE))) (WHEN (NULL (CDDR ONE)) (IL:* IL:\; "Remove redundant COMS enclosures.") (RPLACA TAIL (SECOND ONE)) (IL:* IL:\; "Replace the form with its contents.")) (POP TAIL)) ((OR (EQ (QUOTE IL:EVAL-WHEN) (FIRST ONE)) (EQ (QUOTE EVAL-WHEN) (FIRST ONE))) (IL:* IL:\; "Descend into EVAL-WHENs") (RPLACD (CDR ONE) (PROCESS-COMS-AFTER-LOAD (CDDR ONE))) (POP TAIL)) (T (POP TAIL)))))) (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 SYMBOLS-TRANSLATE (FORM) (IL:BQUOTE ((IL:\\\, (FIRST FORM)) (IL:\\\, (LET ((NONLOCAL-SYMBOLS NIL) (IL:* IL:\; "These are symbols defined elsewhere.") (STRINGIFY-SYMBOLS NIL) (IL:* IL:\; "These are symbols accessible in the current package.")) (DOLIST (SYMBOL (EVAL (TRANSLATE-FORM (SECOND FORM)))) (COND ((EQ SYMBOL (FIND-SYMBOL (SYMBOL-NAME SYMBOL))) (PUSH (SYMBOL-NAME SYMBOL) STRINGIFY-SYMBOLS)) (T (PUSH SYMBOL NONLOCAL-SYMBOLS)))) (IF (NULL NONLOCAL-SYMBOLS) (IL:BQUOTE (MAPCAR (FUNCTION INTERN) (QUOTE (IL:\\\, STRINGIFY-SYMBOLS)))) (IL:BQUOTE (APPEND (QUOTE (IL:\\\, NONLOCAL-SYMBOLS)) (MAPCAR (FUNCTION INTERN) (QUOTE (IL:\\\, STRINGIFY-SYMBOLS)))))))) (IL:\\\,@ (CDDR FORM))))) (DEFMACRO TOP-LEVEL-FORM (&BODY FORMS) "Wrapped around top level forms to install presentations." (IL:BQUOTE (PROGN (IL:\\\,@ (TRANSLATE-FORM FORMS))))) (DEFUN TOP-LEVEL-FORM-FORM (PLACE) "Return the form in the top-level form specifier." (IL:* IL:|;;| "JRB - when PLACE is a (P (FOO) (BAR)...) expression, turn it into a PROGN (should really rework the guts of the converter to handle each clause seperately, but...)") (FLET ((STRIP (FORM) (IF (EQ (FIRST FORM) (QUOTE TOP-LEVEL-FORM)) (SECOND FORM) FORM))) (IF (CDDR PLACE) (IL:BQUOTE (PROGN (IL:\\\,@ (MAPCAR (FUNCTION STRIP) (CDR PLACE))))) (STRIP (SECOND 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))) (IL:* IL:|;;| "Support for semi-colon comments. Semicolon comments are special cased in this code, because rewriting the SEdit support for that presentation would be hard." ) (DEFUN ADJOIN-COMMENTS (FORM) "Smashes same type comments together. No return value." (COND ((NOT (LISTP FORM))) ((OR (NULL FORM) (NULL (CDR FORM))) (IL:* IL:\; "Zero or one element")) (T (IL:* IL:\; "CONSP form = T") (LET ((HEAD FORM) (FIRST NIL) (SECOND NIL)) (LOOP (UNLESS (CONSP (CDR HEAD)) (IL:* IL:\; "Dotted lists") (RETURN)) (SETQ FIRST (FIRST HEAD)) (SETQ SECOND (SECOND HEAD)) (COND ((AND (SEMICOLON-COMMENT-P FIRST) (SEMICOLON-COMMENT-P SECOND) (EQ (SEMICOLON-COMMENT-MARKER FIRST) (SEMICOLON-COMMENT-MARKER SECOND))) (IL:* IL:|;;| "Smash second onto first") (SETF (SEMICOLON-COMMENT-STRING FIRST) (CONCATENATE (QUOTE STRING) (SEMICOLON-COMMENT-STRING FIRST) " " (SEMICOLON-COMMENT-STRING SECOND))) (IL:* IL:|;;| "Delete cell from list.") (RPLACD HEAD (CDDR HEAD))) (T (IL:* IL:|;;| "Recurse") (ADJOIN-COMMENTS FIRST) (IL:* IL:|;;| "Continue") (SETQ HEAD (CDR HEAD)))) (WHEN (NULL HEAD) (RETURN))))))) (DEFUN MAYBE-ADJOIN-COMMENTS (CONTENTS) (DECLARE (SPECIAL *JOIN-COMMENTS*)) (WHEN *JOIN-COMMENTS* (SETQ CONTENTS (ADJOIN-COMMENTS CONTENTS))) CONTENTS) (DEFUN MAYBE-UPGRADE-COMMENTS (FORM) "Depending on setting of *upgrade-comment-length* we upgrade comments in this form." (IF (NUMBERP *UPGRADE-COMMENT-LENGTH*) (UPGRADE-COMMENTS FORM) 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-COPYRIGHT-COMMENTS (ROOT-NAME STREAM) (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))))) (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 (PEEK-CHAR (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 PEEK-CHAR (PEEK-CHAR NIL STREAM NIL EOF-MARKER)) (WHEN (EQL PEEK-CHAR #\#) (READ-CHAR STREAM NIL EOF-MARKER) (RETURN (MAKE-SEMICOLON-COMMENT :MARKER (QUOTE IL:\|) :STRING COMMENT-BUFFER)))) (VECTOR-PUSH-EXTEND SUB-CHAR COMMENT-BUFFER)))) (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. Another pass upgrades long single semi-colon comments to double...") (LOOP (SETQ CHAR (READ-CHAR STREAM NIL EOF-MARKER)) (WHEN (OR (EQL CHAR EOF-MARKER) (EQL CHAR #\Newline)) (SETQ LEVEL (MIN LEVEL (1- (LENGTH COMMENT-LEVEL-MARKERS)))) (RETURN (MAKE-SEMICOLON-COMMENT :MARKER (ELT COMMENT-LEVEL-MARKERS LEVEL) :STRING COMMENT-BUFFER))) (IF STARTING (SETQ STARTING (COND ((EQL CHAR #\;) (INCF LEVEL)) (T (IF (NOT (EQL CHAR #\Space)) (IL:* IL:\; "Ignore a single space after semicolons, save others.") (VECTOR-PUSH-EXTEND CHAR COMMENT-BUFFER)) NIL))) (VECTOR-PUSH-EXTEND CHAR COMMENT-BUFFER)))) (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 UPGRADE-COMMENTS (FORM) "Smash long single semicolon comments into double semies. No return value." (IL:* IL:|;;| "Should only be called if *UPGRADE-COMMENT-LENGTH* is a number!") (WHEN (CONSP FORM) (DO ((TAIL FORM (CDR TAIL))) ((NOT (CONSP TAIL)) (IL:* IL:\; "Dotted lists")) (LET ((FORM (FIRST TAIL))) (COND ((AND (SEMICOLON-COMMENT-P FORM) (> (LENGTH (SEMICOLON-COMMENT-STRING FORM)) *UPGRADE-COMMENT-LENGTH*)) (SETF (SEMICOLON-COMMENT-MARKER FORM) (NTH 1 COMMENT-LEVEL-MARKERS))) ((CONSP FORM) (UPGRADE-COMMENTS FORM))))))) (IL:* IL:|;;| "Support for #b #o #x #r") (DEFUN PRINT-HASH-BASED-NUMBER (OBJECT STREAM DEPTH) (CASE (HASH-BASED-NUMBER-BASE OBJECT) ((2 8 16) (FORMAT STREAM "#~A~VR" (CASE (HASH-BASED-NUMBER-BASE OBJECT) (IL:* IL:|;;| "Using the atoms here looks a little warped, but it makes this print method obey *print-case* for free...") (2 (QUOTE IL:B)) (8 (QUOTE IL:O)) (16 (QUOTE IL:X))) (HASH-BASED-NUMBER-BASE OBJECT) (HASH-BASED-NUMBER-NUMBER OBJECT))) (OTHERWISE (UNLESS (< 2 (HASH-BASED-NUMBER-BASE OBJECT) 37) (ERROR "Bogus base in ~R presentation: ~d" (HASH-BASED-NUMBER-BASE OBJECT))) (FORMAT STREAM "#~DR~VR" (HASH-BASED-NUMBER-BASE OBJECT) (HASH-BASED-NUMBER-BASE OBJECT) (HASH-BASED-NUMBER-NUMBER OBJECT))))) (DEFUN READ-HASH-BASED-NUMBER (STREAM SUB-CHAR ARG) (LET ((RBASE (ECASE SUB-CHAR ((#\b #\B) 2) ((#\o #\O) 8) ((#\x #\X) 16) ((#\r #\R) (UNLESS (< 2 ARG 37) (ERROR "Bogus base in ~R: ~d" ARG)) ARG)))) (MAKE-HASH-BASED-NUMBER :BASE RBASE :NUMBER (LET ((*READ-BASE* RBASE)) (READ STREAM))))) (DEFUN TRANSLATE-HASH-BASED-NUMBER (OBJECT) (HASH-BASED-NUMBER-NUMBER OBJECT)) (IL:* IL:|;;| "Support for #*") (DEFUN PRINT-HASH-STAR (OBJECT STREAM DEPTH) (PRINC "#*" STREAM) (MAP NIL (FUNCTION (LAMBDA (B) (PRINC (IF (ZEROP B) "0" "1") STREAM))) (HASH-STAR-VECTOR OBJECT))) (DEFUN READ-HASH-STAR (STREAM SUB-CHAR ARG) (MAKE-HASH-STAR :VECTOR (IL:HASH-STAR STREAM SUB-CHAR ARG))) (DEFUN TRANSLATE-HASH-STAR (OBJECT) (HASH-STAR-VECTOR OBJECT)) (IL:* IL:|;;| "Support for #+ #-") (DEFUN PRINT-READABLE-READ-TIME-CONDITIONAL (OBJECT STREAM DEPTH) "Form was read as a string, so print it with PRIN1" (LET ((*PACKAGE* IL:*KEYWORD-PACKAGE*)) (FORMAT STREAM "#~a~s " (READ-TIME-CONDITIONAL-SIGN OBJECT) (READ-TIME-CONDITIONAL-FEATURE OBJECT))) (PRIN1 (READ-TIME-CONDITIONAL-FORM OBJECT) STREAM)) (DEFUN PRINT-UNREADABLE-READ-TIME-CONDITIONAL (OBJECT STREAM DEPTH) "Form was read as a string, so print it with PRINC" (LET ((*PACKAGE* IL:*KEYWORD-PACKAGE*)) (FORMAT STREAM "#~a~s " (READ-TIME-CONDITIONAL-SIGN OBJECT) (READ-TIME-CONDITIONAL-FEATURE OBJECT))) (PRINC (READ-TIME-CONDITIONAL-FORM OBJECT) STREAM)) (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) (*READTABLE* (IL:FIND-READTABLE "XCL"))) (DECLARE (SPECIAL *READ-SUPPRESS* *READTABLE*)) (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 (LET ((FORM (LIST (READ STREAM)))) (LOOP (WHEN (NOT (SEMICOLON-COMMENT-P FORM)) (RETURN (IF (EQL 1 (LENGTH FORM)) (FIRST FORM) (IL:BQUOTE (PROGN (IL:\\\,@ (NREVERSE FORM))))))) (PUSH (READ STREAM) FORM))))))) (FUNCALL (IF UNREAD-P (FUNCTION MAKE-HASH-IL-UNREADABLE) (FUNCTION MAKE-HASH-IL-READABLE)) :FEATURE FEATURE :SIGN SUB-CHAR :FORM FORM))) (DEFUN TRANSLATE-READABLE-RTC (OBJECT) (IL:* IL:|;;| "Check out the features, just in case someone accidentally put a non-keyword in there") (WHEN (AND *CONDITIONAL-KEYWORDS* (NON-KEYWORD? (READ-TIME-CONDITIONAL-FEATURE OBJECT))) (CERROR "Make all symbols keywords" "~s contains a non-keyword" (READ-TIME-CONDITIONAL-FEATURE OBJECT)) (SETF (READ-TIME-CONDITIONAL-FEATURE OBJECT) (KEYWORDIZE (READ-TIME-CONDITIONAL-FEATURE OBJECT)))) (IL:* IL:|;;| "For paranoia's sake, we check the feature status again as we translate, in case someone changed the *FEATURES* list behind our back.") (IF (ECASE (READ-TIME-CONDITIONAL-SIGN OBJECT) (#\+ (IL:CMLREAD.FEATURE.PARSER (READ-TIME-CONDITIONAL-FEATURE OBJECT))) (#\- (NOT (IL:CMLREAD.FEATURE.PARSER (READ-TIME-CONDITIONAL-FEATURE OBJECT))))) (READ-TIME-CONDITIONAL-FORM OBJECT) *DELETE-FORM*)) (DEFUN TRANSLATE-UNREADABLE-RTC (OBJECT) (IL:* IL:|;;| "There just might be something other than a string in this unreadable read-time-conditional; check it out and try to fix it if it's not a string.") (UNLESS (STRINGP (READ-TIME-CONDITIONAL-FORM OBJECT)) (CERROR "Replace it with (FORMAT NIL \"~~s\")" "Non-string ~s found in an unreadable read-time-conditional" (READ-TIME-CONDITIONAL-FORM OBJECT)) (SETF (READ-TIME-CONDITIONAL-FORM OBJECT) (FORMAT NIL "~s" (READ-TIME-CONDITIONAL-FORM OBJECT)))) (IL:* IL:|;;| "Check out the features, just in case someone accidentally put a non-keyword in there") (WHEN (AND *CONDITIONAL-KEYWORDS* (NON-KEYWORD? (READ-TIME-CONDITIONAL-FEATURE OBJECT))) (CERROR "Make all symbols keywords" "~s contains a non-keyword" (READ-TIME-CONDITIONAL-FEATURE OBJECT)) (SETF (READ-TIME-CONDITIONAL-FEATURE OBJECT) (KEYWORDIZE (READ-TIME-CONDITIONAL-FEATURE OBJECT)))) (IL:* IL:|;;| "For paranoia's sake, we check the feature status again as we translate, in case someone changed the *FEATURES* list behind our back.") (IF (ECASE (READ-TIME-CONDITIONAL-SIGN OBJECT) (#\+ (IL:CMLREAD.FEATURE.PARSER (READ-TIME-CONDITIONAL-FEATURE OBJECT))) (#\- (NOT (IL:CMLREAD.FEATURE.PARSER (READ-TIME-CONDITIONAL-FEATURE OBJECT))))) (WITH-INPUT-FROM-STRING (S (READ-TIME-CONDITIONAL-FORM OBJECT)) (LET ((F (IL:NLSETQ (READ S)))) (IF F (CAR F) (PROGN (IL:PRINTOUT IL:PROMPTWINDOW T "Warning: Problem trying to read conditional expression. Not read.") *DELETE-FORM*)))) *DELETE-FORM*)) (DEFUN KEYWORDIZE (X) (COND ((CONSP X) (MAPCAR (FUNCTION KEYWORDIZE) X)) ((AND X (SYMBOLP X)) (IF (KEYWORDP X) X (LET ((*PACKAGE* (FIND-PACKAGE "KEYWORD"))) (WITH-INPUT-FROM-STRING (S (SYMBOL-NAME X)) (READ S))))) (T X))) (DEFUN NON-KEYWORD? (X) (COND ((CONSP X) (SOME (FUNCTION NON-KEYWORD?) X)) ((SYMBOLP X) (NOT (KEYWORDP X))) (T))) (IL:* IL:|;;| "Support for #, #,") (IL:* IL:|;;| "TRANSLATE-PREFIX-QUOTE is believed unnecessary now; check this...") (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)) (PRIN1 (PREFIX-QUOTE-CONTENTS OBJECT) STREAM)) (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 TRANSLATE-PREFIX-QUOTE (OBJECT) (IL:* IL:\; "This only has to handle numeric base types.") (PREFIX-QUOTE-CONTENTS OBJECT)) (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))))) (IL:* IL:|;;| "Some functions used in the old implementation of #+/#-") (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)) (PRINC " " STREAM) (IL:* IL:|;;| "JRB - I don't 100% understand why the conditionalization on UNREAD-P is needed here; I DO know, however, that it's causing a conditional expression containing a string to lose big time when I dump a file...") (IL:* IL:|;;| "(IF (READ-TIME-CONDITIONAL-UNREAD-P OBJECT) (PRINC (READ-TIME-CONDITIONAL-FORM OBJECT) STREAM) (PRIN1 (READ-TIME-CONDITIONAL-FORM OBJECT) STREAM))") (PRIN1 (READ-TIME-CONDITIONAL-FORM OBJECT) STREAM)) (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 SIGN 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 LIST)) NAME (IL:* IL:\; "A string naming the specifier.") FILECOM-P (IL:* IL:\; "Predicate on FILECOM, answers true if this is the specifier for this filecom.") FORM-P (IL:* IL:\; "Predicate on FORM (a form from the text file), answers true if this is the specifier for the definition in FORM.") ADD-FORM (IL:* IL:\; "Function of FORM and FILECOMS which adds a specifier for FORM to the FILECOMS.") INSTALL-FORM (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-FILECOM (IL:* IL:\; "Function of FILECOM and STREAM which prettyprints a form onto stream representing the filecom.")) (DEFINE-CONDITION UNKNOWN-FORM (WARNING) (FORM) (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "Can't find specifier for form ~s" (UNKNOWN-FORM-FORM CONDITION))))) (DEFINE-CONDITION UNKNOWN-SPECIFIER (WARNING) (SPECIFIER) (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "Unrecognized filecom ~s" (UNKNOWN-SPECIFIER-SPECIFIER CONDITION))))) (DEFVAR *CONDITIONAL-KEYWORDS* T "Controls whether TEXTMODULES insists on keywords in features of read-time-conditionals") (DEFPARAMETER *CONVERT-LOADED-FILES* T "Convert text files loaded by the first one.") (DEFPARAMETER *UPGRADE-COMMENT-LENGTH* 40 "Length at which a single semicolon comment is upgraded to double.") (DEFPARAMETER *JOIN-COMMENTS* T "Should comments be joined together when read?") (DEFPARAMETER *DEFDEFINER-MACROS* NIL "Names of macros to change to definers on read.") (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.") (DEFVAR *SEDIT-READ-MACROS* (MAKE-HASH-TABLE :TEST (FUNCTION EQUAL)) "Presentation read macro entries that need to be added to SEdit Common Lisp readtables") (DEFPARAMETER *SPECIFIERS* (LIST (MAKE-SPECIFIER :NAME "Comment" :FILECOM-P (FUNCTION SEMICOLON-COMMENT-P) :FORM-P (FUNCTION SEMICOLON-COMMENT-P) :ADD-FORM (FUNCTION (LAMBDA (FORM FILECOMS) (APPEND FILECOMS (LIST FORM)))) :INSTALL-FORM (FUNCTION IDENTITY) :PRINT-FILECOM (FUNCTION PPRINT)) (MAKE-SPECIFIER :NAME "eval-when top level form" :FILECOM-P (FUNCTION (LAMBDA (FILECOM) (EQ (FIRST FILECOM) (QUOTE EVAL-WHEN)))) :FORM-P (FUNCTION (LAMBDA (FORM) (AND (LISTP FORM) (EQ (FIRST FORM) (QUOTE EVAL-WHEN))))) :ADD-FORM (FUNCTION (LAMBDA (FORM FILECOMS) (APPEND FILECOMS (LIST (IL:BQUOTE (EVAL-WHEN (IL:\\\, (SECOND FORM)) (IL:\\\,@ (LET ((FILECOMS NIL)) (MAPC (FUNCTION (LAMBDA (FORM) (SETQ FILECOMS (ADD-FORM FORM FILECOMS)))) (CDDR FORM)) FILECOMS)))))))) :INSTALL-FORM (FUNCTION (LAMBDA (FORM) (WHEN (MEMBER (QUOTE EVAL) (SECOND FORM)) (DOLIST (FORM (CDDR FORM)) (INSTALL-FORM FORM))))) :PRINT-FILECOM (FUNCTION (LAMBDA (FILECOM STREAM) (TERPRI STREAM) (PRINC "(eval-when " STREAM) (PRIN1 (SECOND FILECOM) STREAM) (DOLIST (FILECOM (CDDR FILECOM)) (FRESH-LINE STREAM) (PRINT-FILECOM FILECOM STREAM)) (FRESH-LINE STREAM) (PRINC ")" STREAM)))) (MAKE-SPECIFIER :NAME "Definer" :FILECOM-P (FUNCTION (LAMBDA (FILECOM) (GET (FIRST FILECOM) (QUOTE :DEFINED-BY)))) :FORM-P (FUNCTION (LAMBDA (FORM) (AND (LISTP FORM) (GET (CAR FORM) (QUOTE :DEFINER-FOR))))) :ADD-FORM (FUNCTION (LAMBDA (FORM FILECOMS) (SETQ FORM (IMPORT-DEFINERS FORM)) (LET ((IL:DFNFLG (QUOTE IL:PROP))) (EVAL FORM)) (APPEND FILECOMS (LIST (IL:BQUOTE ((IL:\\\, (DEFINER-FILECOM FORM)) (IL:\\\, (NAME-OF FORM)))))))) :INSTALL-FORM (FUNCTION (LAMBDA (FORM) (SETQ FORM (IMPORT-DEFINERS FORM)) (LET ((IL:DFNFLG T)) (EVAL FORM)))) :PRINT-FILECOM (FUNCTION (LAMBDA (FILECOM STREAM) (LET ((TYPE (FIRST FILECOM))) (DOLIST (NAME (REST FILECOM)) (FRESH-LINE STREAM) (COND ((SEMICOLON-COMMENT-P NAME) (PRINT-FILECOM NAME STREAM)) ((IL:GETDEF NAME TYPE NIL (QUOTE (IL:NOERROR))) (PPRINT (EXPORT-DEFINERS (IL:GETDEF NAME TYPE)) STREAM)) (T (WARN "Unrecognised drek in ~S filecom ignored:~%~s" TYPE NAME)))))))) (MAKE-SPECIFIER :NAME "Group of definitions (COMS)" :FILECOM-P (FUNCTION (LAMBDA (FILECOM) (EQ (CAR FILECOM) (QUOTE IL:COMS)))) :FORM-P (FUNCTION (LAMBDA (FORM) (EQ (CAR FORM) (QUOTE PROGN)))) :ADD-FORM (FUNCTION (LAMBDA (FORM FILECOMS) (APPEND FILECOMS (LIST (IL:BQUOTE (IL:COMS (IL:\\\,@ (LET ((FILECOMS NIL)) (MAPC (FUNCTION (LAMBDA (FORM) (SETQ FILECOMS (ADD-FORM FORM FILECOMS)))) (CDR FORM)) FILECOMS)))))))) :INSTALL-FORM (FUNCTION (LAMBDA (FORM) (DOLIST (FORM (CDR FORM)) (INSTALL-FORM FORM)))) :PRINT-FILECOM (FUNCTION (LAMBDA (FILECOM STREAM) (DOLIST (FILECOM (CDR FILECOM)) (FRESH-LINE STREAM) (PRINT-FILECOM FILECOM STREAM))))) (MAKE-SPECIFIER :NAME "Top-level read-time conditional" :FILECOM-P (FUNCTION (LAMBDA (FORM) NIL)) :FORM-P (FUNCTION READ-TIME-CONDITIONAL-P) :ADD-FORM (FUNCTION (LAMBDA (FORM FILECOMS) (APPEND FILECOMS (LIST (IL:BQUOTE (IL:P (TOP-LEVEL-FORM (IL:\\\, FORM)))))))) :INSTALL-FORM (FUNCTION (LAMBDA (FORM) (EVAL (TRANSLATE-FORM FORM)))) :PRINT-FILECOM (FUNCTION (LAMBDA (FILECOM STREAM) (PPRINT (TOP-LEVEL-FORM-FORM FILECOM) STREAM)))) (MAKE-SPECIFIER :NAME "VARS com translator" :FILECOM-P (FUNCTION (LAMBDA (FILECOM) (EQ (CAR FILECOM) (QUOTE IL:VARS)))) :FORM-P (FUNCTION (LAMBDA (FORM) NIL)) :PRINT-FILECOM (FUNCTION (LAMBDA (FILECOM STREAM) (FLET ((TRANSLATE-VARS (FILECOM) (ETYPECASE FILECOM (SYMBOL (IL:BQUOTE (DEFPARAMETER (IL:\\\, FILECOM) (QUOTE (IL:\\\, (SYMBOL-VALUE FILECOM)))))) (LIST (IL:BQUOTE (DEFPARAMETER (IL:\\\, (FIRST FILECOM)) (IL:\\\, (IF (REST FILECOM) (SECOND FILECOM) NIL)))))))) (DOLIST (SINGLE (REST FILECOM)) (FRESH-LINE STREAM) (PPRINT (TRANSLATE-VARS SINGLE) STREAM)))))) (MAKE-SPECIFIER :NAME "INITVARS com translator" :FILECOM-P (FUNCTION (LAMBDA (FILECOM) (EQ (CAR FILECOM) (QUOTE IL:INITVARS)))) :FORM-P (FUNCTION (LAMBDA (FORM) NIL)) :PRINT-FILECOM (FUNCTION (LAMBDA (FILECOM STREAM) (FLET ((TRANSLATE-INITVARS (FILECOM) (ETYPECASE FILECOM (SYMBOL (IL:BQUOTE (DEFVAR (IL:\\\, FILECOM) NIL))) (LIST (IL:BQUOTE (DEFVAR (IL:\\\, (FIRST FILECOM)) (IL:\\\, (IF (REST FILECOM) (SECOND FILECOM) NIL)))))))) (DOLIST (SPEC (REST FILECOM)) (FRESH-LINE STREAM) (PPRINT (TRANSLATE-INITVARS SPEC) STREAM)))))) (MAKE-SPECIFIER :NAME "CONSTANTS com translator" :FILECOM-P (FUNCTION (LAMBDA (FILECOM) (EQ (CAR FILECOM) (QUOTE IL:CONSTANTS)))) :FORM-P (FUNCTION (LAMBDA (FORM) NIL)) :PRINT-FILECOM (FUNCTION (LAMBDA (FILECOM STREAM) (FLET ((TRANSLATE-CONSTANTS (FILECOM) (ETYPECASE FILECOM (SYMBOL (IL:BQUOTE (DEFCONSTANT (IL:\\\, FILECOM) (QUOTE (IL:\\\, (SYMBOL-VALUE FILECOM)))))) (LIST (IL:BQUOTE (DEFCONSTANT (IL:\\\, (FIRST FILECOM)) (IL:\\\, (IF (REST FILECOM) (SECOND FILECOM) NIL)))))))) (DOLIST (SPEC (REST FILECOM)) (FRESH-LINE STREAM) (PPRINT (TRANSLATE-CONSTANTS SPEC) STREAM)))))) (MAKE-SPECIFIER :NAME "PROPS com translator" :FILECOM-P (FUNCTION (LAMBDA (FILECOM) (EQ (CAR FILECOM) (QUOTE IL:PROPS)))) :FORM-P (FUNCTION (LAMBDA (FORM) NIL)) :PRINT-FILECOM (FUNCTION (LAMBDA (FILECOM STREAM) (FLET ((PPRINT-PROPS (FILECOM) (DECLARE (SPECIAL FILE)) (LET ((PROP (SECOND FILECOM)) (SYMBOL (FIRST FILECOM))) (IF (MEMBER PROP (SYMBOL-PLIST SYMBOL) :TEST (QUOTE EQ)) (UNLESS (AND (EQ FILE SYMBOL) (MEMBER PROP (QUOTE (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)) :TEST (QUOTE EQ))) (PPRINT (IL:BQUOTE (SETF (GET (QUOTE (IL:\\\, SYMBOL)) (QUOTE (IL:\\\, PROP))) (QUOTE (IL:\\\, (GET SYMBOL PROP))))) STREAM)) (WARN "No ~s property for ~s~%" PROP SYMBOL))))) (DOLIST (SPEC (REST FILECOM)) (FRESH-LINE STREAM) (PPRINT-PROPS SPEC)))))) (MAKE-SPECIFIER :NAME "PROP com translator" :FILECOM-P (FUNCTION (LAMBDA (FILECOM) (EQ (CAR FILECOM) (QUOTE IL:PROP)))) :FORM-P (FUNCTION (LAMBDA (FORM) (AND (LISTP FORM) (EQ (FIRST FORM) (QUOTE SETF)) (LISTP (SECOND FORM)) (EQ (FIRST (SECOND FORM)) (QUOTE GETF)) (EQL 3 (LENGTH (SECOND FORM)))))) :ADD-FORM (FUNCTION (LAMBDA (FORM FILECOMS) (APPEND FILECOMS (LIST (IL:BQUOTE (IL:PROP (IL:\\\, (THIRD (SECOND FORM))) (IL:\\\, (SECOND (SECOND FORM))))))))) :INSTALL-FORM (FUNCTION (LAMBDA (FORM) (EVAL (TRANSLATE-FORM FORM)))) :PRINT-FILECOM (FUNCTION (LAMBDA (FILECOM STREAM) (POP FILECOM) (LET ((PROPS-SPEC (POP FILECOM))) (FLET ((PPRINT-PROP (SYMBOL PROP) (DECLARE (SPECIAL FILE)) (IF (MEMBER PROP (SYMBOL-PLIST SYMBOL) :TEST (QUOTE EQ)) (UNLESS (AND (EQ FILE SYMBOL) (MEMBER PROP (QUOTE (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)) :TEST (QUOTE EQ))) (PPRINT (IL:BQUOTE (SETF (GET (QUOTE (IL:\\\, SYMBOL)) (QUOTE (IL:\\\, PROP))) (QUOTE (IL:\\\, (GET SYMBOL PROP))))) STREAM)) (WARN "No ~s property for ~s~%" PROP SYMBOL)))) (DOLIST (SYMBOL FILECOM) (FRESH-LINE STREAM) (COND ((EQ PROPS-SPEC (QUOTE IL:ALL)) (IL:* IL:\; "Everything") (DO ((TAIL (SYMBOL-PLIST SYMBOL) (CDDR TAIL))) ((NULL TAIL)) (DECLARE (GLOBAL IL:SYSPROPS)) (LET ((PROP (FIRST TAIL)) (VALUE (SECOND TAIL))) (WHEN (NOT (MEMBER PROP IL:SYSPROPS :TEST (QUOTE EQ))) (PPRINT-PROP SYMBOL PROP))))) ((LISTP PROPS-SPEC) (DOLIST (PROP PROPS-SPEC) (PPRINT-PROP SYMBOL PROP))) ((SYMBOLP PROPS-SPEC) (PPRINT-PROP SYMBOL PROPS-SPEC)) (T (CERROR "Ignore property" "Bad prop spec ~s in PROPS com" PROPS-SPEC))))))))) (MAKE-SPECIFIER :NAME "FILES com translator" :FILECOM-P (FUNCTION (LAMBDA (FILECOM) (EQ (CAR FILECOM) (QUOTE IL:FILES)))) :FORM-P (FUNCTION (LAMBDA (FORM) NIL)) :PRINT-FILECOM (FUNCTION (LAMBDA (FILECOM STREAM) (POP FILECOM) (DO ((NOERROR NIL)) ((NULL FILECOM)) (FRESH-LINE STREAM) (LET ((ITEM (CAR FILECOM))) (ETYPECASE ITEM (SYMBOL (PPRINT (IL:BQUOTE (LOAD (QUOTE (IL:\\\, ITEM)) (IL:\\\,@ (WHEN NOERROR (IL:BQUOTE (:IF-DOES-NOT-EXIST NIL)))))) STREAM)) (STRING (PPRINT (IL:BQUOTE (LOAD (IL:\\\, ITEM) (IL:\\\,@ (WHEN NOERROR (IL:BQUOTE (:IF-DOES-NOT-EXIST NIL)))))) STREAM)) (LIST (WHEN (MEMBER (QUOTE IL:NOERROR) ITEM :TEST (QUOTE EQ)) (SETQ NOERROR T))))))))) (MAKE-SPECIFIER :NAME "Top level form" :FILECOM-P (FUNCTION TOP-LEVEL-FORM-P) :FORM-P (FUNCTION TRUE) :ADD-FORM (FUNCTION (LAMBDA (FORM FILECOMS) (CONVERT-LOADED-FILES FORM) (APPEND FILECOMS (LIST (IL:BQUOTE (IL:P (TOP-LEVEL-FORM (IL:\\\, FORM)))))))) :INSTALL-FORM (FUNCTION (LAMBDA (FORM) (EVAL (TRANSLATE-FORM FORM)))) :PRINT-FILECOM (FUNCTION (LAMBDA (FILECOM STREAM) (LET ((FORM (TOP-LEVEL-FORM-FORM FILECOM))) (FRESH-LINE STREAM) (PPRINT FORM STREAM) (WHEN (EQ (QUOTE IN-PACKAGE) (FIRST FORM)) (EVAL FORM))))))) "A list of all content specifier types for text files.") (UNLESS (FIND-PACKAGE "EMPTY") (MAKE-PACKAGE "EMPTY" :USE NIL)) (MAKE-LISP-FILE-READTABLE) (IL:* IL:|;;| "PRESENTATIONS handing reading and printing of CL constructs") (DEF-DEFINE-TYPE IL:PRESENTATIONS "presentation types") (DEFPRESENTATION HASH-BASED-NUMBER :FIELDS (BASE NUMBER) :PRINT-FUNCTION PRINT-HASH-BASED-NUMBER :READ-MACRO ((#\# #\B READ-HASH-BASED-NUMBER :SEDIT) (#\# #\O READ-HASH-BASED-NUMBER :SEDIT) (#\# #\X READ-HASH-BASED-NUMBER :SEDIT) (#\# #\R READ-HASH-BASED-NUMBER :SEDIT)) :TRANSLATOR TRANSLATE-HASH-BASED-NUMBER) (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-IL-READABLE :INCLUDE READ-TIME-CONDITIONAL :PRINT-FUNCTION PRINT-READABLE-READ-TIME-CONDITIONAL :READ-MACRO (#\# #\+ READ-READ-TIME-CONDITIONAL) :TRANSLATOR TRANSLATE-READABLE-RTC) (DEFPRESENTATION HASH-IL-UNREADABLE :INCLUDE READ-TIME-CONDITIONAL :PRINT-FUNCTION PRINT-UNREADABLE-READ-TIME-CONDITIONAL :READ-MACRO (#\# #\- READ-READ-TIME-CONDITIONAL) :TRANSLATOR TRANSLATE-UNREADABLE-RTC) (DEFPRESENTATION HASH-STAR :FIELDS (VECTOR) :PRINT-FUNCTION PRINT-HASH-STAR :READ-MACRO (#\# #\* READ-HASH-STAR :SEDIT) :TRANSLATOR TRANSLATE-HASH-STAR) (REINSTALL-ADVICE (QUOTE REMOVE-COMMENTS) :AROUND (QUOTE ((:LAST (TRANSLATE-FORM (CAR ARGLIST)))))) (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:* IL:|;;| "(IL:FILES IL:SEDIT-COMMONLISP)") (IL:PUTPROPS LOAD-TEXTMODULE IL:ARGNAMES (NIL (PATHNAME &KEY :MODULE :INSTALL :PACKAGE :UPGRADE-COMMENT-LENGTH :JOIN-COMMENTS :CONVERT-LOADED-FILES :DEFDEFINER-MACROS))) (IL:PUTPROPS MAKE-TEXTMODULE IL:ARGNAMES (NIL (IL:MODULE &KEY TYPE PATHNAME IL:FILECOMS IL:WIDTH))) (IL:PUTPROPS MAKE-SPECIFIER IL:ARGNAMES (NIL (&KEY :NAME :FILECOM-P :FORM-P :ADD-FORM :INSTALL-FORM :PRINT-FILECOM))) (IL:PUTPROPS INSTALL-FORM IL:ARGNAMES (NIL (IL:FORM &OPTIONAL IL:SPECIFIER))) (IL:PUTPROPS FILECOM-SPECIFIER IL:ARGNAMES (NIL (IL:FILECOM))) (IL:PUTPROPS FORM-SPECIFIER IL:ARGNAMES (NIL (IL:FORM))) (IL:PUTPROPS ADD-FORM IL:ARGNAMES (NIL (IL:FORM IL:FILECOMS &OPTIONAL IL:SPECIFIER))) (IL:PUTPROPS PRINT-FILECOM IL:ARGNAMES (NIL (IL:FILECOM STREAM &OPTIONAL IL:SPECIFIER))) (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") (:EXPORT "LOAD-TEXTMODULE" "MAKE-TEXTMODULE" "*SPECIFIERS*" "MAKE-SPECIFIER" "INSTALL-FORM" "FORM-SPECIFIER" "FILECOM-SPECIFIER" "ADD-FORM" "INSTALL-FORM" "PRINT-FILECOM" "*UPGRADE-COMMENT-LENGTH*" "*JOIN-COMMENTS*" "*CONVERT-LOADED-FILES*" "*DEFDEFINER-MACROS*"))) (IL:FILESLOAD IL:SEDIT-COMMONLISP) *PACKAGE*) :BASE 10)) (IL:PUTPROPS IL:TEXTMODULES IL:COPYRIGHT ("Xerox Corporation" 1987 1988 1989 1990 1991)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/library/TEXTOFD b/library/TEXTOFD new file mode 100644 index 00000000..c4bff250 --- /dev/null +++ b/library/TEXTOFD @@ -0,0 +1,1623 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "11-Feb-2001 12:06:42" {DSK}medley3.5>library>TEXTOFD.;8 176221 changes to%: (FNS \TEXTRIGHTMARGIN) previous date%: " 4-Jan-2001 18:14:27" {DSK}medley3.5>library>TEXTOFD.;7) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994, 1995, 1999, 2000, 2001 by John Sybalsky & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TEXTOFDCOMS) (RPAQQ TEXTOFDCOMS [(FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) (FNS COPYTEXTSTREAM OPENTEXTSTREAM REOPENTEXTSTREAM TEDIT.STREAMCHANGEDP TEXTSTREAMP TXTFILE \DELETECH \SETUPGETCH \TEDIT.REOPEN.STREAM \TEDIT.COPYTEXTSTREAM.PIECEMAPFN \TEXTINIT \TEXTMARK \TEXTTTYBOUT) (FNS \INSERTCH \INSERTCR) (COMS (* ;;; "Functions to manipulate the Piece Table (PCTB)") (FNS \CHTOPC \CHTOPCNO \CLEARPCTB \CREATEPIECEORSTREAM \DELETEPIECE \FINDPIECE \INSERTPIECE \MAKEPCTB \SPLITPIECE \INSERT.FIRST.PIECE)) (COMS (* ;  "Generic-IO type operations support") (FNS \TEXTCLOSEF \TEXTCLOSEF-SUBTREE \TEXTDSPFONT \TEXTEOFP \TEXTGETEOFPTR \TEXTGETFILEPTR \TEXTOPENF \TEXTOPENF-SUBTREE \TEXTOUTCHARFN \TEXTBACKFILEPTR \TEXTBOUT \TEDITOUTCHARFN \TEXTSETEOF \TEXTSETFILEPTR \TEXTDSPXPOSITION \TEXTDSPYPOSITION \TEXTLEFTMARGIN \TEXTRIGHTMARGIN \TEXTDSPCHARWIDTH \TEXTDSPSTRINGWIDTH \TEXTDSPLINEFEED) (FNS \TEXTBIN \TEDIT.TEXTBIN.STRINGSETUP \TEDIT.TEXTBIN.FILESETUP \TEDIT.TEXTBIN.NEW.PAGE) (FNS \TEXTPEEKBIN \TEDIT.PEEKBIN.NEW.PAGE)) (COMS (* ; "Support for TEXTPROP") (FNS CGETTEXTPROP CTEXTPROP GETTEXTPROP PUTTEXTPROP TEXTPROP)) [COMS (* ;; "Support for error handling: The old error handler for the stream-not-open error. This is here, because you only want to do this ONCE, even if you load TEXTOFD multiple times (as, e.g., in development)") (INITVARS (*TEDIT-OLD-STREAM-ERROR-HANDLER* (CONDITION-HANDLER 'XCL:STREAM-NOT-OPEN] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEXTINIT))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA TEXTPROP]) (FILESLOAD TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SCRATCHLEN 64) (CONSTANTS (\SCRATCHLEN 64)) ) (FILESLOAD (LOADCOMP) TEDITDCL) ) (DEFINEQ (COPYTEXTSTREAM + [LAMBDA (ORIGINAL CROSSCOPY) (* ; + "Edited 24-Apr-95 12:02 by sybalsky:mv:envos") + + (* ;; "Given a stream, textobj or window, returns a new textstream with the same contents. If CROSSCOPY then strings will really be allocated providing copies of the text else the fileptrs still will be aliases as in the rest of TEDIT.") + + (PROG ((TEXTOBJ (TEXTOBJ ORIGINAL)) + TSEL PCTB PCLST NEWSTREAM NEWTEXTOBJ) + (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + (SETQ TSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) + (SETQ NEWSTREAM (OPENTEXTSTREAM NIL NIL NIL NIL (fetch (TEXTOBJ EDITPROPS) + of TEXTOBJ))) + (* ; + "First create an empty textstream into which the pieces can be hammered") + (SETQ NEWTEXTOBJ (TEXTOBJ NEWSTREAM)) + (replace (SELECTION CH#) of TSEL with 1) + (* ; + "Set up to select the whole source text") + (replace (SELECTION CHLIM) of TSEL with (ADD1 (fetch (TEXTOBJ TEXTLEN) + of TEXTOBJ))) + (replace (SELECTION DCH) of TSEL with (fetch (TEXTOBJ TEXTLEN) of + TEXTOBJ)) + (SETQ PCLST (TEDIT.SELECTED.PIECES TEXTOBJ TSEL CROSSCOPY (FUNCTION + \TEDIT.COPYTEXTSTREAM.PIECEMAPFN + ) + TEXTOBJ NEWTEXTOBJ)) (* ; + "now get a list of copies of the pieces to be inserted into the empty textstream") + (\TEDIT.INSERT.PIECES NEWTEXTOBJ 1 PCLST (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) + NIL NIL CROSSCOPY) (* ; + "Put the pieces into the copy textstream") + (replace (TEXTOBJ TEXTLEN) of NEWTEXTOBJ with (fetch (TEXTOBJ TEXTLEN) + of TEXTOBJ)) + (* ; + "The copy is the same length as the original") + (replace (TEXTOBJ MENUFLG) of NEWTEXTOBJ with (fetch (TEXTOBJ MENUFLG) + of TEXTOBJ)) + (* ; + "And if the original is a menu, so's the copy") + (RETURN NEWSTREAM]) (OPENTEXTSTREAM + [LAMBDA (TEXT WINDOW START END PROPS) (* ; "Edited 4-May-93 14:38 by jds") + (* ; + "Create a text-type STREAM to describe TEXT. Optionally, connect that to WINDOW for display.") + (PROG* ([WAS-TEXTSTREAM (AND (type? STREAM TEXT) + (type? TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT] + [TEXTOBJ (COND + (WAS-TEXTSTREAM (* ; + "If the guy gave us a text stream to edit, use its TEXTOBJ as ours.") + (create TEXTOBJ + reusing (fetch (TEXTSTREAM TEXTOBJ) of TEXT) + \INSERTFIRSTCH _ -1 \INSERTNEXTCH _ -1 \INSERTPCVALID _ NIL)) + ((type? TEXTOBJ TEXT) + (create TEXTOBJ using TEXT \INSERTFIRSTCH _ -1 \INSERTNEXTCH _ -1 + \INSERTPCVALID _ NIL)) + (T (create TEXTOBJ] + (TEDIT.GET.FINISHEDFORMS NIL) + [PROPS (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS) + (COPY (fetch (TEXTOBJ EDITPROPS) of TEXTOBJ] + [TEXTOBJ.WINDOW.VALID (AND WINDOW (EQ WINDOW (\TEDIT.PRIMARYW TEXTOBJ)) + (EQ TEXTOBJ (WINDOWPROP WINDOW 'TEXTOBJ] + FONT SEL PCTB PC TEXTSTREAM OTEXTOBJ PROP CLEARGET? PARALOOKS PWINDOW) + (* ; + "Remember if the textobj had a window already.") + (replace (TEXTOBJ \WINDOW) of TEXTOBJ with (AND WINDOW (LIST WINDOW))) + (* ; + "Necessary because some incoming object types depend on knowing where the window is.") + (replace (TEXTOBJ LINES) of TEXTOBJ with NIL) + + (* ;; "This is here so if we re-OPENTEXTSTREAM an existing stream/window pair we don't get two sets of line descriptors") + + (for PROPNAME in PROPS by (CDDR PROPNAME) as PROPVAL + in (CDR PROPS) by (CDDR PROPVAL) do (TEXTPROP TEXTOBJ PROPNAME PROPVAL) + ) (* ; + "Save the PROPS for later people who'd like to know them") + [SETQ FONT (COND + ((type? CHARLOOKS (LISTGET PROPS 'FONT)) + (LISTGET PROPS 'FONT)) + (T (\TEDIT.PARSE.CHARLOOKS.LIST [OR (LISTGET PROPS 'LOOKS) + (COND + [(LISTP (LISTGET PROPS 'FONT)) + (FONTCREATE (LISTGET PROPS + 'FONT] + (T (OR (LISTGET PROPS 'FONT) + DEFAULTFONT] + NIL TEXTOBJ] (* ; +"Find the default font for this session -- either what the guy tells us, or the global default font") + (SETQ PARALOOKS (LISTGET PROPS 'PARALOOKS)) + + (* ;; "Get the default paragraph looks. This must come before the first piece is created, so its fields can be filled in right.") + + (replace (TEXTOBJ FMTSPEC) of TEXTOBJ + with (\TEDIT.UNIQUIFY.PARALOOKS [SETQ PARALOOKS (\TEDIT.PARSE.PARALOOKS.LIST + (OR PARALOOKS + (create FMTSPEC + using + TEDIT.DEFAULT.FMTSPEC + ] + TEXTOBJ)) + [COND + [WAS-TEXTSTREAM (* ; + "We got a TEXTOFD stream to edit; just use it") + (SETQ OTEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT)) + (SETQ TEXTSTREAM TEXT) + (for SELN in (LIST (fetch (TEXTOBJ SEL) of TEXTOBJ) + (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ) + (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ) + (fetch (TEXTOBJ MOVESEL) of TEXTOBJ) + (fetch (TEXTOBJ DELETESEL) of TEXTOBJ)) + do + + (* ;; "Make all the selections point to the CURRENT textobj!") + + (COND + ((EQ OTEXTOBJ (fetch (SELECTION \TEXTOBJ) of SELN)) + (replace (SELECTION \TEXTOBJ) of SELN with TEXTOBJ)) + (T (replace (SELECTION SET) of SELN with NIL))) + (replace (SELECTION ONFLG) of SELN with NIL)) + (replace (TEXTSTREAM TEXTOBJ) of TEXTSTREAM with TEXTOBJ) + (replace (TEXTOBJ STREAMHINT) of TEXTOBJ with TEXTSTREAM) + (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + (replace (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ with NIL) + (* ; "Mark the edit incomplete.") + (replace (TEXTOBJ \DIRTY) of TEXTOBJ with NIL) + (* ; "And mark it not changed.") + (COND + (FONT (* ; + "If a new default font was specified, set it up.") + (replace (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ + with (\TEDIT.UNIQUIFY.CHARLOOKS FONT TEXTOBJ] + ((type? TEXTOBJ TEXT) (* ; + "We got a TEXTOBJ to edit; fill in the stream, since it might have been GC'd.") + (SETQ TEXTSTREAM (replace (TEXTOBJ STREAMHINT) of TEXTOBJ + with (create TEXTSTREAM + TEXTOBJ _ TEXTOBJ))) + (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + (for FORM in TEDIT.GET.FINISHEDFORMS do (EVAL FORM))) + (T (* ; + "Otherwise, create a TEXTOFD to describe the text we're editing.-") + (SETQ TEXTSTREAM (replace (TEXTOBJ STREAMHINT) of TEXTOBJ + with (create TEXTSTREAM + TEXTOBJ _ TEXTOBJ))) + [replace (TEXTOBJ PCTB) of TEXTOBJ + with (SETQ PCTB (TEDIT.BUILD.PCTB TEXT TEXTOBJ START END FONT PARALOOKS + (LISTGET PROPS 'CLEARGET] + + (* ;; "(setq pc (\\editelt pctb (add1 |\\FirstPieceOffset|)))") + + (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB) + 0)) + (for FORM in TEDIT.GET.FINISHEDFORMS do (EVAL FORM)) + (replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (fetch (BTREENODE TOTLEN) + of PCTB] + (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ + with (\TEDIT.UNIQUIFY.CHARLOOKS (\TEDIT.CARETLOOKS.VERIFY TEXTOBJ + (replace (TEXTOBJ DEFAULTCHARLOOKS) + of TEXTOBJ with ( + \TEDIT.UNIQUIFY.CHARLOOKS + FONT TEXTOBJ))) + TEXTOBJ)) + (replace (TEXTOBJ CARET) of TEXTOBJ with (create + TEDITCARET + TCCARETDS _ + (AND WINDOW (WINDOWPROP WINDOW + 'DSP)) + TCFORCEUP _ T)) + (replace (TEXTOBJ TXTREADONLY) of TEXTOBJ with (LISTGET PROPS 'READONLY)) + (replace (TEXTOBJ TXTTERMSA) of TEXTOBJ with (AND (SETQ PROP + (LISTGET PROPS 'TERMTABLE)) + (fetch TERMSA + of PROP))) + (replace (TEXTOBJ TXTRTBL) of TEXTOBJ with (LISTGET PROPS 'READTABLE)) + (replace (TEXTOBJ TXTWTBL) of TEXTOBJ with (LISTGET PROPS 'BOUNDTABLE)) + [COND + ((LISTGET PROPS 'PAGEFORMAT) (* ; + "A default page formatting was supplied. Impose it on the document.") + (TEDIT.PAGEFORMAT TEXTOBJ (LISTGET PROPS 'PAGEFORMAT] + (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) + (SETQ PROP (LISTGET PROPS 'SEL)) (* ; "Initial Selection, if any.") + (COND + ((EQ PROP 'DON'T) (* ; + "A SEL prop of DON'T means don't make an initial selection") + (replace (SELECTION SET) of SEL with NIL)) + ((type? SELECTION PROP) (* ; + "We came in with an explicit initial sel. Set it up.") + (\COPYSEL PROP SEL) + (replace (SELECTION SET) of SEL with T) + (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ)) + ((AND (fetch (SELECTION SET) of SEL) + (NOT PROP)) (* ; + "If we came into this with a valid selection, highlight it.") + (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ)) + (T (* ; + "Starting without a selection; let's start with a point selection before the first character.") + (replace (SELECTION CH#) of SEL with (COND + ((FIXP PROP)) + (PROP (CAR PROP)) + (1))) + (replace (SELECTION CHLIM) of SEL with (COND + ((FIXP PROP)) + (PROP (IPLUS (CAR PROP) + (CADR PROP))) + (1))) + (replace (SELECTION DCH) of SEL with (COND + ((FIXP PROP) + 0) + (PROP (CADR PROP)) + (0))) + (replace (SELECTION DX) of SEL with 0) + (replace (SELECTION POINT) of SEL with 'LEFT) + (replace (SELECTION SELKIND) of SEL with 'CHAR) + (replace (SELECTION SET) of SEL with (NOT (fetch (TEXTOBJ + TXTREADONLY) + of TEXTOBJ))) + (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ))) + [COND + ((fetch (SELECTION SET) of SEL) (* ; + "If there's an initial selection, it implies initial caret looks, too.") + (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (\TEDIT.GET.INSERT.CHARLOOKS + TEXTOBJ SEL] + (COND + ((AND WINDOW (NOT TEXTOBJ.WINDOW.VALID)) (* ; + "Only if there's a window to display it in:") + (replace (TEXTOBJ \WINDOW) of TEXTOBJ with NIL) + (\TEDIT.WINDOW.SETUP WINDOW TEXTOBJ TEXTSTREAM PROPS) + (* ; + "Set up the window, and display the initial text.") + ) + ((SETQ PWINDOW (LISTGET PROPS 'PROMPTWINDOW)) + + (* ;; "There is no window for the session, but he has passed in a promptwindow to use, install it in the textobj") + + (replace (TEXTOBJ PROMPTWINDOW) of TEXTOBJ with PWINDOW))) + (\SETUPGETCH (create EDITMARK + PC _ (\GETBASEPTR (\FIRSTNODE PCTB) + 0) + PCOFF _ 0 + PCNO _ 1) + TEXTOBJ) (* ; "Set the file ptr to 0") + (RETURN TEXTSTREAM]) (REOPENTEXTSTREAM + [LAMBDA (STREAM) (* ; "Edited 31-May-91 14:18 by jds") + (replace (STREAM ACCESS) of STREAM with 'BOTH) + (replace (STREAM BINABLE) of STREAM with T) + (replace (STREAM STRMBINFN) of STREAM with (FUNCTION \TEXTBIN)) + (replace (STREAM STRMBOUTFN) of STREAM with (FUNCTION \TEXTBOUT)) + STREAM]) (TEDIT.STREAMCHANGEDP + [LAMBDA (STREAM RESET?) (* ; "Edited 31-May-91 13:57 by jds") + (PROG1 (fetch (TEXTOBJ \DIRTY) of (TEXTOBJ STREAM)) + (COND + (RESET? (replace (TEXTOBJ \DIRTY) of (TEXTOBJ STREAM) with NIL))))]) (TEXTSTREAMP + (LAMBDA (STREAM) (* jds " 3-Apr-84 14:34") + + (* Returns the stream if it is a text stream, else NIL) + + (AND (STREAMP STREAM) + (type? TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) + STREAM))) (TXTFILE + [LAMBDA (TEXTOBJ) (* ; "Edited 31-May-91 13:58 by jds") + (* This function is for compiled + access to the TXTFILE field in + RESETSAVE expressions) + (fetch (TEXTOBJ TXTFILE) of TEXTOBJ]) (\DELETECH [LAMBDA (CH# CHLIM LEN TEXTOBJ DONTDIRTY) (* ; "Edited 29-Jan-99 17:28 by kaplan") (* ;; "Delete the indicated characters from the text object represented by TEXTOBJ") (* ;;  "If DONTDIRTY is non-NIL, then don't notice this change for purposes of UNDO or dirtiness.") (COND ((OR DONTDIRTY (NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ))) (* ;; "Only delete characters if changes are permitted, or if it's a TEdit-internal fixup change, e.g., when an NS character 255-x sequence is seen.") (LET ((\INFIRSTCH (fetch (TEXTOBJ \INSERTFIRSTCH) of TEXTOBJ)) (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) START-OF-PIECE PCLST) (\TEDIT.CHECK (IGEQ LEN 0) "LEN of delete must be >0.") (\TEDIT.CHECK (IEQP LEN (IDIFFERENCE CHLIM CH#))) [COND ((AND (fetch (TEXTOBJ \INSERTPCVALID) of TEXTOBJ) (IEQP CHLIM (fetch (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ)) (IGEQ CH# \INFIRSTCH)) (* ;  "The deletion is from the end of the most recent type-in. Just adjust the buffer string.") (freplace (TEXTOBJ \INSERTLEN) of TEXTOBJ with (replace (PIECE PLEN) of (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ) with (IDIFFERENCE CH# \INFIRSTCH))) (* ; "Cut back the length") (freplace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with (IPLUS (fetch (TEXTOBJ \INSERTLEN) of TEXTOBJ) \INFIRSTCH)) (* ;  "and ch# of next insertion (i.e., 1 past the top CH# in the insert piece.)") (replace THLEN of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ) with (IDIFFERENCE (fetch THLEN of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)) LEN)) (* ;  "Reduce the length of the insertion in the history list, too.") (COND ((ZEROP (fetch (TEXTOBJ \INSERTLEN) of TEXTOBJ)) (* ;; "He's completely emptied the type-in piece. Remove it and force creation of a fresh one at next type-in.") (\DELETEPIECE (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ) PCTB) (* UPDATEPCNODES (fetch  (TEXTOBJ \INSERTPC) of TEXTOBJ)  (IMINUS LEN) PCTB) (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (* ;  "Force the next insertion to be in a fresh piece.") ) (T (UPDATEPCNODES (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ) (IMINUS LEN) PCTB))) (* ; "Adjust CH#s in the Piece Table.") ) ((ILEQ CH# TEXTLEN) (* ;  "General case of deletion: Remove pieces as needed to do it.") (PROG (PCN PC1 PCNON PCSOUT (HIPC NIL) HI LO) (SETQ PC1 (\CHTOPC CH# PCTB T)) (* ;  "Piece # of piece containing start of deleted text") (COND ((IGREATERP CH# START-OF-PIECE) (* ;  "Split the piece, so the deleted text now starts on a piece boundary") (\SPLITPIECE PC1 (- CH# START-OF-PIECE) TEXTOBJ)) (T (SETQ PC1 (fetch (PIECE PREVPIECE) of PC1)) (* ;  "PC1 _ piece before the first piee to be deleted.-") )) (COND ((ILEQ CHLIM TEXTLEN) (* ;  "Find the peice that contains the END of the deleted section") (SETQ PCN (\CHTOPC CHLIM PCTB T))) (T (* ;;  "Deleting past end, so n+1-th piece is the symbol LASTPIECE, which starts 1 past end of all text.") (SETQ START-OF-PIECE (ADD1 TEXTLEN)) (SETQ PCN 'LASTPIECE) (SETQ HIPC NIL))) [COND ((ATOM PCN) (* ;  "Deleting before the end of text.") ) (T (* ;  "Deleting in front of a real piece of text") (COND ([AND (IGREATERP CHLIM START-OF-PIECE) (ILESSP CHLIM (IPLUS START-OF-PIECE (fetch (PIECE PLEN) of PCN] (SETQ HIPC (\SPLITPIECE PCN (- CHLIM START-OF-PIECE) TEXTOBJ PCNON)) (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))) (T (SETQ HIPC PCN] (* ;  "if not on a piece bound, split the last piece.") (AND PC1 (EQ PC1 HIPC) (HELP "circular")) [SETQ PCLST (bind NPC [PC _ (COND (PC1 (fetch (PIECE NEXTPIECE) of PC1)) (T (* ;;  "(\EDITELT PCTB (ADD1 \FirstPieceOffset))") (\GETBASEPTR (\FIRSTNODE PCTB) 0] while (AND PC (NEQ PC HIPC)) collect (PROG1 PC (SETQ PC (fetch (PIECE NEXTPIECE) of PC)))] [OR DONTDIRTY (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT THACTION _ 'Delete THLEN _ LEN THCH# _ CH# THFIRSTPIECE _ (CAR PCLST] (* ;  "Add this event to the history list") (* ;; "Actually delete the pieces:") (for PC in PCLST do [AND (fetch (PIECE POBJ) of PC) (IMAGEOBJPROP (fetch (PIECE POBJ) of PC) 'WHENDELETEDFN) (APPLY* (IMAGEOBJPROP (fetch (PIECE POBJ) of PC) 'WHENDELETEDFN) (fetch (PIECE POBJ) of PC) (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ] (* \DELETEPIECE PC PCTB) (\DELETETREE PC (fetch (PIECE PTREENODE) of PC))) (* ;; "Link around the deleted pieces:") (COND (PC1 (replace (PIECE NEXTPIECE) of PC1 with HIPC))) (COND (HIPC (replace (PIECE PREVPIECE) of HIPC with PC1))) (* ;; "Unchain the deleted pieces from the rest of the document.") (AND (CAR (FLAST PCLST)) (replace (PIECE PREVPIECE) of (CAR (FLAST PCLST)) with NIL)) (AND (CAR PCLST) (replace (PIECE PREVPIECE) of (CAR PCLST) with NIL)) (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) (* ;  "Force the next insertion to be in a fresh piece.") (\TEDIT.DIFFUSE.PARALOOKS PC1 HIPC) (* ;  "PROPOGATE PARALOOKS THRU THE DELETION") ] (freplace (TEXTOBJ TEXTLEN) of TEXTOBJ with (IDIFFERENCE TEXTLEN LEN)) (* ; "Update the file's length") (OR DONTDIRTY (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T]) (\SETUPGETCH + [LAMBDA (CH# TEXTOBJ) (* ; "Edited 14-Apr-93 17:14 by jds") + +(* ;;; "Set up TEXTOBJ so that the next \GETCH will retrieve character # CH#") + + (* ;; "NB that 1st char in the textobj is #1.") + + (* ;; "(declare (localvars . t))") + + (PROG (PC PCNO PS PF CHOFFSET CHARSLEFT (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + (STREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) + FPOS OFFST SUBSTREAM START-OF-PIECE) + (replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL) + [COND + [(LISTP CH#) (* ; + "If CH# is a piece-offset pair, make use of it.") + (SETQ PC (fetch (EDITMARK PC) of CH#)) + (SETQ CHOFFSET (fetch (EDITMARK PCOFF) of CH#)) + (COND + ((ATOM PC) (* ; + "This SETUPGETCH is to the final pseudo-piece!") + (freplace (TEXTSTREAM PIECE) of STREAM with PC) + (freplace (STREAM COFFSET) of STREAM with 0) + (freplace (STREAM CPAGE) of STREAM with 0) + (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0) + (freplace (TEXTSTREAM PCSTARTCH) of STREAM with 0) + (freplace (TEXTSTREAM PCOFFSET) of STREAM with 0) + (RETURN] + ((IGREATERP CH# (IMAX 1 (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) + (ERROR "TRYING TO \SETUPGETCH BEYOND END OF TEXT")) + (T + (* ;; "CH# is indeed a character number. Find the corresponding piece, its pcno, and the offset within that piece.") + + (SETQ PC (\CHTOPC CH# PCTB T)) + + (* ;; "(setq pc (\\editelt pctb (add1 pcno)))") + + (SETQ CHOFFSET (- CH# START-OF-PIECE] + (freplace (TEXTSTREAM PIECE) of STREAM with PC) + (replace (STREAM BINABLE) of STREAM with T) + (SETQ CHARSLEFT (IDIFFERENCE (fetch (PIECE PLEN) of PC) + CHOFFSET)) + (freplace (TEXTSTREAM PCOFFSET) of STREAM with CHOFFSET) + (COND + ((SETQ PS (ffetch (PIECE PSTR) of PC)) (* ; "This piece resides in a STRING.") + (\TEDIT.TEXTBIN.STRINGSETUP CHOFFSET CHARSLEFT STREAM PS)) + ((SETQ PF (ffetch (PIECE PFILE) of PC)) (* ; "This piece resides on a FILE") + (\TEDIT.TEXTBIN.FILESETUP PC CHOFFSET CHARSLEFT STREAM PF (fetch (PIECE PFATP) + of PC))) + [(SETQ PF (ffetch (PIECE POBJ) of PC)) (* ; + "This piece points to an object. set up so \TextBin will be called, and will return it.") + (COND + ((SETQ SUBSTREAM (IMAGEOBJPROP PF 'SUBSTREAM)) + (* ; + "There is a stream below this one! Reflect things upward.") + (* ; + "This is a simple object. Just set things up so it gets read.") + (\SETUPGETCH (ADD1 CHOFFSET) + (fetch (TEXTSTREAM TEXTOBJ) of SUBSTREAM)) + (replace (STREAM BINABLE) of STREAM with NIL) + (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 0) + (freplace (STREAM COFFSET) of STREAM with CHOFFSET) + (freplace (STREAM CBUFSIZE) of STREAM with (fetch (PIECE PLEN) + of PC)) + (freplace (STREAM CPAGE) of STREAM with 0) + (freplace (TEXTSTREAM PCSTARTCH) of STREAM with CHOFFSET) + (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0) + (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with + (fetch (TEXTSTREAM + + CURRENTPARALOOKS + ) of + SUBSTREAM)) + (replace (TEXTSTREAM CURRENTLOOKS) of STREAM with (fetch + (TEXTSTREAM + CURRENTLOOKS) + of SUBSTREAM)) + (RETURN)) + (T (* ; + "This is a simple object. Just set things up so it gets read.") + (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 1) + (freplace (STREAM COFFSET) of STREAM with 0) + (freplace (STREAM CBUFSIZE) of STREAM with 1) + (freplace (STREAM CPAGE) of STREAM with 0) + (freplace (TEXTSTREAM PCSTARTCH) of STREAM with 0) + (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0) + (replace (STREAM BINABLE) of STREAM with NIL) + (* ; + "Force the next BIN to go thru our code.") + ] + (T (ERROR "Piece is neither a file nor a string??" PC))) + (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with + (\TEDIT.APPLY.PARASTYLES + (fetch (PIECE PPARALOOKS) + of PC) + PC TEXTOBJ)) + (* ; + "Set the character looks and font caches.") + (replace (TEXTSTREAM CURRENTLOOKS) of STREAM with (\TEDIT.APPLY.STYLES + (ffetch (PIECE PLOOKS) + of PC) + PC TEXTOBJ]) (\TEDIT.REOPEN.STREAM [LAMBDA (TEXTSTREAM PIECESTREAM) (* ; "Edited 11-Jun-99 15:12 by rmk:") (* ; "Edited 11-Jun-99 15:12 by rmk:") (* ; "Edited 11-Jun-99 14:24 by rmk:") (* ; "Edited 15-Apr-93 15:53 by jds") (* ;; "Re-open the backing file stream, and propogate the change thru the entire piece table. Also, if TXTFILE is set to the closed stream, fill it in as well.") (LET* ([NEWSTREAM (OPENSTREAM PIECESTREAM 'INPUT NIL '((TYPE TEXT] (TEXTOBJ (TEXTOBJ TEXTSTREAM)) (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) PC) (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB) 0)) (* ;; "Run thru the pieces, correcting any that used this stream to use the new one:") (while PC do (COND ((EQ (fetch (PIECE PFILE) of PC) PIECESTREAM) (replace (PIECE PFILE) of PC with NEWSTREAM))) (SETQ PC (fetch (PIECE NEXTPIECE) of PC))) (* ;; "Check the TXTFILE, and if it uses the closed stream, fix it as well:") (COND ((EQ (fetch (TEXTOBJ TXTFILE) of TEXTOBJ) PIECESTREAM) (* ;  "Yup, it was the old, closed stream. Fix it.") (replace (TEXTOBJ TXTFILE) of TEXTOBJ with NEWSTREAM))) (* ;; "Return the new value for the stream:") NEWSTREAM]) (\TEDIT.COPYTEXTSTREAM.PIECEMAPFN + [LAMBDA (PC TEXTOBJ FROMOBJ TOOBJ) (* ; "Edited 31-May-91 14:00 by jds") + (* Called by COPYTEXTSTREAM via + TEDIT.SELECTED.PIECES, to do the + copy-operation processing on the + candidate pieces.) + (PROG (OBJ NEWOBJ COPYFN) + (SETQ PC (create PIECE using PC PNEW _ T)) (* No matter what, we need a fresh + copy.) + [COND + ((fetch (PIECE POBJ) of PC) (* This piece describes an object) + (SETQ OBJ (fetch (PIECE POBJ) of PC)) + [COND + [(SETQ COPYFN (IMAGEOBJPROP OBJ 'COPYFN)) + (SETQ NEWOBJ (APPLY* COPYFN OBJ (fetch (TEXTOBJ STREAMHINT) of FROMOBJ) + (fetch (TEXTOBJ STREAMHINT) of TOOBJ))) + (COND + ((EQ NEWOBJ 'DON'T) (* He said not to copy this piece -- + abort the whole copy.) + (TEDIT.PROMPTPRINT TEXTOBJ "COPY of this object not allowed." T) + (RETFROM 'TEDIT.COPY)) + (NEWOBJ (replace (PIECE POBJ) of PC with NEWOBJ)) + (T (replace (PIECE POBJ) of PC with (COPYALL OBJ] + (OBJ (* No copy fn; just strike off a + copy of our own) + (replace (PIECE POBJ) of PC with (COPYALL OBJ] + (COND + ((SETQ COPYFN (IMAGEOBJPROP OBJ 'WHENCOPIEDFN)) + (* If there's an eventfn for + copying, use it.) + (APPLY* COPYFN OBJ (CAR (fetch (TEXTOBJ \WINDOW) of TOOBJ)) + (fetch (TEXTOBJ STREAMHINT) of FROMOBJ) + (fetch (TEXTOBJ STREAMHINT) of TOOBJ] + (RETURN PC]) (\TEXTINIT + [LAMBDA NIL (* ; "Edited 31-May-91 14:18 by jds") + (* ; + "Create the FDEV and STREAM prototypes for TEXT streams.") + + (* ;; "TEXT streams make use of the following STREAM fields:") + + (* ;; "(DEVICE (* FDEV of this guy -- The TEXT device)") + + (* ;; "F1 (* The STREAM for the PFILE of the current piece (or NIL))") + + (* ;; "F2 (* # chars left in piece at end of underlying file's page)") + + (* ;; "F3 (* The TEXTOBJ for this stream)") + + (* ;; "F4") + + (* ;; "F5 (* The PIECE we're currently inside)") + + (* ;; "(FW6 WORD) (* CPAGE for the start of the piece, for BACKFILEPTR)") + + (* ;; "(FW7 WORD) (* COFFSET for the start of the piece, for BACKFILEPTR)") + + (* ;; "(FW8 WORD)") + + (SETQ \TEXTIMAGEOPS (create IMAGEOPS + IMAGETYPE _ 'TEXT + IMXPOSITION _ (FUNCTION \TEXTDSPXPOSITION) + IMYPOSITION _ (FUNCTION \TEXTDSPYPOSITION) + IMLEFTMARGIN _ (FUNCTION \TEXTLEFTMARGIN) + IMRIGHTMARGIN _ (FUNCTION \TEXTRIGHTMARGIN) + IMFONT _ (FUNCTION \TEXTDSPFONT) + IMCLOSEFN _ (FUNCTION NILL) + IMFONTCREATE _ 'DISPLAY + IMLINEFEED _ (FUNCTION \TEXTDSPLINEFEED) + IMCHARWIDTH _ (FUNCTION \TEXTDSPCHARWIDTH) + IMSTRINGWIDTH _ (FUNCTION \TEXTDSPSTRINGWIDTH))) + (SETQ \TEXTFDEV (create FDEV + DEVICENAME _ 'TEXT + RESETABLE _ T + RANDOMACCESSP _ T + PAGEMAPPED _ NIL + GETFILENAME _ (FUNCTION NILL) + BIN _ (FUNCTION \TEXTBIN) + BOUT _ (FUNCTION \TEXTBOUT) + CLOSEFILE _ (FUNCTION \TEXTCLOSEF) + OPENFILE _ (FUNCTION \TEXTOPENF) + DELETEFILE _ (FUNCTION NILL) + DIRECTORYNAMEP _ (FUNCTION NILL) + EVENTFN _ (FUNCTION NILL) + GENERATEFILES _ (FUNCTION \GENERATENOFILES) + GETFILEINFO _ (FUNCTION NILL) + HOSTNAMEP _ (FUNCTION NILL) + READPAGES _ (FUNCTION NILL) + REOPENFILE _ [FUNCTION (LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV STREAM) + (replace (STREAM ACCESS) of STREAM + with 'BOTH) + STREAM] + SETFILEINFO _ (FUNCTION NILL) + BACKFILEPTR _ (FUNCTION \TEXTBACKFILEPTR) + SETFILEPTR _ (FUNCTION \TEXTSETFILEPTR) + PEEKBIN _ (FUNCTION \TEXTPEEKBIN) + GETEOFPTR _ (FUNCTION \TEXTGETEOFPTR) + GETFILEPTR _ (FUNCTION \TEXTGETFILEPTR) + EOFP _ (FUNCTION \TEXTEOFP) + FDBINABLE _ T + FDBOUTABLE _ NIL + FDEXTENDABLE _ NIL + TRUNCATEFILE _ (FUNCTION NILL) + WRITEPAGES _ (FUNCTION NILL) + READCHARCODE _ (FUNCTION BIN))) + (SETQ \TEXTOFD + (create STREAM + BINABLE _ T + BOUTABLE _ NIL + ACCESS _ 'BOTH + USERCLOSEABLE _ T + USERVISIBLE _ T + DEVICE _ \TEXTFDEV + F1 _ NIL + F2 _ 0 + F3 _ NIL + F5 _ NIL + FW6 _ 0 + FW7 _ 0 + MAXBUFFERS _ 10 + IMAGEOPS _ \TEXTIMAGEOPS + IMAGEDATA _ (create TEXTIMAGEDATA) + OUTCHARFN _ (FUNCTION \TEDITOUTCHARFN))) (* ; "The prototypical Text stream") + + (* ;; "Set up so that FILE NOT OPENs on TEdit streams are caught and fixed.") + + (CL:SETF (CONDITION-HANDLER 'XCL:STREAM-NOT-OPEN) + (FUNCTION (LAMBDA (CONDITION) + (LET ((STREAM (STREAM-ERROR-STREAM CONDITION))) + (COND + [(AND (BOUNDP 'ERRORPOS) + (TEXTSTREAMP STREAM)) + (* ; + "This happened in the error handler, and it happened to a TEdit stream, so try the fix:") + (LET ((XCL::RESULT (REOPENTEXTSTREAM STREAM))) + (CL:WHEN XCL::RESULT + (ENVAPPLY (STKNAME ERRORPOS) + (SUBST XCL::RESULT STREAM (STKARGS ERRORPOS)) + (STKNTH -1 ERRORPOS ERRORPOS) + ERRORPOS T T))] + (*TEDIT-OLD-STREAM-ERROR-HANDLER* + (* ; + "Some other kind of stream, so punt to the old handler (if there is one):") + (APPLY* *TEDIT-OLD-STREAM-ERROR-HANDLER* CONDITION]) (\TEXTMARK + [LAMBDA (TEXTOBJ) (* ; "Edited 31-May-91 14:18 by jds") + (PROG ((STREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ))) + (RETURN (CONS (ffetch (TEXTSTREAM PIECE) of STREAM) + (IDIFFERENCE (create BYTEPTR + PAGE _ (ffetch (STREAM CPAGE) of STREAM) + OFFSET _ (ffetch (STREAM COFFSET) of STREAM)) + (create BYTEPTR + PAGE _ (ffetch (TEXTSTREAM PCSTARTPG) of STREAM) + OFFSET _ (ffetch (TEXTSTREAM PCSTARTCH) of STREAM]) (\TEXTTTYBOUT + [LAMBDA (STREAM BYTE) (* ; "Edited 31-May-91 14:18 by jds") + (* Do BOUT to a text stream, which + is an insertion at the caret.) + (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) + (COND + ((EQ BYTE ERASECHARCODE) + (\TEDIT.CHARDELETE TEXTOBJ "" (fetch (TEXTOBJ SEL) of TEXTOBJ))) + ((EQ IGNORE.CCE (fetch CCECHO of (\SYNCODE (OR (fetch (TEXTOBJ TXTTERMSA) + of TEXTOBJ) + \PRIMTERMSA) + BYTE))) + (* Nothing, ignore it) + ) + (T (SELCHARQ BYTE + ((EOL CR LF) + (\TEXTBOUT STREAM BYTE) + (replace (STREAM CHARPOSITION) of STREAM with 0)) + (PROGN (\TEXTBOUT STREAM BYTE) + (add (fetch (STREAM CHARPOSITION) of STREAM) + 1]) ) (DEFINEQ (\INSERTCH [LAMBDA (CH CH# TEXTOBJ INSERTMARK) (* ; "Edited 29-Jan-99 17:19 by kaplan") (* ;; "If the current ch is 1+last ch in the distinguished INPUTPIECE, then append this text to that piece (make a new one if need be.), and fix up ch#s in the PCTB") (* ;; "else, create a new input piece (as a substring of the old one) and INSERT it at the right spot, perhaps after splitting a piece to make room.") (COND ((NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)) (* ;; "Only insert if the document is allowed to change.") (PROG (PC (LEN (COND ((type? STRINGP CH) (NCHARS CH)) (T 1))) [FATP (COND [(type? STRINGP CH) (AND (fetch (STRINGP FATSTRINGP) of CH) (NOT (NULL (for CHAR instring CH thereis (IGREATERP CHAR \MAXTHINCHAR] (T (IGREATERP CH \MAXTHINCHAR] CHNO NEWPC PREVPC EVENT REPLACING (NEWFLAG NIL) (\INEXTCH (fetch (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ)) (\INLEN (fetch (TEXTOBJ \INSERTLEN) of TEXTOBJ)) (\INLEFT (fetch (TEXTOBJ \INSERTLEFT) of TEXTOBJ)) (\INSTRING (fetch (TEXTOBJ \INSERTSTRING) of TEXTOBJ)) (\INPC (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ)) (\INFIRSTCH (fetch (TEXTOBJ \INSERTFIRSTCH) of TEXTOBJ)) (PCTB (ffetch (TEXTOBJ PCTB) of TEXTOBJ)) (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) (IMARKPC (fetch (EDITMARK PC) of INSERTMARK)) (IMARKCH (fetch (EDITMARK PCOFF) of INSERTMARK)) PLOOKS NLOOKS START-OF-PIECE) [COND ((ZEROP LEN) (* ; "Nothing to insert, really!") (RETURN)) [(ZEROP (fetch (BTREENODE COUNT) of PCTB)) (* ; "PCTB is empty.") (\INSERT.FIRST.PIECE TEXTOBJ) (SETQ \INPC (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ)) (SETQ \INSTRING (fetch (TEXTOBJ \INSERTSTRING) of TEXTOBJ)) (COND ((type? STRINGP CH) (* ;  "If input is a string, copy it to the insert piece's string") (RPLSTRING \INSTRING 1 CH)) (T (* ;  "If it's a single charcode, move it to the piece's string") (RPLCHARCODE \INSTRING 1 CH))) (replace (PIECE PLEN) of \INPC (freplace (TEXTOBJ \INSERTLEN) of TEXTOBJ with LEN)) (freplace (TEXTOBJ \INSERTLEFT) of TEXTOBJ with (IDIFFERENCE 512 LEN)) (freplace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with LEN) (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT THACTION _ 'Insert THLEN _ (fetch (PIECE PLEN) of \INPC) THCH# _ CH# THFIRSTPIECE _ (LIST \INPC) THPOINT _ 'RIGHT] ((OR [AND (fetch (TEXTOBJ \INSERTPCVALID) of TEXTOBJ) (OR (IEQP CH# \INEXTCH) (AND INSERTMARK (EQ IMARKPC (fetch (PIECE NEXTPIECE) of \INPC) ) (EQ IMARKCH 0] (AND NIL (EQ CH# 1) (EQ \INEXTCH -1))) (* ;; "We're inserting at the end of a previous insertion, for which we already have a piece built. Just add to it.") (* ;; "Or, First insertion to empty document.") (COND ((IGEQ \INLEFT LEN) (* ;  "There's enough room in this piece -- fill it in.") (COND ((type? STRINGP CH) (* ;  "If input is a string, copy it to the insert piece's string") (RPLSTRING \INSTRING (ADD1 \INLEN) CH)) (T (* ;  "If it's a single charcode, move it to the piece's string") (RPLCHARCODE \INSTRING (ADD1 \INLEN) CH))) (replace (PIECE PLEN) of \INPC with (freplace (TEXTOBJ \INSERTLEN ) of TEXTOBJ with (IPLUS \INLEN LEN)) ) (* ;  "Fix the length of the insert piece") (freplace (TEXTOBJ \INSERTLEFT) of TEXTOBJ with (IDIFFERENCE \INLEFT LEN) ) (* ; "And the space left in the piece") (freplace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with (IPLUS \INEXTCH LEN)) (* ; "And the next CH#") (* ; "And the piece # for future use") ) (T (* ;  "No room. Chop this piece & start a new one.") (replace (PIECE PSTR) of \INPC with (SUBSTRING \INSTRING 1 \INLEN )) (* ;  "Chop the current piece's string to length") (SETQ NEWPC (create PIECE PSTR _ (ALLOCSTRING 512 '% ) PLOOKS _ (fetch (PIECE PLOOKS) of \INPC) PPARALOOKS _ (fetch (PIECE PPARALOOKS) of \INPC) PPARALAST _ NIL PNEW _ T)) (* ; "Create the new piece") (freplace (TEXTOBJ \INSERTSTRING) of TEXTOBJ with (SETQ \INSTRING (fetch (PIECE PSTR) of NEWPC))) (* ;  "Set the \INSTRING field in TEXTOBJ") (COND ((type? STRINGP CH) (* ;  "If input is a string, copy it to the insert piece's string") (RPLSTRING \INSTRING 1 CH)) (T (* ;  "If it's a single charcode, move it to the piece's string") (RPLCHARCODE \INSTRING 1 CH))) (replace (PIECE PLEN) of NEWPC with LEN) (* ;  "So far, the present input is the only thing in the piece") (replace (TEXTOBJ \INSERTPCNO) of TEXTOBJ with (\INSERTPIECE NEWPC (OR (fetch (PIECE NEXTPIECE) of \INPC) 'LASTPIECE) TEXTOBJ)) (* ;  "Insert the new piece into the text and save the piece #") (* ;; "(SETQ PCTB (fetch PCTB of TEXTOBJ))") (* ;  "Which may have caused a PCTB overflow") (* ;  "This does not happen, after change pctree.") (freplace (TEXTOBJ \INSERTPC) of TEXTOBJ with (SETQ \INPC NEWPC)) (freplace (TEXTOBJ \INSERTLEFT) of TEXTOBJ with (IDIFFERENCE 512 LEN)) (freplace (TEXTOBJ \INSERTLEN) of TEXTOBJ with LEN) (replace (TEXTOBJ \INSERTFIRSTCH) of TEXTOBJ with CH#) (* ;  "CH# of the first inserted character") (replace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with (IPLUS CH# LEN)) (* ;  "The CH# of the next character, if it's inserted at the current caret.") (replace THFIRSTPIECE of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ) with (NCONC1 (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ) NEWPC)) (SETQ NEWFLAG T) (* ; "Note the new piece's creation") )) (add (fetch THLEN of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)) LEN) (* ;  "Update the length of the insertion/replacement text.") ) (T (* ;; "NEW INSERTION POINT; IF THERE'S ANYTHING LEFT OF THE PREVIOUS INSERT PIECE, CRACK OFF A NEW ONE & FILL IT. THEN FIGURE OUT WHERE TO SHOEHORN IT IN.") (SETQ PC (OR IMARKPC (\CHTOPC CH# PCTB T))) [COND ((AND \INPC (IGEQ \INLEFT LEN)) (* ;  "There's room left in the prior input-piece's string; re-use it.") (SETQ NEWPC (create PIECE PSTR _ (SUBSTRING \INSTRING (ADD1 \INLEN)) PLOOKS _ (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) PPARALOOKS _ (fetch (PIECE PPARALOOKS) of \INPC) PPARALAST _ NIL PNEW _ T)) (* ; "Build the new piece") (replace (PIECE PSTR) of \INPC with (SUBSTRING \INSTRING 1 \INLEN )) (freplace (TEXTOBJ \INSERTLEFT) of TEXTOBJ with (IDIFFERENCE \INLEFT LEN))) (T (* ;  "No room left; build a whole new piece.") (SETQ NEWPC (create PIECE PSTR _ (freplace (TEXTOBJ \INSERTSTRING) of TEXTOBJ with (ALLOCSTRING 512)) PLOOKS _ (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ) PPARALOOKS _ (OR (AND \INPC (fetch (PIECE PPARALOOKS ) of \INPC)) (\TEDIT.UNIQUIFY.PARALOOKS (create FMTSPEC copying (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)) TEXTOBJ)) PPARALAST _ NIL PNEW _ T)) (freplace (TEXTOBJ \INSERTLEFT) of TEXTOBJ with (IDIFFERENCE 512 LEN] (freplace (TEXTOBJ \INSERTPC) of TEXTOBJ with (SETQ \INPC NEWPC)) (replace (PIECE PLEN) of NEWPC with LEN) (freplace (TEXTOBJ \INSERTSTRING) of TEXTOBJ with (SETQ \INSTRING (fetch (PIECE PSTR) of NEWPC))) (COND ((type? STRINGP CH) (* ;  "Insert the characters into the piece") (RPLSTRING \INSTRING 1 CH)) (T (RPLCHARCODE \INSTRING 1 CH))) (freplace (TEXTOBJ \INSERTLEN) of TEXTOBJ with LEN) (freplace (TEXTOBJ \INSERTFIRSTCH) of TEXTOBJ with CH#) (* ;  "Cache the first-inserted-ch #, for backspace speed") (SETQ NEWFLAG T) (COND ((OR (IGREATERP CH# TEXTLEN) (IEQP CH# START-OF-PIECE)) (* ;  "We're inserting on a piece boundary; do it, then remember the prior piece.") (\INSERTPIECE \INPC PC TEXTOBJ NIL)) (T (* ;  "Not on a piece boundary; split the piece we're inside of, then insert.") (\INSERTPIECE \INPC (\SPLITPIECE PC (- CH# START-OF-PIECE) TEXTOBJ) TEXTOBJ NIL))) [COND ((NOT (fetch (PIECE PPARALOOKS) of \INPC)) (* ;  "There weren't any paralooks available at creation time. Find some now.") [SETQ PLOOKS (AND (fetch (PIECE PREVPIECE) of \INPC) (fetch (PIECE PPARALOOKS) of (fetch (PIECE PREVPIECE) of \INPC] [SETQ NLOOKS (AND (fetch (PIECE NEXTPIECE) of \INPC) (fetch (PIECE PPARALOOKS) of (fetch (PIECE NEXTPIECE) of \INPC] (replace (PIECE PPARALOOKS) of \INPC with (COND ((NOT PLOOKS) (* ;  "No preceding para to take looks from") (OR NLOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ))) ((NOT NLOOKS) (* ;  "No succeeding paras to take looks from") (OR PLOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ))) (T PLOOKS] (replace (TEXTOBJ \INSERTPCNO) of TEXTOBJ with 0) (* ;  "Save the pcno for future insertions") (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) (* ;  "The PCTB may have expanded during the insert.") (SETQ PREVPC (OR (fetch (PIECE PREVPIECE) of NEWPC) PC)) (* ;  "The piece we're to take the inserted characters' looks from") (replace (PIECE PLOOKS) of NEWPC with (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ)) [replace (PIECE PPARALOOKS) of NEWPC with (COND ((ZEROP TEXTLEN) (* ;  "No text yet; use default paralooks") (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)) ((SETQ PREVPC (fetch (PIECE NEXTPIECE) of \INPC)) (* ;  "There's later text. Use its para looks") (fetch (PIECE PPARALOOKS) of PREVPC)) ((SETQ PREVPC (fetch (PIECE PREVPIECE) of \INPC)) (* ;  "There's earlier text. Use its looks, copied if need be.") (COND ((fetch (PIECE PPARALAST) of PREVPC) (fetch (PIECE PPARALOOKS) of PREVPC)) (T (fetch (PIECE PPARALOOKS) of PREVPC] (SETQ EVENT (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)) (* ; "Prior edit event.") [SETQ REPLACING (AND (EQ (fetch THACTION of EVENT) 'Delete) (IEQP CH# (fetch THCH# of EVENT] (COND ((AND (fetch (TEXTOBJ \INSERTPCVALID) of TEXTOBJ) (IEQP CH# \INEXTCH) (EQ (fetch THACTION of EVENT) 'Insert)) (* ;; "We're continuing a prior insertion, even if we had to create a new piece. Just continue the old history event, too.") (add (fetch THLEN of EVENT) LEN)) (T (* ;  "Nope, this is a new insertion/replacement. Make the new history event.") (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT THACTION _ (COND (REPLACING 'Replace) (T 'Insert)) THLEN _ (fetch (PIECE PLEN) of \INPC) THCH# _ CH# THFIRSTPIECE _ \INPC THPOINT _ 'RIGHT THOLDINFO _ (AND REPLACING EVENT] [OR NEWFLAG (PROGN (* ;  "We didn't add a piece, so we must update character numbers in the PCTB") (* ; "The insert-piece's PCTB entry") (* ;; "(for I from (IPLUS PCNO \EltsPerPiece) to (\EDITELT PCTB \PCTBLastPieceOffset) by \EltsPerPiece do (\EDITSETA PCTB I (IPLUS (\EDITELT PCTB I) LEN)))") (COND ((NOT (AND (EQ CH# 1) (EQ \INEXTCH -1))) (* ;  "Update character numbers in the PCTB doesn't need when 1st insertion.") (UPDATEPCNODES \INPC LEN PCTB] (freplace (TEXTOBJ TEXTLEN) of TEXTOBJ with (SETQ TEXTLEN (IPLUS LEN TEXTLEN))) (replace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with (IPLUS CH# LEN)) (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with T) (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T) (replace (PIECE PFATP) of \INPC with (OR (fetch (PIECE PFATP) of \INPC) FATP]) (\INSERTCR + [LAMBDA (CH CH# TEXTOBJ) (* ; "Edited 31-May-91 14:00 by jds") + + (* ;; "Handle insertion of CR and meta-CR. The former causes a paragraph break, while the latter doesn't. Note, though, that inserting a meta-CR causes the doucment to become formatted.") + + (COND + ((fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)) + (T (LET (INPC) + (COND + ([AND (NOT (fetch (TEXTOBJ FORMATTEDP) of TEXTOBJ)) + (NOT (IEQP CH (CHARCODE CR] (* ; + "Inserting a meta-CR into an unformatted document. Start by setting up para breaks.") + (\TEDIT.CONVERT.TO.FORMATTED TEXTOBJ))) + (\INSERTCH (CHARCODE CR) + CH# TEXTOBJ) (* ; "Put the CR in") + (COND + ((IEQP CH (CHARCODE CR)) (* ; + "It's really a CR, rather than a meta-CR so do para breaking.") + (SETQ INPC (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ)) + (AND INPC (replace (PIECE PPARALAST) of INPC with T)) + (* ; + "Mark the end of the paragraph (INPC might be NIL if the insert got refused somehow).") + (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) + (* ; + "FORCE A NEW PIECE ON THE NEXT CHARACTER") + ]) ) (* ;;; "Functions to manipulate the Piece Table (PCTB)") (DEFINEQ (\CHTOPC + [LAMBDA (CH# PCTB TELL-PC-START?) (* ; "Edited 15-Apr-93 16:05 by jds") + + (* ;; "Given a character # in a text object, and the object's piece table, return a pointer to the piece containing that character, else NIL.") + + (* ;; "If TELL-PC-START? is not NIL, sets the free variable START-OF-PIECE to the ch# of the piece's start.") + + (LET ((TREE PCTB) + (BASE-CH# 1) + TBASE-CH# FOUND) + (while (type? BTREENODE TREE) + do [for I from 1 to (fetch (BTREENODE COUNT) of TREE) + as OFST from 2 by 4 + do (COND + ((IGREATERP (SETQ TBASE-CH# (IPLUS BASE-CH# (\GETBASEFIXP TREE OFST)) + ) + CH#) + (SETQ FOUND (\GETBASEPTR TREE (- OFST 2))) + (RETURN)) + (T (SETQ BASE-CH# TBASE-CH#] + (SETQ TREE FOUND)) + (AND TELL-PC-START? (SETQ START-OF-PIECE BASE-CH#)) + (OR TREE 'LASTPIECE]) (\CHTOPCNO + [LAMBDA (CH# PCTB) (* ; "Edited 13-Jun-90 00:47 by mitani") + + (* ;; "Given a character # in a text object, and the object's piece table, return a pointer to the piece containing that character, else NIL") + + (DECLARE (LOCALVARS . T)) + (LET ((INDEX 0) + (TREE (fetch (PCTNODE HI) of PCTB)) + CHNUM) + [while TREE do (COND + [(IEQP CH# (SETQ CHNUM (fetch (PCTNODE CHNUM) of TREE))) + (* ; "FIND NODE") + (RETURN (SETQ INDEX (IPLUS INDEX (fetch (PCTNODE RANK) + of TREE] + ((IGREATERP CH# CHNUM) (* ; "MOVE RIGHT") + (SETQ INDEX (IPLUS INDEX (fetch (PCTNODE RANK) of TREE))) + (SETQ TREE (fetch (PCTNODE HI) of TREE))) + ((ILESSP CH# CHNUM) (* ; "MOVE LEFT") + (SETQ TREE (fetch (PCTNODE LO) of TREE] + (IMAX INDEX 1]) (\CLEARPCTB + [LAMBDA (PCTB) (* ; "Edited 23-Feb-88 11:11 by jds") + + (* ;; "(PROG ((OLASTPC (\EDITELT PCTB \PCTBLastPieceOffset))) (\EDITSETA PCTB \FirstPieceOffset 1) (* Create the LASTPIECE pseudo-piece placeholder in the first piece of the table) (\EDITSETA PCTB (ADD1 \FirstPieceOffset) (QUOTE LASTPIECE)) (for I from \SecondPieceOffset to OLASTPC do (* Now remove the other pieces, setting them to NIL) (\EDITSETA PCTB I NIL)) (\EDITSETA PCTB \PCTBLastPieceOffset (ADD1 \FirstPieceOffset)) (* Fix up the last-piece pointer) (\EDITSETA PCTB \PCTBFreePieces (IPLUS (\EDITELT PCTB \PCTBFreePieces) (LRSH (IDIFFERENCE OLASTPC (ADD1 \FirstPieceOffset)) 1))) (* And the free count of pieces.) (RETURN PCTB))") + + (HELP]) (\CREATEPIECEORSTREAM [LAMBDA (STRING LOOKS PARALOOKS START END) (* ; "Edited 11-Jun-99 14:25 by rmk:") (* ; "Edited 31-May-91 14:18 by jds") (* ;; "Given a source for text, build a PIECE to describe it.") (* ;; "HOWEVER-- if it's aformatted file, return the stream for that file.") (PROG (PC) [SETQ PC (COND ((STRINGP STRING) (* ; "It's a string.") (create PIECE PSTR _ STRING PFILE _ NIL PLEN _ (NCHARS STRING) PPARALAST _ NIL PPARALOOKS _ PARALOOKS PFATP _ (fetch (STRINGP FATSTRINGP) of STRING))) ((NULL STRING) (* ;  "If it's NIL, use an empty string for the text.") (create PIECE PSTR _ "" PFILE _ NIL PLEN _ 0 PPARALAST _ NIL PPARALOOKS _ PARALOOKS)) ((ATOM STRING) (* ;  "An atom is a file name. Open it.") [SETQ STRING (OPENSTREAM STRING 'INPUT 'OLD '(TYPE TEXT] (RETURN STRING)) [(STREAMP STRING) (COND [(EQ NoBits (fetch (STREAM ACCESSBITS) of STRING)) (* ;  "If the stream is no longer open, open it.") (RETURN (OPENSTREAM STRING 'INPUT 'OLD '((TYPE TEXT] (T (RETURN STRING] ((type? PIECE STRING) STRING) (T (* ;  "Anything else is coerced to a string first.") (SETQ STRING (MKSTRING STRING)) (create PIECE PSTR _ STRING PFILE _ NIL PLEN _ (NCHARS STRING) PPARALAST _ NIL PPARALOOKS _ PARALOOKS] (replace (PIECE PLOOKS) of PC with (OR LOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT)) ) (replace (PIECE PPARALOOKS) of PC with (OR PARALOOKS (create FMTSPEC using TEDIT.DEFAULT.FMTSPEC ))) (RETURN PC]) (\DELETEPIECE + [LAMBDA (PC PCTB PC#) (* ; "Edited 20-Apr-93 19:06 by jds") + + (* ;; "Remove piece PC from the piece table PCTB. Adjust the character numbers of succeeding pieces, if need be.") + + (PROG (PCNODE (NEXT (fetch (PIECE NEXTPIECE) of PC)) + (PREV (fetch (PIECE PREVPIECE) of PC))) + (\DELETETREE PC (fetch (PIECE PTREENODE) of PC)) + (COND + (NEXT (replace (PIECE PREVPIECE) of NEXT with PREV))) + (* ; + "Break any forward link from the piece") + (COND + (PREV (replace (PIECE NEXTPIECE) of PREV with NEXT))) + (* ; "and any backward link.") + ]) (\FINDPIECE + [LAMBDA (PC PCTB) (* ; "Edited 31-May-91 13:53 by jds") + + (* Given a piece and the pctb it's in, return the elt %# of the CH# entry for + that piece in the table) + + (LET ((NODE (FINDPCNODE PC PCTB))) + (INDEX (fetch (PCTNODE CHNUM) of NODE) + PCTB]) (\INSERTPIECE + [LAMBDA (NEW OLD TEXTOBJ DONTUPDATECH#S PC# NEW-PREVLEN PREV) + (* ; "Edited 7-Oct-94 17:43 by jds") + + (* ;; "Insert the piece NEW in front of the piece OLD; re-allocate PCTB if need be") + + (PROG* ((PLEN (fetch (PIECE PLEN) of NEW)) + (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + OLDLEN PCNODE PREVPC) + (COND + ((ZEROP (fetch (BTREENODE COUNT) of PCTB)) + (* ; "PCTB is empty.") + (replace (PIECE NEXTPIECE) of NEW with NIL) + (replace (PIECE PREVPIECE) of NEW with NIL) + (replace (BTREENODE DOWN1) of PCTB with NEW) + (replace (BTREENODE COUNT) of PCTB with 1) + (replace (BTREENODE TOTLEN) of PCTB with PLEN) + (RETURN 1))) + (SETQ OLDLEN (fetch (BTREENODE TOTLEN) of PCTB)) + [SETQ PCNODE (COND + ((OR (NULL OLD) + (ATOM OLD)) (* ; "Inserting in front of a symbol OR NIL, which must be LASTPIECE, the end-of-doc marker. Go find the node that contains it.") + (\LASTNODE PCTB)) + (T (* ; + "Normal case; go find the btree node that contains the piece we're inserting in front of.") + (FINDPCNODE OLD PCTB] + (\INSERTTREE NEW OLD PCNODE NEW-PREVLEN NIL PREV) + + (* ;; "Update inter-piece linkages:") + + (COND + [(OR (NULL OLD) + (ATOM OLD)) (* ; "Inserting in front of a symbol OR NIL, which must be LASTPIECE, the end-of-doc marker. Go find the node that contains it.") + (replace (PIECE NEXTPIECE) of NEW with NIL) + (replace (PIECE PREVPIECE) of NEW with (AND (NOT (ZEROP OLDLEN)) + (SETQ PREVPC (\CHTOPC + OLDLEN PCTB] + (T (* ; + "Normal case; go find the btree node that contains the piece we're inserting in front of.") + (replace (PIECE NEXTPIECE) of NEW with OLD) + (replace (PIECE PREVPIECE) of NEW with (SETQ PREVPC (ffetch + (PIECE PREVPIECE) + of OLD))) + (replace (PIECE PREVPIECE) of OLD with NEW))) + (AND PREVPC (replace (PIECE NEXTPIECE) of PREVPC with NEW]) (\MAKEPCTB + [LAMBDA (PC1 MINLEN) (* ; "Edited 15-Apr-93 15:48 by jds") + + (* ;; "Create a new piece table, with PC1 as its first piece, and a dummy piece at the end, with 1st ch# of 1+ (chlim of pc1)") + + (* ;; "A piece Table has the following format: It's an array, with 2 header words (1_# of pieces left in table unused) (2_offset of last used word in tbl), followed by 2-word entries: the first ch# in the piece, and a pointer to the piece.") + + (* ;; "NEW piece tree ") + + (* ;; "ROOT->LO: total hight of piece tree") + + (* ;; "ROOT->HI : Top node of piece tree") + + (LET ((PCTB (CREATE BTREENODE)) + PLEN) + (COND + (PC1 (FREPLACE (BTREENODE COUNT) OF PCTB WITH 2) + (FREPLACE (BTREENODE TOTLEN) OF PCTB WITH (SETQ PLEN (FETCH + (PIECE PLEN) + OF PC1))) + (FREPLACE (BTREENODE DOWN1) OF PCTB WITH PC1) + (FREPLACE (BTREENODE DLEN1) OF PCTB WITH PLEN) + (FREPLACE (BTREENODE DOWN2) OF PCTB WITH 'LASTPIECE) + (FREPLACE (BTREENODE DLEN2) OF PCTB WITH 0) + (FREPLACE (PIECE PTREENODE) OF PC1 WITH PCTB)) + (T + (* ;; + "No initial piece, so create a 0-long document, with only the ending-piece dummy") + + (FREPLACE (BTREENODE COUNT) OF PCTB WITH 1) + (FREPLACE (BTREENODE TOTLEN) OF PCTB WITH 0) + (FREPLACE (BTREENODE DOWN1) OF PCTB WITH 'LASTPIECE) + (FREPLACE (BTREENODE DLEN1) OF PCTB WITH 0))) + PCTB]) (\SPLITPIECE + [LAMBDA (PC CH TEXTOBJ PC#) (* ; "Edited 21-Apr-93 17:49 by jds") + + (* ;; "Split the piece PC before CH (rel to start of PIECE); return the new second piece.") + + (* ;; "PC#, if present, points at the CH# entry for the piece being split.") + + (PROG* ((PCTB (ffetch (TEXTOBJ PCTB) of TEXTOBJ)) + (NEWPC (create PIECE using PC)) + CHNO NEWLEN NEXTPC) + (SETQ CHNO CH) (* ; + "Offset within the piece before which to break") + (COND + ((ILEQ CHNO 0) + (SHOULDNT "Splitting a piece at the start."))) + (replace (PIECE PPARALAST) of PC with NIL) + (* ; + "There can be no para break before the split, as things now work.") + (COND + ((ffetch (PIECE PSTR) of PC) (* ; + "This piece points to a string. Split it for the two new pieces") + (freplace (PIECE PSTR) of NEWPC with (SUBSTRING (ffetch (PIECE PSTR) + of PC) + (ADD1 CHNO))) + (freplace (PIECE PLEN) of NEWPC with (IDIFFERENCE (ffetch (PIECE + PLEN) + of PC) + CHNO)) + (freplace (PIECE PSTR) of PC with (SUBSTRING (ffetch (PIECE PSTR) + of PC) + 1 CHNO)) + (freplace (PIECE PLEN) of PC with CHNO)) + ((ffetch (PIECE PFILE) of PC) (* ; + "This piece points to a file. Set the fileptrs accordingly") + (freplace (PIECE PFILE) of NEWPC with (ffetch (PIECE PFILE) + of PC)) + [freplace (PIECE PFPOS) of NEWPC with (COND + ((fetch (PIECE PFATP) + of NEWPC) + (* ; + "This is a FAT piece; need to allow 2 bytes per char skipped") + (IPLUS (ffetch (PIECE PFPOS) + of PC) + CHNO CHNO)) + (T + (* ; + "Regular piece; allow 1 byte per char") + (IPLUS (ffetch + (PIECE PFPOS) + of PC) + CHNO] + (freplace (PIECE PLEN) of NEWPC with (IDIFFERENCE (ffetch (PIECE + PLEN) + of PC) + CHNO)) + (FREPLACE (PIECE PLEN) OF PC WITH CHNO))) + (PROGN (* UNINTERRUPTABLY) + (SETQ NEXTPC (ffetch (PIECE NEXTPIECE) of PC)) + (* LET ((PCNODE (FETCH + (PIECE PTREENODE) OF PC))) + (* ;; + "Update the length of the original piece in it's tree entry.") + (for ITEM# from 0 by 4 as I from 1 + to (fetch (BTREENODE COUNT) of + PCNODE) when (EQ (\GETBASEPTR PCNODE + ITEM#) PC) do (* ;; + "FIXME - I think this can be done as aport of \INSERTPIECE / \INSERTTREEE, by looking back 1 from the OLD entry and updating. --JDS") + (\PUTBASEFIXP PCNODE + (IPLUS ITEM# 2) (fetch + (PIECE PLEN) of PC)) + (RETURN))) + (\INSERTPIECE NEWPC (OR NEXTPC 'LASTPIECE) + TEXTOBJ NIL NIL (IMINUS (fetch (PIECE PLEN) of NEWPC)) + PC) + + (* ;; "update nextlink and prevlink") + + (COND + ((NULL NEXTPC) (* ; + "PC is last piece (not LASTPIECE)") + (* ; "NEWPC is new last piece.") + (replace (PIECE NEXTPIECE) of NEWPC with NIL)) + (T (replace (PIECE NEXTPIECE) of NEWPC with NEXTPC) + (replace (PIECE PREVPIECE) of NEXTPC with NEWPC))) + (replace (PIECE NEXTPIECE) of PC with NEWPC) + (replace (PIECE PREVPIECE) of NEWPC with PC)) + (* ; "Now set its starting CH#") + (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) + (* ; + "Whenever you split a piece, you can't add to it anymore.") + (RETURN NEWPC]) (\INSERT.FIRST.PIECE + [LAMBDA (TEXTOBJ) (* ; "Edited 31-May-91 14:00 by jds") + + (* ;; "Insert 1st piece to empty PCTB.") + + (PROG (PC) + (\INSERTPIECE [SETQ PC (\CREATEPIECEORSTREAM NIL (CHARLOOKS.FROM.FONT DEFAULTFONT) + (COND + (TEXTOBJ (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)) + (T (create FMTSPEC using TEDIT.DEFAULT.FMTSPEC + ] + NIL TEXTOBJ) + (replace (TEXTOBJ \INSERTPC) of TEXTOBJ with PC) + (replace (PIECE PSTR) of PC with (freplace (TEXTOBJ \INSERTSTRING) + of TEXTOBJ with (ALLOCSTRING 512]) ) (* ; "Generic-IO type operations support") (DEFINEQ (\TEXTCLOSEF + [LAMBDA (STREAM) (* ; "Edited 15-Apr-93 16:43 by jds") + (* ; + "Close the files underlying a stream") + (PROG ((TEXTOBJ (TEXTOBJ STREAM)) + PCTB PC) + (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + [OR (ZEROP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (COND + ((TYPE? PIECE (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB) + 0))) + (fetch (PIECE PFILE) of PC) + (CLOSEF? (fetch (PIECE PFILE) of PC)) + (SETQ PC (FETCH (PIECE NEXTPIECE) OF PC)) + (WHILE PC DO (AND (fetch (PIECE PFILE) of PC) + (CLOSEF? (fetch (PIECE PFILE) of PC))) + (SETQ PC (FETCH (PIECE NEXTPIECE) OF PC] + + (* ;; "And close the REAL file as well, in case we'd made a local cache.") + + (CLOSEF? (fetch (TEXTOBJ TXTFILE) of TEXTOBJ]) (\TEXTCLOSEF-SUBTREE + [LAMBDA (PCTREE) (* ; "Edited 31-May-91 14:00 by jds") + + (* ;; "Run thru the pieces in the document, closing the underlying file") + + (* ;; "by traverse pctree") + + (LET (PC) + (COND + ((NULL PCTREE) + NIL) + (T (SETQ PC (fetch (PCTNODE PCE) of PCTREE)) + (AND (NOT (ATOM PC)) + (fetch (PIECE PFILE) of PC) + (CLOSEF? (fetch (PIECE PFILE) of PC))) + (\TEXTCLOSEF-SUBTREE (fetch (PCTNODE LO) of PCTREE)) + (\TEXTCLOSEF-SUBTREE (fetch (PCTNODE HI) of PCTREE]) (\TEXTDSPFONT + [LAMBDA (STREAM NEWFONT) (* ; "Edited 31-May-91 14:02 by jds") + + (* ;; "Set the font for a TEdit window. Need change the caret looks, for character insertion, and the WINDOW's looks, so that TEXEC type-out to the window does the right thing.") + + (LET ((TEXTOBJ (TEXTOBJ STREAM))) + (PROG1 (fetch (CHARLOOKS CLFONT) of (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ)) + [COND + (NEWFONT + + (* ;; "Only do this if there's a new font to set:") + + (TEDIT.CARETLOOKS STREAM (\GETFONTDESC NEWFONT 'DISPLAY)) + (COND + ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + + (* ;; "Update the windows, if there are any.") + + (for WIN in (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) + do (DSPFONT NEWFONT WIN])]) (\TEXTEOFP + [LAMBDA (STREAM) (* ; "Edited 31-May-91 14:18 by jds") + + (* ;; "Test for EOF on a text stream: At end of a piece, and there's no more pieces.") + + (OR (NOT (fetch (TEXTSTREAM PIECE) of STREAM)) + (EQ (fetch (TEXTSTREAM PIECE) of STREAM) + 'LASTPIECE) + (AND (IEQP (fetch (STREAM COFFSET) of STREAM) + (fetch (STREAM CBUFSIZE) of STREAM)) + (ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM)) + (OR (NOT (fetch (PIECE NEXTPIECE) of (fetch (TEXTSTREAM PIECE) of STREAM + ))) + (bind (PC _ (fetch (PIECE NEXTPIECE) of (fetch (TEXTSTREAM PIECE) + of STREAM))) while + PC + do (COND + ((NOT (ZEROP (fetch (PIECE PLEN) of PC))) + (RETURN NIL))) + (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) finally (RETURN + T]) (\TEXTGETEOFPTR + [LAMBDA (STREAM) (* ; "Edited 31-May-91 13:58 by jds") + (fetch (TEXTOBJ TEXTLEN) of (fetch (TEXTSTREAM TEXTOBJ) of STREAM]) (\TEXTGETFILEPTR + [LAMBDA (STREAM) (* ; "Edited 28-Mar-94 15:32 by jds") + + (* ;; "GETFILEPTR fn for text streams.") + + (PROG ((PC (fetch (TEXTSTREAM PIECE) of STREAM)) + (CHARSLEFT (fetch (TEXTSTREAM CHARSLEFT) of STREAM)) + (OFFSET (fetch (STREAM COFFSET) of STREAM)) + (LIMIT (fetch (STREAM CBUFSIZE) of STREAM)) + PLEN) + (COND + ((EQ PC 'LASTPIECE) (* ; "STREAM is Empty Document") + (RETURN 0)) + [PC (* ; + "There's a piece. That means he's inside the file somewhere.") + (SETQ PLEN (fetch (PIECE PLEN) of PC)) + (RETURN (IMIN [SUB1 (IPLUS (\TEDIT.PIECE-CHNO PC) + (IDIFFERENCE PLEN CHARSLEFT) + (COND + ((fetch (TEXTSTREAM FATSTREAMP) of STREAM) + (* ; + "This is a 16-bit stream; The difference is in BYTES, and needs to be divided by 2 to get chars") + (IQUOTIENT (IDIFFERENCE OFFSET LIMIT) + 2)) + (T (IDIFFERENCE OFFSET LIMIT] + (fetch (TEXTOBJ TEXTLEN) of (fetch (TEXTSTREAM TEXTOBJ) + of STREAM] + (T (* ; + "Lack of a current piece means he walked off the end.") + (RETURN (IMAX 1 (fetch (TEXTOBJ TEXTLEN) of (fetch (TEXTSTREAM TEXTOBJ) + of STREAM]) (\TEXTOPENF + [LAMBDA (STREAM ACCESS ASDF QWER ZXCV) (* ; "Edited 31-May-91 13:58 by jds") + (* Return the stream, opened for + input) + (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) + PCTB PC) + (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) + (\TEXTOPENF-SUBTREE (fetch (PCTNODE HI) of PCTB)) + + (* ;; "(for I from (ADD1 \FirstPieceOffset) to (SUB1 (\EDITELT PCTB \PCTBLastPieceOffset)) by \EltsPerPiece do (SETQ PC (\EDITELT PCTB I)) (COND ((AND (fetch PFILE of PC) (EQ (fetch ACCESSBITS of (fetch PFILE of PC)) NoBits)) (\TEDIT.REOPEN.STREAM STREAM (fetch PFILE of PC)))))") + + (RETURN STREAM]) (\TEXTOPENF-SUBTREE + [LAMBDA (PCTREE) (* ; "Edited 31-May-91 14:19 by jds") + (LET (PC) + (COND + ((NULL PCTREE) + NIL) + (T (SETQ PC (fetch (PCTNODE PCE) of PCTREE)) + [COND + ((AND (fetch (PIECE PFILE) of PC) + (EQ (fetch (STREAM ACCESSBITS) of (fetch (PIECE PFILE) + of PC)) + NoBits)) + (\TEDIT.REOPEN.STREAM STREAM (fetch (PIECE PFILE) of PC] + (\TEXTOPENF-SUBTREE (fetch (PCTNODE LO) of PCTREE)) + (\TEXTOPENF-SUBTREE (fetch (PCTNODE HI) of PCTREE]) (\TEXTOUTCHARFN + [LAMBDA (CH STREAM) (* ; "Edited 31-May-91 13:59 by jds") + (\INSERTCH CH (fetch (TEXTOBJ TEXTLEN) of (fetch (TEXTSTREAM TEXTOBJ) + of STREAM)) + (fetch (TEXTSTREAM TEXTOBJ) of STREAM]) (\TEXTBACKFILEPTR + [LAMBDA (STREAM) (* ; "Edited 28-Mar-94 15:32 by jds") + + (* ;; "Use this to BACKFILEPTR a text stream.") + + [PROG (PC PS PF REALFILE) + (COND + [(AND (IEQP (fetch (STREAM CPAGE) of STREAM) + (fetch (TEXTSTREAM PCSTARTPG) of STREAM)) + (IEQP (fetch (STREAM COFFSET) of STREAM) + (fetch (TEXTSTREAM PCSTARTCH) of STREAM))) + (* ; + "Hit start of piece; back to PREVPIECE & keep going.") + [SETQ PC (replace (TEXTSTREAM PIECE) of STREAM + with (fetch (PIECE PREVPIECE) of (fetch (TEXTSTREAM PIECE) + of STREAM] + (* ; "Move to previous piece") + (replace (STREAM BINABLE) of STREAM with T) + (replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL) + (* add (fetch (TEXTSTREAM PCNO) of + STREAM) -1) + (while (AND PC (ZEROP (fetch (PIECE PLEN) of PC))) + do (* ; + "Skip over any zero-length pieces as we back along.") + (SETQ PC (fetch (PIECE PREVPIECE) of PC))) + (COND + [PC (replace (TEXTSTREAM CURRENTLOOKS) of STREAM + with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS) of PC) + PC + (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) + (COND + ((SETQ PS (fetch (PIECE PSTR) of PC)) + (* ; "This piece lives in a string.") + (\TEDIT.TEXTBIN.STRINGSETUP (SUB1 (fetch (PIECE PLEN) of PC)) + 1 STREAM PS) + + (* ;; "Set the stream up so that it will use PS for BINs, starting at offset 0 (the front of the piece), and will run for as many chars as there are in the piece.") + + ) + ((SETQ PF (fetch (PIECE PFILE) of PC)) + (* ; "This piece lives on a file.") + (\TEDIT.TEXTBIN.FILESETUP PC (SUB1 (fetch (PIECE PLEN) of PC)) + 1 STREAM PF (fetch (PIECE PFATP) of PC) + 'PEEKBIN)) + ((fetch (PIECE POBJ) of PC) + (replace (TEXTSTREAM CHARSLEFT) of STREAM with 0)) + (T (ERROR "CAN'T GET TO NEXT PIECE"] + (T (ERROR "Trying to BACKFILEPTR thru start of text."] + ((ZEROP (fetch (STREAM COFFSET) of STREAM)) + (* ; "Move back 1 file page") + (SETQ REALFILE (fetch (TEXTSTREAM REALFILE) of STREAM)) + (replace (TEXTSTREAM CHARSLEFT) of STREAM with (IPLUS (fetch + (TEXTSTREAM + CHARSLEFT) + of STREAM) + (fetch + (STREAM CBUFSIZE) + of STREAM))) + (replace (STREAM COFFSET) of REALFILE with 0) + (COND + ((fetch (TEXTSTREAM FATSTREAMP) of STREAM) + (* ; + "16 bit stream, so back up 2 bytes.") + (\BACKFILEPTR REALFILE) + (\BACKFILEPTR REALFILE)) + (T (\BACKFILEPTR REALFILE))) + (\PEEKBIN REALFILE) + (replace (STREAM CPAGE) of STREAM with (fetch (STREAM CPAGE) + of REALFILE)) + (replace (STREAM COFFSET) of STREAM with (fetch (STREAM COFFSET) + of REALFILE)) + (replace (STREAM CBUFSIZE) of STREAM with (fetch (STREAM CBUFSIZE) + of REALFILE)) + (replace (STREAM CPPTR) of STREAM with (fetch (STREAM CPPTR) + of REALFILE))) + (T (* ; "JUST ACT CASUAL & DO IT.") + (COND + ((fetch (TEXTSTREAM FATSTREAMP) of STREAM) + (* ; + "16 bit stream, so back up 2 bytes.") + (\PAGEDBACKFILEPTR STREAM) + (\PAGEDBACKFILEPTR STREAM)) + (T (\PAGEDBACKFILEPTR STREAM] + T]) (\TEXTBOUT + [LAMBDA (STREAM BYTE) (* ; "Edited 10-May-93 16:59 by jds") + (* ; + "Do BOUT to a text stream, which is an insertion at the caret.") + (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)) + (CH# (ADD1 (\TEXTGETFILEPTR STREAM))) + WINDOW TEXTLEN PS PC PSTR OFFST) + (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (SETQ WINDOW (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)) + (AND WINDOW (\TEDIT.MARK.LINES.DIRTY TEXTOBJ CH# CH#)) + (\INSERTCH BYTE CH# TEXTOBJ) + (AND WINDOW (TEDIT.UPDATE.SCREEN TEXTOBJ)) + (AND (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ) + (RETURN)) (* ; + "If teh stream is readonly, nothing happened!") + [SETQ PS (ffetch (PIECE PSTR) of (SETQ PC (fetch (TEXTOBJ \INSERTPC) + of TEXTOBJ] + (* ; "This piece resides in a STRING.") + (replace (TEXTSTREAM PIECE) of STREAM with PC) + (freplace (STREAM CPPTR) of STREAM with (ADDBASE (ffetch (STRINGP BASE) + of PS) + (LRSH (SETQ OFFST + (ffetch (STRINGP + OFFST) + of PS)) + 1))) + (freplace (STREAM CPAGE) of STREAM with 0) + (freplace (STREAM COFFSET) of STREAM with (IPLUS (freplace (TEXTSTREAM + PCSTARTCH) + of STREAM + with (LOGAND 1 OFFST)) + (fetch (TEXTOBJ \INSERTLEN + ) + of TEXTOBJ))) + (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0) + (* ; + "Page # within the 'file' where this piece starts") + (freplace (STREAM CBUFSIZE) of STREAM with (fetch (STREAM COFFSET) + of STREAM)) + (freplace (STREAM EPAGE) of STREAM with 1) + (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 0) + (freplace (TEXTSTREAM REALFILE) of STREAM with NIL]) (\TEDITOUTCHARFN + [LAMBDA (STREAM CHARCODE) (* ; "Edited 31-May-91 14:19 by jds") + + (* ;; "OUTCHARFN for TEdit streams -- always BOUTs the character, because TEdit streams deal in complete charcodes rather than bytes. BUT -- does update the CHARPOSITION of the stream, which is used by some code to decide things.") + + (COND + ((EQ CHARCODE (CHARCODE EOL)) + (\BOUT STREAM (CHARCODE CR)) + (freplace (STREAM CHARPOSITION) of STREAM with 0)) + (T (\BOUT STREAM CHARCODE) + (freplace (STREAM CHARPOSITION) of STREAM with + (PROGN + (* ; "Ugh. Don't overflow") + (IPLUS16 (ffetch (STREAM + CHARPOSITION + ) + of STREAM) + 1]) (\TEXTSETEOF + [LAMBDA (STREAM EOFPTR) (* ; "Edited 31-May-91 14:19 by jds") + (* Set the EPAGE/EOFFSET of the + stream to be (SUB1 of EOFPTR)) + (replace (STREAM EPAGE) of STREAM with (fetch (BYTEPTR PAGE) of EOFPTR)) + (replace (STREAM EOFFSET) of STREAM with (fetch (BYTEPTR OFFSET) of EOFPTR]) (\TEXTSETFILEPTR + [LAMBDA (STREAM FILEPOS) (* ; "Edited 22-Apr-93 13:44 by jds") + (* ; + "Sets the file ptr for a text stream.") + (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))) + (COND + ((ZEROP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) + ((OR (IEQP FILEPOS -1) + (IEQP FILEPOS (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) + (* ; "Means end of file") + (\SETUPGETCH (IMAX 1 (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + TEXTOBJ) + (\BIN STREAM)) + ((OR (ILESSP FILEPOS 0) + (IGREATERP FILEPOS (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))) + (* ; + "If the fileptr is not within the text, punt.") + (\ILLEGAL.ARG FILEPOS)) + (T (\SETUPGETCH (IMAX 1 (ADD1 FILEPOS)) + TEXTOBJ]) (\TEXTDSPXPOSITION [LAMBDA (STREAM XPOSITION) (* ; "Edited 3-Jan-2001 17:27 by rmk:") (* ;  "Edited 24-Oct-88 23:09 by rmk:; Edited 26-Sep-85 16:30 by ajb:") (* ;; "Simply returns the XPOSITION of the primary window's display stream, this is a read-only function") (LET [(WINDOW (CAR (fetch \WINDOW of (TEXTOBJ STREAM] (COND (WINDOW (DSPXPOSITION NIL WINDOW)) (T (* ;  "If there is no window, estimate from character position") (TIMES (CHARWIDTH (CHARCODE SPACE) STREAM) (POSITION STREAM]) (\TEXTDSPYPOSITION + [LAMBDA (STREAM YPOSITION) (* ; "Edited 31-May-91 13:59 by jds") + + (* Simply returns the XPOSITION of the primary window's display stream, this is + a read-only function) + + (LET [(WINDOW (CAR (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ STREAM] + (IF WINDOW + THEN (DSPYPOSITION NIL WINDOW) + ELSE (AND \#DISPLAYLINES (NEQ \CURRENTDISPLAYLINE -1) + (DIFFERENCE \#DISPLAYLINES \CURRENTDISPLAYLINE]) (\TEXTLEFTMARGIN + [LAMBDA (STREAM XPOSITION) (* ; "Edited 31-May-91 14:03 by jds") + +(* ;;; "Returns the left margin of the textstream. This is a read-only function") + + (IF (CAR (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ STREAM))) + THEN [IPLUS 8 (fetch (FMTSPEC LEFTMAR) of (fetch (TEXTOBJ FMTSPEC) + of (TEXTOBJ STREAM] + ELSE 0]) (\TEXTRIGHTMARGIN [LAMBDA (STREAM XPOSITION) (* ; "Edited 31-May-91 14:03 by jds") (* ;;; "Returns the right margin of the textstream. This is a read-only function") (LET ((TEXTOBJ (TEXTOBJ STREAM))) (IF (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) THEN (LET [(RIGHTMAR (fetch (FMTSPEC RIGHTMAR) of (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ] (IF (ZEROP RIGHTMAR) THEN (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) ELSE RIGHTMAR)) ELSE (TIMES (CHARWIDTH (CHARCODE A) STREAM) (LINELENGTH NIL STREAM]) (\TEXTDSPCHARWIDTH [LAMBDA (STREAM CHARCODE) (* ;  "Edited 9-Feb-99 12:59 by kaplan") (CHARWIDTH CHARCODE (DSPFONT NIL STREAM]) (\TEXTDSPSTRINGWIDTH [LAMBDA (STREAM STRING) (* ;  "Edited 9-Feb-99 13:00 by kaplan") (STRINGWIDTH STRING (DSPFONT NIL STREAM]) (\TEXTDSPLINEFEED + [LAMBDA (STREAM VALUE) + (FONTPROP (DSPFONT NIL STREAM) + 'HEIGHT]) ) (DEFINEQ (\TEXTBIN + [LAMBDA (STREAM) (* ; "Edited 28-Mar-94 15:33 by jds") + +(* ;;; "Do BIN slow case for a text stream") + (* ; + "NB that PEEKBIN and BACKFILEPTR need to track changes in this code") + (DECLARE (LOCALVARS . T)) + (PROG (CH FILE STR PF PS PC PO NPC OPC SUBSTREAM) + (COND + [(ILESSP (fetch (STREAM COFFSET) of STREAM) + (fetch (STREAM CBUFSIZE) of STREAM)) + (* ; + "Simple case -- just do the usual BIN") + (COND + [(SETQ PO (fetch (PIECE POBJ) of (fetch (TEXTSTREAM PIECE) of STREAM + ))) + (* ; "Handle objects specially") + (COND + ((SETQ SUBSTREAM (IMAGEOBJPROP PO 'SUBSTREAM)) + (* ; + "If this object has a substream in it, go to that substream") + (add (fetch (STREAM COFFSET) of STREAM) + 1) + (RETURN (\BIN SUBSTREAM))) + (T + (* ;; "Otherwise, just return the object as BIN's result, and make sure we'll go to the next page next time.") + + (replace (STREAM COFFSET) of STREAM with (fetch (STREAM + CBUFSIZE) + of STREAM)) + (replace (TEXTSTREAM CHARSLEFT) of STREAM with 0) + (RETURN PO] + [(fetch (TEXTSTREAM FATSTREAMP) of STREAM) + (* ; + "This is a 16 bit BIN. grab 2 bytes.") + (* ; + "WHAT HAPPENS IF THE SECOND BYTE IS ON ANOTHER PAGE??") + (RETURN (LOGOR (UNFOLD (\PAGEDBIN STREAM) + 256) + (COND + ((ILESSP (fetch (STREAM COFFSET) of STREAM) + (fetch (STREAM CBUFSIZE) of STREAM)) + (* ; + "This pair of characters doesn't straddle a file page bound. Just grab the next char.") + (\PAGEDBIN STREAM)) + (T (* ; + "Need to move to the next page on the backing file. Doing so also grabs the next character.") + (\TEDIT.TEXTBIN.NEW.PAGE STREAM T] + (T (RETURN (\PAGEDBIN STREAM] + (T (* ; + "We've either hit a page bound in a file, or a piece bound.") + (RETURN (COND + [(ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM)) + (* ; "Time for a new piece.") + [repeatwhile (AND PC (ZEROP (fetch (PIECE PLEN) of PC))) + do (* ; + "Skip over any zero-length pieces at the end of the file.") + (SETQ OPC (fetch (TEXTSTREAM PIECE) of STREAM)) + (SETQ PC (replace (TEXTSTREAM PIECE) of STREAM + with (AND OPC (fetch (PIECE NEXTPIECE) + of OPC] + (replace (STREAM BINABLE) of STREAM with T) + (replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL) + (* ; + "Move to the next piece in the chain") + (COND + [PC (* ; + "There IS a next piece to move to.") + (AND (fetch (TEXTSTREAM LOOKSUPDATEFN) of STREAM) + (SETQ NPC (APPLY* (fetch (TEXTSTREAM LOOKSUPDATEFN) + of STREAM) + STREAM PC)) + (replace (TEXTSTREAM PIECE) of STREAM + with (SETQ PC NPC))) + (* ; + "Take care of any piece-change uproar. uproar -- which may include picking a new piece to go to.") + [COND + (NPC (* ; + "If we got an NPC, this was taken care of by the LOOKSUPDATEFN") + ) + ([AND (SETQ PO (fetch (PIECE POBJ) of PC)) + (SETQ SUBSTREAM (IMAGEOBJPROP PO 'SUBSTREAM] + (\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ) + of SUBSTREAM)) + (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM + with (fetch (TEXTSTREAM CURRENTPARALOOKS) + of SUBSTREAM)) + (replace (TEXTSTREAM CURRENTLOOKS) of STREAM + with (fetch (TEXTSTREAM CURRENTLOOKS) of + SUBSTREAM + ))) + [(NEQ (fetch (PIECE PPARALOOKS) of OPC) + (fetch (PIECE PPARALOOKS) of PC)) + (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM + with (\TEDIT.APPLY.PARASTYLES (fetch (PIECE + PPARALOOKS + ) + of PC) + PC + (fetch (TEXTSTREAM TEXTOBJ) + of STREAM))) + (replace (TEXTSTREAM CURRENTLOOKS) of STREAM + with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS) + of PC) + PC + (fetch (TEXTSTREAM TEXTOBJ) + of STREAM] + ((NOT (EQCLOOKS (fetch (PIECE PLOOKS) of PC) + (fetch (PIECE PLOOKS) of OPC))) + (replace (TEXTSTREAM CURRENTLOOKS) of STREAM + with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS) + of PC) + PC + (fetch (TEXTSTREAM TEXTOBJ) + of STREAM] + (COND + ((SETQ PS (fetch (PIECE PSTR) of PC)) + (* ; "This piece lives in a string.") + (\TEDIT.TEXTBIN.STRINGSETUP 0 (fetch (PIECE PLEN) + of PC) + STREAM PS) + + (* ;; "Set the stream up so that it will use PS for BINs, starting at offset 0 (the front of the piece), and will run for as many chars as there are in the piece.") + (* ; + "Then actually grab the next character to hand back to the caller.") + (\BIN STREAM)) + ((SETQ PF (fetch (PIECE PFILE) of PC)) + (* ; "This piece lives on a file.") + (\TEDIT.TEXTBIN.FILESETUP PC 0 (fetch (PIECE PLEN) + of PC) + STREAM PF (fetch (PIECE PFATP) of PC) + 'PEEKBIN) + (\BIN STREAM)) + [(SETQ PO (fetch (PIECE POBJ) of PC)) + (replace (STREAM BINABLE) of STREAM with NIL) + (COND + (SUBSTREAM (* ; + "There is a stream below this one, to feed chars upward.") + (\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ) + of SUBSTREAM)) + (freplace (STREAM COFFSET) of STREAM + with 0) + (freplace (TEXTSTREAM CHARSLEFT) of STREAM + with (fetch (PIECE PLEN) of PC)) + (freplace (STREAM CBUFSIZE) of STREAM + with (fetch (PIECE PLEN) of PC)) + (freplace (STREAM CPAGE) of STREAM + with 0) + (freplace (TEXTSTREAM PCSTARTCH) of STREAM + with 0) + (freplace (TEXTSTREAM PCSTARTPG) of STREAM + with 0) + (replace (TEXTSTREAM CURRENTPARALOOKS) + of STREAM with (fetch (TEXTSTREAM + + CURRENTPARALOOKS + ) of + SUBSTREAM)) + (replace (TEXTSTREAM CURRENTLOOKS) of STREAM + with (fetch (TEXTSTREAM CURRENTLOOKS) + of SUBSTREAM)) + (RETURN (\BIN SUBSTREAM))) + (T (replace (TEXTSTREAM CHARSLEFT) of STREAM + with 0) + (RETURN PO] + (T (ERROR "CAN'T GET TO NEXT PIECE"] + (T (* ; + "There are no more pieces. Punt gracefully") + (COND + ((fetch (STREAM ENDOFSTREAMOP) of STREAM) + (* ; + "If there's an EOF handler, call it & return the result") + (RETURN (APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM + ) + STREAM))) + (T (* ; "Otherwise, return NIL") + (RETURN NIL] + [(SETQ PO (fetch (PIECE POBJ) of (fetch (TEXTSTREAM PIECE) + of STREAM))) + (* ; "This is an object") + (replace (STREAM BINABLE) of STREAM with NIL) + (COND + (SUBSTREAM (* ; + "There is a stream below this one, to feed chars upward.") + (\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ) of + SUBSTREAM)) + (freplace (STREAM COFFSET) of STREAM with 1) + (freplace (TEXTSTREAM CHARSLEFT) of STREAM with + 0) + (freplace (STREAM CBUFSIZE) of STREAM + with (fetch (PIECE PLEN) of PC)) + (freplace (STREAM CPAGE) of STREAM with 0) + (freplace (TEXTSTREAM PCSTARTCH) of STREAM with + 1) + (freplace (TEXTSTREAM PCSTARTPG) of STREAM with + 0) + (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM + with (fetch (TEXTSTREAM CURRENTPARALOOKS) + of SUBSTREAM)) + (replace (TEXTSTREAM CURRENTLOOKS) of STREAM + with (fetch (TEXTSTREAM CURRENTLOOKS) of + SUBSTREAM + )) + (RETURN (\BIN SUBSTREAM))) + (T (replace (TEXTSTREAM CHARSLEFT) of STREAM with 0) + (RETURN PO] + (T (* ; + "Need to move to the next page in a file.") + (RETURN (\TEDIT.TEXTBIN.NEW.PAGE STREAM]) (\TEDIT.TEXTBIN.STRINGSETUP + [LAMBDA (CHOFFSET CHARSLEFT STREAM PS) (* ; "Edited 31-May-91 14:21 by jds") + (PROG (OFFST) + (COND + ((fetch (STRINGP FATSTRINGP) of PS) + + (* The string is FAT. Therefore, make all the offsets and things take account + of the fact that each char is really 2 bytes.) + + (freplace (STREAM CPPTR) of STREAM with (ADDBASE (ffetch (STRINGP + BASE) + of PS) + (ffetch (STRINGP OFFST) + of PS))) + + (* The char page ptr can point to the real first char, since it's a word.) + + (freplace (STREAM CPAGE) of STREAM with 0) + (freplace (STREAM COFFSET) of STREAM with (UNFOLD CHOFFSET 2)) + (* Offset into the string, in bytes. + That 2 should really be something + like BYTESPERFATCHAR.) + (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0) + (* Page %# within the "file" where + this piece starts) + (freplace (TEXTSTREAM PCSTARTCH) of STREAM with 0) + (* Char within "page" where the + piece starts (for BACKFILEPTR)) + (freplace (STREAM CBUFSIZE) of STREAM with (IPLUS (UNFOLD CHARSLEFT 2) + (ffetch (STREAM + COFFSET) + of STREAM))) + (* Since the chars-left field is + words, and we're talking bytes.) + (freplace (STREAM EPAGE) of STREAM with 1) + (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 0) + + (* When we hit the end of the string, we'll have run out off the piece, too.) + + (freplace (TEXTSTREAM REALFILE) of STREAM with NIL) + (replace (STREAM BINABLE) of STREAM with NIL) + (* To force BINs thru the \TEXTBIN + function so we can get two bytes.) + (replace (TEXTSTREAM FATSTREAMP) of STREAM with T) + (* And mark the stream as having + wide characters, so \TEXTBIN knows + what to do.) + ) + (T (* Characters are thin in this + string (the usual case)) + (freplace (STREAM CPPTR) of STREAM with + (ADDBASE (ffetch (STRINGP BASE) + of PS) + (LRSH (SETQ OFFST + (ffetch (STRINGP OFFST) + of PS)) + 1))) + (freplace (STREAM CPAGE) of STREAM with 0) + (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0) + (* Page %# within the "file" where + this piece starts) + (freplace (TEXTSTREAM PCSTARTCH) of STREAM with (LOGAND 1 OFFST)) + (* Char within "page" where the + piece starts (for BACKFILEPTR)) + (freplace (STREAM COFFSET) of STREAM with (IPLUS (LOGAND 1 OFFST) + CHOFFSET)) + (freplace (STREAM CBUFSIZE) of STREAM with (IPLUS CHARSLEFT + (ffetch + (STREAM COFFSET) + of STREAM))) + (freplace (STREAM EPAGE) of STREAM with 1) + (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 0) + (freplace (TEXTSTREAM REALFILE) of STREAM with NIL) + (replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL]) (\TEDIT.TEXTBIN.FILESETUP [LAMBDA (PC CHOFFSET CHARSLEFT STREAM PF FATP OPERATION NOERRORFLG) (* ; "Edited 8-Jun-99 23:37 by rmk:") (* ; "Edited 8-Jun-99 23:33 by rmk:") (* ; "Edited 8-Jun-99 23:32 by rmk:") (* ; "Edited 15-Apr-93 15:53 by jds") (* ;  "Do the setup needed to make a text stream read from a file.") (PROG ((BYTESLEFT (COND (FATP (UNFOLD CHARSLEFT 2)) (T CHARSLEFT))) (BYTEOFFSET (COND (FATP (UNFOLD CHOFFSET 2)) (T CHOFFSET))) CH FPOS) [COND ((IEQP (ffetch (STREAM ACCESSBITS) of PF) NoBits) (* ; "ASSURE THAT THE FILE IS OPEN") (SETQ PF (\TEDIT.REOPEN.STREAM STREAM PF] [freplace (TEXTSTREAM PCSTARTPG) of STREAM with (ffetch (BYTEPTR PAGE) of (SETQ FPOS (ffetch (PIECE PFPOS) of PC] (* ;  "Page within the file where the piece starts") (freplace (TEXTSTREAM PCSTARTCH) of STREAM with (ffetch (BYTEPTR OFFSET) of FPOS)) (* ;  "Char within the page where it starts.") (SETFILEPTR PF (IPLUS FPOS BYTEOFFSET)) [COND ((ZEROP (GETEOFPTR PF)) (* ;  "For zero-length files, do nothing.") ) ((ILESSP (IPLUS FPOS BYTEOFFSET) (GETEOFPTR PF)) (* ;  "Only get the next character if we aren't positioning past the end of the file.") (SETQ CH (IF (EQ OPERATION 'BIN) THEN (CL:IF FATP (LOGOR (UNFOLD (\PAGEDBIN PF) 256) (\PAGEDPEEKBIN PF NOERRORFLG)) (\BIN PF)) ELSE (CL:IF FATP (PROG1 (LOGOR (UNFOLD (\PAGEDBIN PF) 256) (\PAGEDPEEKBIN PF NOERRORFLG)) (\PAGEDBACKFILEPTR PF)) (\PEEKBIN PF NOERRORFLG))] (* ;;; "Move all the relevant fields from the backing file's stream into the text stream, so that microcoded BINs will do the right thing.") (freplace (STREAM CPPTR) of STREAM with (ffetch (STREAM CPPTR) of PF)) (freplace (STREAM CPAGE) of STREAM with (ffetch (STREAM CPAGE) of PF)) (freplace (STREAM COFFSET) of STREAM with (ffetch (STREAM COFFSET) of PF)) (freplace (STREAM EPAGE) of STREAM with 32767) (freplace (STREAM CBUFSIZE) of STREAM with (IMIN (ffetch (STREAM CBUFSIZE) of PF) (IPLUS (ffetch (STREAM COFFSET) of PF) BYTESLEFT))) [freplace (TEXTSTREAM CHARSLEFT) of STREAM with (IDIFFERENCE BYTESLEFT (IDIFFERENCE (ffetch (STREAM CBUFSIZE) of STREAM) (ffetch (STREAM COFFSET ) of STREAM] (freplace (TEXTSTREAM REALFILE) of STREAM with PF) (replace (TEXTSTREAM FATSTREAMP) of STREAM with FATP) (* ;  "Mark the stream, if it contains fat characters for this piece.") (replace (STREAM BINABLE) of STREAM with (NOT FATP)) (* ;  "A stream that has fat chars can't use the micrododed BIN.") (* ;  "And return the next character in line") (RETURN CH]) (\TEDIT.TEXTBIN.NEW.PAGE [LAMBDA (STREAM SPLITCHAR) (* ; "Edited 11-Jun-99 15:10 by rmk:") (* ; "Edited 11-Jun-99 15:10 by rmk:") (* ; "Edited 11-Jun-99 15:01 by rmk:") (* ; "Edited 11-Jun-99 15:01 by rmk:") (* ; "Edited 11-Jun-99 14:18 by rmk:") (* ; "Edited 31-May-91 14:21 by jds") (* * Handle crossing a file-page boundary within TEXTBIN) (* If SPLITCHAR is non-NIL, we've already read the first byte of a two-byte  character, and only need to read the second byte.  Otherwise, this function will read 2 bytes for a fat character.) (PROG ((FILE (fetch (TEXTSTREAM REALFILE) of STREAM)) CH) (* Get the STREAM which describes  the file for real) [COND ((IEQP (fetch (STREAM ACCESSBITS) of FILE) NoBits) (* The file was closed for some  reason; reopen it.) (SETQ FILE (\GETSTREAM [OPENFILE (fetch (STREAM FULLNAME) of FILE) 'INPUT NIL '((TYPE TEXT] 'INPUT] (replace (STREAM COFFSET) of FILE with (fetch (STREAM CBUFSIZE) of FILE)) (* Force it to do a page switch for  us) (SETQ CH (\BIN FILE)) (* Get the next character in the  usual manner) (replace (STREAM CPPTR) of STREAM with (fetch (STREAM CPPTR) of FILE)) (* Steal the fields we need to  simulate that stream) (replace (STREAM COFFSET) of STREAM with (fetch (STREAM COFFSET) of FILE)) (replace (STREAM CPAGE) of STREAM with (fetch (STREAM CPAGE) of FILE)) (replace (STREAM CBUFSIZE) of STREAM with (IMIN (fetch (TEXTSTREAM CHARSLEFT) of STREAM) (fetch (STREAM CBUFSIZE) of FILE))) (* Can't read farther than  end-of-piece, tho) (replace (TEXTSTREAM CHARSLEFT) of STREAM with (IDIFFERENCE (fetch (TEXTSTREAM CHARSLEFT) of STREAM) (fetch (STREAM CBUFSIZE ) of STREAM))) (COND [(AND (fetch (TEXTSTREAM FATSTREAMP) of STREAM) (NOT SPLITCHAR)) (* This piece contains fat characters. Need to grab a second byte from the  file, and construct a 16-bit character) (RETURN (LOGOR (UNFOLD CH 256) (\PAGEDBIN STREAM] (T (* Regular, 8-bit characters.  Just return the one we BINned.) (* or we only need the second byte, since the first byte was on the prior page.) (RETURN CH]) ) (DEFINEQ (\TEXTPEEKBIN + [LAMBDA (STREAM NOERRORFLG) (* ; "Edited 28-Mar-94 15:34 by jds") + (* ; "DO PEEKBIN for a text stream") + (PROG (CH FILE STR PF PS PC PO SUBSTREAM) + (SETQ PC (fetch (TEXTSTREAM PIECE) of STREAM)) + (COND + [(ILESSP (fetch (STREAM COFFSET) of STREAM) + (fetch (STREAM CBUFSIZE) of STREAM)) + (* ; + "Simple case -- just do the usual PEEKBIN") + (COND + ((AND PC (fetch (PIECE POBJ) of PC)) + (RETURN (fetch (PIECE POBJ) of PC))) + [(fetch (TEXTSTREAM FATSTREAMP) of STREAM) + (* ; + "This is a 16 bit PEEKBIN. Grab two chars...") + (RETURN (COND + [(\EOFP STREAM) + (COND + (NOERRORFLG NIL) + (T (\PEEKBIN STREAM] + ((ILESSP (fetch (STREAM COFFSET) of STREAM) + (SUB1 (fetch (STREAM CBUFSIZE) of STREAM))) + (* ; + "We're sure of staying on the same page. Just grab the characters") + (PROG1 (LOGOR (UNFOLD (\PAGEDBIN STREAM) + 256) + (\PAGEDPEEKBIN STREAM NOERRORFLG)) + (\PAGEDBACKFILEPTR STREAM))) + (T (SETQ PS (fetch (STREAM F1) of STREAM)) + (replace (STREAM COFFSET) of PS with (fetch + (STREAM COFFSET) + of STREAM)) + (PROG1 (LOGOR (UNFOLD (\PAGEDBIN PS) + 256) + (\PAGEDPEEKBIN PS NOERRORFLG)) + (\PAGEDBACKFILEPTR PS] + (T (RETURN (\PAGEDPEEKBIN STREAM NOERRORFLG] + [PC (* ; + "We've either hit a page bound in a file, or a piece bound.") + (RETURN (COND + [(ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM)) + (* ; "Time for a new piece.") + (SETQ PC (replace (TEXTSTREAM PIECE) of STREAM + with (fetch (PIECE NEXTPIECE) of PC))) + (* ; + "Move to the next piece in the chain") + (COND + [PC (replace (TEXTSTREAM CURRENTLOOKS) of STREAM + with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS) + of PC) + PC + (fetch (TEXTSTREAM TEXTOBJ) of STREAM) + )) + (COND + [(SETQ PO (fetch (PIECE POBJ) of PC)) + (replace (STREAM BINABLE) of STREAM with NIL) + (freplace (STREAM CBUFSIZE) of STREAM + with (fetch (PIECE PLEN) of PC)) + (freplace (STREAM COFFSET) of STREAM with 0) + (COND + (SUBSTREAM (* ; + "There is a stream below this one, to feed chars upward.") + (\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ) + of SUBSTREAM)) + (freplace (TEXTSTREAM CHARSLEFT) of STREAM + with (fetch (PIECE PLEN) of PC)) + (freplace (STREAM CPAGE) of STREAM + with 0) + (freplace (TEXTSTREAM PCSTARTCH) of STREAM + with 0) + (freplace (TEXTSTREAM PCSTARTPG) of STREAM + with 0) + (replace (TEXTSTREAM CURRENTPARALOOKS) + of STREAM with (fetch (TEXTSTREAM + + CURRENTPARALOOKS + ) + of SUBSTREAM)) + (replace (TEXTSTREAM CURRENTLOOKS) of + STREAM + with (fetch (TEXTSTREAM CURRENTLOOKS) + of SUBSTREAM)) + (RETURN (\BIN SUBSTREAM))) + (T (replace (TEXTSTREAM CHARSLEFT) of STREAM + with 0) + (RETURN PO] + ((SETQ PS (fetch (PIECE PSTR) of PC)) + (* ; "This piece lives in a string.") + (\TEDIT.TEXTBIN.STRINGSETUP 0 (fetch (PIECE PLEN) + of PC) + STREAM PS) + + (* ;; "Set the stream up so that it will use PS for BINs, starting at offset 0 (the front of the piece), and will run for as many chars as there are in the piece.") + + (\PEEKBIN STREAM NOERRORFLG)) + ((SETQ PF (fetch (PIECE PFILE) of PC)) + (* ; "This piece lives on a file.") + (\TEDIT.TEXTBIN.FILESETUP PC 0 (fetch (PIECE PLEN) + of PC) + STREAM PF (fetch (PIECE PFATP) of PC) + 'PEEKBIN NOERRORFLG)) + (T (ERROR "CAN'T GET TO NEXT PIECE"] + (NOERRORFLG (* ; + "There are no more pieces. Punt gracefully") + (RETURN NIL)) + (T (* ; "He wants it the hard way.") + (APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM) + STREAM] + (T (* ; + "Need to move to the next page in a file.") + (RETURN (\TEDIT.PEEKBIN.NEW.PAGE STREAM NOERRORFLG] + (NOERRORFLG (* ; + "There are no more pieces. Punt gracefully") + (RETURN NIL)) + (T (* ; "He wants it the hard way.") + (APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM) + STREAM]) (\TEDIT.PEEKBIN.NEW.PAGE [LAMBDA (STREAM NOERRORFLG) (* ; "Edited 11-Jun-99 15:11 by rmk:") (* ; "Edited 31-May-91 14:21 by jds") (* * Handle crossing a file-page boundary within \TEXTPEEKBIN) (* If SPLITCHAR is non-NIL, we've already read the first byte of a two-byte  character, and only need to read the second byte.  Otherwise, this function will read 2 bytes for a fat character.) (PROG ((FILE (fetch (TEXTSTREAM REALFILE) of STREAM)) CH) (* Get the STREAM which describes  the file for real) [COND ((IEQP (fetch (STREAM ACCESSBITS) of FILE) NoBits) (* The file was closed for some  reason; reopen it.) (SETQ FILE (\GETSTREAM [OPENFILE (fetch (STREAM FULLNAME) of FILE) 'INPUT NIL '((TYPE TEXT] 'INPUT] (replace (STREAM COFFSET) of FILE with (fetch (STREAM CBUFSIZE) of FILE)) (* Force it to do a page switch for  us) [SETQ CH (COND [(\EOFP FILE) (COND (NOERRORFLG NIL) (T (\PEEKBIN FILE] ((fetch (TEXTSTREAM FATSTREAMP) of STREAM) (PROG1 (LOGOR (UNFOLD (\PAGEDBIN FILE) 256) (\PAGEDPEEKBIN FILE NOERRORFLG)) (\PAGEDBACKFILEPTR FILE))) (T (\PEEKBIN FILE NOERRORFLG] (* Get the next character in the  usual manner) (replace (STREAM CPPTR) of STREAM with (fetch (STREAM CPPTR) of FILE)) (* Steal the fields we need to  simulate that stream) (replace (STREAM COFFSET) of STREAM with (fetch (STREAM COFFSET) of FILE)) (replace (STREAM CPAGE) of STREAM with (fetch (STREAM CPAGE) of FILE)) (replace (STREAM CBUFSIZE) of STREAM with (IMIN (fetch (TEXTSTREAM CHARSLEFT) of STREAM) (fetch (STREAM CBUFSIZE) of FILE))) (* Can't read farther than  end-of-piece, tho) (replace (TEXTSTREAM CHARSLEFT) of STREAM with (IDIFFERENCE (fetch (TEXTSTREAM CHARSLEFT) of STREAM) (fetch (STREAM CBUFSIZE ) of STREAM))) (RETURN CH]) ) (* ; "Support for TEXTPROP") (DEFINEQ (CGETTEXTPROP + [LAMBDA (TEXTOBJ PROP) (* ; "Edited 20-Oct-87 12:36 by jds") + + (* ;; "compiles calls on TEXTPROP that are fetching values. This needs to be changed whenever GETTEXTPROP is changed.") + + (SELECTQ PROP + ((READONLY READ-ONLY) + `(fetch (TEXTOBJ TXTREADONLY) of ,TEXTOBJ)) + `(LISTGET (fetch (TEXTOBJ EDITPROPS) of ,TEXTOBJ) + ',PROP]) (CTEXTPROP + [LAMBDA (FORMTAIL) (* ; "Edited 31-May-91 13:59 by jds") + + (* ;; "compiles calls to TEXTPROP") + + (COND + ((NULL (CDR FORMTAIL)) (* ; "less that 2 args") + (printout T "Possible error in call to TEXTPROP: less than 2 args" T (LIST 'TEXTPROP FORMTAIL + ) + T) + (CGETTEXTPROP (LIST 'TEXTOBJ (CAR FORMTAIL)) + NIL)) + ((NOT (EQ (CAADR FORMTAIL) + 'QUOTE)) (* ; "property is not quoted.") + 'IGNOREMACRO) + [(NULL (CDDR FORMTAIL)) (* ; "fetching a TEXTPROP property.") + (CGETTEXTPROP (LIST 'TEXTOBJ (CAR FORMTAIL)) + (CADR (CADR FORMTAIL] + (T (* ; "storing a window property") + (LET ((TEXTOBJ (CAR FORMTAIL)) + (PROP (CDADR FORMTAIL)) + (VAL (CADDR FORMTAIL))) + [SELECTQ PROP + ((READONLY READ-ONLY) + `(REPLACE (TEXTOBJ TXTREADONLY) OF ,TEXTOBJ WITH ,VAL)) + `(COND + [(FETCH (TEXTOBJ EDITPROPS) OF (TEXTOBJ ,TEXTOBJ)) + (LISTPUT (FETCH (TEXTOBJ EDITPROPS) OF (TEXTOBJ ,TEXTOBJ)) + ',PROP + ',VAL] + (T (REPLACE (TEXTOBJ EDITPROPS) OF (TEXTOBJ ,TEXTOBJ) + WITH (LIST ,PROP ,VAL] + (LIST 'COND (LIST (LIST 'FETCH 'EDITPROPS 'OF (LIST 'TEXTOBJ (CAR FORMTAIL))) + (LIST 'LISTPUT (LIST 'FETCH 'EDITPROPS 'OF (LIST 'TEXTOBJ + (CAR FORMTAIL))) + (CADR FORMTAIL) + (CADDR FORMTAIL))) + (LIST T (LIST 'REPLACE 'EDITPROPS 'OF (LIST 'TEXTOBJ (CAR FORMTAIL)) + 'WITH + (LIST 'LIST (CADR FORMTAIL) + (CADDR FORMTAIL]) (GETTEXTPROP + [LAMBDA (TEXTOBJ PROP) (* ; "Edited 9-Feb-89 11:20 by jds") + + (* ;; "Gets values for document properties. Used by TEXTPROP.") + + (SELECTQ PROP + ((READONLY READ-ONLY) + (FETCH (TEXTOBJ TXTREADONLY) OF TEXTOBJ)) + ((BEING-EDITED ACTIVE) + (FETCH (TEXTOBJ TXTEDITING) OF TEXTOBJ)) + ((NO-NS-CHARS NONSCHARS NO-NSCHARS) + (FETCH (TEXTOBJ TXTNONSCHARS) OF TEXTOBJ)) + (LISTGET (fetch (TEXTOBJ EDITPROPS) of TEXTOBJ) + PROP]) (PUTTEXTPROP + [LAMBDA (TEXTOBJ PROP VALUE) (* ; "Edited 9-Feb-89 11:19 by jds") + (* ; + "put a value on prop list for a textobj") + (SELECTQ PROP + ((READONLY READ-ONLY) + (PROG1 (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ) + (replace (TEXTOBJ TXTREADONLY) of TEXTOBJ with VALUE))) + ((BEING-EDITED ACTIVE) + (PROG1 (fetch (TEXTOBJ TXTEDITING) of TEXTOBJ) + (replace (TEXTOBJ TXTEDITING) of TEXTOBJ with VALUE))) + ((NO-NS-CHARS NONSCHARS NO-NSCHARS) + (PROG1 (fetch (TEXTOBJ TXTNONSCHARS) of TEXTOBJ) + (replace (TEXTOBJ TXTNONSCHARS) of TEXTOBJ with VALUE))) + (COND + ((fetch (TEXTOBJ EDITPROPS) of (TEXTOBJ TEXTOBJ)) + (PROG1 (LISTGET (ffetch (TEXTOBJ EDITPROPS) of (TEXTOBJ TEXTOBJ)) + PROP) + (LISTPUT (ffetch (TEXTOBJ EDITPROPS) of (TEXTOBJ TEXTOBJ)) + PROP VALUE))) + (T (freplace (TEXTOBJ EDITPROPS) of (TEXTOBJ TEXTOBJ) with (LIST PROP VALUE)) + NIL]) (TEXTPROP + [LAMBDA X (* ; "Edited 9-Feb-89 11:20 by jds") + + (* ;; "general top level entry for both fetching and setting window properties.") + + (COND + ((IGREATERP X 2) + (PUTTEXTPROP (TEXTOBJ (ARG X 1)) + (ARG X 2) + (ARG X 3))) + ((EQ X 2) + (GETTEXTPROP (TEXTOBJ (ARG X 1)) + (ARG X 2))) + (T (\ILLEGAL.ARG NIL]) ) (* ;; "Support for error handling: The old error handler for the stream-not-open error. This is here, because you only want to do this ONCE, even if you load TEXTOFD multiple times (as, e.g., in development)" ) (RPAQ? *TEDIT-OLD-STREAM-ERROR-HANDLER* (CONDITION-HANDLER 'XCL:STREAM-NOT-OPEN)) (DECLARE%: DONTEVAL@LOAD DOCOPY (\TEXTINIT) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA TEXTPROP) ) (PUTPROPS TEXTOFD COPYRIGHT ("John Sybalsky & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1993 1994 1995 1999 2000 2001)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3014 53058 (COPYTEXTSTREAM 3024 . 6146) (OPENTEXTSTREAM 6148 . 21025) (REOPENTEXTSTREAM 21027 . 21449) (TEDIT.STREAMCHANGEDP 21451 . 21749) (TEXTSTREAMP 21751 . 22065) (TXTFILE 22067 . 22512) (\DELETECH 22514 . 33770) (\SETUPGETCH 33772 . 41051) (\TEDIT.REOPEN.STREAM 41053 . 42903) ( \TEDIT.COPYTEXTSTREAM.PIECEMAPFN 42905 . 45343) (\TEXTINIT 45345 . 50951) (\TEXTMARK 50953 . 51701) ( \TEXTTTYBOUT 51703 . 53056)) (53059 78491 (\INSERTCH 53069 . 76795) (\INSERTCR 76797 . 78489)) (78557 98873 (\CHTOPC 78567 . 79756) (\CHTOPCNO 79758 . 81020) (\CLEARPCTB 81022 . 81818) ( \CREATEPIECEORSTREAM 81820 . 84794) (\DELETEPIECE 84796 . 85709) (\FINDPIECE 85711 . 86077) ( \INSERTPIECE 86079 . 89089) (\MAKEPCTB 89091 . 91006) (\SPLITPIECE 91008 . 97967) (\INSERT.FIRST.PIECE 97969 . 98871)) (98925 123143 (\TEXTCLOSEF 98935 . 100162) (\TEXTCLOSEF-SUBTREE 100164 . 100870) ( \TEXTDSPFONT 100872 . 101864) (\TEXTEOFP 101866 . 103225) (\TEXTGETEOFPTR 103227 . 103437) ( \TEXTGETFILEPTR 103439 . 105502) (\TEXTOPENF 105504 . 106334) (\TEXTOPENF-SUBTREE 106336 . 107137) ( \TEXTOUTCHARFN 107139 . 107487) (\TEXTBACKFILEPTR 107489 . 113390) (\TEXTBOUT 113392 . 116740) ( \TEDITOUTCHARFN 116742 . 117988) (\TEXTSETEOF 117990 . 118499) (\TEXTSETFILEPTR 118501 . 119726) ( \TEXTDSPXPOSITION 119728 . 120585) (\TEXTDSPYPOSITION 120587 . 121132) (\TEXTLEFTMARGIN 121134 . 121617) (\TEXTRIGHTMARGIN 121619 . 122555) (\TEXTDSPCHARWIDTH 122557 . 122795) (\TEXTDSPSTRINGWIDTH 122797 . 123037) (\TEXTDSPLINEFEED 123039 . 123141)) (123144 156888 (\TEXTBIN 123154 . 139940) ( \TEDIT.TEXTBIN.STRINGSETUP 139942 . 145655) (\TEDIT.TEXTBIN.FILESETUP 145657 . 152043) ( \TEDIT.TEXTBIN.NEW.PAGE 152045 . 156886)) (156889 170297 (\TEXTPEEKBIN 156899 . 166038) ( \TEDIT.PEEKBIN.NEW.PAGE 166040 . 170295)) (170335 175553 (CGETTEXTPROP 170345 . 170821) (CTEXTPROP 170823 . 173167) (GETTEXTPROP 173169 . 173764) (PUTTEXTPROP 173766 . 175091) (TEXTPROP 175093 . 175551 ))))) STOP \ No newline at end of file diff --git a/library/TEXTOFD.DATABASE b/library/TEXTOFD.DATABASE new file mode 100644 index 00000000..f312157b --- /dev/null +++ b/library/TEXTOFD.DATABASE @@ -0,0 +1 @@ +(PROGN (PRIN1 "Use LOADDB to load database files! " T) (ERROR!)) ("21-Apr-2000 22:31:12" . {DSK}sybalsky>lispcore>library>TEXTOFD.;8) FNS (COPYTEXTSTREAM OPENTEXTSTREAM REOPENTEXTSTREAM TEDIT.STREAMCHANGEDP TEXTSTREAMP TXTFILE \DELETECH \SETUPGETCH \TEDIT.REOPEN.STREAM \TEDIT.COPYTEXTSTREAM.PIECEMAPFN \TEXTINIT \TEXTMARK \TEXTTTYBOUT \INSERTCH \INSERTCR \CHTOPC \CHTOPCNO \CLEARPCTB \CREATEPIECEORSTREAM \DELETEPIECE \FINDPIECE \INSERTPIECE \MAKEPCTB \SPLITPIECE \INSERT.FIRST.PIECE \TEXTCLOSEF \TEXTCLOSEF-SUBTREE \TEXTDSPFONT \TEXTEOFP \TEXTGETEOFPTR \TEXTGETFILEPTR \TEXTOPENF \TEXTOPENF-SUBTREE \TEXTOUTCHARFN \TEXTBACKFILEPTR \TEXTBOUT \TEDITOUTCHARFN \TEXTSETEOF \TEXTSETFILEPTR \TEXTDSPXPOSITION \TEXTDSPYPOSITION \TEXTLEFTMARGIN \TEXTRIGHTMARGIN \TEXTDSPCHARWIDTH \TEXTDSPSTRINGWIDTH \TEXTDSPLINEFEED \TEXTBIN \TEDIT.TEXTBIN.STRINGSETUP \TEDIT.TEXTBIN.FILESETUP \TEDIT.TEXTBIN.NEW.PAGE \TEXTPEEKBIN \TEDIT.PEEKBIN.NEW.PAGE CGETTEXTPROP CTEXTPROP GETTEXTPROP PUTTEXTPROP TEXTPROP) (READATABASE) ( CALL COPYTEXTSTREAM (TEXTOBJ OPENTEXTSTREAM ADD1 TEDIT.SELECTED.PIECES FUNCTION) OPENTEXTSTREAM (PROG* APPEND COPY \TEDIT.PRIMARYW WINDOWPROP LIST LISTGET \TEDIT.PARSE.CHARLOOKS.LIST FONTCREATE \TEDIT.UNIQUIFY.PARALOOKS \TEDIT.PARSE.PARALOOKS.LIST \TEDIT.UNIQUIFY.CHARLOOKS EVAL TEDIT.BUILD.PCTB \GETBASEPTR \FIRSTNODE \TEDIT.CARETLOOKS.VERIFY FIXP IPLUS \TEDIT.GET.INSERT.CHARLOOKS) REOPENTEXTSTREAM (FUNCTION) TEDIT.STREAMCHANGEDP (TEXTOBJ) TEXTSTREAMP NIL TXTFILE NIL \DELETECH ( IDIFFERENCE IPLUS IMINUS \CHTOPC - ADD1 \SPLITPIECE \GETBASEPTR \FIRSTNODE LIST IMAGEOBJPROP \DELETETREE FLAST) \SETUPGETCH (IMAX \CHTOPC - LRSH IDIFFERENCE IMAGEOBJPROP ADD1 \TEDIT.APPLY.PARASTYLES \TEDIT.APPLY.STYLES) \TEDIT.REOPEN.STREAM (OPENSTREAM TEXTOBJ \GETBASEPTR \FIRSTNODE) \TEDIT.COPYTEXTSTREAM.PIECEMAPFN (IMAGEOBJPROP APPLY* COPYALL) \TEXTINIT (FUNCTION CONDITION-HANDLER GETPROP) \TEXTMARK (CONS IDIFFERENCE) \TEXTTTYBOUT (\SYNCODE GETHASH \GETBASEBYTE PLUS FETCHFIELD) \INSERTCH (NCHARS SUB1 IPLUS ADD1 \GETBASEFAT \GETBASE \GETBASETHIN \GETBASEBYTE IGREATERP IDIFFERENCE LIST SUBSTRING ALLOCSTRING \INSERTPIECE NCONC1 RPLACA PLUS \CHTOPC \TEDIT.UNIQUIFY.PARALOOKS \SPLITPIECE - IEQP) \INSERTCR NIL \CHTOPC (IPLUS \GETBASEFIXP \GETBASEPTR - PLUS) \CHTOPCNO (IPLUS IMAX) \CLEARPCTB (HELP) \CREATEPIECEORSTREAM (NCHARS OPENSTREAM MKSTRING CHARLOOKS.FROM.FONT) \DELETEPIECE NIL \FINDPIECE (FINDPCNODE INDEX) \INSERTPIECE (PROG* \LASTNODE FINDPCNODE \CHTOPC) \MAKEPCTB NIL \SPLITPIECE (PROG* SUBSTRING ADD1 IDIFFERENCE IPLUS IMINUS) \INSERT.FIRST.PIECE (\CREATEPIECEORSTREAM CHARLOOKS.FROM.FONT ALLOCSTRING) \TEXTCLOSEF (TEXTOBJ ZEROP \GETBASEPTR \FIRSTNODE) \TEXTCLOSEF-SUBTREE (\TEXTCLOSEF-SUBTREE) \TEXTDSPFONT (TEXTOBJ \GETFONTDESC DSPFONT) \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR (IMIN SUB1 IPLUS \TEDIT.PIECE-CHNO IDIFFERENCE IQUOTIENT IMAX) \TEXTOPENF NIL \TEXTOPENF-SUBTREE (\TEXTOPENF-SUBTREE) \TEXTOUTCHARFN ( \INSERTCH) \TEXTBACKFILEPTR (\TEDIT.APPLY.STYLES SUB1 IPLUS) \TEXTBOUT (ADD1 \TEXTGETFILEPTR ADDBASE \ADDBASE LRSH IPLUS LOGAND) \TEDITOUTCHARFN (IPLUS16 \LOLOC \ADDBASE) \TEXTSETEOF NIL \TEXTSETFILEPTR (ZEROP IMAX ADD1) \TEXTDSPXPOSITION (TEXTOBJ DSPXPOSITION POSITION) \TEXTDSPYPOSITION (TEXTOBJ DSPYPOSITION DIFFERENCE) \TEXTLEFTMARGIN (TEXTOBJ IPLUS) \TEXTRIGHTMARGIN (TEXTOBJ LINELENGTH) \TEXTDSPCHARWIDTH (TEXTOBJ CHARWIDTH DSPFONT) \TEXTDSPSTRINGWIDTH (TEXTOBJ STRINGWIDTH DSPFONT NCHARS) \TEXTDSPLINEFEED (FONTPROP DSPFONT) \TEXTBIN (IMAGEOBJPROP PLUS FETCHFIELD \BIN LOGOR UNFOLD LLSH \PAGEDBIN \TEDIT.TEXTBIN.NEW.PAGE APPLY* \TEDIT.APPLY.PARASTYLES \TEDIT.APPLY.STYLES ERROR) \TEDIT.TEXTBIN.STRINGSETUP (ADDBASE \ADDBASE UNFOLD LLSH IPLUS LRSH LOGAND) \TEDIT.TEXTBIN.FILESETUP ( UNFOLD LLSH \TEDIT.REOPEN.STREAM IPLUS GETEOFPTR LOGOR \PAGEDBIN \PAGEDPEEKBIN \BIN \PEEKBIN IMIN IDIFFERENCE) \TEDIT.TEXTBIN.NEW.PAGE (\GETSTREAM OPENFILE \BIN IMIN IDIFFERENCE LOGOR UNFOLD LLSH \PAGEDBIN) \TEXTPEEKBIN (SPREADAPPLY* \PEEKBIN SUB1 LOGOR UNFOLD LLSH \PAGEDBIN \PAGEDPEEKBIN \TEDIT.APPLY.STYLES \BIN \TEDIT.TEXTBIN.FILESETUP ERROR APPLY* \TEDIT.PEEKBIN.NEW.PAGE) \TEDIT.PEEKBIN.NEW.PAGE (\GETSTREAM OPENFILE SPREADAPPLY* \PEEKBIN LOGOR UNFOLD LLSH \PAGEDBIN \PAGEDPEEKBIN IMIN IDIFFERENCE) CGETTEXTPROP (SELECTQ BQUOTE LIST) CTEXTPROP (LIST TERPRI CGETTEXTPROP ) GETTEXTPROP (SELECTQ LISTGET) PUTTEXTPROP (SELECTQ TEXTOBJ LISTGET LIST) TEXTPROP (PUTTEXTPROP TEXTOBJ ARG GETTEXTPROP \ILLEGAL.ARG) NIL BIND COPYTEXTSTREAM NIL OPENTEXTSTREAM (CLEARGET?) REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH (PCSOUT HI LO NPC) \SETUPGETCH (PCNO FPOS OFFST) \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT (FILE ACCESS RECOG OTHERINFO FDEV) \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH (CHNO \INFIRSTCH) \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB (PCTB) \CREATEPIECEORSTREAM (START END) \DELETEPIECE (PCTB PC# PCNODE) \FINDPIECE NIL \INSERTPIECE (DONTUPDATECH#S PC#) \MAKEPCTB (MINLEN) \SPLITPIECE (PC# PCTB NEWLEN) \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF (ACCESS ASDF QWER ZXCV PC) \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT (PSTR) \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION (YPOSITION) \TEXTLEFTMARGIN (XPOSITION) \TEXTRIGHTMARGIN ( XPOSITION) \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED (VALUE) \TEXTBIN (CH FILE STR) \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN (CH FILE STR) \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL NLAMBDA COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR (CHARCODE) \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN (CHARCODE) \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL NOBIND COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB T \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL RECORD COPYTEXTSTREAM (TEXTOBJ SELECTION) OPENTEXTSTREAM (STREAM TEXTOBJ TEXTSTREAM CHARLOOKS SELECTION BTREENODE) REOPENTEXTSTREAM (STREAM) TEDIT.STREAMCHANGEDP (TEXTOBJ) TEXTSTREAMP (TEXTOBJ TEXTSTREAM) TXTFILE (TEXTOBJ) \DELETECH (TEXTOBJ PIECE) \SETUPGETCH (TEXTOBJ TEXTSTREAM EDITMARK STREAM PIECE) \TEDIT.REOPEN.STREAM (TEXTOBJ PIECE) \TEDIT.COPYTEXTSTREAM.PIECEMAPFN (PIECE TEXTOBJ) \TEXTINIT (STREAM) \TEXTMARK (TEXTOBJ TEXTSTREAM STREAM) \TEXTTTYBOUT (TEXTSTREAM TEXTOBJ CHARTABLE STREAM) \INSERTCH (TEXTOBJ STRINGP EDITMARK BTREENODE PIECE) \INSERTCR (TEXTOBJ PIECE) \CHTOPC ( BTREENODE) \CHTOPCNO (PCTNODE) \CLEARPCTB NIL \CREATEPIECEORSTREAM (STRINGP STREAM PIECE) \DELETEPIECE (PIECE) \FINDPIECE (PCTNODE) \INSERTPIECE (PIECE TEXTOBJ BTREENODE) \MAKEPCTB (BTREENODE PIECE) \SPLITPIECE (TEXTOBJ PIECE) \INSERT.FIRST.PIECE (TEXTOBJ PIECE) \TEXTCLOSEF (TEXTOBJ PIECE) \TEXTCLOSEF-SUBTREE (PCTNODE PIECE) \TEXTDSPFONT (CHARLOOKS TEXTOBJ) \TEXTEOFP (TEXTSTREAM STREAM PIECE) \TEXTGETEOFPTR (TEXTOBJ TEXTSTREAM) \TEXTGETFILEPTR (TEXTSTREAM STREAM PIECE TEXTOBJ) \TEXTOPENF (TEXTSTREAM TEXTOBJ PCTNODE) \TEXTOPENF-SUBTREE (PCTNODE PIECE STREAM) \TEXTOUTCHARFN ( TEXTOBJ TEXTSTREAM) \TEXTBACKFILEPTR (STREAM TEXTSTREAM PIECE) \TEXTBOUT (TEXTSTREAM TEXTOBJ PIECE STREAM STRINGP) \TEDITOUTCHARFN (STREAM) \TEXTSETEOF (STREAM BYTEPTR) \TEXTSETFILEPTR (TEXTSTREAM TEXTOBJ) \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION (TEXTOBJ) \TEXTLEFTMARGIN (TEXTOBJ FMTSPEC) \TEXTRIGHTMARGIN (TEXTOBJ FMTSPEC) \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN (STREAM PIECE TEXTSTREAM) \TEDIT.TEXTBIN.STRINGSETUP (STRINGP STREAM TEXTSTREAM) \TEDIT.TEXTBIN.FILESETUP (STREAM TEXTSTREAM BYTEPTR PIECE) \TEDIT.TEXTBIN.NEW.PAGE (TEXTSTREAM STREAM) \TEXTPEEKBIN (TEXTSTREAM STREAM PIECE FDEV) \TEDIT.PEEKBIN.NEW.PAGE (TEXTSTREAM STREAM FDEV) CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP (TEXTOBJ) PUTTEXTPROP (TEXTOBJ) TEXTPROP NIL NIL CREATE COPYTEXTSTREAM NIL OPENTEXTSTREAM (TEXTOBJ FMTSPEC TEXTSTREAM TEDITCARET EDITMARK) REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH (TEDITHISTORYEVENT ) \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN (PIECE) \TEXTINIT ( IMAGEOPS FDEV STREAM TEXTIMAGEDATA) \TEXTMARK (BYTEPTR) \TEXTTTYBOUT NIL \INSERTCH (TEDITHISTORYEVENT PIECE FMTSPEC) \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM (PIECE FMTSPEC) \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB (BTREENODE) \SPLITPIECE (PIECE) \INSERT.FIRST.PIECE (FMTSPEC) \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL FETCH COPYTEXTSTREAM (PCTB SCRATCHSEL EDITPROPS TEXTLEN MENUFLG) OPENTEXTSTREAM (TEXTOBJ EDITPROPS SEL SCRATCHSEL SHIFTEDSEL MOVESEL DELETESEL \TEXTOBJ PCTB TOTLEN TERMSA SET TXTREADONLY) REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP (\DIRTY) TEXTSTREAMP (TEXTOBJ) TXTFILE (TXTFILE) \DELETECH (TXTREADONLY \INSERTFIRSTCH TEXTLEN PCTB \INSERTPCVALID \INSERTNEXTCH \INSERTPC \INSERTLEN TXTHISTORY THLEN PREVPIECE PLEN NEXTPIECE POBJ \WINDOW PTREENODE) \SETUPGETCH (PCTB STREAMHINT PC PCOFF TEXTLEN PFATP PLEN PSTR PFILE POBJ TEXTOBJ CURRENTPARALOOKS CURRENTLOOKS PPARALOOKS PLOOKS) \TEDIT.REOPEN.STREAM ( PCTB PFILE NEXTPIECE TXTFILE) \TEDIT.COPYTEXTSTREAM.PIECEMAPFN (POBJ STREAMHINT \WINDOW) \TEXTINIT NIL \TEXTMARK (STREAMHINT PIECE CPAGE COFFSET PCSTARTPG PCSTARTCH) \TEXTTTYBOUT (TEXTOBJ SEL CCECHO NSCHARHASH TXTTERMSA CHARPOSITION) \INSERTCH (TXTREADONLY FATSTRINGP OFFST BASE LENGTH \INSERTNEXTCH \INSERTLEN \INSERTLEFT \INSERTSTRING \INSERTPC \INSERTFIRSTCH PCTB TEXTLEN PC PCOFF COUNT PLEN \INSERTPCVALID NEXTPIECE PLOOKS PPARALOOKS PSTR TXTHISTORY THLEN CARETLOOKS FMTSPEC PREVPIECE PPARALAST THACTION THCH# PFATP) \INSERTCR (TXTREADONLY FORMATTEDP \INSERTPC) \CHTOPC (COUNT) \CHTOPCNO (HI CHNUM RANK LO) \CLEARPCTB NIL \CREATEPIECEORSTREAM (FATSTRINGP ACCESSBITS) \DELETEPIECE ( NEXTPIECE PREVPIECE PTREENODE) \FINDPIECE (CHNUM) \INSERTPIECE (PLEN PCTB COUNT TOTLEN PREVPIECE) \MAKEPCTB (PLEN) \SPLITPIECE (PCTB PSTR PLEN PFILE PFATP PFPOS NEXTPIECE) \INSERT.FIRST.PIECE (FMTSPEC ) \TEXTCLOSEF (PCTB TEXTLEN PFILE NEXTPIECE TXTFILE) \TEXTCLOSEF-SUBTREE (PCE PFILE LO HI) \TEXTDSPFONT (CLFONT CARETLOOKS \WINDOW) \TEXTEOFP (PIECE COFFSET CBUFSIZE CHARSLEFT NEXTPIECE PLEN) \TEXTGETEOFPTR (TEXTLEN TEXTOBJ) \TEXTGETFILEPTR (PIECE CHARSLEFT COFFSET CBUFSIZE PLEN FATSTREAMP TEXTLEN TEXTOBJ) \TEXTOPENF (TEXTOBJ PCTB HI) \TEXTOPENF-SUBTREE (PCE PFILE ACCESSBITS LO HI) \TEXTOUTCHARFN (TEXTLEN TEXTOBJ) \TEXTBACKFILEPTR (CPAGE PCSTARTPG COFFSET PCSTARTCH PREVPIECE PIECE PLEN PLOOKS TEXTOBJ PSTR PFILE PFATP POBJ REALFILE CHARSLEFT CBUFSIZE FATSTREAMP CPPTR) \TEXTBOUT ( TEXTOBJ TEXTLEN \WINDOW TXTREADONLY PSTR \INSERTPC BASE OFFST \INSERTLEN COFFSET) \TEDITOUTCHARFN ( CHARPOSITION) \TEXTSETEOF (PAGE OFFSET) \TEXTSETFILEPTR (TEXTOBJ TEXTLEN) \TEXTDSPXPOSITION (\WINDOW) \TEXTDSPYPOSITION (\WINDOW) \TEXTLEFTMARGIN (\WINDOW LEFTMAR FMTSPEC) \TEXTRIGHTMARGIN (\WINDOW RIGHTMAR FMTSPEC WRIGHT) \TEXTDSPCHARWIDTH (\WINDOW) \TEXTDSPSTRINGWIDTH (\WINDOW) \TEXTDSPLINEFEED NIL \TEXTBIN (COFFSET CBUFSIZE POBJ PIECE FATSTREAMP CHARSLEFT NEXTPIECE PLEN LOOKSUPDATEFN TEXTOBJ CURRENTPARALOOKS CURRENTLOOKS PPARALOOKS PLOOKS PSTR PFILE PFATP ENDOFSTREAMOP) \TEDIT.TEXTBIN.STRINGSETUP (FATSTRINGP BASE OFFST COFFSET) \TEDIT.TEXTBIN.FILESETUP (ACCESSBITS PAGE PFPOS OFFSET CPPTR CPAGE COFFSET CBUFSIZE) \TEDIT.TEXTBIN.NEW.PAGE (REALFILE ACCESSBITS FULLNAME CBUFSIZE CPPTR COFFSET CPAGE CHARSLEFT FATSTREAMP) \TEXTPEEKBIN (PIECE COFFSET CBUFSIZE POBJ FATSTREAMP EOFP DEVICE F1 CHARSLEFT NEXTPIECE PLOOKS TEXTOBJ PLEN CURRENTPARALOOKS CURRENTLOOKS PSTR PFILE PFATP ENDOFSTREAMOP) \TEDIT.PEEKBIN.NEW.PAGE (REALFILE ACCESSBITS FULLNAME CBUFSIZE EOFP DEVICE FATSTREAMP CPPTR COFFSET CPAGE CHARSLEFT) CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP (TXTREADONLY TXTEDITING TXTNONSCHARS EDITPROPS) PUTTEXTPROP (TXTREADONLY TXTEDITING TXTNONSCHARS EDITPROPS) TEXTPROP NIL NIL REPLACE COPYTEXTSTREAM (CH# CHLIM DCH TEXTLEN MENUFLG) OPENTEXTSTREAM (\INSERTFIRSTCH \INSERTNEXTCH \INSERTPCVALID \WINDOW LINES FMTSPEC \TEXTOBJ SET ONFLG TEXTOBJ STREAMHINT EDITFINISHEDFLG \DIRTY DEFAULTCHARLOOKS PCTB TEXTLEN CARETLOOKS CARET TCCARETDS TCFORCEUP TXTREADONLY TXTTERMSA TXTRTBL TXTWTBL CH# CHLIM DCH DX POINT SELKIND PROMPTWINDOW PC PCOFF PCNO) REOPENTEXTSTREAM (ACCESS BINABLE STRMBINFN STRMBOUTFN) TEDIT.STREAMCHANGEDP (\DIRTY) TEXTSTREAMP NIL TXTFILE NIL \DELETECH (\INSERTLEN PLEN \INSERTNEXTCH THLEN \INSERTPCVALID THACTION THCH# THFIRSTPIECE NEXTPIECE PREVPIECE TEXTLEN \DIRTY ) \SETUPGETCH (FATSTREAMP PIECE COFFSET CPAGE PCSTARTPG PCSTARTCH PCOFFSET BINABLE CHARSLEFT CBUFSIZE CURRENTPARALOOKS CURRENTLOOKS) \TEDIT.REOPEN.STREAM (PFILE TXTFILE) \TEDIT.COPYTEXTSTREAM.PIECEMAPFN ( PNEW POBJ) \TEXTINIT (IMAGETYPE IMXPOSITION IMYPOSITION IMLEFTMARGIN IMRIGHTMARGIN IMFONT IMCLOSEFN IMFONTCREATE IMLINEFEED IMCHARWIDTH IMSTRINGWIDTH DEVICENAME RESETABLE RANDOMACCESSP PAGEMAPPED GETFILENAME BIN BOUT CLOSEFILE OPENFILE DELETEFILE DIRECTORYNAMEP EVENTFN GENERATEFILES GETFILEINFO HOSTNAMEP READPAGES REOPENFILE ACCESS SETFILEINFO BACKFILEPTR SETFILEPTR PEEKBIN GETEOFPTR GETFILEPTR EOFP FDBINABLE FDBOUTABLE FDEXTENDABLE TRUNCATEFILE WRITEPAGES READCHARCODE BINABLE BOUTABLE USERCLOSEABLE USERVISIBLE DEVICE F1 F2 F3 F5 FW6 FW7 MAXBUFFERS IMAGEOPS IMAGEDATA OUTCHARFN) \TEXTMARK (PAGE OFFSET) \TEXTTTYBOUT (CHARPOSITION) \INSERTCH (PLEN \INSERTLEN \INSERTLEFT \INSERTNEXTCH THACTION THLEN THCH# THFIRSTPIECE THPOINT PSTR PLOOKS PPARALOOKS PPARALAST PNEW \INSERTSTRING \INSERTPCNO \INSERTPC \INSERTFIRSTCH THOLDINFO TEXTLEN \INSERTPCVALID \DIRTY PFATP) \INSERTCR (PPARALAST \INSERTPCVALID) \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM ( PSTR PFILE PLEN PPARALAST PPARALOOKS PFATP PLOOKS) \DELETEPIECE (PREVPIECE NEXTPIECE) \FINDPIECE NIL \INSERTPIECE (NEXTPIECE PREVPIECE DOWN1 COUNT TOTLEN) \MAKEPCTB (COUNT TOTLEN DOWN1 DLEN1 DOWN2 DLEN2 PTREENODE) \SPLITPIECE (PPARALAST PSTR PLEN PFILE PFPOS NEXTPIECE PREVPIECE \INSERTPCVALID) \INSERT.FIRST.PIECE (\INSERTPC PSTR \INSERTSTRING) \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR (PIECE BINABLE FATSTREAMP CURRENTLOOKS CHARSLEFT COFFSET CPAGE CBUFSIZE CPPTR) \TEXTBOUT (PIECE CPPTR CPAGE COFFSET PCSTARTCH PCSTARTPG CBUFSIZE EPAGE CHARSLEFT REALFILE) \TEDITOUTCHARFN (CHARPOSITION) \TEXTSETEOF (EPAGE EOFFSET) \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN (COFFSET CHARSLEFT PIECE BINABLE FATSTREAMP CURRENTPARALOOKS CURRENTLOOKS CBUFSIZE CPAGE PCSTARTCH PCSTARTPG) \TEDIT.TEXTBIN.STRINGSETUP (CPPTR CPAGE COFFSET PCSTARTPG PCSTARTCH CBUFSIZE EPAGE CHARSLEFT REALFILE BINABLE FATSTREAMP) \TEDIT.TEXTBIN.FILESETUP (PCSTARTPG PCSTARTCH CPPTR CPAGE COFFSET EPAGE CBUFSIZE CHARSLEFT REALFILE FATSTREAMP BINABLE) \TEDIT.TEXTBIN.NEW.PAGE (COFFSET CPPTR CPAGE CBUFSIZE CHARSLEFT ) \TEXTPEEKBIN (COFFSET PIECE CURRENTLOOKS BINABLE CBUFSIZE CHARSLEFT CPAGE PCSTARTCH PCSTARTPG CURRENTPARALOOKS) \TEDIT.PEEKBIN.NEW.PAGE (COFFSET CPPTR CPAGE CBUFSIZE CHARSLEFT) CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP (TXTREADONLY TXTEDITING TXTNONSCHARS EDITPROPS) TEXTPROP NIL NIL REFFREE COPYTEXTSTREAM NIL OPENTEXTSTREAM (TEDIT.DEFAULT.PROPS DEFAULTFONT TEDIT.DEFAULT.FMTSPEC) REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT (ERRORPOS) \TEXTMARK NIL \TEXTTTYBOUT (ERASECHARCODE IGNORE.CCE \MAXTHINCHAR \PRIMTERMSA) \INSERTCH (\MAXTHINCHAR) \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM (NoBits DEFAULTFONT TEDIT.DEFAULT.FMTSPEC) \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE (DEFAULTFONT TEDIT.DEFAULT.FMTSPEC) \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE (NoBits STREAM) \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION ( \CURRENTDISPLAYLINE) \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP (NoBits) \TEDIT.TEXTBIN.NEW.PAGE (NoBits) \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE (NoBits) CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL REF COPYTEXTSTREAM (ORIGINAL TEXTOBJ CROSSCOPY) OPENTEXTSTREAM (TEXT PROPS TEDIT.GET.FINISHEDFORMS FORM START END) REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP (STREAM) TEXTSTREAMP (STREAM) TXTFILE ( TEXTOBJ) \DELETECH (CHLIM CH# \INFIRSTCH LEN TEXTLEN PCNON) \SETUPGETCH (TEXTOBJ CH# PCTB START-OF-PIECE) \TEDIT.REOPEN.STREAM (PIECESTREAM TEXTSTREAM PCTB NEWSTREAM) \TEDIT.COPYTEXTSTREAM.PIECEMAPFN (FROMOBJ TOOBJ TEXTOBJ) \TEXTINIT (CONDITION) \TEXTMARK (TEXTOBJ STREAM) \TEXTTTYBOUT (BYTE TEXTOBJ TABLEA0347) \INSERTCH (CH LEN CH# \INEXTCH IMARKPC IMARKCH \INLEFT \INLEN START-OF-PIECE FATP) \INSERTCR (CH CH#) \CHTOPC (PCTB CH#) \CHTOPCNO (PCTB CH#) \CLEARPCTB NIL \CREATEPIECEORSTREAM (PARALOOKS LOOKS) \DELETEPIECE (PC) \FINDPIECE (PC PCTB NODE) \INSERTPIECE ( TEXTOBJ PLEN NEW-PREVLEN PREV) \MAKEPCTB NIL \SPLITPIECE (CH) \INSERT.FIRST.PIECE NIL \TEXTCLOSEF ( STREAM TEXTOBJ) \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT (STREAM TEXTOBJ WIN) \TEXTEOFP (STREAM) \TEXTGETEOFPTR (STREAM) \TEXTGETFILEPTR (STREAM CHARSLEFT OFFSET LIMIT) \TEXTOPENF (STREAM TEXTOBJ) \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN (CH STREAM) \TEXTBACKFILEPTR NIL \TEXTBOUT (TEXTOBJ CH# BYTE) \TEDITOUTCHARFN (CHARCODE) \TEXTSETEOF (EOFPTR) \TEXTSETFILEPTR (STREAM TEXTOBJ FILEPOS) \TEXTDSPXPOSITION (STREAM XPOSITION) \TEXTDSPYPOSITION (STREAM) \TEXTLEFTMARGIN (STREAM) \TEXTRIGHTMARGIN (STREAM TEXTOBJ RIGHTMAR) \TEXTDSPCHARWIDTH (STREAM CHARCODE) \TEXTDSPSTRINGWIDTH ( STREAM STRING) \TEXTDSPLINEFEED (STREAM) \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP (PS CHOFFSET CHARSLEFT) \TEDIT.TEXTBIN.FILESETUP (CHARSLEFT CHOFFSET PC BYTEOFFSET OPERATION NOERRORFLG BYTESLEFT) \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP (PROP TEXTOBJ) CTEXTPROP (FORMTAIL PROP TEXTOBJ VAL) GETTEXTPROP (PROP TEXTOBJ) PUTTEXTPROP (PROP VALUE) TEXTPROP (X) NIL SETFREE COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT (\TEXTIMAGEOPS \TEXTFDEV \TEXTOFD) \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC (START-OF-PIECE) \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL SET COPYTEXTSTREAM (PCTB TSEL NEWSTREAM NEWTEXTOBJ PCLST) OPENTEXTSTREAM (PROPNAME PROPVAL FONT PARALOOKS OTEXTOBJ TEXTSTREAM PCTB PC PROP SEL PWINDOW) REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH (PC1 PCN START-OF-PIECE HIPC PCTB PCLST PC) \SETUPGETCH (PC CHOFFSET CHARSLEFT PS PF SUBSTREAM) \TEDIT.REOPEN.STREAM (PC) \TEDIT.COPYTEXTSTREAM.PIECEMAPFN (PC OBJ COPYFN NEWOBJ) \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH (CHAR \INPC \INSTRING NEWPC NEWFLAG PC PLOOKS NLOOKS PCTB PREVPC EVENT REPLACING TEXTLEN) \INSERTCR (INPC) \CHTOPC (TBASE-CH# FOUND BASE-CH# I OFST TREE) \CHTOPCNO (CHNUM INDEX TREE) \CLEARPCTB NIL \CREATEPIECEORSTREAM (PC STRING) \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE (OLDLEN PCNODE PREVPC) \MAKEPCTB (PLEN) \SPLITPIECE (CHNO NEXTPC) \INSERT.FIRST.PIECE (PC) \TEXTCLOSEF (PCTB PC) \TEXTCLOSEF-SUBTREE (PC) \TEXTDSPFONT NIL \TEXTEOFP (PC) \TEXTGETEOFPTR NIL \TEXTGETFILEPTR (PLEN) \TEXTOPENF (PCTB) \TEXTOPENF-SUBTREE (PC) \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR (PC PS PF REALFILE) \TEXTBOUT (TEXTLEN WINDOW PS PC OFFST) \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN (PO SUBSTREAM OPC PC NPC PS PF) \TEDIT.TEXTBIN.STRINGSETUP (OFFST) \TEDIT.TEXTBIN.FILESETUP (PF FPOS CH) \TEDIT.TEXTBIN.NEW.PAGE (FILE CH) \TEXTPEEKBIN (PC PS PO PF) \TEDIT.PEEKBIN.NEW.PAGE (FILE CH) CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL SMASHFREE COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL SMASH COPYTEXTSTREAM (TSEL NEWTEXTOBJ) OPENTEXTSTREAM (TEXTOBJ SELN TEXTSTREAM SEL) REOPENTEXTSTREAM ( STREAM) TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH (TEXTOBJ PC1 HIPC) \SETUPGETCH (STREAM) \TEDIT.REOPEN.STREAM (PC TEXTOBJ) \TEDIT.COPYTEXTSTREAM.PIECEMAPFN (PC) \TEXTINIT (STREAM) \TEXTMARK NIL \TEXTTTYBOUT (STREAM) \INSERTCH (\INPC TEXTOBJ NEWPC) \INSERTCR (INPC TEXTOBJ) \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM (PC) \DELETEPIECE (NEXT PREV) \FINDPIECE NIL \INSERTPIECE (NEW PCTB OLD PREVPC) \MAKEPCTB (PCTB PC1) \SPLITPIECE (PC NEWPC NEXTPC TEXTOBJ) \INSERT.FIRST.PIECE (TEXTOBJ PC) \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR (STREAM REALFILE) \TEXTBOUT (STREAM) \TEDITOUTCHARFN (STREAM) \TEXTSETEOF (STREAM) \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN (STREAM) \TEDIT.TEXTBIN.STRINGSETUP (STREAM) \TEDIT.TEXTBIN.FILESETUP (STREAM) \TEDIT.TEXTBIN.NEW.PAGE (FILE STREAM) \TEXTPEEKBIN (PS STREAM) \TEDIT.PEEKBIN.NEW.PAGE (FILE STREAM) CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP (TEXTOBJ) TEXTPROP NIL NIL PROP COPYTEXTSTREAM NIL OPENTEXTSTREAM (FONT LOOKS PARALOOKS CLEARGET READONLY TERMTABLE READTABLE BOUNDTABLE PAGEFORMAT SEL PROMPTWINDOW) REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT (%%CONDITION-HANDLER) \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL TEST COPYTEXTSTREAM NIL OPENTEXTSTREAM (WAS-TEXTSTREAM WINDOW FONT PROP TEXTOBJ.WINDOW.VALID) REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP (RESET?) TEXTSTREAMP NIL TXTFILE NIL \DELETECH (DONTDIRTY PC1 PC HIPC) \SETUPGETCH NIL \TEDIT.REOPEN.STREAM (PC) \TEDIT.COPYTEXTSTREAM.PIECEMAPFN (NEWOBJ OBJ) \TEXTINIT (XCL::RESULT) \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH (INSERTMARK \INPC PLOOKS NLOOKS REPLACING) \INSERTCR (INPC) \CHTOPC (TELL-PC-START?) \CHTOPCNO (TREE) \CLEARPCTB NIL \CREATEPIECEORSTREAM (STRING) \DELETEPIECE (NEXT PREV) \FINDPIECE NIL \INSERTPIECE (OLD PREVPC) \MAKEPCTB (PC1) \SPLITPIECE (NEXTPC) \INSERT.FIRST.PIECE (TEXTOBJ) \TEXTCLOSEF (PC) \TEXTCLOSEF-SUBTREE (PCTREE) \TEXTDSPFONT (NEWFONT) \TEXTEOFP (PC) \TEXTGETEOFPTR NIL \TEXTGETFILEPTR (PC) \TEXTOPENF NIL \TEXTOPENF-SUBTREE (PCTREE) \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR (PC) \TEXTBOUT ( WINDOW) \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION (WINDOW) \TEXTDSPYPOSITION (WINDOW) \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH (WINDOW) \TEXTDSPSTRINGWIDTH (WINDOW) \TEXTDSPLINEFEED NIL \TEXTBIN (OPC PC NPC SUBSTREAM) \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP (FATP) \TEDIT.TEXTBIN.NEW.PAGE (SPLITCHAR) \TEXTPEEKBIN (PC NOERRORFLG SUBSTREAM) \TEDIT.PEEKBIN.NEW.PAGE (NOERRORFLG) CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL TESTFREE COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT (*TEDIT-OLD-STREAM-ERROR-HANDLER*) \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION (\#DISPLAYLINES) \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL PREDICATE COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP (STREAMP) TXTFILE NIL \DELETECH (IEQP IGEQ ZEROP ILEQ IGREATERP ATOM ILESSP) \SETUPGETCH ( ATOM IGREATERP) \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT (IGREATERP) \INSERTCH (ZEROP IGEQ) \INSERTCR (IEQP) \CHTOPC (GREATERP IGREATERP) \CHTOPCNO (IEQP IGREATERP ILESSP) \CLEARPCTB NIL \CREATEPIECEORSTREAM (STRINGP ATOM STREAMP) \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE (ZEROP ATOM) \MAKEPCTB NIL \SPLITPIECE (ILEQ) \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE (ATOM) \TEXTDSPFONT NIL \TEXTEOFP (IEQP ZEROP) \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR (IEQP ZEROP) \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR (IEQP ILESSP IGREATERP) \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN ( ZEROP) \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN (ILESSP ZEROP EQCLOOKS) \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP (IEQP ZEROP ILESSP) \TEDIT.TEXTBIN.NEW.PAGE (IEQP) \TEXTPEEKBIN (ILESSP \EOFP ZEROP) \TEDIT.PEEKBIN.NEW.PAGE (IEQP \EOFP) CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP (IGREATERP) NIL EFFECT COPYTEXTSTREAM (\TEDIT.INSERT.PIECES) OPENTEXTSTREAM (TEXTPROP MAPC TEDIT.PAGEFORMAT \COPYSEL \TEDIT.WINDOW.SETUP \SETUPGETCH) REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH (\TEDIT.CHECK \DELETEPIECE UPDATEPCNODES HELP FRPLACD \TEDIT.HISTORYADD MAPC APPLY* \TEDIT.DIFFUSE.PARALOOKS) \SETUPGETCH (ERROR \TEDIT.TEXTBIN.STRINGSETUP \TEDIT.TEXTBIN.FILESETUP \SETUPGETCH) \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN (TEDIT.PROMPTPRINT RETFROM) \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT (\TEDIT.CHARDELETE DECLARE CHECK SELCHARQ \TEXTBOUT REPLACEFIELD) \INSERTCH (DECLARE \INSERT.FIRST.PIECE RPLSTRING RPLCHARCODE \TEDIT.HISTORYADD UPDATEPCNODES) \INSERTCR (\TEDIT.CONVERT.TO.FORMATTED \INSERTCH) \CHTOPC NIL \CHTOPCNO (DECLARE) \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE (\DELETETREE) \FINDPIECE NIL \INSERTPIECE ( \INSERTTREE) \MAKEPCTB NIL \SPLITPIECE (SHOULDNT \INSERTPIECE) \INSERT.FIRST.PIECE (\INSERTPIECE) \TEXTCLOSEF (CLOSEF?) \TEXTCLOSEF-SUBTREE (CLOSEF?) \TEXTDSPFONT (TEDIT.CARETLOOKS MAPC) \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF (\TEXTOPENF-SUBTREE) \TEXTOPENF-SUBTREE ( \TEDIT.REOPEN.STREAM) \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR (\TEDIT.TEXTBIN.STRINGSETUP \TEDIT.TEXTBIN.FILESETUP ERROR \BACKFILEPTR \PEEKBIN \PAGEDBACKFILEPTR) \TEXTBOUT ( \TEDIT.MARK.LINES.DIRTY \INSERTCH TEDIT.UPDATE.SCREEN) \TEDITOUTCHARFN (\BOUT) \TEXTSETEOF NIL \TEXTSETFILEPTR (\SETUPGETCH \BIN \ILLEGAL.ARG) \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN (DECLARE REPLACEFIELD \SETUPGETCH \TEDIT.TEXTBIN.STRINGSETUP \TEDIT.TEXTBIN.FILESETUP) \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP (SETFILEPTR \PAGEDBACKFILEPTR) \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN (\PAGEDBACKFILEPTR \SETUPGETCH \TEDIT.TEXTBIN.STRINGSETUP) \TEDIT.PEEKBIN.NEW.PAGE (\PAGEDBACKFILEPTR) CGETTEXTPROP NIL CTEXTPROP ( printout PRIN1 SELECTQ BQUOTE) GETTEXTPROP NIL PUTTEXTPROP (LISTPUT) TEXTPROP NIL NIL CLISP COPYTEXTSTREAM NIL OPENTEXTSTREAM (type? for in by as do) REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP (type?) TXTFILE NIL \DELETECH (bind while collect for in do) \SETUPGETCH NIL \TEDIT.REOPEN.STREAM (while do) \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH (type? for instring thereis) \INSERTCR NIL \CHTOPC (while do type? for from to as by) \CHTOPCNO (while do) \CLEARPCTB NIL \CREATEPIECEORSTREAM (type?) \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF (type? while do) \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT (for in do) \TEXTEOFP (bind while do finally) \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR (while do) \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN (repeatwhile do) \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL SPECVARS COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL LOCALVARS COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT (TABLEA0347) \INSERTCH ( $$TEM1 $$TEM2 $$TEM3 $$TEM4 $$TEM5) \INSERTCR NIL \CHTOPC NIL \CHTOPCNO (T) \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN (T) \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL APPLY COPYTEXTSTREAM (\TEDIT.COPYTEXTSTREAM.PIECEMAPFN) OPENTEXTSTREAM NIL REOPENTEXTSTREAM (\TEXTBIN \TEXTBOUT) TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN (TEDIT.COPY) \TEXTINIT (\TEXTDSPXPOSITION \TEXTDSPYPOSITION \TEXTLEFTMARGIN \TEXTRIGHTMARGIN \TEXTDSPFONT NILL \TEXTDSPLINEFEED \TEXTDSPCHARWIDTH \TEXTDSPSTRINGWIDTH \TEXTBIN \TEXTBOUT \TEXTCLOSEF \TEXTOPENF \GENERATENOFILES \TEXTBACKFILEPTR \TEXTSETFILEPTR \TEXTPEEKBIN \TEXTGETEOFPTR \TEXTGETFILEPTR \TEXTEOFP BIN \TEDITOUTCHARFN STREAM-ERROR-STREAM BOUNDP TEXTSTREAMP REOPENTEXTSTREAM CL:WHEN ENVAPPLY STKNAME SUBST STKARGS STKNTH APPLY*) \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL ERROR COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH (apply) \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN (apply) \TEXTINIT (apply stackfn) \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN (apply) \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN (apply) \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL LOCALFREEVARS COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL ARGS COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL USERTEMPLATES \FIRST-COLUMN-START MACRO WITHOUT-UPDATES MACRO \NEW-COLUMN-START MACRO NIL 0 COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL FPTYPE COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL KEYACCEPT COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL KEYSPECIFY COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL KEYCALL COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL FLET COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL LABEL COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL MACROLET COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL COMPILER-LET COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL SENDNOTSELF COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL SENDSELF COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL IMPLEMENT COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL GETNOTSELF COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL GETSELF COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL GETCVSELF COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL GETCVNOTSELF COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL PUTNOTSELF COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL PUTSELF COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL PUTCVSELF COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL PUTCVNOTSELF COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL OBJECT COPYTEXTSTREAM NIL OPENTEXTSTREAM NIL REOPENTEXTSTREAM NIL TEDIT.STREAMCHANGEDP NIL TEXTSTREAMP NIL TXTFILE NIL \DELETECH NIL \SETUPGETCH NIL \TEDIT.REOPEN.STREAM NIL \TEDIT.COPYTEXTSTREAM.PIECEMAPFN NIL \TEXTINIT NIL \TEXTMARK NIL \TEXTTTYBOUT NIL \INSERTCH NIL \INSERTCR NIL \CHTOPC NIL \CHTOPCNO NIL \CLEARPCTB NIL \CREATEPIECEORSTREAM NIL \DELETEPIECE NIL \FINDPIECE NIL \INSERTPIECE NIL \MAKEPCTB NIL \SPLITPIECE NIL \INSERT.FIRST.PIECE NIL \TEXTCLOSEF NIL \TEXTCLOSEF-SUBTREE NIL \TEXTDSPFONT NIL \TEXTEOFP NIL \TEXTGETEOFPTR NIL \TEXTGETFILEPTR NIL \TEXTOPENF NIL \TEXTOPENF-SUBTREE NIL \TEXTOUTCHARFN NIL \TEXTBACKFILEPTR NIL \TEXTBOUT NIL \TEDITOUTCHARFN NIL \TEXTSETEOF NIL \TEXTSETFILEPTR NIL \TEXTDSPXPOSITION NIL \TEXTDSPYPOSITION NIL \TEXTLEFTMARGIN NIL \TEXTRIGHTMARGIN NIL \TEXTDSPCHARWIDTH NIL \TEXTDSPSTRINGWIDTH NIL \TEXTDSPLINEFEED NIL \TEXTBIN NIL \TEDIT.TEXTBIN.STRINGSETUP NIL \TEDIT.TEXTBIN.FILESETUP NIL \TEDIT.TEXTBIN.NEW.PAGE NIL \TEXTPEEKBIN NIL \TEDIT.PEEKBIN.NEW.PAGE NIL CGETTEXTPROP NIL CTEXTPROP NIL GETTEXTPROP NIL PUTTEXTPROP NIL TEXTPROP NIL NIL ) \ No newline at end of file diff --git a/library/TFBRAVO b/library/TFBRAVO new file mode 100644 index 00000000..4f9af91c --- /dev/null +++ b/library/TFBRAVO @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Apr-2018 12:19:55" {DSK}kaplan>Local>medley3.5>lispcore>library>TFBRAVO.;2 74262 changes to%: (VARS TFBRAVOCOMS) previous date%: "31-May-91 15:27:45" {DSK}kaplan>Local>medley3.5>lispcore>library>TFBRAVO.;1) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1990, 1991, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TFBRAVOCOMS) (RPAQQ TFBRAVOCOMS [(FILES TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) (FILES (LOADCOMP) TEDITDCL)) [DECLARE%: EVAL@COMPILE DONTCOPY (COMS (* ; "Compile-time needs") (RECORDS FONT PARA RUN TFBRAVOPAGEFRAMES) (CONSTANTS (PTSPERINCH 72.27) (DefaultLeftMargin 2540) (DefaultFirstLineLeftMargin 2540) (DefaultRightMargin 19050) (HardwareLeftMargin 2540) (HardwareRightMargin (ITIMES 8 2540)) (BRAVO.TRAILER.CHARS '(l d z x e y k j c q %( %) %, s S u U b B i I g G v V w W t f o % \ 0 1 2 3 4 5 6 7 8 9] (FNS \TFBRAVO.FIND.LAST.TRAILER \TFBRAVO.HANDLE.HEADING \TFBRAVO.INIT.CHARLOOKS \TFBRAVO.INIT.PAGEFORMAT \TFBRAVO.INSTALL.PAGEFORMAT \TFBRAVO.PARSE.PROFILE.PARA \TFBRAVO.PARSE.PROFILE.VALUE \TFBRAVO.GET.FONTSIZE \TFBRAVO.GET.FONTSTYLE \TFBRAVO.WRITE.RUN \TFBRAVO.ASSERT \SHIFT.DOCUMENT \TEDIT.BRAVOFILE? \TEST.CHARACTER.LOOKS \TEST.PARAGRAPH.LOOKS) (FNS \TFBRAVO.COPY.NAMEDTAB \TFBRAVO.PUT.NAMEDTAB \TFBRAVO.GET.NAMEDTAB \TFBRAVO.ADD.NAMEDTAB \NAMEDTABNYET \NAMEDTABSIZE \NAMEDTAB.INIT) (FNS \TFBRAVO.APPLY.PARALOOKS TEDITFROMBRAVO \TFBRAVO.WRITE.PARAGRAPH \TFBRAVO.WRITE.RUNS \TFBRAVO.SPREAD.LOOKS \TFBRAVO.PARSE.PARA \TFBRAVO.INIT.PARALOOKS \TFBRAVO.READ.PARALOOKS \TFBRAVO.READ.CHARLOOKS \TFBRAVO.READ.USER.CM \TFBRAVO.GETPARAMS \TFBRAVO.PARAMNAMEP \TFBRAVO.EOLS \TFBRAVO.LCASER \TFBRAVO.FONT.FROM.CHARLOOKS) (INITVARS (USER.CM.RDTBL (COPYREADTABLE)) (PROFILE.PARA.RDTBL (COPYREADTABLE))) (P (SETSYNTAX (CHARCODE %:) 'SEPRCHAR PROFILE.PARA.RDTBL) (SETSYNTAX (CHARCODE EOL) 'BREAKCHAR PROFILE.PARA.RDTBL) (SETSYNTAX (CHARCODE ^Z) 'SEPRCHAR PROFILE.PARA.RDTBL)) (GLOBALVARS \NAMEDTAB.IMAGEFNS) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (ADDTOVAR TEDIT.INPUT.FORMATS (\TEDIT.BRAVOFILE? TEDITFROMBRAVO)) (\NAMEDTAB.INIT]) (FILESLOAD TEDITDCL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SCRATCHLEN 64) (CONSTANTS (\SCRATCHLEN 64)) ) (FILESLOAD (LOADCOMP) TEDITDCL) ) (DECLARE%: EVAL@COMPILE DONTCOPY (* ; "Compile-time needs") (DECLARE%: EVAL@COMPILE (RECORD FONT (SIZE STYLE THICKNESS . SLANT)) (RECORD PARA (PARALOOKS . RUNS)) (RECORD RUN (RUNLENGTH . RUNLOOKS)) (RECORD TFBRAVOPAGEFRAMES (TFBRAVODEFAULT TFBRAVOODD TFBRAVOEVEN)) ) (DECLARE%: EVAL@COMPILE (RPAQQ PTSPERINCH 72.27) (RPAQQ DefaultLeftMargin 2540) (RPAQQ DefaultFirstLineLeftMargin 2540) (RPAQQ DefaultRightMargin 19050) (RPAQQ HardwareLeftMargin 2540) (RPAQ HardwareRightMargin (ITIMES 8 2540)) (RPAQQ BRAVO.TRAILER.CHARS (l d z x e y k j c q %( %) %, s S u U b B i I g G v V w W t f o % \ 0 1 2 3 4 5 6 7 8 9)) [CONSTANTS (PTSPERINCH 72.27) (DefaultLeftMargin 2540) (DefaultFirstLineLeftMargin 2540) (DefaultRightMargin 19050) (HardwareLeftMargin 2540) (HardwareRightMargin (ITIMES 8 2540)) (BRAVO.TRAILER.CHARS '(l d z x e y k j c q %( %) %, s S u U b B i I g G v V w W t f o % \ 0 1 2 3 4 5 6 7 8 9] ) ) (DEFINEQ (\TFBRAVO.FIND.LAST.TRAILER (LAMBDA (FILE) (* jds "27-Dec-84 19:13") (* scans backwards from the end of the file trying to find the beginning of the  last Bravo trailer. Returns NIL if not found, otherwise T) (PROG ((STREAM (GETSTREAM FILE))) (SETFILEPTR STREAM -1) (RETURN (COND ((IGREATERP (GETFILEPTR STREAM) 0) (COND ((NEQ (\BACKBIN STREAM) (CHARCODE CR)) (* last character of a trailer must be a carriage return) NIL) (T (while (AND (IGREATERP (GETFILEPTR STREAM) 0) (FMEMB (CHARACTER (\BACKBIN STREAM)) BRAVO.TRAILER.CHARS)) do NIL) (COND ((EQ (\PEEKBIN STREAM) (CHARCODE ^Z)) (* this is a potentially legal trailer) T) (T NIL))))) (T (* empty files are not Bravo files.  It says here!) NIL)))))) (\TFBRAVO.HANDLE.HEADING [LAMBDA (INPUT TEXTOBJ) (* ; "Edited 31-May-91 15:26 by jds") (* Called from  \tfbravo.parse.profile.para) (DECLARE%: USEDFREE NEXTPARAPTR) (PROG ((AFTERHEADINGPTR) PARALOOKS HEADINGDESC) (SETFILEPTR IN NEXTPARAPTR) (* skip over the trailer of the  profile para) (SETQ HEADINGPARA (\TFBRAVO.PARSE.PARA USER.CM.PARALOOKS IN)) (SETQ AFTERHEADINGPTR (GETFILEPTR IN)) (SETQ PARALOOKS (fetch PARALOOKS of HEADINGPARA)) (replace (FMTSPEC FMTPARATYPE) of PARALOOKS with 'PAGEHEADING) (* This is where the vertical tab info is placed for the heading, remove the  special x and y and use them as the position for the descriptor) (SETQ HEADINGDESC (LIST (GENSYM 'PageHeading) (OR (fetch (FMTSPEC FMTSPECIALX) of PARALOOKS) 0) (OR (fetch (FMTSPEC FMTSPECIALY) of PARALOOKS) 0))) (replace (FMTSPEC FMTPARASUBTYPE) of PARALOOKS with (CAR HEADINGDESC)) (replace (FMTSPEC FMTSPECIALX) of PARALOOKS with NIL) (replace (FMTSPEC FMTSPECIALY) of PARALOOKS with NIL) (* now write out the paragraph) (SETFILEPTR IN NEXTPARAPTR) (\TFBRAVO.WRITE.PARAGRAPH HEADINGPARA IN TEXTOBJ MAX.FIXP) (SETQ NEXTPARAPTR AFTERHEADINGPTR) (RETURN HEADINGDESC]) (\TFBRAVO.INIT.CHARLOOKS [LAMBDA NIL (* ; "Edited 31-May-91 15:25 by jds") (* * Creates the charlooks instance which is used as the template for the rest) (PROG ((LOOKS (create CHARLOOKS))) (replace (CHARLOOKS CLSIZE) of LOOKS with (\TFBRAVO.GET.FONTSIZE 0)) (replace (CHARLOOKS CLNAME) of LOOKS (\TFBRAVO.GET.FONTSTYLE 0)) (* (FONTCREATE (  \TFBRAVO.GET.FONTSTYLE)  (fetch (CHARLOOKS CLSIZE) of LOOKS))) (replace (CHARLOOKS CLOFFSET) of LOOKS with 0) (RETURN LOOKS]) (\TFBRAVO.INIT.PAGEFORMAT (LAMBDA (TEXTOBJ) (* gbn "31-May-85 17:13") (* * installs the default values of the page formatting nonsense as textprops) (TEXTPROP TEXTOBJ 'PAGENUMBERS T) (TEXTPROP TEXTOBJ 'PAGENUMBERX 307) (TEXTPROP TEXTOBJ 'PAGENUMBERY 756) (TEXTPROP TEXTOBJ 'TOPMARGIN 72) (TEXTPROP TEXTOBJ 'BOTTOMMARGIN 72) (TEXTPROP TEXTOBJ 'PAGENUMBER.NOTONFIRSTPAGE T))) (\TFBRAVO.INSTALL.PAGEFORMAT [LAMBDA (TEXTOBJ) (* ; "Edited 13-Jun-90 01:00 by mitani") (* * using the information from the profile paragraphs, this function installs  the pageframes) (PROG (PAGENUMBERS PAGENUMBERX PAGENUMBERY TOPMARGIN BOTTOMMARGIN NUMBEROFCOLUMNS BETWEENCOLUMNS ODDHEADINGDESC HEADINGDESC EVENHEADINGDESC HEADING.NOTONFIRSTPAGE PAGENUMBER.NOTONFIRSTPAGE EVENHEADING.NOTONFIRSTPAGE ODDHEADING.NOTONFIRSTPAGE PAGEFRAMES) (for VAR in '(PAGENUMBERS PAGENUMBERX PAGENUMBERY TOPMARGIN BOTTOMMARGIN NUMBEROFCOLUMNS BETWEENCOLUMNS ODDHEADINGDESC HEADINGDESC EVENHEADINGDESC HEADING.NOTONFIRSTPAGE PAGENUMBER.NOTONFIRSTPAGE EVENHEADING.NOTONFIRSTPAGE ODDHEADING.NOTONFIRSTPAGE) do (SET VAR (TEXTPROP TEXTOBJ VAR))) (SETQ PAGEFRAMES (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with (create TFBRAVOPAGEFRAMES ))) (* this assumes that TEdit does not build a default page spec.  If it ever does, then this logic must change.) (* * the default page frame is always built.  It is sometimes built as the only page frame when there is no headings  specified. However, if heading is specified with the not-on-first-page  specified, then we must build the default page frame simply for that reason) (replace (TFBRAVOPAGEFRAMES TFBRAVODEFAULT) of PAGEFRAMES with (TEDIT.SINGLE.PAGEFORMAT (AND PAGENUMBERS (NOT PAGENUMBER.NOTONFIRSTPAGE)) PAGENUMBERX PAGENUMBERY NIL NIL 0 0 TOPMARGIN BOTTOMMARGIN NUMBEROFCOLUMNS NIL BETWEENCOLUMNS [COND (HEADINGDESC (if HEADING.NOTONFIRSTPAGE then NIL else (LIST HEADINGDESC))) (ODDHEADINGDESC (if ODDHEADING.NOTONFIRSTPAGE then NIL else (LIST HEADINGDESC))) (EVENHEADINGDESC (if EVENHEADING.NOTONFIRSTPAGE then NIL else (LIST EVENHEADINGDESC] 'POINTS)) [COND ((OR ODDHEADINGDESC HEADING.NOTONFIRSTPAGE PAGENUMBER.NOTONFIRSTPAGE) (replace TFBRAVOODD of PAGEFRAMES with (TEDIT.SINGLE.PAGEFORMAT PAGENUMBERS PAGENUMBERX PAGENUMBERY NIL NIL 0 0 TOPMARGIN BOTTOMMARGIN NUMBEROFCOLUMNS NIL BETWEENCOLUMNS (COND (ODDHEADINGDESC (LIST ODDHEADINGDESC)) (HEADINGDESC (LIST HEADINGDESC)) (T NIL)) 'POINTS] [COND ((OR EVENHEADINGDESC HEADING.NOTONFIRSTPAGE PAGENUMBER.NOTONFIRSTPAGE) (replace TFBRAVOEVEN of PAGEFRAMES with (TEDIT.SINGLE.PAGEFORMAT PAGENUMBERS PAGENUMBERX PAGENUMBERY NIL NIL 0 0 TOPMARGIN BOTTOMMARGIN NUMBEROFCOLUMNS NIL BETWEENCOLUMNS (COND (EVENHEADINGDESC (LIST EVENHEADINGDESC)) (HEADINGDESC (LIST HEADINGDESC)) (T NIL)) 'POINTS] (RETURN]) (\TFBRAVO.PARSE.PROFILE.PARA (LAMBDA (IN PARA TEXTOBJ) (* gbn " 3-Jun-85 17:23") (* * Parse a Bravo profile paragraph, and set up the corresponding TEdit page  looks, headings, page numbers, Much of the state for building the pageframe  must be stuffed on the textstream, so that after this fn has been called for  the last time, the pageframe can be built) (DECLARE%: USEDFREE NEXTPARAPTR) (PROG (TOKEN TOKENS (PARAEND NEXTPARAPTR)) (* * check that the positioning takes into account binding and edgemargin etc.) (while (ILESSP (GETFILEPTR IN) PARAEND) do (SETQ TOKENS (U-CASE (RATOMS (CHARACTER (CHARCODE EOL)) IN PROFILE.PARA.RDTBL))) (SELECTQ (SETQ TOKEN (pop TOKENS)) (PAGE (* parse the page numbers stuff) (\TFBRAVO.ASSERT 'NUMBERS (pop TOKENS)) (while TOKENS do (SELECTQ (SETQ TOKEN (pop TOKENS)) (NO (TEXTPROP TEXTOBJ 'PAGENUMBERS 'NIL)) (YES (* this is default)) (FIRST (\TFBRAVO.ASSERT 'PAGE (pop TOKENS)) (* If a first page is specified, we can't handle that yet, but at least number  the first page, since the only way to number the first page in Bravo is to  specify the number for the first page. Not-on-first-page is assumed) (TEXTPROP TEXTOBJ 'PAGENUMBER.NOTONFIRSTPAGE 'NIL) (TEXTPROP TEXTOBJ 'FIRSTPAGENO (pop TOKENS))) (NOT-ON-FIRST-PAGE (TEXTPROP TEXTOBJ 'PAGENUMBER.NOTONFIRSTPAGE 'T)) (X (TEXTPROP TEXTOBJ 'PAGENUMBERX (  \TFBRAVO.PARSE.PROFILE.VALUE TOKENS))) (Y (TEXTPROP TEXTOBJ 'PAGENUMBERY (  \TFBRAVO.PARSE.PROFILE.VALUE TOKENS))) (ROMAN (* tough, I don't do Roman Numerals) NIL) (PROGN (* otherwise, just presume we've hit the end of the page number stuff) NIL)))) (COLUMNS (* parse the columns numbers stuff) (TEXTPROP TEXTOBJ 'NUMBEROFCOLUMNS (pop TOKENS)) (while TOKENS do (SELECTQ (SETQ TOKEN (pop TOKENS)) (EDGE (\TFBRAVO.ASSERT 'MARGIN (pop TOKENS)) (TEXTPROP TEXTOBJ 'EDGEMARGIN (  \TFBRAVO.PARSE.PROFILE.VALUE TOKENS))) (BETWEEN (\TFBRAVO.ASSERT 'COLUMNS (pop TOKENS)) (TEXTPROP TEXTOBJ 'BETWEENCOLUMNS (\TFBRAVO.PARSE.PROFILE.VALUE TOKENS))) (PROGN NIL)))) (MARGINS (* parse the margins stuff) (while TOKENS do (SELECTQ (SETQ TOKEN (pop TOKENS)) (TOP (TEXTPROP TEXTOBJ 'TOPMARGIN (  \TFBRAVO.PARSE.PROFILE.VALUE TOKENS))) (BOTTOM (TEXTPROP TEXTOBJ 'BOTTOMMARGIN (\TFBRAVO.PARSE.PROFILE.VALUE TOKENS ))) (BINDING (TEXTPROP TEXTOBJ 'BINDING (  \TFBRAVO.PARSE.PROFILE.VALUE TOKENS))) (PROGN (* otherwise, just presume we've hit the end of the page number stuff) NIL)))) (ODD (\TFBRAVO.ASSERT (pop TOKENS) 'HEADING) (COND ((AND TOKENS (EQ (CAR TOKENS) 'NOT-ON-FIRST-PAGE)) (pop TOKENS) (TEXTPROP TEXTOBJ 'ODDHEADING.NOTONFIRSTPAGE T))) (TEXTPROP TEXTOBJ 'ODDHEADINGDESC (\TFBRAVO.HANDLE.HEADING IN TEXTOBJ))) (EVEN (\TFBRAVO.ASSERT (pop TOKENS) 'HEADING) (COND ((AND TOKENS (EQ (CAR TOKENS) 'NOT-ON-FIRST-PAGE)) (pop TOKENS) (TEXTPROP TEXTOBJ 'EVENHEADING.NOTONFIRSTPAGE T))) (TEXTPROP TEXTOBJ 'EVENHEADINGDESC (\TFBRAVO.HANDLE.HEADING IN TEXTOBJ))) (HEADING (COND ((AND TOKENS (EQ (CAR TOKENS) 'NOT-ON-FIRST-PAGE)) (pop TOKENS) (TEXTPROP TEXTOBJ 'HEADING.NOTONFIRSTPAGE T))) (TEXTPROP TEXTOBJ 'HEADINGDESC (\TFBRAVO.HANDLE.HEADING IN TEXTOBJ))) (LINE (* don't support Line Numbers) NIL) (PRIVATE (* private data stamp bull, ignore) NIL) (PROGN (* do nothing with this line,) NIL))) (* The left margin is 0 for all bravo relative measurements) (COND ((TEXTPROP TEXTOBJ 'NUMBEROFCOLUMNS) (* if this is to be printed multicolumn then determine the column width from  the numberofcolumns and the space between them) (TEXTPROP TEXTOBJ 'COLUMNWIDTH (IQUOTIENT (IDIFFERENCE (IDIFFERENCE (CONSTANT (TIMES 8.5 PTSPERINCH )) (ITIMES 2 (TEXTPROP TEXTOBJ 'EDGEMARGIN))) (ITIMES (SUB1 (TEXTPROP TEXTOBJ ' NUMBEROFCOLUMNS)) (TEXTPROP TEXTOBJ 'BETWEENCOLUMNS))) (TEXTPROP TEXTOBJ 'NUMBEROFCOLUMNS)))))))) (\TFBRAVO.PARSE.PROFILE.VALUE (LAMBDA (TOKENLIST) (* gbn "15-Nov-84 13:48") (* * returns a value always specified in pts, regardless of whether it was that  way in the token list (NB since RPLNODE is being used, there must always be a  token after the value and/or inches sign)) (PROG ((VALUE (PROG1 (CAR TOKENLIST) (RPLNODE2 TOKENLIST (CDR TOKENLIST)))) (POINTSPERINCH 72.27) (INCHES '%")) (if (EQ (CAR TOKENLIST) INCHES) then (SETQ VALUE (TIMES VALUE POINTSPERINCH)) (RPLNODE2 TOKENLIST (CDR TOKENLIST))) (RETURN (FIX VALUE))))) (\TFBRAVO.GET.FONTSIZE (LAMBDA (FONT) (* gbn "19-Sep-84 01:47") (* ADD CL:DECLARATION TO ADMIT THAT YOU ARE USING L FREE, BEST TO REPLACE WITH  AN ARRAY IN FACT) (CADDR (FASSOC FONT (FASSOC 'Font USER.CM.ALIST))))) (\TFBRAVO.GET.FONTSTYLE (LAMBDA (FONT) (* gbn "19-Sep-84 01:46") (* ADD CL:DECLARATION TO ADMIT THAT YOU ARE USING USER.CM.ALIST FREE, BEST TO  REPLACE WITH AN ARRAY IN FACT) (CADR (FASSOC FONT (FASSOC 'Font USER.CM.ALIST))))) (\TFBRAVO.WRITE.RUN [LAMBDA (RUN IN PARALOOKS TEXTOBJ) (* ; "Edited 31-May-91 15:25 by jds") (PROG (START END NAMEDTABNUMBER (LOOKS (fetch RUNLOOKS of RUN))) (SETQ NAMEDTABNUMBER (fetch (CHARLOOKS CLUSERINFO) of (fetch RUNLOOKS of RUN))) (COND ((ILEQ (fetch RUNLENGTH of RUN) 0) (RETURN)) ([AND NAMEDTABNUMBER (EQUAL (PEEKC) (CHARACTER (CHARCODE ^I] (* only treat the run like a tab if it has charcode 9, even if it has a tab  number. Color is overloaded onto tab numbers in BRAVO.  Jerks! Jerks!) (\TFBRAVO.ADD.NAMEDTAB TEXTOBJ NAMEDTABNUMBER PARALOOKS)) (T (SETQ END (IPLUS (SETQ START (GETFILEPTR IN)) (fetch RUNLENGTH of RUN))) (TEDIT.RAW.INCLUDE TEXTOBJ IN START END) (TEDIT.LOOKS TEXTOBJ LOOKS]) (\TFBRAVO.ASSERT (LAMBDA (X Y) (* gbn "19-Sep-84 21:39") (if (NEQ X Y) then (HELP "While parsing profile paragraph, " (CONCAT X " was expected, but " Y " was found."))))) (\SHIFT.DOCUMENT [LAMBDA (PCTB DELTAX) (* ; "Edited 31-May-91 15:26 by jds") (* ;; "shifts all tabs, left and right margins by deltax. DOES NOT VERIFY that this produces reasonable values") (* ; "a change for DFNFLG") (PROG ((PC (\EDITELT PCTB (ADD1 \FirstPieceOffset))) TSPEC LASTPARALOOKS PARALOOKS) (while PC do (COND [(NEQ (fetch (PIECE PPARALOOKS) of PC) LASTPARALOOKS) (* ;  "This is a new set of looks -- go ahead and change it.") (COND ((SETQ TAB.OBJECT (fetch (PIECE POBJ) of PC)) (* ; "shift the tabspec by deltax") (IMAGEOBJPROP TAB.OBJECT 'OBJECTDATUM (IPLUS (fetch OBJECTDATUM of TAB.OBJECT) DELTAX))) ((SETQ PARALOOKS (fetch (PIECE PPARALOOKS) of PC)) (SETQ PARALOOKS (replace (PIECE PPARALOOKS) of PC with (create FMTSPEC using PARALOOKS))) (replace (FMTSPEC 1STLEFTMAR) of PARALOOKS with (IPLUS (fetch (FMTSPEC 1STLEFTMAR) of PARALOOKS) DELTAX)) (replace (FMTSPEC LEFTMAR) of PARALOOKS with (IPLUS (fetch (FMTSPEC LEFTMAR) of PARALOOKS) DELTAX)) (replace (FMTSPEC RIGHTMAR) of PARALOOKS with (IPLUS (fetch (FMTSPEC RIGHTMAR) of PARALOOKS) DELTAX)) (SETQ TSPEC (fetch (FMTSPEC TABSPEC) of PARALOOKS)) (* ;; "only subtract the deltax from the absolute positions, not from the relative tabstop (the car of the tabspec)") (* ;  "this has too much leeway. I think tabspecs are fixed format. Check!") [replace (FMTSPEC TABSPEC) of PARALOOKS with (CONS (CAR TSPEC) (for ELEMENT in (CDR TSPEC) collect (SELECTQ (TYPENAME ELEMENT) (FIXP (IPLUS DELTAX ELEMENT)) (LISTP (CONS (IPLUS DELTAX (CAR ELEMENT)) (CDR ELEMENT))) (NILL] (replace (PIECE PPARALOOKS) of PC with ( \TEDIT.UNIQUIFY.PARALOOKS PARALOOKS TEXTOBJ] (T (replace (PIECE PPARALOOKS) of PC with LASTPARALOOKS))) (SETQ LASTPARALOOKS (fetch (PIECE PPARALOOKS) of PC)) (SETQ PC (fetch (PIECE NEXTPIECE) of PC]) (\TEDIT.BRAVOFILE? (LAMBDA (FILE A B C) (* gbn " 3-Jun-85 21:06") (* Test a file to see if it is a BRAVO file, asking if it is to be converted) (* Returns the name of the user.cm file to be used in the conversion of this  file) (PROG (PLOOKS ENDCONDITION (ORIGINAL.FILE.POSITION (GETFILEPTR FILE)) NAME DIRS) (* first look for a ^z,  (beginning of a Bravo trailer)) (COND ((NOT (\TFBRAVO.FIND.LAST.TRAILER FILE)) (SETFILEPTR FILE ORIGINAL.FILE.POSITION) (RETURN NIL))) (* BIN past the ^z) (BIN FILE) (SETQ PLOOKS (\TEST.PARAGRAPH.LOOKS FILE)) (* if the next symbol is a slash then check if the character looks are valid) (SETQ ENDCONDITION (COND ((EQ (CAR PLOOKS) '\) (repeatuntil (\TEST.CHARACTER.LOOKS FILE))))) (COND ((EQ ENDCONDITION 'BADLOOKS) (SETFILEPTR FILE ORIGINAL.FILE.POSITION) (RETURN NIL)) (T (SETFILEPTR FILE ORIGINAL.FILE.POSITION) (* look for user.cm files in the following order, the directory the file came  from, the connected directory, the login dir, {dsk} device) (SETQ NAME (FULLNAME FILE)) (SETQ DIRS '(T NIL {DSK})) (if (LITATOM NAME) then (push DIRS (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY NAME))) (RETURN (MKATOM (TEDIT.GETINPUT TEXTOBJ "USER.CM file:(NIL to suppress BRAVO conversion) " (FINDFILE 'USER.CM T DIRS))))))))) (\TEST.CHARACTER.LOOKS (LAMBDA (FILE) (* gbn " 6-Feb-84 19:11") (* returns nil until done when it returns BADLOOKS or T) (PROG (PROPERTY VALFLAG TEM (VALUE 0) CHAR) LP (while (NUMBERP (SETQ CHAR (FCHARACTER (BIN FILE)))) do (SETQ VALUE CHAR) (SETQ VALFLAG T)) (COND (PROPERTY (COND ((NULL VALFLAG) (RETURN 'BADLOOKS)) (T NIL)) (SETQ PROPERTY NIL)) (VALFLAG (SETFILEPTR FILE (IDIFFERENCE (GETFILEPTR FILE) (COND ((EQ CHAR (CONSTANT (CHARACTER (CHARCODE EOL)))) 2) (T 1)))) (RETURN NIL))) (COND ((SETQ TEM (SELECTQ CHAR ((s u b i g v S U B I G V) T) NIL)) T (SETQ PROPERTY T)) ((SETQ TEM (SELECTQ CHAR ((t f o) T) NIL)) T) ((EQ CHAR (CONSTANT (CHARACTER (CHARCODE EOL)))) (RETURN T)) ((NEQ CHAR '% ) (RETURN 'BADLOOKS))) (SETQ VALUE 0) (SETQ VALFLAG NIL) (GO LP)))) (\TEST.PARAGRAPH.LOOKS (LAMBDA (FILE) (* gbn " 6-Feb-84 18:30") (* test if the sequence form valid paragraph looks, do not allow empty  paragraph looks) (PROG ((VALUE 0) CHAR PROPERTY (TABS) NONEMPTY) LP (while (NUMBERP (SETQ CHAR (FCHARACTER (BIN FILE)))) do (SETQ VALUE CHAR)) (COND ((SELECTQ PROPERTY ((l d z x e y k j c q) (SETQ NONEMPTY T)) NIL) (* keep going, these are all ok) NIL) (T (SELECTQ PROPERTY (%( (SELECTQ CHAR (%) (SETQ NONEMPTY T)) (%, (COND ((IGREATERP VALUE 14) (* not a legal tab no) (RETURN NIL)) (T (SETQ NONEMPTY T))) T) (* not legal after) (RETURN NIL))) (%, (SETQ NONEMPTY T)) ((%) (SETQ NONEMPTY T))) (* not a legal paragraph look) (RETURN NIL)))) (COND ((AND (NEQ CHAR (CONSTANT (CHARACTER (CHARCODE EOL)))) (NEQ CHAR '\)) (SETQ PROPERTY CHAR) (SETQ VALUE 0) (GO LP))) (if NONEMPTY then (RETURN CHAR) else (RETURN))))) ) (DEFINEQ (\TFBRAVO.COPY.NAMEDTAB (LAMBDA (OBJ PIECE OLDCH NEWCH) (* jds " 8-Feb-84 19:58") (* just creates a named tab stop with the same value as the original) (* Note that the USING phrase will create a new TEDITOBJ as well as a  TEDITUSEROBJ) (COPY OBJ))) (\TFBRAVO.PUT.NAMEDTAB (LAMBDA (OBJ CHARSTREAM FMTSTREAM) (* jds " 8-Feb-84 19:59") (* just writes the position of the tab so that a new one can be created on read) (PRINT (IMAGEOBJPROP OBJ 'OBJECTDATUM) CHARSTREAM))) (\TFBRAVO.GET.NAMEDTAB (LAMBDA (CHARSTREAM TEXTSTREAM) (* jds " 8-Feb-84 19:59") (* should read the position, create an obj and return it) (IMAGEOBJCREATE (RATOM CHARSTREAM) \NAMEDTAB.IMAGEFNS))) (\TFBRAVO.ADD.NAMEDTAB [LAMBDA (TEXTOBJ TABNO PARALOOKS) (* ; "Edited 31-May-91 15:26 by jds") [COND ((NEQ TABNO 0) (BIN) (* Advance the input stream past the  tab character) (TEDIT.INSERT.OBJECT (IMAGEOBJCREATE (LISTGET (fetch (FMTSPEC FMTUSERINFO) of PARALOOKS ) (SUB1 TABNO)) \NAMEDTAB.IMAGEFNS) TEXTOBJ (ADD1 (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ] (* one is subtracted from the tabno because BRAVO seems to specify there  numbers differently in the run from the paragraph looks) ]) (\NAMEDTABNYET (LAMBDA NIL (* gbn "30-Dec-83 17:23") (PROMPTPRINT "Can't do that to a named tab!"))) (\NAMEDTABSIZE (LAMBDA (TABOBJECT IMAGESTREAM CURRENTX RIGHTMARGIN MODE) (* gbn "19-May-84 22:52") (PROG ((PTSIZE (IMAGEOBJPROP TABOBJECT 'OBJECTDATUM)) (MODE (if (STKPOS '\FORMATLINE) then 'DISPLAY else 'HARDCOPY))) (* hack until I get called with the right mode.  SHit!) (RETURN (create IMAGEBOX XSIZE _ (IMAX 1 (IDIFFERENCE (COND ((EQ MODE 'DISPLAY) PTSIZE) (T (ITIMES PTSIZE 35))) CURRENTX)) YSIZE _ 1 YDESC _ 0 XKERN _ 0))))) (\NAMEDTAB.INIT (LAMBDA NIL (* jds "22-Aug-84 14:49") (SETQ \NAMEDTAB.IMAGEFNS (IMAGEFNSCREATE 'NILL '\NAMEDTABSIZE '\TFBRAVO.PUT.NAMEDTAB ' \TFBRAVO.GET.NAMEDTAB '\TFBRAVO.COPY.NAMEDTAB 'NILL 'NILL 'MOVE.NAMED.TAB 'NILL 'NILL 'NILL 'NILL 'NIL)))) ) (DEFINEQ (\TFBRAVO.APPLY.PARALOOKS [LAMBDA (PARALOOKS LENGTH TEXTOBJ MARGIN.CANDIDATE) (* ; "Edited 31-May-91 15:26 by jds") (* Returns the smaller of%: the left margin so far, the smallest left margin in  this para) (PROG (TABPHRASE (SMALLEST.MARGIN MARGIN.CANDIDATE)) (TEDIT.PARALOOKS TEXTOBJ PARALOOKS (ADD1 (IDIFFERENCE (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) LENGTH)) LENGTH) (TEDIT.SETSEL TEXTOBJ (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) 1 'RIGHT) (* now return the smallest margin) (RETURN (IMIN (fetch (FMTSPEC RIGHTMAR) of PARALOOKS) (fetch (FMTSPEC LEFTMAR) of PARALOOKS) (fetch (FMTSPEC 1STLEFTMAR) of PARALOOKS) MARGIN.CANDIDATE]) (TEDITFROMBRAVO [LAMBDA (FILIN USER.CM TEXTSTREAM) (* ; "Edited 13-Jun-90 01:00 by mitani") (* * Top level entry for conversion from Bravo to a Textstream which is  returned) (INFILE FILIN) (PROG (OLDPLOOKS CURRENT.PARAGRAPH USER.CM.ALIST START NEXTPARAPTR TEDITWINDOW TEXTOBJ (NONFEATURES NIL) (SMALLEST.MARGIN MAX.FIXP) (NEWSTREAM (OR TEXTSTREAM (OPENTEXTSTREAM ""))) USER.CM.PARALOOKS USER.CM.CHARLOOKS) (DECLARE (SPECVARS NOUT)) (SETQ TEXTOBJ (TEXTOBJ NEWSTREAM)) (SETQ USER.CM.ALIST (\TFBRAVO.READ.USER.CM USER.CM)) (* read the user.cm file and produce  the alist of default values) (CLOSEF? USER.CM) (SETQ OLDPLOOKS (SETQ USER.CM.PARALOOKS (\TFBRAVO.INIT.PARALOOKS USER.CM.ALIST))) (SETQ USER.CM.CHARLOOKS (\TFBRAVO.INIT.CHARLOOKS)) (SETFILEPTR FILIN 0) (\TFBRAVO.INIT.PAGEFORMAT TEXTOBJ) (ERSETQ (first (SETQ START (GETFILEPTR FILIN)) (SETQ CURRENT.PARAGRAPH (\TFBRAVO.PARSE.PARA OLDPLOOKS FILIN)) while (fetch RUNS of CURRENT.PARAGRAPH) do (SETQ NEXTPARAPTR (GETFILEPTR FILIN)) (SETFILEPTR FILIN START) (SETQ SMALLEST.MARGIN (\TFBRAVO.WRITE.PARAGRAPH CURRENT.PARAGRAPH FILIN TEXTOBJ SMALLEST.MARGIN)) (SETFILEPTR FILIN NEXTPARAPTR) (SETQ OLDPLOOKS (fetch PARALOOKS of CURRENT.PARAGRAPH)) (SETQ START (GETFILEPTR FILIN)) (SETQ CURRENT.PARAGRAPH (\TFBRAVO.PARSE.PARA OLDPLOOKS FILIN)) finally (* (\SHIFT.DOCUMENT  (fetch (TEXTOBJ PCTB) of TEXTOBJ)  (MINUS SMALLEST.MARGIN))) NIL)) (CLOSEF (INPUT)) (\TFBRAVO.INSTALL.PAGEFORMAT TEXTOBJ) (RETURN NEWSTREAM]) (\TFBRAVO.WRITE.PARAGRAPH [LAMBDA (PARA INFILE TEXTOBJ MARGIN.CANDIDATE) (* ; "Edited 31-May-91 15:26 by jds") (* outputs the character runs, writes an EOL, then apply paragraph looks.  Returns the smallest left margin seen to date) (* * this is not a guaranteed free field.  Perhaps later the profile bit will have to be elsewhere.) (SELECTQ (fetch (FMTSPEC FMTPARATYPE) of (fetch PARALOOKS of PARA)) (PROFILE (replace (FMTSPEC FMTPARATYPE) of (fetch PARALOOKS of PARA) with NIL) (\TFBRAVO.PARSE.PROFILE.PARA INFILE PARA TEXTOBJ) MARGIN.CANDIDATE) (PROG (LENGTH) (SETQ LENGTH (ADD1 (\TFBRAVO.WRITE.RUNS PARA INFILE TEXTOBJ))) (\TFBRAVO.EOLS 1 TEXTOBJ) (RETURN (\TFBRAVO.APPLY.PARALOOKS (fetch PARALOOKS of PARA) LENGTH TEXTOBJ MARGIN.CANDIDATE]) (\TFBRAVO.WRITE.RUNS (LAMBDA (PARA INFILE TEXTOBJ) (* gbn "18-Sep-84 16:29") (DECLARE (USEDFREE UNDERLINE SUPERSCRIPT)) (PROG ((RUNS (fetch RUNS of PARA)) (PARALOOKS (fetch PARALOOKS of PARA)) (LENGTH 0)) (for RUN in old RUNS do (\TFBRAVO.WRITE.RUN RUN INFILE PARALOOKS TEXTOBJ) (SETQ LENGTH (IPLUS (fetch RUNLENGTH of RUN) LENGTH))) (RETURN LENGTH)))) (\TFBRAVO.SPREAD.LOOKS (LAMBDA (RUN LOOKS) (* jds "22-Aug-84 14:53") (DECLARE (USEDFREE STYLE SLANT THICKNESS SIZE OVERSTRIKE UNDERLINE SUPERSCRIPT)) (for INSTR in (fetch RUNLOOKS of RUN) do (SELECTQ (CAR INSTR) (Bold (LISTPUT LOOKS 'WEIGHT (COND ((CDR INSTR) 'BOLD) (T 'MEDIUM)))) (Font (LISTPUT LOOKS 'SIZE (\TFBRAVO.GET.FONTSIZE (CDR INSTR))) (LISTPUT LOOKS 'FAMILY (\TFBRAVO.GET.FONTSTYLE (CDR INSTR)))) (Italic (LISTPUT LOOKS 'SLOPE (COND ((CDR INSTR) 'ITALIC) (T 'REGULAR)))) (Overstrike (add OVERSTRIKE 1)) (Underline (LISTPUT LOOKS 'UNDERLINE (COND ((CDR INSTR) 'ON) (T 'OFF)))) (Superscript (COND ((IGREATERP (CDR INSTR) 127) (* turn off subscripting and set superscripting, though possibly to zero) (LISTPUT LOOKS 'SUBSCRIPT (IDIFFERENCE 256 (CDR INSTR))) (LISTPUT LOOKS 'SUPERSCRIPT NIL)) (T (LISTPUT LOOKS 'SUPERSCRIPT (CDR INSTR)) (LISTPUT LOOKS 'SUBSCRIPT NIL)))) NIL)) LOOKS)) (\TFBRAVO.PARSE.PARA (LAMBDA (OLDPLOOKS FILE) (* gbn "31-May-85 22:08") (* PLOOKS are the paragraph looks, and RUNi are the character runs in the form  returned by READCHARACTERLOOKS, except that the character count for the last  run has been filled in correctly. Leaves the input file pointer at the end of  the trailer, after the EOL.) (PROG (LEN PLOOKS RUNS ORIGPTR) (SETQ ORIGPTR (GETFILEPTR FILE)) (SETQ LEN (FILEPOS (CHARACTER (CHARCODE ^Z)) FILE)) (COND ((NOT LEN) (RETURN (create PARA PARALOOKS _ DefaultParagraphLooks RUNS _ NIL)))) (SETQ LEN (IDIFFERENCE LEN ORIGPTR)) (BIN FILE) (* BIN past the ^z) (SETQ PLOOKS (\TFBRAVO.READ.PARALOOKS OLDPLOOKS FILE)) (COND ((NEQ (CAR (PROG1 PLOOKS (SETQ PLOOKS (CDR PLOOKS)))) '\) (RETURN (create PARA PARALOOKS _ PLOOKS RUNS _ (LIST (create RUN RUNLENGTH _ LEN RUNLOOKS _ (\TFBRAVO.FONT.FROM.CHARLOOKS USER.CM.CHARLOOKS))))))) CLP (while (fetch RUNLENGTH of (CAR (push RUNS (\TFBRAVO.READ.CHARLOOKS FILE)))) do (SETQ LEN (IDIFFERENCE LEN (fetch RUNLENGTH of (CAR RUNS))))) (replace RUNLENGTH of (CAR RUNS) with LEN) (RETURN (create PARA PARALOOKS _ PLOOKS RUNS _ (DREVERSE RUNS)))))) (\TFBRAVO.INIT.PARALOOKS [LAMBDA (USER.CM.LOOKS) (* ; "Edited 31-May-91 15:26 by jds") (* * creates the first paragraph looks from the USER.CM) (PROG ((INITPARALOOKS (create FMTSPEC using TEDIT.DEFAULT.FMTSPEC)) LM VALUE 1LM (MICASPERPOINT 35)) (SETQ HardwareWidth (IDIFFERENCE HardwareRightMargin HardwareLeftMargin)) (* Basic page width) (SETQ DefaultParagraphLooks USER.CM.LOOKS) (COND [(SETQ LM (CDR (ASSOC 'LeftMargin DefaultParagraphLooks] (T (SETQ LM HardwareLeftMargin))) (COND [(SETQ 1LM (CDR (ASSOC 'FirstLineLeftMargin DefaultParagraphLooks] (T (SETQ 1LM LM))) (replace (FMTSPEC LEFTMAR) of INITPARALOOKS with (IQUOTIENT LM MICASPERPOINT)) (replace (FMTSPEC 1STLEFTMAR) of INITPARALOOKS with (IQUOTIENT 1LM MICASPERPOINT)) (replace (FMTSPEC LINELEAD) of INITPARALOOKS with (COND ((SETQ VALUE (ASSOC 'LineLeading DefaultParagraphLooks )) (CDR VALUE)) (T 1))) (replace (FMTSPEC LEADBEFORE) of INITPARALOOKS with (COND ((SETQ VALUE (ASSOC ' ParagraphLeading DefaultParagraphLooks )) (CDR VALUE)) (T 1))) (replace (FMTSPEC RIGHTMAR) of INITPARALOOKS with (IQUOTIENT (COND ((SETQ VALUE (ASSOC 'RightMargin DefaultParagraphLooks)) (CDR VALUE)) (T DefaultRightMargin)) MICASPERPOINT)) (replace (FMTSPEC LEADAFTER) of INITPARALOOKS with 0) (replace (FMTSPEC TABSPEC) of INITPARALOOKS with (LIST NIL)) (replace (FMTSPEC FMTSPECIALX) of INITPARALOOKS with 0) (replace (FMTSPEC FMTSPECIALY) of INITPARALOOKS with 0) (RETURN INITPARALOOKS]) (\TFBRAVO.READ.PARALOOKS [LAMBDA (OLDLOOKS FILE) (* ; "Edited 31-May-91 15:26 by jds") (PROG ((TEDITPARALOOKS (create FMTSPEC using USER.CM.PARALOOKS)) LMFLAG FLLMFLAG PROPERTY CHAR TABINDEX TEM (VALUE 0) (MICASPERPOINT 35)) (replace (FMTSPEC TABSPEC) of TEDITPARALOOKS with (COPY (fetch (FMTSPEC TABSPEC) of OLDLOOKS))) (replace (FMTSPEC FMTUSERINFO) of TEDITPARALOOKS with (COPY (fetch (FMTSPEC FMTUSERINFO ) of OLDLOOKS))) LP (while [NUMBERP (SETQ CHAR (FCHARACTER (BIN FILE] do (SETQ VALUE (IPLUS (ITIMES VALUE 10) CHAR))) [COND ((SELECTQ PROPERTY (l (SETQQ LMFLAG LeftMargin) (replace (FMTSPEC LEFTMAR) of TEDITPARALOOKS with (IQUOTIENT VALUE MICASPERPOINT ))) (d (SETQQ FLLMFLAG FirstLineLeftMargin) (replace (FMTSPEC 1STLEFTMAR) of TEDITPARALOOKS with (IQUOTIENT VALUE MICASPERPOINT) )) (z (replace (FMTSPEC RIGHTMAR) of TEDITPARALOOKS with (IQUOTIENT VALUE MICASPERPOINT ))) (x (replace (FMTSPEC LINELEAD) of TEDITPARALOOKS with VALUE)) (e (replace (FMTSPEC LEADAFTER) of TEDITPARALOOKS with 0) (replace (FMTSPEC LEADBEFORE) of TEDITPARALOOKS with VALUE)) (y (* (COND ((IEQP VALUE 65535)  (SETQ VALUE NIL)))) (* vertical tabs are supported) (replace (FMTSPEC FMTSPECIALX) of TEDITPARALOOKS with 0) (replace (FMTSPEC FMTSPECIALY) of TEDITPARALOOKS with VALUE)) (k (* same with Keep) 'Keep) (w 'HardcopyMode) NIL)) ((SETQ TEM (SELECTQ PROPERTY (j (replace (FMTSPEC QUAD) of TEDITPARALOOKS with 'JUSTIFIED)) (c (replace (FMTSPEC QUAD) of TEDITPARALOOKS with 'CENTERED)) (q (* not a legal value for FMTPARATYPE But it signals that this is a profile  paragraph) (replace (FMTSPEC FMTPARATYPE) of TEDITPARALOOKS with 'PROFILE)) NIL))) (T (SELECTQ PROPERTY (%( (SELECTQ CHAR (%) (RPLACA (fetch (FMTSPEC TABSPEC) of TEDITPARALOOKS) (IQUOTIENT VALUE MICASPERPOINT))) (%, [COND ((IGREATERP VALUE 14) (HELP VALUE '" is not a legal tab #"] (SETQ TABINDEX VALUE)) (HELP CHAR '" is not legal after ("))) (%, [COND ((NOT (IEQP VALUE 65535)) (* this is not a delete tab, record  it) (SETQ VALUE (IQUOTIENT VALUE MICASPERPOINT)) (* * returning to adding a normal tab as well, since there are docs, e.b.  refreminder.bravo which do not have named tab looks on the tab chars  (* I no longer gratuitously add a normal tab at the position of each named tab.  Turns out that, in some cases, that will change the meaning of an already  present unnamed tab. (RPLACD (fetch (FMTSPEC TABSPEC) of TEDITPARALOOKS)  (CONS (CONS VALUE (QUOTE LEFT)) (CDR (fetch  (FMTSPEC TABSPEC) of TEDITPARALOOKS)))))) [RPLACD (fetch (FMTSPEC TABSPEC) of TEDITPARALOOKS) (CONS (CONS VALUE 'LEFT) (CDR (fetch (FMTSPEC TABSPEC) of TEDITPARALOOKS] (replace (FMTSPEC FMTUSERINFO) of TEDITPARALOOKS with (NCONC (LIST TABINDEX VALUE) (fetch (FMTSPEC FMTUSERINFO) of TEDITPARALOOKS ]) ((%) NIL)) (HELP CHAR '" is not a legal paragraph look"] (COND ((AND [NEQ CHAR (CONSTANT (CHARACTER (CHARCODE EOL] (NEQ CHAR '\)) (SETQ PROPERTY CHAR) (SETQ VALUE 0) (GO LP))) [COND ((AND LMFLAG (NOT FLLMFLAG)) (* If there was a Left margin but no  firstline left then default it) (replace (FMTSPEC 1STLEFTMAR) of TEDITPARALOOKS with (fetch (FMTSPEC LEFTMAR) of TEDITPARALOOKS ] (RETURN (CONS CHAR TEDITPARALOOKS)) (* return the looks together with  the indication of how the looks  ended) ]) (\TFBRAVO.READ.CHARLOOKS [LAMBDA (FILE) (* ; "Edited 31-May-91 15:25 by jds") (* this function reads the character looks trailer building a TEDIT charlooks  record. Most fields are immediately valid, however, the tabcolor is stored in  the cluserinfo field of the looks, and the font is still in numeric form) (PROG ((TEDITCHARLOOKS (create CHARLOOKS using USER.CM.CHARLOOKS)) PROPERTY VALFLAG TEM (VALUE 0) CHAR) (RETURN (while T do (* Keep going until we run out of  things to read) (while [NUMBERP (SETQ CHAR (FCHARACTER (BIN FILE] do (* If we're looking at digits, read  them as a number) (SETQ VALUE (IPLUS (ITIMES VALUE 10) CHAR)) (SETQ VALFLAG T)) [COND (PROPERTY [COND ((NULL VALFLAG) (HELP PROPERTY '"- no value for character look")) (T (SELECTQ PROPERTY (TabColor (* Hide the named tab in the user field of the looks where writerun can look  for it) (replace (CHARLOOKS CLUSERINFO) of TEDITCHARLOOKS with VALUE)) (Font (replace (CHARLOOKS CLSIZE) of TEDITCHARLOOKS with (\TFBRAVO.GET.FONTSIZE VALUE) ) (replace (CHARLOOKS CLNAME) of TEDITCHARLOOKS with (\TFBRAVO.GET.FONTSTYLE VALUE)) (* (* a hack so that font is  cumulative. Change the  "default charlooks" to reflect this  font each time) (replace  (CHARLOOKS CLSIZE) of  USER.CM.CHARLOOKS with  (fetch (CHARLOOKS CLSIZE) of  TEDITCHARLOOKS)) (replace  (CHARLOOKS CLNAME) of  USER.CM.CHARLOOKS with  (fetch (CHARLOOKS CLNAME) of  TEDITCHARLOOKS))) ) (Superscript (replace (CHARLOOKS CLOFFSET) of TEDITCHARLOOKS with (COND ((IGREATERP VALUE 127) (* is a negative numero) (IDIFFERENCE VALUE 256 )) (T VALUE)))) (HELP PROPERTY " is unknown property in \TFBRAVO.READ.CHARLOOKS" ] (SETQ PROPERTY NIL)) (VALFLAG [SETFILEPTR FILE (IDIFFERENCE (GETFILEPTR FILE) (COND ([EQ CHAR (CONSTANT (CHARACTER (CHARCODE EOL] 2) (T 1] (RETURN (CONS VALUE (\TFBRAVO.FONT.FROM.CHARLOOKS TEDITCHARLOOKS] (COND ((SELECTQ CHAR (s (replace (CHARLOOKS CLSTRIKE) of TEDITCHARLOOKS with T)) (S (replace (CHARLOOKS CLSTRIKE) of TEDITCHARLOOKS with NIL) T) (u (replace (CHARLOOKS CLULINE) of TEDITCHARLOOKS with T)) (U (replace (CHARLOOKS CLULINE) of TEDITCHARLOOKS with NIL) T) (b (replace (CHARLOOKS CLBOLD) of TEDITCHARLOOKS with T)) (B (replace (CHARLOOKS CLBOLD) of TEDITCHARLOOKS with NIL) T) (i (replace (CHARLOOKS CLITAL) of TEDITCHARLOOKS with T)) (I (replace (CHARLOOKS CLITAL) of TEDITCHARLOOKS with NIL) T) (g '(Graphic . T)) (G '(Graphic)) (v (replace (CHARLOOKS CLINVISIBLE) of TEDITCHARLOOKS with NIL) T) (V (replace (CHARLOOKS CLINVISIBLE) of TEDITCHARLOOKS with T)) NIL) (SETQ PROPERTY NIL)) ((SETQ TEM (SELECTQ CHAR (t 'TabColor) (f 'Font) (o 'Superscript) NIL)) (SETQ PROPERTY TEM)) [[EQ CHAR (CONSTANT (CHARACTER (CHARCODE EOL] (RETURN (CONS NIL (\TFBRAVO.FONT.FROM.CHARLOOKS TEDITCHARLOOKS] ((NEQ CHAR '% ) (HELP CHAR " is not a legal character look"))) (SETQ VALUE 0) (SETQ VALFLAG NIL]) (\TFBRAVO.READ.USER.CM (LAMBDA (FILE) (* gbn "17-Sep-84 18:53") (* digests a user.cm file returning an alist of contents.  Returns ((Font)) if no bravo section of user.cm file) (PROG ((RDTBL USER.CM.RDTBL) (ALIST (LIST (LIST 'Font))) LINE) (* (ERRORTYPELST (CONS (QUOTE (16 (RETFROM  (QUOTE RATOM) (QUOTE END.OF.FILE)))) ERRORTYPELST)) The errortypelist inclusion  guarantees that eof's will return from RATOM as  (CHARCODE 13)) (* (DECLARE (SPECVARS ERRORTYPELST))) (SETBRK (CHARCODE (%, %: = EOL)) NIL RDTBL) (SETSEPR '(% ) NIL RDTBL) (OR (OPENP FILE) (SETQ FILE (OPENSTREAM FILE 'INPUT 'OLD))) (COND ((NOT (FILEPOS (CONCAT '"[BRAVO]" (CONSTANT (CHARACTER (CHARCODE EOL)))) FILE NIL NIL NIL T)) (RETURN ALIST))) (* Read lines of the user.cm file until getting the empty line caused by eof  (and the errortypelst entry) or until a line starts with "[" %.) LLP (COND ((NOT (NLSETQ (SETQ LINE (RATOMS (CONSTANT (CHARACTER (CHARCODE EOL))) FILE RDTBL)))) (RETURN ALIST))) (* If the "[BRAVO]" section is the  last one) (COND ((NULL LINE) (* ignore blank lines) (GO LLP)) ((EQ (CAR LINE) 'END.OF.FILE) (RETURN ALIST)) ((EQ (NTHCHAR (CAR LINE) 1) '%[) (* if "[" is the first character of the line, return the alist so far, because  this is the beginning of the next section of the user.cm) (RETURN ALIST)) ((NEQ (CADR LINE) '%:) (GO LLP))) (SELECTQ (PROG1 (CAR LINE) (SETQ LINE (CDDR LINE))) (FONT (COND ((NUMBERP (CAR LINE)) (NCONC1 (FASSOC 'Font ALIST) (LIST (CAR LINE) (CADR LINE) (CADDR LINE)))))) (TABS (SETQ ALIST (NCONC (\TFBRAVO.GETPARAMS LINE '((Tabs standard tab width))) ALIST))) (MARGINS (SETQ ALIST (NCONC (\TFBRAVO.GETPARAMS LINE '((LeftMargin left margin) (RightMargin right margin))) ALIST))) (LEAD (SETQ ALIST (NCONC (\TFBRAVO.GETPARAMS LINE '((ParagraphLeading paragraph leading ) (LineLeading line leading))) ALIST))) NIL) (GO LLP)))) (\TFBRAVO.GETPARAMS (LAMBDA (LIS NAMES) (* jds "27-Aug-84 09:37") (PROG ((L LIS) ALIST TEST REST) (MAP L (FUNCTION (LAMBDA (WORDL) (COND ((LITATOM (CAR WORDL)) (FRPLACA WORDL (\TFBRAVO.LCASER (CAR WORDL)))))))) LP (COND ((NULL L) (RETURN ALIST))) (SETQ TEST NAMES) NLP (COND ((SETQ REST (\TFBRAVO.PARAMNAMEP L (CDAR TEST))) (SETQ ALIST (CONS (CONS (CAAR TEST) (CAR REST)) ALIST))) ((SETQ TEST (CDR TEST)) (GO NLP))) (SETQ L (CDR (FMEMB '%, L))) (GO LP)))) (\TFBRAVO.PARAMNAMEP (LAMBDA (LIS NAME) (* lpd "16-JUL-77 19:55") (PROG ((L LIS)) (RETURN (AND (EVERY NAME (FUNCTION (LAMBDA (WORD) (PROG1 (EQ WORD (CAR L)) (SETQ L (CDR L)))))) (EQ (CAR L) '=) (CDR L)))))) (\TFBRAVO.EOLS [LAMBDA (N TEXTOBJ) (* ; "Edited 13-Jun-90 01:00 by mitani") (* ;; "Insert N carriage-returns into the document named by TEXTOBJ at the current location.") (for I FROM 1 to N do (TEDIT.INSERT TEXTOBJ (CHARCODE EOL))) (TEDIT.SETSEL TEXTOBJ (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ) 1 'RIGHT]) (\TFBRAVO.LCASER (LAMBDA (WORD) (* lpd "23-SEP-77 14:40") (PROG ((LST (CHCON WORD)) Z) (MAP LST (FUNCTION (LAMBDA (L) (COND ((AND (IGREATERP (SETQ Z (CAR L)) 64) (ILESSP Z 91)) (* Z is an uppercase character) (FRPLACA L (IPLUS Z 32))))))) (RETURN (PACKC LST))))) (\TFBRAVO.FONT.FROM.CHARLOOKS [LAMBDA (CHARLOOKS) (* ; "Edited 31-May-91 15:26 by jds") (* Takes a CHARLOOKS with fields filled in  (CLNAME = family name) and creates the font to fill it.) [replace (CHARLOOKS CLFONT) of CHARLOOKS with (FONTCREATE (fetch (CHARLOOKS CLNAME) of CHARLOOKS) (fetch (CHARLOOKS CLSIZE) of CHARLOOKS) (LIST (COND ((fetch (CHARLOOKS CLBOLD ) of CHARLOOKS) 'BOLD) (T 'MEDIUM)) (COND ((fetch (CHARLOOKS CLITAL ) of CHARLOOKS) 'ITALIC) (T 'REGULAR)) 'REGULAR] CHARLOOKS]) ) (RPAQ? USER.CM.RDTBL (COPYREADTABLE)) (RPAQ? PROFILE.PARA.RDTBL (COPYREADTABLE)) (SETSYNTAX (CHARCODE %:) 'SEPRCHAR PROFILE.PARA.RDTBL) (SETSYNTAX (CHARCODE EOL) 'BREAKCHAR PROFILE.PARA.RDTBL) (SETSYNTAX (CHARCODE ^Z) 'SEPRCHAR PROFILE.PARA.RDTBL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \NAMEDTAB.IMAGEFNS) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDTOVAR TEDIT.INPUT.FORMATS (\TEDIT.BRAVOFILE? TEDITFROMBRAVO)) (\NAMEDTAB.INIT) ) (PUTPROPS TFBRAVO COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1990 1991 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4236 34112 (\TFBRAVO.FIND.LAST.TRAILER 4246 . 5739) (\TFBRAVO.HANDLE.HEADING 5741 . 7619) (\TFBRAVO.INIT.CHARLOOKS 7621 . 8437) (\TFBRAVO.INIT.PAGEFORMAT 8439 . 8917) ( \TFBRAVO.INSTALL.PAGEFORMAT 8919 . 13556) (\TFBRAVO.PARSE.PROFILE.PARA 13558 . 22071) ( \TFBRAVO.PARSE.PROFILE.VALUE 22073 . 22840) (\TFBRAVO.GET.FONTSIZE 22842 . 23158) ( \TFBRAVO.GET.FONTSTYLE 23160 . 23488) (\TFBRAVO.WRITE.RUN 23490 . 24597) (\TFBRAVO.ASSERT 24599 . 24911) (\SHIFT.DOCUMENT 24913 . 28789) (\TEDIT.BRAVOFILE? 28791 . 30838) (\TEST.CHARACTER.LOOKS 30840 . 32480) (\TEST.PARAGRAPH.LOOKS 32482 . 34110)) (34113 37660 (\TFBRAVO.COPY.NAMEDTAB 34123 . 34482) ( \TFBRAVO.PUT.NAMEDTAB 34484 . 34780) (\TFBRAVO.GET.NAMEDTAB 34782 . 35059) (\TFBRAVO.ADD.NAMEDTAB 35061 . 36038) (\NAMEDTABNYET 36040 . 36205) (\NAMEDTABSIZE 36207 . 37092) (\NAMEDTAB.INIT 37094 . 37658)) (37661 73665 (\TFBRAVO.APPLY.PARALOOKS 37671 . 38702) (TEDITFROMBRAVO 38704 . 41106) ( \TFBRAVO.WRITE.PARAGRAPH 41108 . 42130) (\TFBRAVO.WRITE.RUNS 42132 . 42713) (\TFBRAVO.SPREAD.LOOKS 42715 . 45687) (\TFBRAVO.PARSE.PARA 45689 . 47594) (\TFBRAVO.INIT.PARALOOKS 47596 . 50920) ( \TFBRAVO.READ.PARALOOKS 50922 . 58098) (\TFBRAVO.READ.CHARLOOKS 58100 . 66233) (\TFBRAVO.READ.USER.CM 66235 . 69565) (\TFBRAVO.GETPARAMS 69567 . 70396) (\TFBRAVO.PARAMNAMEP 70398 . 70846) (\TFBRAVO.EOLS 70848 . 71261) (\TFBRAVO.LCASER 71263 . 71815) (\TFBRAVO.FONT.FROM.CHARLOOKS 71817 . 73663))))) STOP \ No newline at end of file diff --git a/library/TTYCHAT b/library/TTYCHAT new file mode 100644 index 00000000..251fd17b --- /dev/null +++ b/library/TTYCHAT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "13-Jun-90 01:04:08" {DSK}local>lde>lispcore>library>TTYCHAT.;2 2460 changes to%: (VARS TTYCHATCOMS) previous date%: "20-Nov-86 18:15:36" {DSK}local>lde>lispcore>library>TTYCHAT.;1) (* ; " Copyright (c) 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TTYCHATCOMS) (RPAQQ TTYCHATCOMS ( (* ;;; "CHAT interface for the DLion/DayBreak TTY port") (FNS TTYCHAT.HOST.FILTER TTYCHAT.OPEN) (ADDVARS (NETWORKOSTYPES (TTY)) (CHAT.PROTOCOLTYPES (TTY . TTYCHAT.HOST.FILTER))) (DECLARE%: DONTCOPY (FILES (LOADCOMP) CHATDECLS)) (FILES DLTTY RS232CHAT CHAT))) (* ;;; "CHAT interface for the DLion/DayBreak TTY port") (DEFINEQ (TTYCHAT.HOST.FILTER (LAMBDA (NAME) (* ejs%: "27-Aug-85 16:45") (COND ((FMEMB (U-CASE NAME) '(TTY PRINTER)) (COND ((NULL \TTYFLG) (TTY.INIT TTY.DEFAULT.INIT.INFO))) (LIST 'TTY (FUNCTION TTYCHAT.OPEN)))))) (TTYCHAT.OPEN [LAMBDA (HOST) (* lmm "20-Nov-86 18:14") (* ;;; "Return a pair of SPP streams for a chat connection, or NIL. Add CHAT specific operations to the STREAM via STREAMPROP.") (PROG (OUTSTREAM STREAM) (SETQ STREAM (OPENSTREAM '{TTY} 'BOTH)) [TTY.SET.PARAMETERS '((CTS . T) (DSR . T] (SETQ OUTSTREAM STREAM) (STREAMPROP STREAM 'SETDISPLAYTYPE (FUNCTION NILL)) (STREAMPROP STREAM 'LOGINFO (FUNCTION NILL)) (STREAMPROP STREAM 'FLUSH&WAIT (FUNCTION NILL)) (STREAMPROP STREAM 'SENDSCREENPARAMS (FUNCTION NILL)) [STREAMPROP STREAM 'OPTIONS '(("Set Line Parameters" 'RS232CHAT.SET.PARAMETERS "Modify TTY port parameters"] (RETURN (CONS STREAM OUTSTREAM]) ) (ADDTOVAR NETWORKOSTYPES (TTY)) (ADDTOVAR CHAT.PROTOCOLTYPES (TTY . TTYCHAT.HOST.FILTER)) (DECLARE%: DONTCOPY (FILESLOAD (LOADCOMP) CHATDECLS) ) (FILESLOAD DLTTY RS232CHAT CHAT) (PUTPROPS TTYCHAT COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (871 2165 (TTYCHAT.HOST.FILTER 881 . 1208) (TTYCHAT.OPEN 1210 . 2163))))) STOP \ No newline at end of file diff --git a/library/UNICODE b/library/UNICODE new file mode 100644 index 00000000..9520ef28 --- /dev/null +++ b/library/UNICODE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "11-Aug-2020 20:28:31"  {DSK}kaplan>Local>medley3.5>lispcore>library>UNICODE.;150 62728 changes to%: (FNS UNICODE.UNMAPPED MAKE-UNICODE-TRANSLATION-TABLES) previous date%: "11-Aug-2020 09:35:15" {DSK}kaplan>Local>medley3.5>lispcore>library>UNICODE.;148) (PRETTYCOMPRINT UNICODECOMS) (RPAQQ UNICODECOMS [(COMS (* ;; "External formats") (FNS UTF8.OUTCHARFN UTF8.INCCODEFN UTF8.PEEKCCODEFN \UTF8.BACKCHARFN) (FNS UTF16BE.OUTCHARFN UTF16BE.INCCODEFN UTF16BE.PEEKCCODEFN \UTF16.BACKCHARFN) (INITVARS (EXTERNALEOL 'LF)) (FNS MAKE-UNICODE-FORMATS) (P (MAKE-UNICODE-FORMATS EXTERNALEOL)) (ADDVARS (*DEFAULT-EXTERNAL-FORMATS* (UNIX :UTF8))) (FNS UNICODE.UNMAPPED) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE)) (FNS XTOUCODE UTOXCODE)) [COMS (* ;; "Unicode mapping files") (FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING WRITE-UNICODE-MAPPING WRITE-UNICODE-INCLUDED WRITE-UNICODE-MAPPING-HEADER WRITE-UNICODE-MAPPING-FILENAME ) (VARS XCCS-SET-NAMES) (* ;; "Automate dumping of a documentation prefix") [DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16)) (UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16] (VARS UNICODE-MAPPING-HEADER) (INITVARS (UNICODEDIRECTORIES NIL)) (P (PUSHNEW UNICODEDIRECTORIES (PACK* (UNIX-GETENV "MEDLEYDIR") '/lispcore/unicode/xerox/] (COMS (* ;; "Set up translation tables for UTF8 and UTFBE external formats") (FNS MAKE-UNICODE-TRANSLATION-TABLES) [INITVARS (DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS SYMBOLS3 SYMBOLS4 ACCENTED-LATIN] [DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-UNICODE-TRANSLATION-TABLES ( READ-UNICODE-MAPPING DEFAULT-XCCS-CHARSETS T) '*XCCSTOUNICODE* '*UNICODETOXCCS*] (GLOBALVARS *XCCSTOUNICODE* *UNICODETOXCCS*)) (FNS HEXSTRING UTF8HEXSTRING NUTF8CODEBYTES NUTF8STRINGBYTES XTOUSTRING) (FNS SHOWCHARS) (DECLARE%: EVAL@COMPILE DONTCOPY (* ;; "This is taken from FILEIO") (CONSTANTS (LF.EOLC 1) (CR.EOLC 0) (CRLF.EOLC 2)) (* ;; "These control the layout of the translation tables. Since many of the upper panels are sparse, doing it per-panel (128) seems more space-efficient, and residual alists can be shorter") (CONSTANTS (TRANSLATION-SEGMENT-SIZE 128) (MAX-ALIST-LENGTH 10) (N-TRANSLATION-SEGMENTS (IQUOTIENT 65536 TRANSLATION-SEGMENT-SIZE)) (TRANSLATION-SHIFT (INTEGERLENGTH (SUB1 TRANSLATION-SEGMENT-SIZE))) (TRANSLATION-MASK (SUB1 TRANSLATION-SEGMENT-SIZE))) (P (EVAL (SYSRECLOOK1 'EXTERNALFORMAT)) (EVAL (SYSRECLOOK1 'STREAM]) (* ;; "External formats") (DEFINEQ (UTF8.OUTCHARFN [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 8-Aug-2020 15:20 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (* ;; "PRINT UTF8 sequence for CHARCODE. Do not do XCCS to Unicode translation of RAW.") (CHANGE (FETCH (STREAM CHARPOSITION) OF STREAM) (CL:IF (EQ CHARCODE (CHARCODE EOL)) 0 (IPLUS DATUM 1))) (* ; "Avoid overflow") (CL:UNLESS RAW (SETQ CHARCODE (UNICODE.TRANSLATE CHARCODE *XCCSTOUNICODE*))) (IF (ILESSP CHARCODE 128) THEN (\BOUT STREAM CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (\BOUT STREAM (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (\BOUT STREAM (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (\BOUT STREAM (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (\BOUT STREAM (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (UTF8.INCCODEFN [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 6-Aug-2020 17:13 by rmk:") (* ;; "Do not do UNICODE to XCSS translation if RAW.") (* ;; "Test for smallp because the stream's End-of-file operation may suppress the error") (LET (BYTE1 BYTE2 BYTE3 BYTE4 CODE (COUNT 1)) (SETQ BYTE1 (\BIN STREAM)) (* ;; "Distinguish on header bytes (modulo peculiar EOF behavior--the caller will get whatever ended up in BYTE1") (CL:WHEN (SMALLP BYTE1) [SETQ CODE (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE2)) (ILESSP BYTE2 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE3)) (ILESSP BYTE3 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE4)) (ILESSP BYTE4 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (SETQ COUNT 4) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE2)) (ILESSP BYTE2 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE3)) (ILESSP BYTE3 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ COUNT 3) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ COUNT 2) (SETQ BYTE2 (\BIN STREAM)) (CL:WHEN (OR (NOT (SMALLP BYTE2)) (ILESSP BYTE2 128)) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) (CL:UNLESS (OR RAW (NOT (SMALLP CODE))) (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*))) (CL:IF COUNTP (CL:VALUES CODE COUNT) CODE)]) (UTF8.PEEKCCODEFN [LAMBDA (STREAM NOERROR COUNTP RAW) (* ; "Edited 6-Aug-2020 17:12 by rmk:") (* ;; "Modeled this after \EUCPEEK on LLREAD. In the multi-byte (non-ASCII) case, backs the file pointer to the beginning by the proper number of \BACKFILEPTRs, and returns a count of 0. Returns NIL if NOERROR and either invalid UTF8 or end of file.") (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.") (* ;; "Do not do UNICODE to XCCS translation if RAW") (PROG (BYTE1 BYTE2 BYTE3 BYTE4 CODE) (SETQ BYTE1 (\PEEKBIN STREAM NOERROR)) (* ;; "Distinguish on header bytex") (CL:UNLESS BYTE1 (RETURN (AND COUNTP (CL:VALUES NIL 0)))) [IF (ILESSP BYTE1 128) THEN (* ;;  "Test first: Ascii is the common case. No need to back up, since we peeked.") (SETQ CODE BYTE1) ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (\BIN STREAM) (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (IGEQ BYTE2 128)) (\BACKFILEPTR STREAM) (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (RETURN (IF COUNTP THEN (CL:VALUES CODE 0) ELSE CODE))) (\BIN STREAM) (CL:UNLESS (AND (SETQ BYTE3 (\PEEKBIN STREAM NOERROR)) (IGEQ BYTE3 128)) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (RETURN (IF COUNTP THEN (CL:VALUES CODE 0) ELSE CODE))) (\BIN STREAM) (SETQ BYTE4 (\PEEKBIN STREAM NOERROR)) (* ;  "PEEK the last, no need to back it up") (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (IF (AND BYTE4 (IGEQ BYTE4 128)) THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6))) ELSEIF NOERROR ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (\BIN STREAM) (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (IGEQ BYTE2 128)) (\BACKFILEPTR STREAM) (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (RETURN (IF COUNTP THEN (CL:VALUES CODE 0) ELSE CODE))) (\BIN STREAM) (SETQ BYTE3 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (IF (AND BYTE3 (IGEQ BYTE3 128)) THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6))) ELSEIF NOERROR ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) ELSE (* ; "Must be 2 bytes") (\BIN STREAM) (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (IF (AND BYTE2 (IGEQ BYTE2 128)) THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6))) ELSEIF NOERROR ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2] (CL:WHEN (AND CODE (NOT RAW)) (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*))) (RETURN (IF COUNTP THEN (CL:VALUES CODE 0) ELSE CODE]) (\UTF8.BACKCHARFN [LAMBDA (STREAM COUNTP) (* ; "Edited 26-Jul-2020 10:41 by rmk:") (* ;; "\BACKFILEPTR is NIL at beginning of FILE, just return COUNT") (BIND (C _ 0) WHILE (CL:WHEN (\BACKFILEPTR STREAM) (ADD C 1) (EQ 2 (LRSH (\PEEKBIN STREAM) 6))) REPEATUNTIL (EQ C 4) FINALLY (RETURN (AND COUNTP C]) ) (DEFINEQ (UTF16BE.OUTCHARFN [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 8-Aug-2020 15:21 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:") (* ;; "PRINT UTF16 sequence for CHARCODE. Do not do XCCS to UNICODE translation if RAW.") (CHANGE (FETCH (STREAM CHARPOSITION) OF STREAM) (CL:IF (EQ CHARCODE (CHARCODE EOL)) 0 (IPLUS DATUM 1))) (CL:UNLESS RAW (SETQ CHARCODE (UNICODE.TRANSLATE CHARCODE *XCCSTOUNICODE*))) (\BOUT STREAM (LRSH CHARCODE 8)) (\BOUT STREAM (LOGAND CHARCODE 255]) (UTF16BE.INCCODEFN [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 6-Aug-2020 17:48 by rmk:") (* ;;  "Do not do UNICODE to XCCS translation if RAW. Test for SMALLPin case of funky EOF behavior") (LET (CODE BYTE1 BYTE2 COUNT) (IF [AND (SMALLP (SETQ BYTE1 (\BIN STREAM))) (SMALLP (SETQ BYTE2 (\BIN STREAM] THEN (SETQ COUNT 2) (SETQ CODE (LOGOR (LLSH (\BIN STREAM) 8) (\BIN STREAM))) (CL:UNLESS RAW (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*))) (CL:IF COUNTP (CL:VALUES CODE COUNT) CODE) ELSE (ERROR "ODD NUMBER OF BYTES IN UTF16 FILE" STREAM]) (UTF16BE.PEEKCCODEFN [LAMBDA (STREAM NOERROR COUNTP RAW) (* ; "Edited 30-Jul-2020 14:06 by rmk:") (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.") (* ;; "Do not do UNICODE to XCCS translation if RAW") (LET (BYTE1 BYTE2 CODE) (SETQ BYTE1 (\PEEKBIN STREAM NOERROR)) (IF BYTE1 THEN (\BIN STREAM) (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (IF BYTE2 THEN (SETQ CODE (LOGOR (LLSH BYTE1 8) BYTE2)) (CL:IF COUNTP (CL:VALUES (CL:IF RAW CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*)) 0)) ELSEIF NOERROR ELSE (AND COUNTP (CL:VALUES NIL 0))) ELSEIF NOERROR THEN (AND COUNTP (CL:VALUES NIL 0)) ELSE (ERROR "INVALID UTF16 CHARACTER" (LIST BYTE1 BYTE2]) (\UTF16.BACKCHARFN [LAMBDA (STREAM COUNTP) (* ; "Edited 26-Jul-2020 13:05 by rmk:") (* ;; "\BACKFILEPTR is NIL at beginning of FILE, just return COUNT.") (* ;; "Common for big-ending and little-ending") (IF (NOT (\BACKFILEPTR STREAM)) THEN (AND COUNTP 0) ELSEIF (\BACKFILEPTR STREAM) THEN (AND COUNTP 2) ELSE (AND COUNTP 1]) ) (RPAQ? EXTERNALEOL 'LF) (DEFINEQ (MAKE-UNICODE-FORMATS [LAMBDA (EXTERNALEOL) (* ; "Edited 9-Aug-2020 08:40 by rmk:") (* ;; "RAW formats do not do XCCS/Unicode translation, just deal with the byte encoding.") (* ;; "The EXTERNALEOL specifies the EOLCONVENTION of the stream, particularly to produce output files with the desired convention. On input the macro \CHECKEOLC (LLREAD) coerces only that coding to the internal EOL, which is a mistake.") (SETQ EXTERNALEOL (SELECTQ EXTERNALEOL (LF LF.EOLC) (CR CR.EOLC) (CRLF CRLF.EOLC) (SHOULDNT))) (\INSTALL.EXTERNALFORMAT :UTF16BE (CREATE EXTERNALFORMAT EOLVALID _ T EOL _ EXTERNALEOL INCCODEFN _ (FUNCTION UTF16BE.INCCODEFN) PEEKCCODEFN _ (FUNCTION UTF16BE.PEEKCCODEFN) BACKCHARFN _ (FUNCTION \UTF16.BACKCHARFN) FILEOUTCHARFN _ (FUNCTION UTF16BE.OUTCHARFN))) [\INSTALL.EXTERNALFORMAT :UTF16BE-RAW (CREATE EXTERNALFORMAT EOLVALID _ T EOL _ EXTERNALEOL INCCODEFN _ [FUNCTION (LAMBDA (STREAM) (UTF16BE.INCCODEFN STREAM T] PEEKCCODEFN _ [FUNCTION (LAMBDA (STREAM NOERROR COUNTP) (UTF16BE.PEEKCCODEFN STREAM NOERROR COUNTP T] BACKCHARFN _ (FUNCTION \UTF16.BACKCHARFN) FILEOUTCHARFN _ (FUNCTION (LAMBDA (STREAM CHARCODE) (UTF16BE.OUTCHARFN STREAM CHARCODE T] [\INSTALL.EXTERNALFORMAT :UTF8-RAW (CREATE EXTERNALFORMAT EOLVALID _ T EOL _ EXTERNALEOL INCCODEFN _ [FUNCTION (LAMBDA (STREAM COUNTP) (UTF8.INCCODEFN STREAM COUNTP T] PEEKCCODEFN _ [FUNCTION (LAMBDA (STREAM NOERROR COUNTP) (UTF8.PEEKCCODEFN STREAM NOERROR COUNTP T] BACKCHARFN _ (FUNCTION \UTF8.BACKCHARFN) FILEOUTCHARFN _ (FUNCTION (LAMBDA (STREAM CHARCODE) (UTF8.OUTCHARFN STREAM CHARCODE T] (\INSTALL.EXTERNALFORMAT :UTF8 (CREATE EXTERNALFORMAT EOLVALID _ T EOL _ EXTERNALEOL INCCODEFN _ (FUNCTION UTF8.INCCODEFN) PEEKCCODEFN _ (FUNCTION UTF8.PEEKCCODEFN) BACKCHARFN _ (FUNCTION \UTF8.BACKCHARFN) FILEOUTCHARFN _ (FUNCTION UTF8.OUTCHARFN]) ) (MAKE-UNICODE-FORMATS EXTERNALEOL) (ADDTOVAR *DEFAULT-EXTERNAL-FORMATS* (UNIX :UTF8)) (DEFINEQ (UNICODE.UNMAPPED [LAMBDA (CODE TRANSLATION-TABLE) (* ; "Edited 11-Aug-2020 20:23 by rmk:") (* ;; "This is the slow fall-out when UNICODE.TRANSLATE determines that CODED has no fast mapping in TRANSLATION-TABLE.") (* ;; "We return an existing entry in the hash array of the table. If CODE has not previously been seen, we allocate a new code in the forward unmapped hasharray and put the inverse in the backward array.") (LET ((FORWARD (CL:SVREF TRANSLATION-TABLE N-TRANSLATION-SEGMENTS)) INVERSE NEXTCODE) (IF (GETHASH CODE (CAR FORWARD)) ELSEIF (AND (ILEQ CODE (CADDR FORWARD)) (IGEQ CODE (CADDDR FORWARD))) THEN (ERROR "UNMAPPED CODE IS EITHER XCCS-UNUSED OR UNICODE-PRIVATE" CODE) ELSE (SETQ INVERSE (CL:SVREF TRANSLATION-TABLE (ADD1 N-TRANSLATION-SEGMENTS))) (SETQ NEXTCODE (ADD (CADR INVERSE) 1)) (CL:WHEN (IGREATERP NEXTCODE (CADDR INVERSE)) (ERROR "EXHAUSTED RANGE FOR UNMAPPED CODES" CODE)) (PUTHASH CODE NEXTCODE (CAR FORWARD)) (PUTHASH NEXTCODE CODE (CAR INVERSE)) NEXTCODE]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS UNICODE.TRANSLATE MACRO [OPENLAMBDA (CODE TRANSLATION-TABLE) (LET [(X (CL:SVREF TRANSLATION-TABLE (LRSH CODE TRANSLATION-SHIFT ] (COND ((LISTP X) (OR (CDR (FASSOC (LOGAND CODE TRANSLATION-SHIFT) X)) CODE)) [(AND X (CL:SVREF X (LOGAND CODE TRANSLATION-MASK ] (T (UNICODE.UNMAPPED CODE TRANSLATION-TABLE]) ) ) (DEFINEQ (XTOUCODE [LAMBDA (XCCSCODE) (* ; "Edited 9-Aug-2020 09:04 by rmk:") (UNICODE.TRANSLATE XCCSCODE *XCCSTOUNICODE*]) (UTOXCODE [LAMBDA (UNICODE) (* ; "Edited 9-Aug-2020 09:04 by rmk:") (UNICODE.TRANSLATE UNICODE *UNICODETOXCCS*]) ) (* ;; "Unicode mapping files") (DEFINEQ (READ-UNICODE-MAPPING-FILENAMES [LAMBDA (FILESPEC) (* ; "Edited 5-Aug-2020 15:59 by kaplan") (* ;  "Edited 4-Aug-2020 17:31 by rmk:") (FOR F X CSI INSIDE FILESPEC COLLECT (IF (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT) T UNICODEDIRECTORIES) ELSEIF [SETQ CSI (OR (SASSOC F XCCS-SET-NAMES) (FIND N IN XCCS-SET-NAMES SUCHTHAT (EQ F (CADR N] THEN (FINDFILE (PACKFILENAME 'BODY (CONCAT 'XCCS- (CAR CSI) '= (CADR CSI)) 'EXTENSION 'TXT) T UNICODEDIRECTORIES) ELSE F]) (READ-UNICODE-MAPPING [LAMBDA (FILESPEC NOPRINT NOERROR) (* ; "Edited 6-Aug-2020 08:24 by rmk:") (* ;; "Combines the char-mapping tables from FILES coded in the Uncode-CDROM format. Comments prefixed by # and") (* ;; " Column 1: Input hex code in the format %"0xXXXX%" (fromcode)") (* ;; " Column 2: Corresponding Unicode code in the format %"0xXXXX%" (tocode)") (* ;; " Column 3: (after #) Character name in some mapping files, utf-8 character for XCCS mapping files") (* ;; "") (* ;; "Result is a list of (fromcode tocode) integer pairs, where pairs are suppress where fromcode and tocode are the same, since the absence of a pair indicates identity.") (FOR FILE IN (READ-UNICODE-MAPPING-FILENAMES FILESPEC) JOIN (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :EXTERNAL-FORMAT :UTF8-RAW) (BIND FROMCODE TOCODE AFTERFROM LINE [WSBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] [CBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE %#] FIRST (CL:UNLESS (FILEPOS "Name:" STREAM NIL NIL NIL T) (ERROR "NOT A UNICODE MAPPING FILE" (FULLNAME STREAM))) (SETQ LINE (CL:READ-LINE STREAM NIL NIL)) (CL:UNLESS NOPRINT (PRINTOUT T T "Unicode mapping: " (CL:STRING-TRIM " " LINE) T)) WHILE (SETQ LINE (CL:READ-LINE STREAM NIL NIL)) UNLESS (OR [EQ (CHARCODE %#) (CHCON1 (SETQ LINE (CL:STRING-LEFT-TRIM " " LINE] (EQ 0 (NCHARS LINE))) COLLECT (SETQ AFTERFROM (STRPOSL WSBITTABLE LINE)) [SETQ FROMCODE (CHARCODE.DECODE (SUBSTRING LINE 1 (SUB1 AFTERFROM) (CONSTANT (CONCAT] [SETQ LINE (CL:STRING-LEFT-TRIM '(#\Space #\Tab) (SUBSTRING LINE AFTERFROM NIL (CONSTANT (CONCAT] [SETQ TOCODE (CHARCODE.DECODE (SUBSTRING LINE 1 [SUB1 (OR (STRPOSL CBITTABLE LINE) (ADD1 (NCHARS LINE] NIL (CONSTANT (CONCAT] (LIST FROMCODE TOCODE]) (WRITE-UNICODE-MAPPING [LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK) (* ; "Edited 6-Aug-2020 08:20 by rmk:") (* ;; "Writes a symbol unicode mapping file. Mapping is a list of (XCCS-code Unicode) pairs, which may contain codes in multiple character sets.") (* ;; "If FILE is NIL, it defaults to a name XCCS- followed by the octal character sets in the mapping, in the unicode/XEROX directory.") (* ;; "The output lines are of the form x0XXXx0UUUU# Unicode-char") (* ;;  "If INCLUDECHARSETS=T then the mappings are split up into separate per-character set files.") (* ;; "Otherwise, all and only mappings included in thos charsets are included in a single output file--an implicit subset.") (IF (AND (EQ INCLUDECHARSETS T) (NULL FILE)) THEN (IF MAPPING THEN (FOR CSI F IN XCCS-SET-NAMES WHEN (SETQ F (WRITE-UNICODE-MAPPING MAPPING (CAR CSI) NIL T)) COLLECT F) ELSE (PRINTOUT T "THERE ARE NO MAPPINGS" T) NIL) ELSE (LET (IMAPPING CSETINFO RANGES) (CL:MULTIPLE-VALUE-SETQ (IMAPPING CSETINFO RANGES) (WRITE-UNICODE-INCLUDED MAPPING INCLUDECHARSETS)) (IF IMAPPING THEN (CL:WITH-OPEN-FILE (STREAM (WRITE-UNICODE-MAPPING-FILENAME FILE CSETINFO RANGES) :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :EXTERNAL-FORMAT :UTF8-RAW) (WRITE-UNICODE-MAPPING-HEADER STREAM CSETINFO RANGES) (SORT IMAPPING T) (FOR M CSET LEFTC RIGHTC CSI IN IMAPPING DO (SETQ LEFTC (CAR M)) (SETQ RIGHTC (CADR M)) (CL:UNLESS (EQ CSET (LRSH LEFTC 8)) (SETQ CSET (LRSH LEFTC 8)) (SETQ CSI (ASSOC CSET CSETINFO)) (PRINTOUT STREAM T "# " .P2 (CADR CSI) " " (CADDR CSI) T)) (PRINTOUT STREAM "0x" (HEXSTRING LEFTC 4) " " "0x" (HEXSTRING RIGHTC 4) " # " (SELECTC RIGHTC (UNDEFINEDCODE (* ;; "FFFF") "UNDEFINED") (MISSINGCODE (* ;; "FFFE") "MISSING") (IF (ILESSP RIGHTC 32) THEN [CONCAT "^" (CHARACTER (IPLUS RIGHTC (CHARCODE @] ELSE (CHARACTER RIGHTC))) T)) (FULLNAME STREAM)) ELSEIF (NOT EMPTYOK) THEN (PRINTOUT T "THERE ARE NO MAPPINGS") (CL:WHEN INCLUDECHARSETS (PRINTOUT T " FOR " .PPVTL (MKLIST INCLUDECHARSETS) T)) NIL]) (WRITE-UNICODE-INCLUDED [LAMBDA (MAPPING INCLUDECHARSETS) (* ; "Edited 4-Aug-2020 17:47 by rmk:") (* ;; "CSETINFO is a list of (num string name) for each included character set.") (LET (CHARSETS CSETINFO RANGES ICSETS IMAPPING) (* ;; "Normalize the INCLUDECHARSETS, then reduce MAPPING to the included mappings") [SETQ ICSETS (FOR C POS KNOWN INSIDE (OR INCLUDECHARSETS (FOR CSI IN XCCS-SET-NAMES COLLECT (CAR CSI))) JOIN [SETQ KNOWN (OR (SASSOC C XCCS-SET-NAMES) (FIND N IN XCCS-SET-NAMES SUCHTHAT (EQ C (CADR N))) (HELP "UNKNOWN CHARACTER SET" (OCTALSTRING C] (IF (SETQ POS (STRPOS "-" (CAR KNOWN))) THEN (FOR I FROM (CL:PARSE-INTEGER (SUBSTRING (CAR KNOWN) 1 (SUB1 POS)) :RADIX 8) TO (CL:PARSE-INTEGER (SUBSTRING (CAR KNOWN) (ADD1 POS)) :RADIX 8) COLLECT (LIST I (OCTALSTRING I) (CADR KNOWN))) ELSE (CONS (CONS (CL:PARSE-INTEGER (CAR KNOWN) :RADIX 8) KNOWN] (SETQ IMAPPING (FOR M CSI IN MAPPING WHEN (SETQ CSI (ASSOC (LRSH (CAR M) 8) ICSETS)) COLLECT (* ;; "The attested subset of INCLUDED") (CL:UNLESS (MEMB CSI CSETINFO) (PUSH CSETINFO CSI)) M)) (* ;; "Sort as numbers, not octal strings, then group into consecutive ranges") (SETQ CSETINFO (SORT CSETINFO T)) [SETQ RANGES (FOR CTAIL C START END ON (FOR CSI IN CSETINFO COLLECT (CAR CSI)) WHILE CTAIL COLLECT (SETQ START (CAR CTAIL)) (SETQ END START) (CONS START (WHILE [AND (CDR CTAIL) (EQ END (SUB1 (CADR CTAIL] COLLECT (SETQ CTAIL (CDR CTAIL)) (SETQ END (CAR CTAIL] (* ;; "Split out groups of less than 3. But if a range exhaustively covers a known subset (like JIS), replace by the name") [SETQ RANGES (FOR R STR KNOWN LAST IN RANGES JOIN (SETQ LAST (CAR (LAST R))) (IF (EQ (CAR R) LAST) THEN (CONS (OCTALSTRING (CAR R))) ELSEIF (SETQ KNOWN (SASSOC (SETQ STR (CONCAT (OCTALSTRING (CAR R)) "-" (OCTALSTRING LAST))) XCCS-SET-NAMES)) THEN (CONS (CADR KNOWN)) ELSEIF (CDDR R) THEN (CONS STR) ELSE (LIST (OCTALSTRING (CAR R)) (OCTALSTRING LAST] (CL:VALUES IMAPPING CSETINFO RANGES]) (WRITE-UNICODE-MAPPING-HEADER [LAMBDA (STREAM CSETINFO RANGES) (* ; "Edited 4-Aug-2020 17:38 by rmk:") (* ;; "Writes the standard per-file header information") (FOR LINE IN UNICODE-MAPPING-HEADER DO (PRINTOUT STREAM "#" 2) (SELECTQ LINE (XCCSCHARACTERSETS (PRINTOUT STREAM " XCCS charset") (IF (CDR CSETINFO) THEN (PRINTOUT STREAM "s:" -4) (FOR R IN RANGES DO (PRINTOUT STREAM R " ")) (TERPRI STREAM) ELSE (* ; "Singleton") (PRINTOUT STREAM ": " -4 (CADAR CSETINFO) " " (CADDAR CSETINFO))) (TERPRI STREAM)) (DATE (PRINTOUT STREAM " Date:" -13 (DATE (DATEFORMAT NO.TIME NO.LEADING.SPACES)) T)) (PRINTOUT STREAM LINE T))) (TERPRI STREAM]) (WRITE-UNICODE-MAPPING-FILENAME [LAMBDA (FILE CSETINFO RANGES) (* ; "Edited 4-Aug-2020 19:34 by rmk:") (PACKFILENAME 'BODY [OR FILE (CONCATLIST (CONS 'XCCS- (IF (CDR CSETINFO) THEN (FOR RTAIL R ON RANGES JOIN (SETQ R (CAR RTAIL)) (SETQ R (CL:IF (LISTP R) (LIST (CAR R) "-" (CDR R)) (CONS R))) (CL:IF (CDR RTAIL) (NCONC1 R ",")) R) ELSE (LIST (CADAR CSETINFO) "=" (CADDAR CSETINFO] 'DIRECTORY (CAR UNICODEDIRECTORIES) 'EXTENSION 'TXT]) ) (RPAQQ XCCS-SET-NAMES (("0" LATIN) ("41" SYMBOLS1) ("42" SYMBOLS2) ("43" EXTENDED-LATIN) ("44" HIRAGANA) ("45" KATAKANA) ("46" GREEK) ("47" CYRILLIC) ("50" FORMS) ("60-172" JIS) ("340" ARABIC) ("341" HEBREW) ("342" IPA) ("343" HANGUL) ("344" GEORGIAN-ARMENIAN) ("356" SYMBOLS3) ("357" SYMBOLS4) ("360" LIGATURES) ("361" ACCENTED-LATIN) ("365" MORE-ARABIC) ("375" GRAPHIC-VARIANTS))) (* ;; "Automate dumping of a documentation prefix") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQ MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16)) (RPAQ UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16)) (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16)) (UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16))) ) ) (RPAQQ UNICODE-MAPPING-HEADER ("" " Name: XCCS (XC-3-1-1-0) to Unicode" " Unicode version: 3.0" XCCSCHARACTERSETS " Table version: 0.1" " Table format: Format A" DATE " Author: Ron Kaplan " "" "This file contains mappings from the Xerox Character Code Standard (version" "XC1-3-3-0, 1987) into Unicode 3.0. standard codes. That is the version of" "XCCS corresponding to the fonts in the Medley system." "" "The format of this file conforms to the format of the other Unicode-supplied" "mapping files:" " Three white-space (tab or spaces) separated columns:" " Column 1 is the XCCS code (as hex 0xXXXX)" " Column 2 is the corresponding Unicode (as hex 0xXXXX)" " Column 3 (after #) is a comment column. For convenience, it contains the" " Unicode character itself (since the Unicode character names" " are not available)" "Unicode FFFF is used for undefined XCCS codes (Column 3 = UNDEFINED" "Unicode FFFE is used for XCCS codes that have not yet been filled in." "(Column 3 = MISSING)" "" "This file is encoded in UTF8, so that the Unicode characters" "are properly displayed in Column 3 and can be edited by standard" "Unicode-enabled editors (e.g. Mac Textedit)." "" "This file can also be read by the function" "READ-UNICODE-MAPPING in the UNICODE Medley library package." "" "The entries are in XCCS order and grouped by character sets. In front of" "the mappings, for convenience, there is a line with the octal XCCS" "character set, after #." "" "Note that a given XCCS code might map to codes in several different Unicode" "positions, since there are repetitions in the Unicode standard." "" "For more details, see the associated README.TXT file." "" "Any comments or problems, contact ")) (RPAQ? UNICODEDIRECTORIES NIL) (PUSHNEW UNICODEDIRECTORIES (PACK* (UNIX-GETENV "MEDLEYDIR") '/lispcore/unicode/xerox/)) (* ;; "Set up translation tables for UTF8 and UTFBE external formats") (DEFINEQ (MAKE-UNICODE-TRANSLATION-TABLES [LAMBDA (MAPPING LTORVAR RTOLVAR) (* ; "Edited 11-Aug-2020 20:13 by rmk:") (* ;; "MAPPING is the list of numeric code correspondence pairs constructed by applying READ-UNICODE-MAPPING to a Unicode mapping file.") (* ;; "This produces two recoding arrays, one maps left-side codes into right-side codes (e.g. XCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. XCCS).") (* ;; "") (* ;; "We assume that the left-to-right mapping into Unicode is functional, so that each left code maps to a unique right (Unicode) code, because Unicode is presumably the most refined coding scheme. But several Unicode codes may map to the same left code, for logically different codes that happen to have the same glyphs. In that case the heuristic is to map each %"from%" code to the lowest of the possible %"to%" codes. This means that round-trip reading/writing or writing/reading from one or both starting points may not always be lossless.") (* ;; " ") (* ;; " Each recoding array has 256 elements, one for each possible high-order byte of a character code. An array entry is either NIL, a 256-array of codes indexed by low-order bytes, or an alist of (lower-order-bytes . codes). The latter is used to save space for sparsely populated character sets.") (* ;; "") (* ;; "The element 256 of each array contains a hash table for characters that might be encountered in XCCS memory or Unicode files for which there is no mapping. Element 257 contains the corresponding inverse unmapped hash-array, so that UNICODE.TRANSLATE can update them consistently.") (* ;; "") (* ;; "UNICODE.TRANSLATE assigns an unmapped Unicode character to a %"not used%" XCCS code position (from 5,0 to 40,FF, leaving other low not-used sets for other internal uses (TEDIT?).") (* ;; "") (* ;;  "An unmapped XCCS character is assigned a code in the %"private use%" code blocks 0xE000-F8FF") (* ;; "") (* ;; "For the convenience of not having to deal with the multiple values, if LTORVAR or RTOLVAR are given, they are set to the constructed arrays before return.") (* ;; "") (LET ((LTORARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS) :INITIAL-ELEMENT NIL)) (RTOLARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS) :INITIAL-ELEMENT NIL))) (* ;; "The left-to-right direction (into Unicode). We start by distributing the mappings into alists in arrays indexed by the higher-order (charaset set byte). The second loop converts long alists into arrays.") [FOR PAIR LEFTC RIGHTC IN MAPPING EACHTIME (SETQ LEFTC (CAR PAIR)) (SETQ RIGHTC (CADR PAIR)) UNLESS (IGEQ RIGHTC MISSINGCODE) DO (CL:PUSH (CONS (LOGAND LEFTC TRANSLATION-MASK ) RIGHTC) (CL:SVREF LTORARRAY (LRSH LEFTC TRANSLATION-SHIFT ] (FOR I CSA FROM 0 TO (SUB1 N-TRANSLATION-SEGMENTS) WHEN (IGREATERP (LENGTH (CL:SVREF LTORARRAY I)) MAX-ALIST-LENGTH) DO (* ;; "Leave it alone if the alist is short") (SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL)) (FOR P IN (CL:SVREF LTORARRAY I) DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR P) TRANSLATION-MASK)) (CDR P))) (CL:SETF (CL:SVREF LTORARRAY I) CSA)) (* ;; "") (* ;; "Now the right-to-left direction (from Unicode). Here we have to detect and compensate for ambiguity.") (FOR PAIR LEFTC RIGHTC PREV IN MAPPING EACHTIME (SETQ LEFTC (CAR PAIR)) (SETQ RIGHTC (CADR PAIR)) UNLESS (IGEQ RIGHTC MISSINGCODE) DO (* ;; "Have we already seen an explicit mapping from right to left?") [SETQ PREV (ASSOC (LOGAND RIGHTC TRANSLATION-MASK) (CL:SVREF RTOLARRAY (LRSH RIGHTC TRANSLATION-SHIFT] (IF (NULL PREV) THEN (CL:PUSH (CONS (LOGAND RIGHTC TRANSLATION-MASK) LEFTC) (CL:SVREF RTOLARRAY (LRSH RIGHTC TRANSLATION-SHIFT))) ELSEIF (IGREATERP (CDR PREV) LEFTC) THEN (RPLACD PREV LEFTC))) (FOR I CSA FROM 0 TO (SUB1 N-TRANSLATION-SEGMENTS) WHEN (IGREATERP (LENGTH (CL:SVREF RTOLARRAY I)) MAX-ALIST-LENGTH) DO (* ;; "Long list, make an array") (SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL)) (FOR P IN (CL:SVREF RTOLARRAY I) DO (CL:SETF (CL:SVREF CSA (LOGAND (CAR P) TRANSLATION-MASK)) (CDR P))) (CL:SETF (CL:SVREF RTOLARRAY I) CSA)) (* ;; "") (* ;; "Allocate the hash arrays for future out-of-map codes. We we have to keep track of the next available and last possible codes, as well as the first available, for error checking.") (CL:SETF (CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS) (LIST (HASHARRAY 10) (CHARCODE.DECODE "5,0") (CHARCODE.DECODE "40,0") (CHARCODE.DECODE "5,0"))) (CL:SETF (CL:SVREF RTOLARRAY N-TRANSLATION-SEGMENTS) (LIST (HASHARRAY 10) (CHARCODE.DECODE "E000") (CHARCODE.DECODE "F8FF") (CHARCODE.DECODE "E000"))) (* ;; "Now put in the inverse unmapped hash arrays") (CL:SETF (CL:SVREF LTORARRAY (ADD1 N-TRANSLATION-SEGMENTS)) (CL:SVREF RTOLARRAY N-TRANSLATION-SEGMENTS)) (CL:SETF (CL:SVREF RTOLARRAY (ADD1 N-TRANSLATION-SEGMENTS)) (CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS)) (* ;; "") (CL:WHEN LTORVAR (SETATOMVAL LTORVAR LTORARRAY)) (CL:WHEN RTOLVAR (SETATOMVAL RTOLVAR RTOLARRAY)) (CL:VALUES LTORARRAY RTOLARRAY]) ) (RPAQ? DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS SYMBOLS3 SYMBOLS4 ACCENTED-LATIN)) (DECLARE%: DONTEVAL@LOAD DOCOPY (MAKE-UNICODE-TRANSLATION-TABLES (READ-UNICODE-MAPPING DEFAULT-XCCS-CHARSETS T) '*XCCSTOUNICODE* '*UNICODETOXCCS*) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *XCCSTOUNICODE* *UNICODETOXCCS*) ) (DEFINEQ (HEXSTRING [LAMBDA (N WIDTH) (* ; "Edited 23-Jul-2020 08:28 by rmk:") (* ; "Edited 20-Dec-93 17:51 by rmk:") (* ;;  "Converts positive numbers to Hex strings, padding on the right with 0 up to WIDTH if given.") (CL:UNLESS (FIXP N) (SETQ N (CHARCODE.DECODE N))) (LET [CHAR (STR (ALLOCSTRING [IMAX (OR WIDTH 0) (FOR I (LEFT _ N) FROM 0 UNTIL (EQ LEFT 0) DO (SETQ LEFT (LRSH LEFT 4)) FINALLY (RETURN (MAX I 1] (CHARCODE 0] (FOR I FROM -1 BY -1 UNTIL (EQ N 0) DO (SETQ CHAR (LOGAND N 15)) [RPLCHARCODE STR I (IF (ILESSP CHAR 10) THEN (+ CHAR (CHARCODE 0)) ELSE (+ (- CHAR 10) (CHARCODE A] (SETQ N (LRSH N 4))) STR]) (UTF8HEXSTRING [LAMBDA (CHARCODE) (* ; "Edited 10-Aug-2020 08:33 by rmk:") (* ;; "Utility to produces the UTF8 hexstring representing CODE") (HEXSTRING (IF (ILESSP CHARCODE 128) THEN CHARCODE ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (LOGOR (LLSH (LOGOR (LLSH 3 6) (LRSH CHARCODE 6)) 8) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (LOGOR (LLSH (LOGOR (LLSH 7 5) (LRSH CHARCODE 12)) 16) (LLSH (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6)) 8) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (LOGOR (LLSH (LOGOR (LLSH 15 4) (LRSH CHARCODE 18)) 24) (LLSH (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6)) 16) (LLSH (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6)) 8) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) (NUTF8CODEBYTES [LAMBDA (N) (* ; "Edited 10-Aug-2020 12:35 by rmk:") (* ;; "Returns the number of bytes needed to encode N in UTF8, ") (IF (ILESSP N 128) THEN 1 ELSEIF (ILESSP N 2048) THEN (* ; "x800") 4 ELSEIF (ILESSP N 65536) THEN (* ; "x10000") 3 ELSEIF (ILESSP N 2097152) THEN (* ; "x200000") 2 ELSE (SHOULDNT]) (NUTF8STRINGBYTES [LAMBDA (STRING RAWFLG) (* ; "Edited 10-Aug-2020 09:06 by rmk:") (* ;; "Returns the number of bytes it would take to represent STRING in UTF8, assuming it is an XCCS string unless RAWFLG. ") (FOR I C FROM 1 WHILE (SETQ C (NTHCHARCODE STRING I)) SUM (NUTF8CODEBYTES (CL:IF RAWFLG C (XTOUCODE C))]) (XTOUSTRING [LAMBDA (XCCSSTRING RAWFLG) (* ; "Edited 10-Aug-2020 21:42 by rmk:") (* ;; "Produces a string that contains the UTF8 bytes that represent the characters in XCCSSTRING. Applies the XCCSTOUNICODE translation unless RAWFLG. ") (* ;; "The resulting string will not be readable inside Medley.") (LET [(USTR (ALLOCSTRING (NUTF8STRINGBYTES XCCSSTRING RAWFLG] (FOR I CHARCODE (SINDEX _ 0) FROM 1 WHILE (SETQ CHARCODE (NTHCHARCODE XCCSSTRING I)) DO (CL:UNLESS RAWFLG (SETQ CHARCODE (XTOUCODE CHARCODE))) (IF (ILESSP CHARCODE 128) THEN (RPLCHARCODE USTR (ADD SINDEX 1) CHARCODE) ELSEIF (ILESSP CHARCODE 2048) THEN (* ; "x800") (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 3 6) (LRSH CHARCODE 6))) (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 65536) THEN (* ; "x10000") (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 7 5) (LRSH CHARCODE 12))) (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSEIF (ILESSP CHARCODE 2097152) THEN (* ; "x200000") (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 15 4) (LRSH CHARCODE 18))) (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 12 6))) (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 6 6))) (RPLCHARCODE USTR (ADD SINDEX 1) (LOGOR (LLSH 2 6) (LOADBYTE CHARCODE 0 6))) ELSE (SHOULDNT))) USTR]) ) (DEFINEQ (SHOWCHARS [LAMBDA (FROMCHAR TOCHAR FONT) (* ; "Edited 1-Aug-2020 09:27 by rmk:") (RESETFORM (DSPFONT (OR FONT '(CLASSIC 12)) T) (CL:WHEN (AND (SMALLP FROMCHAR) (NOT TOCHAR)) (* ;;  "If a small number, assume it's an octal (in decimal) character set, no need for string quotes") (SETQ TOCHAR (CONCAT FROMCHAR "," 376)) (SETQ FROMCHAR (CONCAT FROMCHAR "," 41))) (CL:UNLESS (SMALLP FROMCHAR) (SETQ FROMCHAR (CHARCODE.DECODE FROMCHAR))) (CL:UNLESS (SMALLP TOCHAR) (SETQ TOCHAR (CL:IF TOCHAR (CHARCODE.DECODE TOCHAR) FROMCHAR))) (FOR C FROM FROMCHAR TO TOCHAR UNLESS (AND (IGEQ (LOGAND C 255) 127) (ILEQ (LOGAND C 255) (PLUS 128 33))) DO (PRINTOUT T .P2 (CONCAT (OCTALSTRING (LRSH CODE 8)) "," (OCTALSTRING (LOGAND CODE 255))) 10 (CHARACTER C) T]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ LF.EOLC 1) (RPAQQ CR.EOLC 0) (RPAQQ CRLF.EOLC 2) (CONSTANTS (LF.EOLC 1) (CR.EOLC 0) (CRLF.EOLC 2)) ) (DECLARE%: EVAL@COMPILE (RPAQQ TRANSLATION-SEGMENT-SIZE 128) (RPAQQ MAX-ALIST-LENGTH 10) (RPAQ N-TRANSLATION-SEGMENTS (IQUOTIENT 65536 TRANSLATION-SEGMENT-SIZE)) (RPAQ TRANSLATION-SHIFT (INTEGERLENGTH (SUB1 TRANSLATION-SEGMENT-SIZE))) (RPAQ TRANSLATION-MASK (SUB1 TRANSLATION-SEGMENT-SIZE)) (CONSTANTS (TRANSLATION-SEGMENT-SIZE 128) (MAX-ALIST-LENGTH 10) (N-TRANSLATION-SEGMENTS (IQUOTIENT 65536 TRANSLATION-SEGMENT-SIZE)) (TRANSLATION-SHIFT (INTEGERLENGTH (SUB1 TRANSLATION-SEGMENT-SIZE))) (TRANSLATION-MASK (SUB1 TRANSLATION-SEGMENT-SIZE))) ) (EVAL (SYSRECLOOK1 'EXTERNALFORMAT)) (EVAL (SYSRECLOOK1 'STREAM)) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (4076 16062 (UTF8.OUTCHARFN 4086 . 6172) (UTF8.INCCODEFN 6174 . 10273) (UTF8.PEEKCCODEFN 10275 . 15553) (\UTF8.BACKCHARFN 15555 . 16060)) (16063 19317 (UTF16BE.OUTCHARFN 16073 . 16738) ( UTF16BE.INCCODEFN 16740 . 17617) (UTF16BE.PEEKCCODEFN 17619 . 18874) (\UTF16.BACKCHARFN 18876 . 19315) ) (19347 23487 (MAKE-UNICODE-FORMATS 19357 . 23485)) (23584 24890 (UNICODE.UNMAPPED 23594 . 24888)) ( 25960 26309 (XTOUCODE 25970 . 26138) (UTOXCODE 26140 . 26307)) (26349 41880 ( READ-UNICODE-MAPPING-FILENAMES 26359 . 27521) (READ-UNICODE-MAPPING 27523 . 30414) ( WRITE-UNICODE-MAPPING 30416 . 34388) (WRITE-UNICODE-INCLUDED 34390 . 39112) ( WRITE-UNICODE-MAPPING-HEADER 39114 . 40346) (WRITE-UNICODE-MAPPING-FILENAME 40348 . 41878)) (45226 52408 (MAKE-UNICODE-TRANSLATION-TABLES 45236 . 52406)) (52823 60364 (HEXSTRING 52833 . 53994) ( UTF8HEXSTRING 53996 . 56201) (NUTF8CODEBYTES 56203 . 56866) (NUTF8STRINGBYTES 56868 . 57349) ( XTOUSTRING 57351 . 60362)) (60365 61834 (SHOWCHARS 60375 . 61832))))) STOP \ No newline at end of file diff --git a/library/UNICODE.TXT b/library/UNICODE.TXT new file mode 100644 index 00000000..1c55d69f --- /dev/null +++ b/library/UNICODE.TXT @@ -0,0 +1,96 @@ +This file describes the UNICODE Lisp Library package. + +Contributed by Ron Kaplan, August 2020. + +The UNICODE library package defines external file formats that enable Medley to read and write files where 16 bit character codes are represented as UTF8 byte sequences or big-endian UTF16 byte-pairs. It also provides for character codes to be converted (on reading) from Unicode codes to equivalent codes in the Medley-internal Xerox Character Code Standard (XCCS) and (on writing) from XCCS codes to equivalent Unicode codes. + +Four external formats are defined when the package is loaded: + + :UTF8 codes are represented as UTF8 byte sequences and XCCS/Unicode character + conversion takes place. + + :UTF16BE codes are represented as 2-byte pairs, with the high order by appearing + first in the file, and characters are converted. + +The two other external formats translate byte sequences into codes, but do not translate the codes. These allow Medley to see and process characters in their native encoding. + + :UTF8-RAW codes are represented as UTF8 byte sequences, but character conversion + does not take place. + + :UTF16BE-RAW codes are represented as big-ending 2-byte pairs but there is no + conversion. + +These formats all define the end-of-line convention (mostly for writing) for the external files according to the variable EXTERNALEOL (LF, CR, CRLF), with LF the default. + +The external format can be specified as a parameter when a stream is opened: + + (OPENSTREAM 'foo.txt 'INPUT 'OLD '((EXTERNALFORMAT :UTF8))) + + (CL:OPEN 'foo.txt :DIRECTION :INPUT :EXTERNAL-FORMAT :UTF8) + +The function STREAMPROP obtains or changes the external format of an open stream: + + (STREAMPROP stream 'EXTERNALFORMAT) -> :UTF8 + + (STREAMPROP stream 'EXTERNALFORMAT :UTF8) -> :XCCS + +In the latter case, the stream's format is changed to :UTF8 and the previous value is returned, in this example it is Medley's historical default format :XCCS. + +Entries can be placed on the variable *DEFAULT-EXTERNAL-FORMATS* to change the external format that is set by default when a file is opened on a particular device. Loading UNICODE executes + + (PUSH *DEFAULT-EXTERNAL-FORMATS* '(UNIX :UTF8)) + +so that all files opened (by OPENSTREAM, CL:OPEN, etc.) on the UNIX file device will be initialized with :UTF8. Note that the UNIX and DSK file devices are equivalent in that they reference the same files, but the device name in a file name ({UNIX}/Users/... vs. {DSK}/Users/...) selects one or the other. The default setting above applies only to files specified with {UNIX}; a separate default entry for DSK must be established to change its default from :XCCS. + +The XCCS/Unicode mapping tables are defined by the code-mapping files for particular XCCS character sets. These are typically located in the Library sister directory + + ../Unicode/Xerox/ + +and the variable UNICODEDIRECTORIES is initialized with a globally valid reference to that path. The global reference is constructed by prepending the value of the Unix environment-variable "MEDLEYDIR" to the suffix /Unicode/Xerox/. MEDLEYDIR should be set by the Medley start-up shell script (e.g. /Users/kaplan/local/medley3.5/lispcore/) + +The mapping files have conventional names of the form XCCS-=.TXT, for example, XCCS-0=LATIN.TXT, XCCS-357=SYMBOLS4.TXT. The translations used by the external formats are read from these files by the function + + (READ-UNICODE-MAPPING FILESPEC NOPRINT NOERROR) + +where FILESPEC can be a list of files, charset octal strings ("0" "357"), or XCCS charset names (LATIN EXTENDED-LATIN). Reading will be silent if NOPRINT, and the process will not abort if an error occurs and NOERROR. The value is a flat list of the mappings for all the character sets, with elements of the form (XCCC-code Unicode-code). + +When UNICODE is loaded the mappings for the character sets specified in the variable DEFAULT-XCCS-CHARSETS are installed. This is initialized to + + (LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS SYMBOLS3 SYMBOLS4 ACCENTED-LATIN) + +but DEFAULT-XCCS-CHARSETS can be set to a different collection before UNICODE is loaded. + +The internal translation tables used by the external formats are constructed from a list of correspondence pairs by the function + + (MAKE-UNICODE-TRANSLATION-TABLES MAPPING [FROM-XCCS-VAR][TO-XCCS-VAR]) + +This returns a two-array multiple-value containing the relevant translation information organized for rapid access. If the optional from/to-variables arguments are provide, they are the names of variables whose top-level values will be set to these arrays, for convenience. For the external formats defined above, these variables are *XCCSTOUNICODE* and *UNICODETOXCCS*. + +The macro + + (UNICODE.TRANSLATE CODE TRANSLATION-TABLE) + +is used by the external formats to perform the mappings described by the translation-tables. + +The following utilities are provided for lower-level manipulation of codes and strings + + (XTOUCODE XCCSCODE) -> corresponding Unicode + (UTOXCODE UNICODE) -> corresponding XCCS code + (NUTF8CODEBYTES N) -> number of bytes in the UTF8 representation of N + (NUTF8STRINGBYTES STRING RAWFLG) -> number of UTF8 bytes in the UTF8 + representation of STRING, translating XCCS to Unicode unless RAWFLG. + (XTOUSTRING XCCSSTRING RAWFLG) -> The string of bytes in the UTF8 representation + of the characters in XCCSSTRING (= the bytes in its UTF8 file encoding) + (HEXSTRING N WIDTH) -> the hex string for N, padded to WIDTH + + +The UNICODE file also contains a function for writing a mapping file given a list of mapping pairs. The function + + (WRITE-TRANSLATION-TABLE MAPPING [INCLUDEDCHARSETS] [FILE]) + +produces one or more mapping files for the mapping-pairs in mapping. If the optional FILE argument is provided, then that single file will be produced and contain all the mappings for all the character sets in MAPPING. If FILE and INCLUDEDCHARSETS are not provided, then all of the mappings will again go to a single file with a composite name XCCS-csn1,csn2,csn3.TXT. Each cs may be a single charset number, or a range of adjacent charset numbers. For example, if the mappings contain entries for characters in charset LATIN, SYMBOLS1, SYMBOLS2, and SYMBOLS3, the file name will be XCCS-0,41-43.TXT. + +If INCLUDEDCHARSETS is provided, it specifies possibly a subset of the mappings in MAPPING for which files should be produced. This provides an implicit subsetting capability. + +Finally, if FILE is not provided and INCLUDEDCHARSETS is T, then a separate file will be produced for each of the character sets, essentially a way of splitting out characters from a collection of character sets. + diff --git a/library/UNIXCHAT b/library/UNIXCHAT new file mode 100644 index 00000000..3cccfed3 --- /dev/null +++ b/library/UNIXCHAT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "15-Aug-90 11:05:53" |{PELE:MV:ENVOS}LIBRARY>UNIXCHAT.;3| 6995 changes to%: (VARS UNIXCHATCOMS) previous date%: "13-Jun-90 01:05:35" |{PELE:MV:ENVOS}LIBRARY>UNIXCHAT.;2|) (* ; " Copyright (c) 1989, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT UNIXCHATCOMS) (RPAQQ UNIXCHATCOMS ( (* ;; "A Chat %"protocol%" that handles 1 host: SHELL, by opening a pty & fork to a csh.") (FILES UNIXCOMM CHAT) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) UNIXCOMM CHATDECLS)) (COMS (* ;; "Tell Chat about us: give host filter & opening fn.") (FNS UNIX.HOST.FILTER UNIXCHAT.OPEN) (ADDVARS (CHAT.PROTOCOLTYPES (SHELL . UNIX.HOST.FILTER)) (CHAT.HOST.TO.PROTOCOL (SHELL . SHELL))) (* ;; "make the BS key send DEL when talking to shell") (ALISTS (CHAT.HOSTINFO SHELL))) (COMS (* ;  "pseudo ostype for Shell. Not sure if this is still needed. Make sure it survives logout") (ADDVARS (NETWORKOSTYPES (SHELL . SHELL))) (PROP VARTYPE SYSTEMINITVARS) (ALISTS (SYSTEMINITVARS NETWORKOSTYPES))) (COMS (* ; "telling unix about terminal") (FNS UNIX.SENDSCREENPARAMS UNIX.SETDISPLAYTYPE LISP-TO-UNIX-TERMTYPE UNIX.PARAMS.CONFIRM) (INITVARS (CHAT.TO.UNIX.TERMINALS) (UNIXCHAT.NOTICE.RESHAPE 'ASK) (UNIXCHAT.TSET.DELAY 2000)) (GLOBALVARS CHAT.TO.UNIX.TERMINALS UNIXCHAT.NOTICE.RESHAPE)) (VARS (CHAT.ALLHOSTS (SORT (UNION '(SHELL) CHAT.ALLHOSTS) (FUNCTION UALPHORDER))) (CHAT.HOSTMENU)))) (* ;; "A Chat %"protocol%" that handles 1 host: SHELL, by opening a pty & fork to a csh.") (FILESLOAD UNIXCOMM CHAT) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) UNIXCOMM CHATDECLS) ) (* ;; "Tell Chat about us: give host filter & opening fn.") (DEFINEQ (UNIX.HOST.FILTER (LAMBDA (HOST) (* ; "Edited 13-Apr-89 17:18 by bvm") (if (AND (EQ \MACHINETYPE \MAIKO) (STRING.EQUAL HOST "SHELL")) then (QUOTE (SHELL UNIXCHAT.OPEN)))) ) (UNIXCHAT.OPEN (LAMBDA (HOST TERMTYPE) (* ; "Edited 15-Feb-90 15:01 by bvm") (* ;; "Return input and output sides of a stream connection to the %"host%" SHELL.") (AND (EQ \MACHINETYPE \MAIKO) (LET ((STR (CREATE-SHELL-STREAM TERMTYPE))) (* ; "Tell chat that no login is necessary") (LIST STR STR (QUOTE LOGOPTION) (QUOTE NONE))))) ) ) (ADDTOVAR CHAT.PROTOCOLTYPES (SHELL . UNIX.HOST.FILTER)) (ADDTOVAR CHAT.HOST.TO.PROTOCOL (SHELL . SHELL)) (* ;; "make the BS key send DEL when talking to shell") (ADDTOVAR CHAT.HOSTINFO [SHELL :KEYACTIONS ((BS (127 127]) (* ; "pseudo ostype for Shell. Not sure if this is still needed. Make sure it survives logout") (ADDTOVAR NETWORKOSTYPES (SHELL . SHELL)) (PUTPROPS SYSTEMINITVARS VARTYPE ALIST) (ADDTOVAR SYSTEMINITVARS (NETWORKOSTYPES (SHELL . SHELL))) (* ; "telling unix about terminal") (DEFINEQ (UNIX.SENDSCREENPARAMS (LAMBDA (STREAM HEIGHT WIDTH ASK) (* ; "Edited 14-Feb-90 14:14 by bvm") (if (SUBRCALL UNIX-HANDLECOMM 8) then (* ; "It's implemented right") (LET ((CONN (UNIX-CHANNEL STREAM))) (AND CONN (SUBRCALL UNIX-HANDLECOMM 10 (\DTEST CONN (QUOTE SMALLP)) (\DTEST HEIGHT (QUOTE SMALLP)) (\DTEST WIDTH (QUOTE SMALLP))))) elseif (if ASK then (UNIX.PARAMS.CONFIRM STREAM "size") elseif (STREAMPROP STREAM (QUOTE UNIXWINDOWSIZE) (CONS WIDTH HEIGHT)) then (* ; "Not the first time, so spawn a process to handle the interaction") (ADD.PROCESS (BQUOTE (UNIX.SENDSCREENPARAMS (QUOTE (\, STREAM)) (QUOTE (\, HEIGHT)) (QUOTE (\, WIDTH)) T))) NIL else (* ; "First time, do it!") T) then (CL:FORMAT STREAM "stty rows ~D columns ~D~%%" HEIGHT WIDTH))) ) (UNIX.SETDISPLAYTYPE (LAMBDA (STREAM CODE NAME ASK) (* ; "Edited 14-Feb-90 15:27 by bvm") (LET (OLDTYPE) (if (AND NAME (if (SETQ OLDTYPE (STREAMPROP STREAM (QUOTE UNIXTERMTYPE))) then (* ; "Not the first time") (if ASK then (UNIX.PARAMS.CONFIRM STREAM "type") else (* ; "spawn a proc so we don't tie up the typeout proc") (ADD.PROCESS (BQUOTE (UNIX.SETDISPLAYTYPE (QUOTE (\, STREAM)) NIL (QUOTE (\, NAME)) T))) NIL) elseif (SUBRCALL UNIX-HANDLECOMM 8) then (STREAMPROP STREAM (QUOTE UNIXTERMTYPE) NAME) (* ; "The open shell stream already told it the type, so just note it now") NIL else (* ; "First time, do it!") T)) then (if (NOT OLDTYPE) then (* ;; "On the very first call, wait until there's some output. Newer chats do this before opening the stream, which is a big improvement. This is actually a race here with chat.typeout") (LET ((TIMER (SETUPTIMER 15000)) (WINDOW (PROCESSPROP (THIS.PROCESS) (QUOTE WINDOW)))) (if (AND WINDOW (SETQ WINDOW (WINDOWPROP WINDOW (QUOTE CHATSTATE)))) then (replace (CHAT.STATE HELD) of WINDOW with T)) (until (OR (READP STREAM) (TIMEREXPIRED? TIMER)) do (BLOCK)) (if WINDOW then (replace (CHAT.STATE HELD) of WINDOW with NIL) (DISMISS UNIXCHAT.TSET.DELAY)))) (CL:FORMAT STREAM "set noglob; eval `tset ~@[-e^~A ~]-srIQ ~A`; set glob~%%" (AND (NULL OLDTYPE) (LET ((BS (CAAR (KEYACTION (QUOTE BS))))) (if (EQ BS 127) then "?" else (CL:CODE-CHAR (LOGOR BS (CHARCODE "@")))))) (LISP-TO-UNIX-TERMTYPE NAME)) (STREAMPROP STREAM (QUOTE UNIXTERMTYPE) NAME)))) ) (LISP-TO-UNIX-TERMTYPE (LAMBDA (TERMTYPE) (* ; "Edited 14-Feb-90 14:20 by bvm") (OR (CDR (ASSOC TERMTYPE CHAT.TO.UNIX.TERMINALS)) (CL:STRING-DOWNCASE TERMTYPE))) ) (UNIX.PARAMS.CONFIRM (LAMBDA (STREAM TYPE) (* ; "Edited 31-Jan-90 16:00 by bvm") (CASE UNIXCHAT.NOTICE.RESHAPE ((T) T) (ASK (EQ (MENU (create MENU ITEMS _ (QUOTE (("Stuff shell command to adjust terminal parms" T "Chat will inject a command to set the terminal parameters. You must be talking to a shell prompt for this to work. If you're not at a shell prompt now, get to one before selecting this.") ("Skip it--I'm not talking to the shell" :NO "Don't tell the host about the change"))) CENTERFLG _ T TITLE _ (CL:FORMAT NIL "Tell host about change in terminal ~A?" TYPE)) NIL T) T)))) ) ) (RPAQ? CHAT.TO.UNIX.TERMINALS ) (RPAQ? UNIXCHAT.NOTICE.RESHAPE 'ASK) (RPAQ? UNIXCHAT.TSET.DELAY 2000) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CHAT.TO.UNIX.TERMINALS UNIXCHAT.NOTICE.RESHAPE) ) (RPAQ CHAT.ALLHOSTS (SORT (UNION '(SHELL) CHAT.ALLHOSTS) (FUNCTION UALPHORDER))) (RPAQQ CHAT.HOSTMENU NIL) (PUTPROPS UNIXCHAT COPYRIGHT ("Venue & Xerox Corporation" 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2393 2918 (UNIX.HOST.FILTER 2403 . 2579) (UNIXCHAT.OPEN 2581 . 2916)) (3473 6503 ( UNIX.SENDSCREENPARAMS 3483 . 4239) (UNIX.SETDISPLAYTYPE 4241 . 5738) (LISP-TO-UNIX-TERMTYPE 5740 . 5907) (UNIX.PARAMS.CONFIRM 5909 . 6501))))) STOP \ No newline at end of file diff --git a/library/UNIXCOMM b/library/UNIXCOMM new file mode 100644 index 00000000..64f2f65a --- /dev/null +++ b/library/UNIXCOMM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "25-Apr-2018 07:31:56"  {DSK}kaplan>Local>medley3.5>lispcore>library>UNIXCOMM.;39 19642 changes to%: (VARS UNIXCOMMCOMS) previous date%: "24-Apr-2018 20:45:11" {DSK}kaplan>Local>medley3.5>lispcore>library>UNIXCOMM.;38) (* ; " Copyright (c) 1988, 1989, 1990, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT UNIXCOMMCOMS) (RPAQQ UNIXCOMMCOMS [ (* ;; "streams to UNIX processes & pseudo terminals") (* ;; "this stuff should really be implemented in terms of {SHELL} and {PTY} devices") (COMS (* ; "Forking stuff") (FNS FORK-SHELL FORK-UNIX UNIX-KILL UNIX-WRITE CREATE-SHELL-STREAM CREATE-PROCESS-STREAM UNIXCOMM-AROUNDEXITFN)) [COMS (* ; "Operations on the shell device") (FNS INITIALIZE-NEW-SHELL-DEVICE UNIX-GET-NEXT-BUFFER UNIX-BACKFILEPTR-NEW UNIX-STREAM-EOFP-NEW UNIX-STREAM-OUT UNIX-STREAM-CLOSE) (GLOBALVARS *NEW-SHELL-DEVICE*) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INITIALIZE-NEW-SHELL-DEVICE)) (ADDVARS (AROUNDEXITFNS UNIXCOMM-AROUNDEXITFN] (COMS (* ;  "Stuff for direct manipulation of Unix sockets") (FNS CREATE-UNIX-SOCKET-STREAM ACCEPT-UNIX-SOCKET-STREAM)) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNIX-CHANNEL) (P (CHECKIMPORTS '(FILEIO LLSUBRS) T))) [COMS (* ;; "Obsolete stuff. This is for pre-Medley1.2, where there wasn't support for buffered input on the shell device") (FNS UNIX-BACKFILEPTR UNIX-READ INITIALIZE-SHELL-DEVICE UNIX-STREAM-IN UNIX-STREAM-EOFP UNIX-STREAM-PEEK) (GLOBALVARS *SHELL-DEVICE*) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNIX-PEEKEDCHAR UNIX-LASTCHAR)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INITIALIZE-SHELL-DEVICE] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ;; "streams to UNIX processes & pseudo terminals") (* ;; "this stuff should really be implemented in terms of {SHELL} and {PTY} devices") (* ; "Forking stuff") (DEFINEQ (FORK-SHELL [LAMBDA (TERMTYPE COMMAND) (* ; "Edited 14-Feb-90 14:27 by bvm") (if (SUBRCALL UNIX-HANDLECOMM 8) then (* ;  "Yes, lde supports this new version") [SUBRCALL UNIX-HANDLECOMM 11 (if (NULL TERMTYPE) then "" elseif (TYPEP TERMTYPE 'ONED-ARRAY) then TERMTYPE else (\DTEST (LISP-TO-UNIX-TERMTYPE TERMTYPE) 'ONED-ARRAY)) (if (NULL COMMAND) then "" else (\DTEST COMMAND 'ONED-ARRAY] elseif COMMAND then (* ;  "have to use a different old call") (FORK-UNIX COMMAND) else (SUBRCALL UNIX-HANDLECOMM 4]) (FORK-UNIX [LAMBDA (STR) (* ; "Edited 25-May-88 15:47 by drc:") (SUBRCALL UNIX-HANDLECOMM 0 (\DTEST STR 'ONED-ARRAY]) (UNIX-KILL [LAMBDA (CONN) (* ; "Edited 25-May-88 16:04 by drc:") (if CONN then (SUBRCALL UNIX-HANDLECOMM 3 CONN 0]) (UNIX-WRITE [LAMBDA (CONN VAL) (* ; "Edited 24-Sep-90 11:27 by jds") (* ;; "Write a byte (VAL) to the outgoing pipe connection CONN. If the write fails for non-fatal reasons (i.e., would block), loop unitl it succeeds. If the write returns NIL (meaning total failure), pass that along to the caller.") (PROG (LENGTH-WRITTEN) WRITE-LOOP [SETQ LENGTH-WRITTEN (SUBRCALL UNIX-HANDLECOMM 1 (\DTEST CONN 'SMALLP) (\DTEST VAL 'SMALLP] (COND ((AND LENGTH-WRITTEN (IEQP 0 LENGTH-WRITTEN)) (BLOCK) (GO WRITE-LOOP))) (RETURN LENGTH-WRITTEN]) (CREATE-SHELL-STREAM [LAMBDA (TERMTYPE COMMAND) (* ; "Edited 21-May-90 15:39 by jrb:") (LET ((CHAN (FORK-SHELL TERMTYPE COMMAND)) (SHELL-DEV (if (SUBRCALL UNIX-HANDLECOMM 8) then (* ;  "SUBRCALL tests that this is supported") *NEW-SHELL-DEVICE* else *SHELL-DEVICE*))) (COND (CHAN (LET ((STR (create STREAM ACCESS _ 'BOTH DEVICE _ SHELL-DEV))) (CL:SETF (UNIX-CHANNEL STR) CHAN) (* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.") (push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*) STR) (STREAMPROP STR 'SENDSCREENPARAMS (FUNCTION UNIX.SENDSCREENPARAMS)) (STREAMPROP STR 'SETDISPLAYTYPE (FUNCTION UNIX.SETDISPLAYTYPE)) STR]) (CREATE-PROCESS-STREAM [LAMBDA (COMM) (* ; "Edited 21-May-90 15:39 by jrb:") (LET* ((SHELL-DEV (if (SUBRCALL UNIX-HANDLECOMM 8) then (* ;  "SUBRCALL tests that this is supported") *NEW-SHELL-DEVICE* else *SHELL-DEVICE*)) (STR (create STREAM ACCESS _ 'BOTH DEVICE _ SHELL-DEV EOLCONVENTION _ LF.EOLC)) (CHAN (FORK-UNIX COMM))) (if CHAN then (CL:SETF (UNIX-CHANNEL STR) CHAN) (* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.") (push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*) STR) STR else NIL]) (UNIXCOMM-AROUNDEXITFN [LAMBDA (EVENT) (* ; "Edited 2-Jul-90 16:35 by jrb:") (CASE EVENT ((AFTERLOGOUT AFTERMAKESYS AFTERSAVEVM AFTERSYSOUT) (for STREAM in (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*) do (CLOSEF STREAM))) ((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT) (* ;;  "Make sure any Unix sockets get closed here, so their file system handles get closed as well") (for STREAM in (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*) when (EQ -3 (SUBRCALL UNIX-HANDLECOMM 14 (UNIX-CHANNEL STREAM))) do (CLOSEF STREAM))))]) ) (* ; "Operations on the shell device") (DEFINEQ (INITIALIZE-NEW-SHELL-DEVICE [LAMBDA NIL (* ; "Edited 12-Feb-90 17:00 by bvm") (SETQ *NEW-SHELL-DEVICE* (create FDEV FDBINABLE _ T NODIRECTORIES _ T DEVICENAME _ (FUNCTION UNIX-PTY-NEW) BIN _ (FUNCTION \BUFFERED.BIN) BOUT _ (FUNCTION UNIX-STREAM-OUT) PEEKBIN _ (FUNCTION \BUFFERED.PEEKBIN) CLOSEFILE _ (FUNCTION UNIX-STREAM-CLOSE) GETFILEINFO _ (FUNCTION NILL) SETFILEINFO _ (FUNCTION NILL) EOFP _ (FUNCTION UNIX-STREAM-EOFP-NEW) BACKFILEPTR _ (FUNCTION UNIX-BACKFILEPTR-NEW) GETNEXTBUFFER _ (FUNCTION UNIX-GET-NEXT-BUFFER) BLOCKIN _ (FUNCTION \BUFFERED.BINS]) (UNIX-GET-NEXT-BUFFER [LAMBDA (STREAM WHATFOR NOERRORFLG) (* ;  "Edited 13-Jun-90 01:07 by mitani") (CASE WHATFOR (READ [PROG ([BUF (ffetch (STREAM CBUFPTR) of (\DTEST STREAM 'STREAM] (CONN (UNIX-CHANNEL STREAM)) LEN) RETRY (BLOCK) (* ;  "Just so other procs get to run when someone is pounding output at Chat") (if [AND CONN (SETQ LEN (SUBRCALL UNIX-HANDLECOMM 9 (\DTEST CONN 'SMALLP) (OR BUF (replace (STREAM CBUFPTR) of STREAM with (SETQ BUF (NCREATE 'VMEMPAGEP] then (if (EQ LEN T) then (* ;  " no input available, but still alive") (if NOERRORFLG then (RETURN NIL) else (* ;  "Called from BIN--wait and try again") (GO RETRY)) else (UNINTERRUPTABLY (replace (STREAM COFFSET) of STREAM with 0) (replace (STREAM CBUFSIZE) of STREAM with LEN)) (RETURN T)) else (RETURN (AND (NOT NOERRORFLG) (\EOF.ACTION STREAM]) (T (SHOULDNT)))]) (UNIX-BACKFILEPTR-NEW [LAMBDA (STREAM) (* ;  "Edited 13-Jun-90 01:07 by mitani") (COND ((AND (fetch (STREAM CBUFPTR) of STREAM) (> (fetch (STREAM COFFSET) of STREAM) 0)) (add (fetch (STREAM COFFSET) of STREAM) -1)) (T (ERROR "Can't back up this unix Stream" STREAM]) (UNIX-STREAM-EOFP-NEW [LAMBDA (STREAM) (* ;  "Edited 13-Jun-90 01:07 by mitani") (* ;;; "true if bsp STREAM is at end of file, i.e. is at a mark") (COND ((AND (ffetch (STREAM CBUFPTR) of (\DTEST STREAM 'STREAM)) (< (ffetch (STREAM COFFSET) of STREAM) (ffetch (STREAM CBUFSIZE) of STREAM))) NIL) (T (NOT (UNIX-GET-NEXT-BUFFER STREAM 'READ T]) (UNIX-STREAM-OUT [LAMBDA (STREAM CHAR) (* ; "Edited 12-Jun-90 12:58 by jrb:") (OR (UNIX-WRITE (UNIX-CHANNEL STREAM) (\DTEST CHAR 'SMALLP)) (CL:ERROR 'XCL:STREAM-NOT-OPEN STREAM]) (UNIX-STREAM-CLOSE [LAMBDA (STREAM) (* ; "Edited 12-Aug-88 13:24 by drc:") (PROG1 (UNIX-KILL (UNIX-CHANNEL STREAM)) (CL:SETF (UNIX-CHANNEL STREAM) NIL) (CL:SETF (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*) (REMOVE STREAM (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*))))]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *NEW-SHELL-DEVICE*) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (INITIALIZE-NEW-SHELL-DEVICE) (ADDTOVAR AROUNDEXITFNS UNIXCOMM-AROUNDEXITFN) ) (* ; "Stuff for direct manipulation of Unix sockets") (DEFINEQ (CREATE-UNIX-SOCKET-STREAM [LAMBDA (PATHNAME) (* ; "Edited 29-May-90 16:23 by jrb:") (LET [(STR (create STREAM ACCESS _ 'BOTH DEVICE _ *NEW-SHELL-DEVICE* EOLCONVENTION _ LF.EOLC)) (CHAN (SUBRCALL UNIX-HANDLECOMM 12 (\DTEST PATHNAME 'ONED-ARRAY] (if CHAN then (CL:SETF (UNIX-CHANNEL STR) CHAN) (* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.") (push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*) STR) STR else NIL]) (ACCEPT-UNIX-SOCKET-STREAM [LAMBDA (SOCKSTREAM) (* ; "Edited 29-May-90 16:31 by jrb:") (LET ((CHAN (UNIX-CHANNEL SOCKSTREAM)) NEWCHAN) (SELECTQ (SETQ NEWCHAN (SUBRCALL UNIX-HANDLECOMM 13 CHAN)) ((-1 NIL) NEWCHAN) (LET ((NEWSTREAM (create STREAM ACCESS _ 'BOTH DEVICE _ *NEW-SHELL-DEVICE* EOLCONVENTION _ LF.EOLC))) (CL:SETF (UNIX-CHANNEL NEWSTREAM) NEWCHAN) (* ;; "JRB - In a future release, make *SHELL-DEVICE* below SHELL-DEV, or just remove *SHELL-DEVICE* altogether. Must also hack UNIX-STREAM-CLOSE and the aroundexitfn for Unix streams.") (push (fetch (FDEV OPENFILELST) of *SHELL-DEVICE*) NEWSTREAM) NEWSTREAM]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS UNIX-CHANNEL MACRO ((STR) (fetch (STREAM F1) of STR))) ) (CHECKIMPORTS '(FILEIO LLSUBRS) T) ) (* ;; "Obsolete stuff. This is for pre-Medley1.2, where there wasn't support for buffered input on the shell device" ) (DEFINEQ (UNIX-BACKFILEPTR [LAMBDA (STREAM) (* ; "Edited 14-Dec-88 09:52 by bane") (* ;; "The trick here is to use the existing mechanisms for UNIX-PEEKCHAR") (COND ((UNIX-PEEKEDCHAR STREAM) (ERROR "Can only back up one character" STREAM)) ((NOT (UNIX-LASTCHAR STREAM)) (ERROR "Can't back up past beginning of stream" STREAM)) (T (CL:SETF (UNIX-PEEKEDCHAR STREAM) (UNIX-LASTCHAR STREAM]) (UNIX-READ [LAMBDA (STREAM NO-ERROR) (* ; "Edited 14-Dec-88 09:18 by bane") (LET* [(CONN (UNIX-CHANNEL STREAM)) (CH (AND CONN (SUBRCALL UNIX-HANDLECOMM 2 (\DTEST CONN 'SMALLP) 0] (COND ((EQ CH T) NIL) [(EQ CH NIL) (COND (NO-ERROR NIL) (T (\EOF.ACTION STREAM] (T (CL:SETF (UNIX-LASTCHAR STREAM) CH]) (INITIALIZE-SHELL-DEVICE [LAMBDA NIL (* ; "Edited 14-Dec-88 10:45 by bane") (SETQ *SHELL-DEVICE* (create FDEV NODIRECTORIES _ T DEVICENAME _ 'UNIX-PTY BIN _ 'UNIX-STREAM-IN BOUT _ 'UNIX-STREAM-OUT PEEKBIN _ 'UNIX-STREAM-PEEK CLOSEFILE _ 'UNIX-STREAM-CLOSE GETFILEINFO _ 'NILL SETFILEINFO _ 'NILL EOFP _ 'UNIX-STREAM-EOFP BACKFILEPTR _ 'UNIX-BACKFILEPTR]) (UNIX-STREAM-IN [LAMBDA (STREAM) (* ; "Edited 9-May-88 15:05 by ") (LET (CH) (if (SETQ CH (UNIX-PEEKEDCHAR STREAM)) then (CL:SETF (UNIX-PEEKEDCHAR STREAM) NIL) else (while (NOT (SETQ CH (UNIX-READ STREAM))) do (BLOCK))) CH]) (UNIX-STREAM-EOFP [LAMBDA (STREAM) (* ; "Edited 2-Apr-90 11:51 by jds") (* ;; "EOFP method for unix-shell streams. Notices when there are chars yet to read and doesn't set EOFP.") (AND (NOT (UNIX-PEEKEDCHAR STREAM)) (LET* [(CONN (UNIX-CHANNEL STREAM)) (CH (AND CONN (SUBRCALL UNIX-HANDLECOMM 2 (\DTEST CONN 'SMALLP) 0] (COND ((EQ CH T) NIL) ((EQ CH NIL) T) (T (CL:SETF (UNIX-PEEKEDCHAR STREAM) CH) (CL:SETF (UNIX-LASTCHAR STREAM) CH) NIL]) (UNIX-STREAM-PEEK [LAMBDA (STREAM NO-ERROR) (* ; "Edited 24-Jun-88 15:07 by drc:") (OR (UNIX-PEEKEDCHAR STREAM) (CL:SETF (UNIX-PEEKEDCHAR STREAM) (UNIX-READ STREAM NO-ERROR]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *SHELL-DEVICE*) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS UNIX-PEEKEDCHAR MACRO ((STR) (FETCH (STREAM F2) OF STR))) (PUTPROPS UNIX-LASTCHAR MACRO ((STR) (FETCH (STREAM F3) OF STR))) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (INITIALIZE-SHELL-DEVICE) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS UNIXCOMM COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2704 8376 (FORK-SHELL 2714 . 3911) (FORK-UNIX 3913 . 4089) (UNIX-KILL 4091 . 4280) ( UNIX-WRITE 4282 . 4993) (CREATE-SHELL-STREAM 4995 . 6311) (CREATE-PROCESS-STREAM 6313 . 7473) ( UNIXCOMM-AROUNDEXITFN 7475 . 8374)) (8424 13412 (INITIALIZE-NEW-SHELL-DEVICE 8434 . 9527) ( UNIX-GET-NEXT-BUFFER 9529 . 11729) (UNIX-BACKFILEPTR-NEW 11731 . 12210) (UNIX-STREAM-EOFP-NEW 12212 . 12758) (UNIX-STREAM-OUT 12760 . 13016) (UNIX-STREAM-CLOSE 13018 . 13410)) (13668 15533 ( CREATE-UNIX-SOCKET-STREAM 13678 . 14539) (ACCEPT-UNIX-SOCKET-STREAM 14541 . 15531)) (15856 19035 ( UNIX-BACKFILEPTR 15866 . 16364) (UNIX-READ 16366 . 16888) (INITIALIZE-SHELL-DEVICE 16890 . 17629) ( UNIX-STREAM-IN 17631 . 18007) (UNIX-STREAM-EOFP 18009 . 18783) (UNIX-STREAM-PEEK 18785 . 19033))))) STOP \ No newline at end of file diff --git a/library/UNIXPRINT b/library/UNIXPRINT new file mode 100644 index 00000000..3ce35fcb --- /dev/null +++ b/library/UNIXPRINT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 4-May-2018 17:18:00"  {DSK}kaplan>Local>medley3.5>lispcore>library>UNIXPRINT.;8 14600 changes to%: (FNS UnixPrintCommand) previous date%: "16-Apr-2018 17:25:15" {DSK}kaplan>Local>medley3.5>lispcore>library>UNIXPRINT.;7) (* ; " Copyright (c) 1990, 1991, 1992, 1993, 1995, 1997, 1999, 2001, 2018 by Venue. All rights reserved. ") (PRETTYCOMPRINT UNIXPRINTCOMS) (RPAQQ UNIXPRINTCOMS [(FNS InstallUnixPrinter UnixPrint UnixShellQuote UnixTempFile UnixPrintCommand) (FUNCTIONS ShellCommand) (INITVARS (UnixPrinterName NIL) (UNIXPRINTSWITCHES " -r -s ")) (P (* ;;  "(InstallUnixPrinter) commented out because POSTSCRIPT indirects according to platform") (PRIN1 "Please feel free to edit UnixPrintCommand." PROMPTWINDOW)) (PROP FILETYPE UNIXPRINT) (DECLARE%: DONTEVAL@COMPILE DOCOPY (FNS UnixPrintCommand)) (DECLARE%: EVAL@COMPILE DOCOPY (FILES UNIXCOMM)) (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS UnixPrinterName)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (DEFINEQ (InstallUnixPrinter [LAMBDA (PrinterTypes) (* ; "Edited 8-Feb-97 11:33 by rmk:") (* ;; "Set up any printers in PrinterTypes (or just Postscript by default) so that they'll be printed using the unix LPR command.") (DECLARE (GLOBALVARS PRINTERTYPES)) (for type inside (OR PrinterTypes '(POSTSCRIPT)) do (for x in PRINTERTYPES when (EQMEMB type (CAR x)) do (LET ((PRINTERTYPE type)) (PUTASSOC 'SEND (LIST 'UnixPrint) (CDR x]) (UnixPrint [LAMBDA (HOST FILE PRINTOPTIONS) (* ; "Edited 7-Dec-2001 14:55 by rmk:") (* ; "Edited 20-May-92 14:13 by nilsson") (* ;; "Given a print FILE, use the Unix %"lpr%" command to spool it to a printer.") (* ;; "The printer is named by HOST or UnixPrinterName, a Global variable.") [LET* ((PRINTER (OR HOST UnixPrinterName)) (COPIES (LISTGET PRINTOPTIONS '%#COPIES)) (NAME (LISTGET PRINTOPTIONS 'DOCUMENT.NAME)) (NSIDES (LISTGET PRINTOPTIONS '%#SIDES)) (TYPE (PRINTERTYPE PRINTER))) (* ;; "Removed redundant check (we already know it's a PS printer), JDS 2/19/92:") (* ;; "(COND ((NULL TYPE) (ERROR (CONCAT %"Printertype unknown for %" PRINTER))) ((NOT (EQL (U-CASE TYPE) 'POSTSCRIPT)) (ERROR (CONCAT %"Printertype for %" PRINTER %" is not Postscript%"))))") [COND ((OR (NULL NAME) (STRPOS "{LPT}" NAME 1 NIL T)) (SETQ NAME "Medley Output")) ((EQ (CHCON1 NAME) (CHARCODE {)) (SETQ NAME (UNPACKFILENAME.STRING NAME 'NAME)) (COND ((EQ (NCHARS NAME) 0) (SETQ NAME "Medley Output"] (* ;; "Don't break if you have trouble with preexisting files, e.g. because of protection.") (FOR F IN [CAR (NLSETQ (FILDIR (PACKFILENAME 'HOST 'DSK 'EXTENSION '* 'BODY (UnixTempFile 'medleyprint. T] WHEN (CAR (NLSETQ (IGREATERP (DIFFERENCE (IDATE) (GETFILEINFO F 'ICREATIONDATE)) 120))) DO (NLSETQ (DELFILE F))) (* ;; "The temp file's name will be of the form medleyprint., so all such files can be found for deletion on a subsequent call after a certain amount of time (2 minutes) has gone by. If we delete immediately, it may happen before lpr has done its thing. ") (CL:MULTIPLE-VALUE-BIND (tmpstream tmpname) (UnixTempFile 'medleyprint.) (COND (tmpstream (* ;; "First, copy the lisp file to /tmp so lpr can find it.") [CL:WITH-OPEN-STREAM (out tmpstream) (CL:WITH-OPEN-STREAM (in (OPENSTREAM FILE 'INPUT)) (printout PROMPTWINDOW .TAB0 0 "Spooling output to Unix printer" (COND (PRINTER (CONCAT " '" PRINTER "'")) (T "")) "...") (IF NSIDES THEN (* ;; "Have to put magic simplex/duplex stuff in the tmp file itself, after the first line, cause there is no other way to control some duplex printers.") (BIND C SAWCR DO (SETQ C (BIN in)) (IF (MEMB C (CHARCODE (CR LF))) THEN (BOUT out C) (SETQ SAWCR T) ELSEIF SAWCR THEN (* ;;  "First char of 2nd line: nonCR/LF after CR/LF") (* ;;  "Put out simplex header, then print character in C") (PRINTOUT out "%%BeginSetup" T) (PRINTOUT out "[{" T "%%%%BeginFeature: *Duplex Simplex" T "<< /Duplex " (CL:IF (EQ NSIDES 1) "false" "true") " /Tumble false >> setpagedevice" T "%%%%EndFeature" T "} stopped cleartomark" T) (PRINTOUT out "%%EndSetup" T) (BOUT out C) (COPYCHARS in out (GETFILEPTR in) -1) (RETURN) ELSE (BOUT out C))) ELSE (COPYCHARS in out 0 -1] (* ;; "Now make Unix print the /tmp file.") (ShellCommand (UnixPrintCommand PRINTER COPIES NAME tmpname) PROMPTWINDOW) (printout PROMPTWINDOW "done" T)) (T (ERROR "Couldn't create unix temp file"] T]) (UnixShellQuote [LAMBDA (STRING) (DECLARE (LOCALVARS . T)) (* ; "Edited 19-Apr-89 21:14 by TAL") (LET* ((X (CHCON STRING)) (CT X) C FLG) [while (LISTP CT) do (SETQ C (CAR CT)) (COND ([OR (<= (CHARCODE a) C (CHARCODE z)) (<= (CHARCODE A) C (CHARCODE Z)) (<= (CHARCODE 0) C (CHARCODE 9)) (FMEMB C (CHARCODE (- /] (SETQ CT (CDR CT))) (T (SETQ FLG T) (RPLNODE CT (CHARCODE \) (CONS (COND ((FMEMB C (CHARCODE (CR LF))) (CHARCODE SPACE)) (T C)) (SETQ CT (CDR CT] (COND (FLG (CONCATCODES X)) (T STRING]) (UnixTempFile [LAMBDA (Prefix DontOpen) (* ; "Edited 28-Apr-93 13:49 by rmk:") (* ; "Edited 12-Jan-89 19:07 by TAL") (LET* ([host (AND (BOUNDP 'FISTempDir) (UNPACKFILENAME.STRING FISTempDir 'HOST] (dir (OR [COND ((OR (STRING-EQUAL host "UNIX") (STRING-EQUAL host "DSK")) (UNPACKFILENAME.STRING FISTempDir 'DIRECTORY] "tmp")) (str (CONCAT (OR Prefix "") (IDATE))) file unix) (COND ([for i from 1 to 100 thereis (NOT (INFILEP (SETQ file (CONCAT "{UNIX}" (SETQ unix (CONCAT "/" dir "/" str i] (CL:VALUES [COND (DontOpen file) (T (* ;;  "Type TEXT seems to be important for Apple LaserWriters at PARC") (OPENSTREAM file 'OUTPUT NIL '((TYPE TEXT] unix]) (UnixPrintCommand [LAMBDA (PRINTER COPIES NAME TMPNAME) (* ; "Edited 4-May-2018 17:17 by rmk:") (* ;  "Edited 20-May-92 14:26 by nilsson") (* ;; "This function is called when the user wants to UNIXPRINT a file. It has to return a string that when sent to a shell prints the file tmpname. In the cub version this should look something like %"/usr/ucb/lpr tmpname%". The arguments to this function are:") (* ;; " PRINTER - the name of the printer. Usually something like lw or plw.") (* ;; "COPIES - how many copies of this job to be printed.") (* ;; "NAME - the name of this job. This gets printed on the banner of your job.") (* ;;  "TMPNAME - The name of the temporary file that contains the postscript code for this job. ") (* ;; "Note the clever function UnixShellQuote. It converts any lisp name to a string that is quoted according to /bin/sh syntax") (* ;; "UNIXPRINTSWITCHES makes it easy for other sites to change just the lpr switches.") (* ;; "Use raw lpr, let system decide where it is located.") (CONCAT "lpr " (COND ((AND PRINTER (NEQ 0 (NCHARS PRINTER))) (CONCAT "-P" (UnixShellQuote PRINTER) " ")) (T "")) (COND ((AND (FIXP COPIES) (NEQ COPIES 1)) (CONCAT "-#" COPIES " ")) (T "")) " -J" (UnixShellQuote NAME) " " (OR UNIXPRINTSWITCHES "") " " TMPNAME]) ) (CL:DEFUN ShellCommand (Cmd &OPTIONAL (Output T)) (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM Cmd)) (CL:TAGBODY [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (GO OUT] (CL:LOOP (PRINTCCODE (READCCODE s) Output)) OUT)) NIL) (RPAQ? UnixPrinterName NIL) (RPAQ? UNIXPRINTSWITCHES " -r -s ") (* ;; "(InstallUnixPrinter) commented out because POSTSCRIPT indirects according to platform") (PRIN1 "Please feel free to edit UnixPrintCommand." PROMPTWINDOW) (PUTPROPS UNIXPRINT FILETYPE :COMPILE-FILE) (DECLARE%: DONTEVAL@COMPILE DOCOPY (DEFINEQ (UnixPrintCommand [LAMBDA (PRINTER COPIES NAME TMPNAME) (* ; "Edited 4-May-2018 17:17 by rmk:") (* ;  "Edited 20-May-92 14:26 by nilsson") (* ;; "This function is called when the user wants to UNIXPRINT a file. It has to return a string that when sent to a shell prints the file tmpname. In the cub version this should look something like %"/usr/ucb/lpr tmpname%". The arguments to this function are:") (* ;; " PRINTER - the name of the printer. Usually something like lw or plw.") (* ;; "COPIES - how many copies of this job to be printed.") (* ;; "NAME - the name of this job. This gets printed on the banner of your job.") (* ;;  "TMPNAME - The name of the temporary file that contains the postscript code for this job. ") (* ;; "Note the clever function UnixShellQuote. It converts any lisp name to a string that is quoted according to /bin/sh syntax") (* ;; "UNIXPRINTSWITCHES makes it easy for other sites to change just the lpr switches.") (* ;; "Use raw lpr, let system decide where it is located.") (CONCAT "lpr " (COND ((AND PRINTER (NEQ 0 (NCHARS PRINTER))) (CONCAT "-P" (UnixShellQuote PRINTER) " ")) (T "")) (COND ((AND (FIXP COPIES) (NEQ COPIES 1)) (CONCAT "-#" COPIES " ")) (T "")) " -J" (UnixShellQuote NAME) " " (OR UNIXPRINTSWITCHES "") " " TMPNAME]) ) ) (DECLARE%: EVAL@COMPILE DOCOPY (FILESLOAD UNIXCOMM) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS UnixPrinterName) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS UNIXPRINT COPYRIGHT ("Venue" 1990 1991 1992 1993 1995 1997 1999 2001 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1423 11730 (InstallUnixPrinter 1433 . 2041) (UnixPrint 2043 . 7114) (UnixShellQuote 7116 . 8670) (UnixTempFile 8672 . 9980) (UnixPrintCommand 9982 . 11728)) (11732 12105 (ShellCommand 11732 . 12105)) (12439 14197 (UnixPrintCommand 12449 . 14195))))) STOP \ No newline at end of file diff --git a/library/UNIXPRINTCOMMAND b/library/UNIXPRINTCOMMAND new file mode 100644 index 00000000..24fd2e1e --- /dev/null +++ b/library/UNIXPRINTCOMMAND @@ -0,0 +1,78 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") +(FILECREATED "20-May-92 15:34:18" |{DSK}nilsson>UNIXPRINTCOMMAND.;1| 3317 + + |changes| |to:| (VARS UNIXPRINTCOMMANDCOMS) + (FUNCTIONS FOOT) + (FNS |UnixPrintCommandForHP|)) + + +; Copyright (c) 1992 by Venue. All rights reserved. + +(PRETTYCOMPRINT UNIXPRINTCOMMANDCOMS) + +(RPAQQ UNIXPRINTCOMMANDCOMS ((FNS |UnixPrintCommand| |UnixPrintCommandForHP|))) +(DEFINEQ + +(|UnixPrintCommand| + (LAMBDA (PRINTER COPIES NAME TMPNAME) (* \; "Edited 20-May-92 14:26 by nilsson") + + (* |;;| "This function is called when the user wants to UNIXPRINT a file. It has to return a string that when sent to a shell prints the file tmpname. In the cub version this should look something like \"/usr/ucb/lpr tmpname\". The arguments to this function are:") + + (* |;;| " PRINTER - the name of the printer. Usually something like lw or plw.") + + (* |;;| "COPIES - how many copies of this job to be printed.") + + (* |;;| "NAME - the name of this job. This gets printed on the banner of your job.") + + (* |;;| + "TMPNAME - The name of the temporary file that contains the postscript code for this job. ") + + (* |;;| "Note the clever function UnixShellQuote. It converts any lisp name to a string that is quoted according to /bin/sh syntax") + + (CONCAT "/usr/ucb/lpr " (COND + (PRINTER (CONCAT "-P" (|UnixShellQuote| PRINTER) + " ")) + (T "")) + (COND + ((AND (FIXP COPIES) + (NEQ COPIES 1)) + (CONCAT "-#" COPIES " ")) + (T "")) + " -J" + (|UnixShellQuote| NAME) + " -r -s " TMPNAME))) + +(|UnixPrintCommandForHP| + (LAMBDA (PRINTER COPIES NAME TMPNAME) (* \; "Edited 20-May-92 15:33 by nilsson") + + (* |;;| "This function is called when the user wants to UNIXPRINT a file. It has to return a string that when sent to a shell prints the file tmpname. In the cub version this should look something like \"/usr/ucb/lpr tmpname\". The arguments to this function are:") + + (* |;;| " PRINTER - the name of the printer. Usually something like lw or plw.") + + (* |;;| "COPIES - how many copies of this job to be printed.") + + (* |;;| "NAME - the name of this job. This gets printed on the banner of your job.") + + (* |;;| + "TMPNAME - The name of the temporary file that contains the postscript code for this job. ") + + (* |;;| "Note the clever function UnixShellQuote. It converts any lisp name to a string that is quoted according to /bin/sh syntax") + + (CONCAT "/usr/ucb/lp " (* \; "HPUX uses lp instead.") + (COND + (PRINTER (CONCAT "-P" (|UnixShellQuote| PRINTER) + " ")) + (T "")) + (COND + ((AND (FIXP COPIES) + (NEQ COPIES 1)) + (CONCAT "-#" COPIES " ")) + (T "")) + " -J" + (|UnixShellQuote| NAME) + " -r -s " TMPNAME))) +) +(PUTPROPS UNIXPRINTCOMMAND COPYRIGHT ("Venue" 1992)) +(DECLARE\: DONTCOPY + (FILEMAP (NIL (472 3241 (|UnixPrintCommand| 482 . 1843) (|UnixPrintCommandForHP| 1845 . 3239))))) +STOP diff --git a/library/VIRTUALKEYBOARDS b/library/VIRTUALKEYBOARDS new file mode 100644 index 00000000..3f605956 --- /dev/null +++ b/library/VIRTUALKEYBOARDS @@ -0,0 +1,1489 @@ +(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "XCL" BASE 10) (FILECREATED "22-Dec-2018 22:58:47"  |{DSK}kaplan>Local>medley3.5>lispcore>library>VIRTUALKEYBOARDS.;10| 141793 |changes| |to:| (VARS VIRTUALKEYBOARDSCOMS VKBD.BACKGROUND-MENU-SUBITEMS VKBD.NON-CHAR-ASSIGNMENTS-LABELS VKBD.WINDOW-MENU-SUBITEMS VKBD.ICON VKBD.MASK MODEACTIONS) (RECORDS KEYBOARDCONFIGURATION VIRTUALKEYBOARD) |previous| |date:| "22-Dec-2018 22:52:44" |{DSK}kaplan>Local>medley3.5>lispcore>library>VIRTUALKEYBOARDS.;9|) ; Copyright (c) 1985, 1986, 1987, 1988, 1990, 1992, 1993, 1995, 1996, 2017, 2018 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT VIRTUALKEYBOARDSCOMS) (RPAQQ VIRTUALKEYBOARDSCOMS ((FNS FINDVIRTUALKEYBOARD PROCESS.KEYBOARD VKBD.CREATE-KEYACTION-TABLE VKBD.WINDOWMENUFN VKBD.WINDOWMENUINIT) (COMS (FNS LOADKEYBOARDDISPLAYFONTS) (INITVARS VKBD.CACHEDCHARSETS) (GLOBALVARS VKBD.CACHEDCHARSETS)) (FNS DEFINEKEYBOARD) (FNS VKBD.ADD-ITEM-TO-BACKGROUND-MENU VKBD.INIT VKBD.CREATE-DEFAULT-KEYBOARD VKBD.ADD-DEFAULT-KEYBOARD) (FNS VKBD.LOAD-FILE-COMMAND VKBD.LOAD-KEYBOARD-FILE VKBD.STORE-FILE-COMMAND VKBD.STORE-KEYBOARD-FILE) (FNS SWITCHKEYBOARDS VKBD.POP-MENU-AND-SWITCH-KEYBOARDS VKBD.POP-UP-KEYBOARDS-MENU VKBD.GET-CONFIGURATION VKBD.SUBCONFIGURATION) (FNS VKBD.BUTTONEVENTFN VKBD.CENTER-BITMAP-IN-REGION VKBD.CLEAR-KEY-DISPLAY VKBD.CREATE-KEYBOARD-BITMAP VKBD.CREATE-KEYBOARD-DISPLAY VKBD.CURSORMOVEDFN VKBD.DISPLAY-CHARACTER VKBD.DISPLAY-EMPTY-KEY-CAP VKBD.DISPLAY-KEY VKBD.DISPLAY-KEY-CHARACTERS VKBD.DRAW-KEY-CAPS VKBD.ERASE-FRAME VKBD.EXTEND-REGION VKBD.GET-KEY-AND-REGIONS-OF-CURSOR-POSITION VKBD.GET-KEY-REGIONS VKBD.INVERT-KEY VKBD.INVERT-REGION VKBD.KEYBOARD-WINDOW-REPAINTFN VKBD.LOWER-HALF-REGION VKBD.POSITION-IS-IN-KEY-REGION VKBD.REMOVE-KEYBOARD-COMMAND VKBD.UNION-REGIONS VKBD.UPPER-HALF-REGION) (FNS VKBD.KEY-ASSOC VKBD.CHAR-ASSIGNMENTP VKBD.COMPLETE-KEYBOARD VKBD.CTRL-ASSIGNMENTP VKBD.EVENT-ASSIGNMENTP VKBD.META-ASSIGNMENTP VKBD.FRAME-KEY VKBD.GET-CURRENT-KEY-ASSIGNMENT VKBD.GET-NON-CHAR-LABEL VKBD.ICONFN VKBD.INVERT-LOCK-KEYS VKBD.INVERT-SHIFT-KEYS VKBD.TRANSLATE-KEY-ID VKBD.KEY-ID-TO-KEY-NAMES VKBD.KEYBOARD-IS-KEYBOARDTYPE-KEYBOARD VKBD.LOCK-ASSIGNMENTP VKBD.LOCK-KEYP VKBD.LOCK/NOLOCK VKBD.LOCKDOWN-ASSIGNMENTP VKBD.LOCKUP-ASSIGNMENTP VKBD.PARSE-CHAR-CODE VKBD.PARSE-KEY-ASSIGNMENT VKBD.RESET-KEYBOARD-WINDOW VKBD.SEND-CHARACTER VKBD.SHIFT-ASSIGNMENTP VKBD.SHIFTED-CHAR VKBD.UNDEFINE-KEYBOARD VKBD.UNSHIFTED-CHAR) (ALISTS (CHARACTERNAMES BREAK HOME PGUP END PGDN INS HELP SCRL NUMLK CLEAR DOIT CENTER NOTCENTER BOLD NOTBOLD ITALIC NOTITALIC UCASE LCASE STRIKEOUT NOTSTRIKEOUT UNDERLINE NOTUNDERLINE SUBSCRIPT SUPERSCRIPT SMALLER LARGER MARGINS NOTMARGINS LOOKS NOTLOOKS F11 NOTF11 F12 NOTF12)) (RECORDS KEYBOARDCONFIGURATION VIRTUALKEYBOARD) (INITVARS (VKBD.KNOWN-KEYBOARDS NIL)) (FILES (SOURCE) KEYBOARDCONFIGS) (VARS VKBD.BACKGROUND-MENU-SUBITEMS VKBD.NON-CHAR-ASSIGNMENTS-LABELS VKBD.WINDOW-MENU-SUBITEMS) (BITMAPS VKBD.ICON VKBD.MASK) (GLOBALVARS VKBD.BACKGROUND-MENU-SUBITEMS VKBD.DEFAULT-CONFIGURATION-NAME VKBD.KNOWN-KEYBOARDS VKBD.NON-CHAR-ASSIGNMENTS-LABELS VKBD.ICON VKBD.MASK CURRENTKEYBOARDCONFIG VKBD.CONFIGURATIONS VKBD.COMMONCODELABELS VKBD.COMMONKEYLABELS VKBD.COMMONDEFAULTASSIGNMENT) (COMS (DECLARE\: FIRST (P (MOVD? '\\KEYBOARDEVENTFN '\\OLDKEYBOARDEVENTFN))) (INITVARS (\\ORIGINALDEFAULTKEYACTION)) (FNS VKBD.\\KEYBOARDEVENTFN VKBD.RESETKEYACTIONTABLES) (P (MOVD 'VKBD.\\KEYBOARDEVENTFN '\\KEYBOARDEVENTFN))) (COMS (DECLARE\: FIRST (P (MOVD? 'KEYACTION 'OLDKEYACTION))) (FNS NEWKEYACTION) (P (MOVD 'NEWKEYACTION 'KEYACTION)) (INITVARS (MODEKEYS)) (VARS MODEACTIONS) (GLOBALVARS MODEKEYS MODEACTIONS)) (ADDVARS (BREAKRESETFORMS ((LAMBDA (K) (PROCESS.KEYBOARD NIL K)) 'DEFAULT))) (FNS FIXKEYBOARD FIXKEYBOARDCONFIG FIXKEYASSIGNMENTS) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (VKBD.INIT))) (COMS (FNS METASHIFT) (* \;  "Call new definition if the old one had been called") (P (AND (MEMB (MACHINETYPE) '(MAIKO DORADO)) (EQUAL (KEYACTION 'BLANK-BOTTOM) '(METADOWN . METAUP)) (METASHIFT T)))) (FILES ICONW) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA METASHIFT))))) (DEFINEQ (FINDVIRTUALKEYBOARD + (LAMBDA (KEYBOARDNAME CONFIGURATIONNAME) (* \; "Edited 27-Feb-96 10:27 by rmk") + (LET ((KBTYPE (COND + (CONFIGURATIONNAME) + ((LISTP KEYBOARDNAME) + (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) OF KEYBOARDNAME)) + ((KEYBOARDTYPE)) + (T DEFAULTVIRTUALKEYBOARDTYPE)))) + (CL:WHEN (AND (LISTP KEYBOARDNAME) + (MEMB KEYBOARDNAME VKBD.KNOWN-KEYBOARDS)) + + (* |;;| "Gave a keyboard, use it to indicate keyboard name for new configuration") + + (SETQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) OF KEYBOARDNAME))) + + (* |;;| "Find keyboard of default type if current type doesn't exist and CONFIGURATIONNAME wasn't given--PROCESS.KEYBOARD won't switch this in. Note that a keyboard that has a NIL configuration is declared to go with anything,but we look for an explicit match first") + + (IF (FIND KB IN VKBD.KNOWN-KEYBOARDS + SUCHTHAT (AND (EQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) + OF KB)) + (EQ KBTYPE (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) + OF KB)))) + ELSEIF (FIND KB IN VKBD.KNOWN-KEYBOARDS + SUCHTHAT (AND (EQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) + OF KB)) + (NULL (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) + OF KB)))) + ELSEIF (OR (NOT CONFIGURATIONNAME) + (EQ CONFIGURATIONNAME KBTYPE)) + THEN (OR (FOR C IN (CDR (ASSOC KBTYPE KEYBOARDCONFIGCOERCIONS)) + WHEN (SETQ C (FINDVIRTUALKEYBOARD KEYBOARDNAME C)) + DO (RETURN C)) + (AND DEFAULTVIRTUALKEYBOARDTYPE (NEQ DEFAULTVIRTUALKEYBOARDTYPE KBTYPE) + (FOR KB IN VKBD.KNOWN-KEYBOARDS + WHEN (AND (EQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD + KEYBOARDNAME) + OF KB)) + (EQ DEFAULTVIRTUALKEYBOARDTYPE (FETCH + (VIRTUALKEYBOARD + + KEYBOARDCONFIGURATION + ) OF KB))) + DO (RETURN KB)))))))) (PROCESS.KEYBOARD (LAMBDA (PROCESS/WINDOW KEYBOARD) (* \; "Edited 23-May-95 17:00 by rmk:") (* |;;;| "Get/set the keyboard just for this process/window. Value is previous keyboard.") (PROG (KEYACTIONTABLE FOUND (PROCESS (COND ((NULL PROCESS/WINDOW) (TTY.PROCESS)) ((PROCESSP PROCESS/WINDOW) PROCESS/WINDOW) ((AND (WINDOWP PROCESS/WINDOW) (WINDOWPROP PROCESS/WINDOW 'PROCESS))) (T (THIS.PROCESS))))) (COND ((SETQ KEYACTIONTABLE (IF (AND KEYBOARD (SETQ FOUND (FINDVIRTUALKEYBOARD KEYBOARD))) THEN (* |;;| "We believe in whatever FINDVIRTUALKEYBOARD returns, even though it might not have the configuration we expect.") (* \;  "Get/create the KEYACTIONTABLE for the FOUND") (VKBD.CREATE-KEYACTION-TABLE FOUND))) (* \;  "Make sure to copy the current interrupt list.") (REPLACE (KEYACTION INTERRUPTLIST) OF KEYACTIONTABLE WITH (COPY (FETCH (KEYACTION INTERRUPTLIST) OF (OR (PROCESSPROP PROCESS 'KEYACTION) \\DEFAULTKEYACTION)))) (PROCESSPROP PROCESS 'KEYACTION KEYACTIONTABLE) (COND ((TTY.PROCESSP PROCESS) (* \; "install the key action table") (* \;  "Hack--wait until dangerous shifts are up") (|while| (OR (SHIFTDOWNP 'META) (SHIFTDOWNP 'CTRL))) (SETQ \\CURRENTKEYACTION (OR KEYACTIONTABLE (KEYACTIONTABLE))))) (RETURN (OR (PROCESSPROP PROCESS 'KEYBOARD KEYBOARD) 'DEFAULT))) (T (RETURN (OR (PROCESSPROP PROCESS 'KEYBOARD) 'DEFAULT))))))) (VKBD.CREATE-KEYACTION-TABLE + (LAMBDA (NEW-KEYBOARD OLDTABLE) (* \; "Edited 29-Feb-96 12:32 by rmk") + (PROG (KEYBOARDNAME FOUND KEYACTION-TABLE CONFIG) + (CL:UNLESS (COND + ((AND (ATOM NEW-KEYBOARD) + (SETQ FOUND (FINDVIRTUALKEYBOARD NEW-KEYBOARD))) + (SETQ NEW-KEYBOARD FOUND)) + ((MEMB NEW-KEYBOARD VKBD.KNOWN-KEYBOARDS))) + + (* |;;| "Use FOUND to preserve NEW-KEYBOARD for error") + + (ERROR "INVALID KEYBOARD" NEW-KEYBOARD)) + (SETQ KEYBOARDNAME (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) OF NEW-KEYBOARD)) + (COND + (OLDTABLE (SETQ KEYACTION-TABLE (RESETKEYACTION OLDTABLE))) + ((SETQ KEYACTION-TABLE (GETPROP KEYBOARDNAME 'KEYACTIONTABLE)) + (RETURN KEYACTION-TABLE)) + (T (SETQ KEYACTION-TABLE (KEYACTIONTABLE)))) + (SETQ NEW-KEYBOARD (VKBD.COMPLETE-KEYBOARD NEW-KEYBOARD)) + (SETQ CONFIG (VKBD.GET-CONFIGURATION (FETCH (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) + OF NEW-KEYBOARD))) + (FOR KEY-ASSIGNMENT IN (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) + OF NEW-KEYBOARD) DO (OLDKEYACTION (CAR + KEY-ASSIGNMENT + ) + (CDR KEY-ASSIGNMENT) + KEYACTION-TABLE)) + (PUTPROP KEYBOARDNAME 'KEYACTIONTABLE KEYACTION-TABLE) + (RETURN KEYACTION-TABLE)))) (vkbd.windowmenufn + (lambda (w) (* \; "Edited 15-Dec-87 16:27 by Snow") + + (let (keyboard) + (setq keyboard (vkbd.pop-up-keyboards-menu)) + (and keyboard (process.keyboard w keyboard))))) (vkbd.windowmenuinit + (lambda nil (* \; "Edited 15-Dec-87 16:28 by Snow") + + (setq |WindowMenuCommands| (remove (sassoc '|Keyboard| |WindowMenuCommands|) + |WindowMenuCommands|)) + (nconc1 |WindowMenuCommands| `(|Keyboard| (function (lambda (w) + (switchkeyboards t nil w))) + "Changes the keyboard associated with this window." + ,vkbd.window-menu-subitems)) + (setq |WindowMenu| nil))) ) (DEFINEQ (LOADKEYBOARDDISPLAYFONTS (LAMBDA (FONT) (* \; "Edited 13-Dec-96 17:40 by rmk:") (* \; "Edited 7-Mar-96 12:30 by rmk") (* |;;| "Insures that all the characters on virtual keycaps have been instantiated in FONT (or at least on the keycaps). Saves the needed charsets in VKBD.CACHEDCHARSETS. This means that we don't have to parse all the keyboards every time. In order to make use of the cache, we instantiate all the charsets in all the fonts that are specified in any of the keyboards or configurations.") (DECLARE (GLOBALVARS VKBD.CACHEDCHARSETS)) (CL:UNLESS VKBD.CACHEDCHARSETS (FOR K IN VKBD.KNOWN-KEYBOARDS DO (* |;;| "Ignore errorful transitions in this background function, fail when the user actually asks for the keyboard. Accumulate 0th character in each charset (presumably very few), saving them in the cache.") (FOR A TRANS CHARSETS IN (FETCH KEYASSIGNMENTS OF K) WHEN (NLSETQ (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT A NIL T))) DO (CL:WHEN (LISTP (SETQ TRANS (CADR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))) (CL:WHEN (LISTP (SETQ TRANS (CDDR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))))) (FOR CONFIG COMMON IN VKBD.CONFIGURATIONS DO (* |;;| "We aren't letting the configs assignment override the VKBD.COMMONDEFAULTASSIGNMENT on the same key. Thus, in principle we could be instantiating a font that isn't actually needed, but this is unlikely, harmless, and not worth the bother to keep track. VKBD.COMPLETE-KEYBOARD does it right.") (FOR A TRANS IN (APPEND (FETCH DEFAULTASSIGNMENT OF CONFIG) VKBD.COMMONDEFAULTASSIGNMENT) WHEN (NLSETQ (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT A CONFIG))) DO (CL:WHEN (LISTP (SETQ TRANS (CADR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))) (CL:WHEN (LISTP (SETQ TRANS (CDDR A))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CAR TRANS) (CHARCODE 377\,0))) (PUSHNEW VKBD.CACHEDCHARSETS (LOGAND (CADR TRANS) (CHARCODE 377\,0)))))) (SETQ VKBD.CACHEDCHARSETS (DREMOVE 0 VKBD.CACHEDCHARSETS))) (IF FONT THEN (SETQ FONT (FONTCREATE FONT NIL NIL NIL 'DISPLAY)) (FOR C IN VKBD.CACHEDCHARSETS DO (CHARWIDTH C FONT)) ELSE (LET (DONEFONTS) (FOR K F IN VKBD.KNOWN-KEYBOARDS UNLESS (MEMB (SETQ F (FONTCREATE (OR (FETCH (VIRTUALKEYBOARD KEYBOARDDISPLAYFONT ) OF K) DEFAULTKEYBOARDDISPLAYFONT) NIL NIL NIL 'DISPLAY)) DONEFONTS) DO (PUSH DONEFONTS F) (FOR C IN VKBD.CACHEDCHARSETS DO (CHARWIDTH C F))) (FOR CONFIG F IN VKBD.CONFIGURATIONS UNLESS (MEMB (SETQ F (FONTCREATE (OR (FETCH (KEYBOARDCONFIGURATION KEYBOARDDISPLAYFONT) OF CONFIG) DEFAULTKEYBOARDDISPLAYFONT) NIL NIL NIL 'DISPLAY)) DONEFONTS) DO (PUSH DONEFONTS F) (FOR C IN VKBD.CACHEDCHARSETS DO (CHARWIDTH C F))))))) ) (RPAQ? VKBD.CACHEDCHARSETS NIL) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS VKBD.CACHEDCHARSETS) ) (DEFINEQ (DEFINEKEYBOARD + (LAMBDA (KEYBOARD-OBJECT) (* \; "Edited 28-Feb-96 11:41 by rmk") + (* \; "Edited 15-Dec-87 16:29 by Snow") + + (* |;;| + "Checks assignments before it installs, returns a copy unless the object is already known.") + + (FOR KEY-ASSIGNMENT (CONFIGURATION _ (VKBD.GET-CONFIGURATION (FETCH (VIRTUALKEYBOARD + + KEYBOARDCONFIGURATION + ) OF + KEYBOARD-OBJECT + ))) + IN (FETCH (VIRTUALKEYBOARD KEYASSIGNMENTS) OF KEYBOARD-OBJECT) + DO (VKBD.PARSE-KEY-ASSIGNMENT KEY-ASSIGNMENT CONFIGURATION)) + (OR (FINDVIRTUALKEYBOARD KEYBOARD-OBJECT) + (CAR (PUSH VKBD.KNOWN-KEYBOARDS (COPY KEYBOARD-OBJECT)))))) ) (DEFINEQ (vkbd.add-item-to-background-menu + (lambda (label command message subitemlist) (* \; "Edited 15-Dec-87 16:29 by Snow") + + (setq |BackgroundMenuCommands| (remove (sassoc label |BackgroundMenuCommands|) + |BackgroundMenuCommands|)) + (nconc1 |BackgroundMenuCommands| (list label command message subitemlist)) + (setq |BackgroundMenu| nil))) (VKBD.INIT (LAMBDA NIL (* \; "Edited 14-Jun-2017 14:22 by kaplan") (* \; "Edited 16-Jun-92 11:14 by kaplan") (* |;;| "Reads virtual keyboard file for current type (or default type), if it can be found. Keyboards that don't match current keyboard can be displayed but not installed (via PROCESS.KEYBOARD)") (CL:UNLESS \\ORIGINALDEFAULTKEYACTION (SETQ \\ORIGINALDEFAULTKEYACTION (KEYACTIONTABLE \\DEFAULTKEYACTION))) (SETQ VKBD.COMMONCODELABELS (FOR X IN VKBD.COMMONCHARLABELS COLLECT (IF (LISTP X) THEN (IF (SMALLP (CAR X)) THEN X ELSE (LIST (CHARCODE.DECODE (CAR X)) (CADR X))) ELSE (LIST (CHARCODE.DECODE X) X)))) (VKBD.ADD-ITEM-TO-BACKGROUND-MENU "Keyboard" ''(SWITCHKEYBOARDS T NIL) "Displays a menu for switching keyboards" VKBD.BACKGROUND-MENU-SUBITEMS) (VKBD.WINDOWMENUINIT) (LET (FILE (KT (KEYBOARDTYPE))) (SETQ CURRENTKEYBOARDCONFIG (VKBD.GET-CONFIGURATION KT)) (COND ((SETQ FILE (COND ((AND KT (FINDFILE (PACK* KT "KEYBOARDS") T))) (T (FINDFILE (PACK* DEFAULTVIRTUALKEYBOARDTYPE "KEYBOARDS") T)))) (VKBD.LOAD-KEYBOARD-FILE FILE) (* |;;| "Loading a keyboard file may change our notion of KEYBOARDTYPE, because of new coercion paths. The default keyboard will be added for the new type") (VKBD.ADD-DEFAULT-KEYBOARD)) (T (* |;;| "Special printing here to avoid file-not-found error in case where user calls VKBD.LOAD-KEYBOARD-FILE directly") (PROMPTPRINT "Note: virtual keyboard file for type " (OR (KEYBOARDTYPE) DEFAULTVIRTUALKEYBOARDTYPE) " keyboards not found")))))) (VKBD.CREATE-DEFAULT-KEYBOARD + (LAMBDA (CONFIGURATION) (* \; "Edited 27-Feb-96 20:51 by rmk") + + (* |;;| "Don't bother copying in the default keyassignments, since they will always be inserted by VKBD.COMPLETE-KEYBOARD") + + (CL:WHEN (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION CONFIGURATION)) + (CREATE VIRTUALKEYBOARD + KEYBOARDNAME _ 'DEFAULT + KEYBOARDCONFIGURATION _ (FETCH (KEYBOARDCONFIGURATION CONFIGURATIONNAME) + OF CONFIGURATION))))) (VKBD.ADD-DEFAULT-KEYBOARD (LAMBDA (KEYBOARDTYPE) (* \; "Edited 23-May-95 17:04 by rmk:") (* |;;;| "It is useful practice to be able to switch back to the original key assignments. Thus the program is adding one special keyboard with the name DEFAULT which is the current keyboardtype's default keyboard.") (SETQ KEYBOARDTYPE (OR KEYBOARDTYPE (KEYBOARDTYPE))) (BIND DEFAULT WHILE (SETQ DEFAULT (FINDVIRTUALKEYBOARD 'DEFAULT KEYBOARDTYPE)) DO (SETQ VKBD.KNOWN-KEYBOARDS (REMOVE DEFAULT VKBD.KNOWN-KEYBOARDS))) (SETQ VKBD.KNOWN-KEYBOARDS (CONS (VKBD.CREATE-DEFAULT-KEYBOARD KEYBOARDTYPE) VKBD.KNOWN-KEYBOARDS)) (COND ((EQ KEYBOARDTYPE (KEYBOARDTYPE)) (VKBD.CREATE-KEYACTION-TABLE 'DEFAULT \\DEFAULTKEYACTION))))) ) (DEFINEQ (VKBD.LOAD-FILE-COMMAND + (LAMBDA (REDEFINE? DELETE-FIRST?) (* \; "Edited 3-Mar-96 18:16 by rmk") + (* \; "Edited 15-Dec-87 16:30 by Snow") + (LET (F) + (SETQ F (MKATOM (PROMPTFORWORD "Keyboard file name: " NIL NIL PROMPTWINDOW NIL 'TTY))) + (IF F + THEN (VKBD.LOAD-KEYBOARD-FILE F REDEFINE? DELETE-FIRST? T))))) (VKBD.LOAD-KEYBOARD-FILE + (LAMBDA (FILENAME REDEFINE? DELETE-CURRENT-DEFINITIONS? PROMPTPRINT) + (* \; "Edited 4-Mar-96 10:53 by rmk") + + (* |;;| "Note: Can't switch to READFILE, since it uses OLD-INTERLISP readtable which doesn't honor vertical bars around numeric atoms.") + + (LET ((NEWKEYBOARDS (CL:WITH-OPEN-FILE (STREAM FILENAME :DIRECTION :INPUT) + (BIND KB DATE (*PACKAGE* _ *INTERLISP-PACKAGE*) + (RDTBL _ (FIND-READTABLE "INTERLISP")) + FIRST (SETQ DATE (READ STREAM RDTBL)) + (CL:UNLESS (LISTP DATE) + (CL:WHEN (STRINGP DATE) + (SETQ DATE (CONCAT "Keyboards from " (FULLNAME STREAM + ) + " [" DATE "]")) + (IF PROMPTPRINT + THEN (PROMPTPRINT DATE) + ELSE (PRINTOUT T DATE T))) + (SETQ DATE NIL)) WHILE (SKIPSEPRCODES STREAM RDTBL) + UNTIL (EQ 'STOP (SETQ KB (READ STREAM RDTBL))) COLLECT + KB + FINALLY (CL:WHEN DATE + + (* |;;| + "Was a LISTP date, must have been a keyboard") + + (PUSH DATE $$VAL)))))) + (COND + (DELETE-CURRENT-DEFINITIONS? (SETQ VKBD.KNOWN-KEYBOARDS NEWKEYBOARDS) + (VKBD.ADD-DEFAULT-KEYBOARD)) + (T (FOR NEWKEYBOARD KN KC IN NEWKEYBOARDS + DO + + (* |;;| +"To make sure that COMPLETEDASSIGNMENTS cell (or any other new cells) exist--backward compatibility") + + (SETQ NEWKEYBOARD (CREATE VIRTUALKEYBOARD USING NEWKEYBOARD)) + (SETQ KN (FETCH KEYBOARDNAME OF NEWKEYBOARD)) + (SETQ KC (FETCH KEYBOARDCONFIGURATION OF NEWKEYBOARD)) + (FOR TAIL OLDKEYBOARD ON VKBD.KNOWN-KEYBOARDS + WHEN (AND (EQ KN (FETCH KEYBOARDNAME OF (SETQ OLDKEYBOARD + (CAR TAIL)))) + (EQ KC (FETCH KEYBOARDCONFIGURATION OF OLDKEYBOARD)) + ) DO + + (* |;;| "If REDEFINE?, then replace one with same name and configuration. Otherwise, keep the old one instead of installing the new one.") + + (COND + (REDEFINE? (RPLACA TAIL NEWKEYBOARD)) + (T (RETURN))) FINALLY (SETQ + VKBD.KNOWN-KEYBOARDS + (NCONC1 + VKBD.KNOWN-KEYBOARDS + NEWKEYBOARD)))) + ))))) (vkbd.store-file-command + (lambda (f) (* \; "Edited 15-Dec-87 16:31 by Snow") + + (setq f (promptforword "ENTER FILE NAME: " nil nil promptwindow nil 'tty)) + (|if| f + |then| (vkbd.store-keyboard-file (mkatom f)) + |else| (promptprint "FILE NOT FOUND")))) (VKBD.STORE-KEYBOARD-FILE + (LAMBDA (FILENAME CONFIGURATIONNAME) (* \; "Edited 4-Mar-96 13:38 by rmk") + + (* |;;| "COMPLETEDKEYASSIGNMENTS are in a separate hasharray, don't get printed. Can't use WRITEFILE because of vertical-bar problems") + + (CL:WITH-OPEN-FILE (STREAM FILENAME :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) + (LET ((RDTBL (FIND-READTABLE "INTERLISP"))) + (PRINT (DATE) + STREAM RDTBL) + (IF CONFIGURATIONNAME + THEN (FOR KB IN VKBD.KNOWN-KEYBOARDS + WHEN (EQ CONFIGURATIONNAME (FETCH (VIRTUALKEYBOARD + KEYBOARDCONFIGURATION + ) OF KB)) + UNLESS (EQ 'DEFAULT (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) + OF KB)) + DO (PRINT KB STREAM RDTBL)) + ELSE (* \; + "Don't print DEFAULT keyboards, since they are reconstructed from configuration") + (FOR KB IN VKBD.KNOWN-KEYBOARDS + UNLESS (EQ 'DEFAULT (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) + OF KB)) DO (PRINT KB STREAM RDTBL)))) + (PROMPTPRINT (CONCAT "Current known keyboards are stored in " FILENAME)) + (FULLNAME STREAM)))) ) (DEFINEQ (SWITCHKEYBOARDS + (LAMBDA (SWITCH-FLG DISPLAY-FLG PROCESS NEW-KEYBOARD DISPLAY-POSITION) + (* \; "Edited 27-Feb-96 12:35 by rmk") + (* \; "Edited 15-Dec-87 16:32 by Snow") + +(* |;;;| "This is the main function of the package. SWITCH-FLG and DISPLAY-FLG will produce the 3 logical combinations of switching a keyboard. The 4th comb NIl & NIL is NOOP. Any change of the KEYACTION handeling should be reflected here.") + + (PROG (WINDOW) + (COND + ((NULL NEW-KEYBOARD) + (SETQ NEW-KEYBOARD (VKBD.POP-UP-KEYBOARDS-MENU)))) + (COND + ((LITATOM NEW-KEYBOARD) + (SETQ NEW-KEYBOARD (FINDVIRTUALKEYBOARD NEW-KEYBOARD)))) + (COND + ((NULL NEW-KEYBOARD) + (RETURN NIL))) + (COND + (SWITCH-FLG (PROCESS.KEYBOARD PROCESS NEW-KEYBOARD))) + (COND + (DISPLAY-FLG (VKBD.COMPLETE-KEYBOARD NEW-KEYBOARD) + + (* |;;| "This is necessary to enable the menu to generate the right characters for the keys that are defaulted") + + (* |;;| "(RETURN OLD-KEYACTIONS)") + + (SETQ WINDOW (VKBD.CREATE-KEYBOARD-DISPLAY NEW-KEYBOARD DISPLAY-POSITION + (FUNCTION VKBD.SEND-CHARACTER)))))))) (vkbd.pop-menu-and-switch-keyboards + (lambda (process switch-flg display-flg) (* \; "Edited 15-Dec-87 16:48 by Snow") + + (prog (keyboard) + (setq keyboard (vkbd.pop-up-keyboards-menu "Select an alternative keyboard")) + (|if| keyboard + |then| (switchkeyboards keyboard switch-flg display-flg))))) (VKBD.POP-UP-KEYBOARDS-MENU + (LAMBDA (PROMPT-STRING) (* \; "Edited 27-Feb-96 13:22 by rmk") + (* \; "Edited 16-Jun-92 11:35 by kaplan") + (COND + (PROMPT-STRING (PROMPTPRINT PROMPT-STRING) + (FLASHWINDOW PROMPTWINDOW 1))) + (LET ((KEYBOARDTYPES `(NIL ,(KEYBOARDTYPE) + ,@(CDR (ASSOC (KEYBOARDTYPE) + KEYBOARDCONFIGCOERCIONS)) + ,DEFAULTVIRTUALKEYBOARDTYPE))) + (MENU (CREATE MENU + ITEMS _ (CONS '(|Quit| NIL) + (SORT (FOR K IN VKBD.KNOWN-KEYBOARDS + WHEN (MEMB (FETCH KEYBOARDCONFIGURATION + OF K) + KEYBOARDTYPES) + UNLESS (MEMB (FETCH KEYBOARDNAME OF K) + $$VAL) + COLLECT (FETCH KEYBOARDNAME OF K)) + (FUNCTION UALPHORDER))) + MENUFONT _ BIGFONT))))) (VKBD.GET-CONFIGURATION + (LAMBDA (CONFNAME/WINDOW) (* \; "Edited 27-Feb-96 11:13 by rmk") + + (* |;;| "NIL means use the CURRENTKEYBOARDCONFIG, if it exists") + + (COND + ((WINDOWP CONFNAME/WINDOW) + (SETQ CONFNAME/WINDOW (|fetch| (VIRTUALKEYBOARD KEYBOARDCONFIGURATION) + |of| (WINDOWPROP CONFNAME/WINDOW 'VKBD.KEYBOARD))))) + (COND + ((AND CONFNAME/WINDOW (|type?| KEYBOARDCONFIGURATION CONFNAME/WINDOW)) + CONFNAME/WINDOW) + ((AND (NULL CONFNAME/WINDOW) + CURRENTKEYBOARDCONFIG)) + ((FASSOC (OR CONFNAME/WINDOW VKBD.DEFAULT-CONFIGURATION-NAME (KEYBOARDTYPE)) + VKBD.CONFIGURATIONS)) + (T (FOR C IN (CDR (ASSOC CONFNAME/WINDOW KEYBOARDCONFIGCOERCIONS)) + WHEN (SETQ C (FASSOC C VKBD.CONFIGURATIONS)) DO (RETURN C)))))) (VKBD.SUBCONFIGURATION (LAMBDA (FULL NEWNAME LOWERLEFTKEY UPPERRIGHTKEY SCALE MARGIN) (* \; "Edited 8-Oct-96 12:28 by rmk:") (* |;;| "Returns a sub-configuration of FULL, including only keys that lie completely within the region enclosed by the bounding box of LOWERLEFTKEY and UPPERRIGHTKEY. Translates regions so that origin is the lower-left corner of the lower-left key.") (SETQ FULL (VKBD.GET-CONFIGURATION FULL)) (CL:UNLESS MARGIN (SETQ MARGIN 0)) (LET (NEWREGIONS (LEFT 65535) (BOTTOM 65535) (TOP 0) (RIGHT 0)) (CL:UNLESS NEWNAME (SETQ NEWNAME (FETCH CONFIGURATIONNAME OF FULL))) (FOR R IN (OR (CDR (VKBD.KEY-ASSOC LOWERLEFTKEY (FETCH KEYREGIONS OF FULL) FULL)) (ERROR "KEY HAS NO REGION" LOWERLEFTKEY)) DO (CL:WHEN (ILESSP (FETCH LEFT OF R) LEFT) (SETQ LEFT (FETCH LEFT OF R))) (CL:WHEN (ILESSP (FETCH BOTTOM OF R) BOTTOM) (SETQ BOTTOM (FETCH BOTTOM OF R)))) (FOR R IN (OR (CDR (VKBD.KEY-ASSOC UPPERRIGHTKEY (FETCH KEYREGIONS OF FULL) FULL)) (ERROR "KEY HAS NO REGION" UPPERRIGHTKEY)) DO (CL:WHEN (IGREATERP (FETCH RIGHT OF R) RIGHT) (SETQ RIGHT (FETCH RIGHT OF R))) (CL:WHEN (IGREATERP (FETCH TOP OF R) TOP) (SETQ TOP (FETCH TOP OF R)))) (SETQ NEWREGIONS (FOR KR IN (FETCH KEYREGIONS OF FULL) WHEN (FOR R IN (CDR KR) ALWAYS (AND (IGEQ (FETCH LEFT OF R) LEFT) (IGEQ (FETCH BOTTOM OF R) BOTTOM) (ILEQ (FETCH TOP OF R) TOP) (ILEQ (FETCH RIGHT OF R) RIGHT))) COLLECT (CONS (CAR KR) (FOR R IN (CDR KR) COLLECT (IF SCALE THEN (CREATE REGION LEFT _ (FIXR (TIMES SCALE (+ MARGIN (- (FETCH LEFT OF R) LEFT)))) BOTTOM _ (FIXR (TIMES SCALE (+ MARGIN (- (FETCH BOTTOM OF R) BOTTOM)))) WIDTH _ (FIXR (TIMES SCALE (FETCH WIDTH OF R))) HEIGHT _ (FIXR (TIMES SCALE (FETCH HEIGHT OF R)))) ELSE (CREATE REGION USING R LEFT _ (+ MARGIN (- (FETCH LEFT OF R) LEFT)) BOTTOM _ (+ MARGIN (- (FETCH BOTTOM OF R) BOTTOM)))))))) (CREATE KEYBOARDCONFIGURATION COPYING FULL CONFIGURATIONNAME _ NEWNAME KEYREGIONS _ NEWREGIONS DEFAULTASSIGNMENT _ (FOR A IN (FETCH DEFAULTASSIGNMENT OF FULL) WHEN (VKBD.KEY-ASSOC (CAR A) NEWREGIONS FULL) COLLECT (COPY A)))))) ) (DEFINEQ (vkbd.buttoneventfn + (lambda (window) (* \; "Edited 15-Dec-87 16:32 by Snow") + +(* |;;;| "This is a general 'menu' function for the keyboard when used as a menu --- it is used for all such uses: When displaying a virtual keyboard, when editing one and when editing a default assignments for a configuration. The only difference is what will be the action taken when a KEY was selected. This will be determined by the property VKBD.MENUFN which specify the name of the function that should be called. This function will get 3 arguments : The KEYID, the WINDOW and the mouse key; In the regular keyboard display this function will send a character to the system buffer. In the Editor it will make the key the CURRENT key. In the configuration info window it will display information about the key") + + (prog (mouse-position shaded-key last-mouse-key current-key-and-regions shift-is-down) + (setq mouse-position (cursorposition nil window)) + (totopw window) (* \; + "This should be checked if changes to the keyboard handling is done") + + (setq shift-is-down (or (keydownp 'rshift) + (keydownp 'lshift))) + (setq shaded-key (windowprop window 'vkbd.shaded-key)) + (setq last-mouse-key (windowprop window 'vkbd.mouse-button)) + (setq current-key-and-regions (vkbd.get-key-and-regions-of-cursor-position + mouse-position window)) + (cond + ((mousestate up) + (cond + ((and shaded-key (eq shaded-key (car current-key-and-regions))) + (apply (windowprop window 'vkbd.menufn) + (list (windowprop window 'vkbd.shaded-key) + window + (windowprop window 'vkbd.last-mouse-state))) + (vkbd.reset-keyboard-window window)))) + ((or (mousestate (only left)) + (mousestate (only middle))) + (windowprop window 'vkbd.shaded-key (car current-key-and-regions)) + (|for| region |in| (cdr current-key-and-regions) |do| (vkbd.invert-region + region window)) + (windowprop window 'vkbd.last-mouse-state (cond + ((lastmousestate (only left)) + 'left) + (t 'middle))) + (cond + ((or shift-is-down (lastmousestate (only middle))) + (vkbd.invert-shift-keys window) + (windowprop window 'vkbd.shift-down t)))))))) (vkbd.center-bitmap-in-region + (lambda (bm region window allignment) (* \; "Edited 15-Dec-87 16:32 by Snow") + + (bitblt bm 0 0 window (iplus (|fetch| (region left) |of| region) + (iquotient (idifference (|fetch| (region width) |of| region) + (bitmapwidth bm)) + 2)) + (cond + ((greaterp (bitmapheight bm) + (|fetch| (region height) |of| region)) + (cond + ((eq allignment 'top) + (idifference (|fetch| (region bottom) |of| region) + (idifference (bitmapheight bm) + (|fetch| (region height) |of| region)))) + ((eq allignment 'bottom) + (|fetch| (region bottom) |of| region)) + (t (iplus (|fetch| (region bottom) |of| region) + (iquotient (idifference (|fetch| (region height) |of| region) + (bitmapheight bm)) + 2))))) + (t (iplus (|fetch| (region bottom) |of| region) + (iquotient (idifference (|fetch| (region height) |of| region) + (bitmapheight bm)) + 2)))) + nil nil 'input 'paint))) (VKBD.CLEAR-KEY-DISPLAY + (LAMBDA (KEY-REGIONS VKBD-WINDOW) (* \; "Edited 27-Feb-96 13:50 by rmk") + (FOR REGION LEFT BOTTOM WIDTH HEIGHT IN KEY-REGIONS + DO (SETQ LEFT (FETCH (REGION LEFT) OF REGION)) + (SETQ BOTTOM (FETCH (REGION BOTTOM) OF REGION)) + (SETQ WIDTH (FETCH (REGION WIDTH) OF REGION)) + (SETQ HEIGHT (FETCH (REGION HEIGHT) OF REGION)) + (BITBLT NIL NIL NIL VKBD-WINDOW (ADD1 LEFT) + (ADD1 BOTTOM) + (IDIFFERENCE WIDTH 2) + (IDIFFERENCE HEIGHT 2) + 'TEXTURE + 'REPLACE WHITESHADE) + (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) + (ADD1 BOTTOM) + (ITIMES (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) + BOTTOM) + (BITMAPBIT VKBD-WINDOW LEFT (ADD1 BOTTOM)))) + (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) + (ADD1 BOTTOM) + (ITIMES (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) + BOTTOM) + (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (SUB1 WIDTH)) + (ADD1 BOTTOM)))) + (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) + (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2)) + (ITIMES (BITMAPBIT VKBD-WINDOW (ADD1 LEFT) + (IPLUS BOTTOM (ADD1 HEIGHT))) + (BITMAPBIT VKBD-WINDOW LEFT (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2))))) + (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) + (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2)) + (ITIMES (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (SUB1 WIDTH)) + (IPLUS BOTTOM (IDIFFERENCE HEIGHT 2))) + (BITMAPBIT VKBD-WINDOW (IPLUS LEFT (IDIFFERENCE WIDTH 2)) + (IPLUS BOTTOM (SUB1 HEIGHT)))))))) (VKBD.CREATE-KEYBOARD-BITMAP + (LAMBDA (CONFIGURATION) (* \; "Edited 17-Jan-96 13:45 by rmk") + (* \; "Edited 15-Dec-87 16:35 by Snow") + (LET (BM KEYS-REGION BM-WIDTH BM-HEIGHT MAX-REGION) + (COND + ((ATOM CONFIGURATION) + (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION CONFIGURATION)))) + (SETQ MAX-REGION (VKBD.UNION-REGIONS CONFIGURATION)) + (SETQ BM-WIDTH (IPLUS (ITIMES 2 (FETCH (REGION LEFT) OF MAX-REGION)) + (FETCH (REGION WIDTH) OF MAX-REGION))) + (SETQ BM-HEIGHT (IPLUS (ITIMES 2 (FETCH (REGION BOTTOM) OF MAX-REGION)) + (FETCH (REGION HEIGHT) OF MAX-REGION))) + (SETQ BM (BITMAPCREATE BM-WIDTH BM-HEIGHT)) + (BITBLT NIL NIL NIL BM 0 0 BM-WIDTH BM-HEIGHT 'TEXTURE 'REPLACE BLACKSHADE) + (BITBLT NIL NIL NIL BM 1 1 (IDIFFERENCE BM-WIDTH 2) + (IDIFFERENCE BM-HEIGHT 2) + 'TEXTURE + 'REPLACE + (FETCH (KEYBOARDCONFIGURATION BACKGROUNDSHADE) OF CONFIGURATION)) + (FOR KEY-AND-REGIONS IN (FETCH (KEYBOARDCONFIGURATION KEYREGIONS) OF + CONFIGURATION + ) DO + + (* |;;| + "CDR cause odd-shaped keys (like ENTER) are described by multiple regions") + + (VKBD.DISPLAY-EMPTY-KEY-CAP (CDR + KEY-AND-REGIONS + ) + BM)) + BM))) (VKBD.CREATE-KEYBOARD-DISPLAY + (LAMBDA (KEYBOARD MENU-POSITION MENU-FUNCTION BM SHOWCONFIG) + (* \; "Edited 28-Feb-96 12:02 by rmk") + (* \; "Edited 25-May-95 11:33 by rmk:") + (* \; "Edited 20-Apr-89 13:26 by atm") + (LET (WINDOW WINDOW-WIDTH WINDOW-HEIGHT KEYBOARD-BITMAP CONFIGURATION) + (SETQ CONFIGURATION (VKBD.GET-CONFIGURATION (|fetch| KEYBOARDCONFIGURATION + |of| KEYBOARD))) + (SETQ KEYBOARD-BITMAP (OR BM (VKBD.CREATE-KEYBOARD-BITMAP CONFIGURATION))) + (SETQ WINDOW-WIDTH (IPLUS 8 (BITMAPWIDTH KEYBOARD-BITMAP))) + (SETQ WINDOW-HEIGHT (IPLUS 18 (BITMAPHEIGHT KEYBOARD-BITMAP))) + (CL:UNLESS MENU-POSITION + (SETQ MENU-POSITION (GETBOXPOSITION WINDOW-WIDTH WINDOW-HEIGHT))) + (SETQ WINDOW (CREATEW (CREATEREGION (|fetch| (POSITION XCOORD) |of| MENU-POSITION) + (|fetch| (POSITION YCOORD) |of| MENU-POSITION) + WINDOW-WIDTH WINDOW-HEIGHT) + (CONCAT "Virtual Keyboard : " (|fetch| (VIRTUALKEYBOARD KEYBOARDNAME + ) |of| KEYBOARD) + (CL:IF SHOWCONFIG + (CONCAT " for " (|fetch| (VIRTUALKEYBOARD + KEYBOARDCONFIGURATION) + |of| KEYBOARD)) + "")))) + (WINDOWPROP WINDOW 'VKBD.KEYBOARD KEYBOARD) + (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION VKBD.BUTTONEVENTFN)) + (WINDOWPROP WINDOW 'CURSORMOVEDFN (FUNCTION VKBD.CURSORMOVEDFN)) + (WINDOWPROP WINDOW 'CURSOROUTFN (FUNCTION VKBD.RESET-KEYBOARD-WINDOW)) + (WINDOWPROP WINDOW 'CURSORINFN (FUNCTION VKBD.RESET-KEYBOARD-WINDOW)) + (WINDOWPROP WINDOW 'VKBD.MENUFN MENU-FUNCTION) + (WINDOWPROP WINDOW 'REPAINTFN (FUNCTION VKBD.KEYBOARD-WINDOW-REPAINTFN)) + (WINDOWPROP WINDOW 'RESHAPEFN (FUNCTION RESHAPEBYREPAINTFN)) + (WINDOWPROP WINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) + (WINDOWPROP WINDOW 'EXTENT (CREATEREGION 0 0 (BITMAPWIDTH KEYBOARD-BITMAP) + (BITMAPHEIGHT KEYBOARD-BITMAP))) + (WINDOWPROP WINDOW 'ICONFN (FUNCTION VKBD.ICONFN)) + (WINDOWPROP WINDOW 'VKBD.KEYBOARDDISPLAYFONT (OR (|fetch| (VIRTUALKEYBOARD + KEYBOARDDISPLAYFONT) + |of| KEYBOARD) + DEFAULTKEYBOARDDISPLAYFONT)) + (REDISPLAYW WINDOW) + WINDOW))) (vkbd.cursormovedfn + (lambda (window) (* \; "Edited 15-Dec-87 16:41 by Snow") + + (prog (mouse-position shaded-key current-key-and-regions shift-is-down) + (setq mouse-position (cursorposition nil window)) + (setq shaded-key (windowprop window 'vkbd.shaded-key)) + (setq shift-is-down (or (keydownp 'lshift) + (keydownp 'rshift))) + (cond + (shaded-key (cond + ((not (vkbd.position-is-in-key-region shaded-key mouse-position + window)) + (vkbd.reset-keyboard-window window)) + (t (return t))))) + (cond + ((mousestate (or (only left) + (only middle))) + (setq current-key-and-regions (vkbd.get-key-and-regions-of-cursor-position + mouse-position window)) + (cond + (current-key-and-regions (|for| region |in| (cdr current-key-and-regions) + |do| (vkbd.invert-region region window)) + (cond + ((or shift-is-down (lastmousestate (only middle))) + (vkbd.invert-shift-keys window) + (windowprop window 'vkbd.shift-down t))) + (windowprop window 'vkbd.shaded-key (car current-key-and-regions)) + (windowprop window 'vkbd.last-mouse-state (cond + ((lastmousestate (only left)) + 'left) + (t 'middle)))))))))) (VKBD.DISPLAY-CHARACTER + (LAMBDA (CHAR REGION CHARLABELS WINDOW CONF ALLIGNMENT)(* \; "Edited 7-Mar-96 02:14 by rmk") + (* \; "Edited 17-Feb-95 12:58 by rmk:") + (LET (CHARLABEL) + (SETQ REGION (VKBD.EXTEND-REGION REGION -1)) + (COND + ((SETQ CHARLABEL (CADR (OR (FASSOC CHAR CHARLABELS) + (FASSOC CHAR VKBD.COMMONCODELABELS)))) + (DSPFONT (OR (|fetch| (KEYBOARDCONFIGURATION KEYLABELSFONT) |of| CONF) + DEFAULTKEYBOARDLABELSFONT) + WINDOW) + (CENTERPRINTINREGION CHARLABEL REGION WINDOW)) + (T (VKBD.CENTER-BITMAP-IN-REGION (GETCHARBITMAP CHAR + (FONTCREATE (OR (WINDOWPROP WINDOW + + ' + VKBD.KEYBOARDDISPLAYFONT + ) + (|fetch| ( + KEYBOARDCONFIGURATION + + KEYBOARDDISPLAYFONT + ) |of| + CONF) + DEFAULTKEYBOARDDISPLAYFONT))) + REGION WINDOW ALLIGNMENT)))))) (VKBD.DISPLAY-EMPTY-KEY-CAP + (LAMBDA (KEY-REGIONS BM) (* \; "Edited 27-Feb-96 13:32 by rmk") + (LET (LEFT BOTTOM WIDTH HEIGHT) + (FOR REGION IN KEY-REGIONS + DO (SETQ LEFT (FETCH (REGION LEFT) OF REGION)) + (SETQ BOTTOM (FETCH (REGION BOTTOM) OF REGION)) + (SETQ WIDTH (FETCH (REGION WIDTH) OF REGION)) + (SETQ HEIGHT (FETCH (REGION HEIGHT) OF REGION)) + (BITBLT NIL NIL NIL BM LEFT BOTTOM WIDTH HEIGHT 'TEXTURE 'REPLACE BLACKSHADE) + (BITBLT NIL NIL NIL BM (ADD1 LEFT) + (ADD1 BOTTOM) + (IDIFFERENCE WIDTH 2) + (IDIFFERENCE HEIGHT 2) + 'TEXTURE + 'REPLACE WHITESHADE) + (BITMAPBIT BM LEFT BOTTOM 0) + (BITMAPBIT BM (IPLUS LEFT (SUB1 WIDTH)) + BOTTOM 0) + (BITMAPBIT BM LEFT (IPLUS BOTTOM (SUB1 HEIGHT)) + 0) + (BITMAPBIT BM (IPLUS LEFT (SUB1 WIDTH)) + (IPLUS BOTTOM (SUB1 HEIGHT)) + 0)) + (COND + ((CDR KEY-REGIONS) + (FOR REGION1 IN KEY-REGIONS + DO (FOR REGION2 IN KEY-REGIONS BIND INTERSECT + DO (COND + ((NOT (EQUAL REGION1 REGION2)) + (SETQ INTERSECT (INTERSECTREGIONS + (CREATEREGION (SUB1 (FETCH (REGION LEFT) + OF REGION1)) + (SUB1 (FETCH (REGION BOTTOM) + OF REGION1)) + (IPLUS (FETCH (REGION WIDTH) + OF REGION1) + 2) + (IPLUS (FETCH (REGION HEIGHT) + OF REGION1) + 2)) + (CREATEREGION (SUB1 (FETCH (REGION LEFT) + OF REGION2)) + (SUB1 (FETCH (REGION BOTTOM) + OF REGION2)) + (IPLUS (FETCH (REGION WIDTH) + OF REGION2) + 2) + (IPLUS (FETCH (REGION HEIGHT) + OF REGION2) + 2)))) + (COND + (INTERSECT (COND + ((GREATERP (FETCH (REGION HEIGHT) + OF INTERSECT) + (FETCH (REGION WIDTH) OF + INTERSECT + )) + (SETQ INTERSECT + (CREATEREGION (FETCH (REGION LEFT) + OF INTERSECT) + (ADD1 (FETCH (REGION BOTTOM) + OF INTERSECT)) + (FETCH (REGION WIDTH) OF + INTERSECT) + (IDIFFERENCE (FETCH (REGION HEIGHT + ) + OF INTERSECT) + 2))) + (BITBLT NIL NIL NIL BM (FETCH (REGION + LEFT) + OF INTERSECT) + (FETCH (REGION BOTTOM) OF + INTERSECT) + (FETCH (REGION WIDTH) OF + INTERSECT + ) + (FETCH (REGION HEIGHT) OF + INTERSECT) + 'TEXTURE + 'REPLACE BLACKSHADE) + (BITBLT NIL NIL NIL BM (FETCH (REGION + LEFT) + OF INTERSECT) + (ADD1 (FETCH (REGION BOTTOM) + OF INTERSECT)) + (FETCH (REGION WIDTH) OF + INTERSECT + ) + (IDIFFERENCE (FETCH (REGION HEIGHT) + OF INTERSECT) + 2) + 'TEXTURE + 'REPLACE WHITESHADE)) + (T (SETQ INTERSECT + (CREATEREGION (ADD1 (FETCH (REGION + LEFT) + OF INTERSECT)) + (FETCH (REGION BOTTOM) + OF INTERSECT) + (IDIFFERENCE (FETCH (REGION + WIDTH) + OF INTERSECT) + 2) + (FETCH (REGION HEIGHT) + OF INTERSECT))) + (BITBLT NIL NIL NIL BM (FETCH + (REGION LEFT) + OF INTERSECT) + (FETCH (REGION BOTTOM) + OF INTERSECT) + (FETCH (REGION WIDTH) + OF INTERSECT) + (FETCH (REGION HEIGHT) + OF INTERSECT) + 'TEXTURE + 'REPLACE BLACKSHADE) + (BITBLT NIL NIL NIL BM + (ADD1 (FETCH (REGION LEFT) + OF INTERSECT)) + (FETCH (REGION BOTTOM) + OF INTERSECT) + (IDIFFERENCE (FETCH (REGION + WIDTH) + OF INTERSECT) + 2) + (FETCH (REGION HEIGHT) + OF INTERSECT) + 'TEXTURE + 'REPLACE WHITESHADE)))))))))))))) (VKBD.DISPLAY-KEY + (LAMBDA (KEYID WINDOW CONFIG KEYLABELS CHARLABELS KEYREGIONS) + (* \; "Edited 7-Mar-96 01:53 by rmk") + (* \; "Edited 15-Dec-87 17:40 by Snow") + (SETQ KEYID (VKBD.TRANSLATE-KEY-ID KEYID CONFIG)) + (LET (KEY-ASSIGNMENT LABEL-STRING KEYREGIONS) + (CL:WHEN (OR KEYREGIONS (SETQ KEYREGIONS (CDR (VKBD.KEY-ASSOC KEYID (FETCH + ( + KEYBOARDCONFIGURATION + KEYREGIONS) + OF CONFIG) + CONFIG)))) + + (* |;;| "If the REGION doesn't exist, we can't display it. E.g., our picture doesn't include the F1 keys. CAR because some keys (e.g. for ENTER) are defined by two rectangles") + + (VKBD.CLEAR-KEY-DISPLAY KEYREGIONS WINDOW) + (SETQ KEYLABELS (OR KEYLABELS (FETCH (KEYBOARDCONFIGURATION KEYLABELS) OF CONFIG + ))) + (COND + ((SETQ LABEL-STRING (CADR (VKBD.KEY-ASSOC KEYID KEYLABELS CONFIG)))) + (T (SETQ KEY-ASSIGNMENT (VKBD.KEY-ASSOC KEYID (FETCH (VIRTUALKEYBOARD + COMPLETEKEYASSIGNMENTS + ) + OF (WINDOWPROP WINDOW + 'VKBD.KEYBOARD)) + CONFIG)) + (SETQ LABEL-STRING (VKBD.GET-NON-CHAR-LABEL KEY-ASSIGNMENT)))) + (COND + (LABEL-STRING (DSPFONT (OR (FETCH (KEYBOARDCONFIGURATION KEYLABELSFONT) + OF CONFIG) + DEFAULTKEYBOARDLABELSFONT) + WINDOW) + (COND + ((AND (LISTP LABEL-STRING) + (CDR LABEL-STRING)) + (CENTERPRINTINREGION (CAR LABEL-STRING) + (VKBD.UPPER-HALF-REGION (CAR KEYREGIONS)) + WINDOW) + (CENTERPRINTINREGION (CADR LABEL-STRING) + (VKBD.LOWER-HALF-REGION (CAR KEYREGIONS)) + WINDOW)) + (T (CENTERPRINTINREGION LABEL-STRING (CAR KEYREGIONS) + WINDOW)))) + (T (VKBD.DISPLAY-KEY-CHARACTERS KEY-ASSIGNMENT (CAR KEYREGIONS) + WINDOW CONFIG CHARLABELS))))))) (VKBD.DISPLAY-KEY-CHARACTERS + (LAMBDA (KEY-ASSIGNMENT KEY-REGION WINDOW CONFIG CHARLABELS) + (* \; "Edited 7-Mar-96 01:15 by rmk") + (LET (SHIFTED-CHAR UNSHIFTED-CHAR) + (COND + ((AND KEY-ASSIGNMENT (LISTP (CADR KEY-ASSIGNMENT))) + (CL:WHEN KEY-REGION + (SETQ SHIFTED-CHAR (VKBD.SHIFTED-CHAR KEY-ASSIGNMENT)) + (SETQ UNSHIFTED-CHAR (VKBD.UNSHIFTED-CHAR KEY-ASSIGNMENT)) + (COND + ((EQ SHIFTED-CHAR UNSHIFTED-CHAR) + (VKBD.DISPLAY-CHARACTER SHIFTED-CHAR KEY-REGION CHARLABELS WINDOW CONFIG)) + (T (VKBD.DISPLAY-CHARACTER UNSHIFTED-CHAR (VKBD.LOWER-HALF-REGION + KEY-REGION) + CHARLABELS WINDOW CONFIG 'BOTTOM) + (VKBD.DISPLAY-CHARACTER SHIFTED-CHAR (VKBD.UPPER-HALF-REGION + KEY-REGION) + CHARLABELS WINDOW CONFIG 'TOP))))))))) (VKBD.DRAW-KEY-CAPS + (LAMBDA (LIST-OF-REGIONS BITMAP) (* \; "Edited 13-Jun-90 01:10 by mitani") + (|for| REGION |in| LIST-OF-REGIONS |do| (BITBLT NIL NIL NIL BITMAP + (|fetch| (REGION LEFT) + |of| REGION) + (|fetch| (REGION BOTTOM) + |of| REGION) + (|fetch| (REGION WIDTH) + |of| REGION) + (|fetch| (REGION HEIGHT) + |of| REGION) + 'TEXTURE + 'REPLACE BLACKSHADE) + (BITBLT NIL NIL NIL BITMAP + (ADD1 (|fetch| (REGION LEFT) + |of| REGION)) + (ADD1 (|fetch| (REGION BOTTOM) + |of| REGION)) + (IDIFFERENCE (|fetch| (REGION WIDTH) + |of| REGION) + 2) + (IDIFFERENCE (|fetch| (REGION HEIGHT) + |of| REGION) + 2) + 'TEXTURE + 'REPLACE WHITESHADE)))) (vkbd.erase-frame + (lambda (key window framesize) (* \; "Edited 15-Dec-87 16:42 by Snow") + + (vkbd.frame-key key window (|fetch| (keyboardconfiguration backgroundshade) + |of| (vkbd.get-configuration window)) + framesize))) (vkbd.extend-region + (lambda (region nbits) (* \; "Edited 15-Dec-87 16:42 by Snow") + + (cond + ((null nbits) + (setq nbits 1))) + (createregion (idifference (|fetch| (region left) |of| region) + nbits) + (idifference (|fetch| (region bottom) |of| region) + nbits) + (iplus (|fetch| (region width) |of| region) + (itimes nbits 2)) + (iplus (|fetch| (region height) |of| region) + (itimes nbits 2))))) (vkbd.get-key-and-regions-of-cursor-position + (lambda (cursor-position window) (* \; "Edited 15-Dec-87 16:43 by Snow") + + (|for| key-regions |in| (|fetch| (keyboardconfiguration keyregions) + |of| (vkbd.get-configuration window)) + |thereis| (|for| region |in| (cdr key-regions) |thereis| (insidep region + cursor-position + ))))) (VKBD.GET-KEY-REGIONS + (LAMBDA (KEY-ID CONFIG) (* \; "Edited 27-Feb-96 21:18 by rmk") + (CDR (VKBD.KEY-ASSOC KEY-ID (FETCH (KEYBOARDCONFIGURATION KEYREGIONS) OF CONFIG) + CONFIG)))) (VKBD.INVERT-KEY + (LAMBDA (KEY-ID VKBD-WINDOW) (* \; "Edited 27-Feb-96 21:14 by rmk") + (FOR REGION IN (VKBD.GET-KEY-REGIONS KEY-ID (VKBD.GET-CONFIGURATION VKBD-WINDOW)) + DO (VKBD.INVERT-REGION REGION VKBD-WINDOW)))) (vkbd.invert-region + (lambda (region window) (* \; "Edited 15-Dec-87 16:46 by Snow") + + (|if| region + |then| (bitblt window (|fetch| (region left) |of| region) + (|fetch| (region bottom) |of| region) + window + (|fetch| (region left) |of| region) + (|fetch| (region bottom) |of| region) + (|fetch| (region width) |of| region) + (|fetch| (region height) |of| region) + 'invert + 'replace)))) (VKBD.KEYBOARD-WINDOW-REPAINTFN + (LAMBDA (WINDOW) (* \; "Edited 7-Mar-96 13:38 by rmk") + (LET (BM KEYLABELS CHARLABELS (CONFIG (VKBD.GET-CONFIGURATION WINDOW)) + (KEYBOARD (WINDOWPROP WINDOW 'VKBD.KEYBOARD))) + (SETQ KEYLABELS (FOR K IN (FETCH (KEYBOARDCONFIGURATION KEYLABELS) OF CONFIG + ) COLLECT (LIST (VKBD.TRANSLATE-KEY-ID + (CAR K) + CONFIG) + (CADR K)))) + + (* |;;| "Build this up each time, so that the keyids are specialized to this keyboard. But the internal search will be much faster. ") + + (FOR K TR IN VKBD.COMMONKEYLABELS WHEN (SETQ TR (VKBD.TRANSLATE-KEY-ID + (CAR K) + CONFIG)) + UNLESS (ASSOC TR KEYLABELS) DO (PUSH KEYLABELS (LIST TR (CADR K)))) + (SETQ CHARLABELS (FETCH (KEYBOARDCONFIGURATION CHARLABELS) OF CONFIG)) + (SETQ BM (VKBD.CREATE-KEYBOARD-BITMAP CONFIG)) + (BITBLT BM 0 0 WINDOW) + + (* |;;| "Display all the keys") + + (FOR R IN (FETCH KEYREGIONS OF CONFIG) + DO (VKBD.DISPLAY-KEY (VKBD.TRANSLATE-KEY-ID (CAR R) + CONFIG) + WINDOW CONFIG KEYLABELS CHARLABELS (CDR R))) + (COND + ((WINDOWPROP WINDOW 'VKBD.LOCKED) + (VKBD.INVERT-LOCK-KEYS WINDOW))) + (WINDOWPROP WINDOW 'VKBD.SHADED-KEY NIL) + (WINDOWPROP WINDOW 'VKBD.LAST-MOUSE-STATE NIL)))) (vkbd.lower-half-region + (lambda (region) (* \; "Edited 15-Dec-87 16:48 by Snow") + + (createregion (|fetch| (region left) |of| region) + (|fetch| (region bottom) |of| region) + (|fetch| (region width) |of| region) + (iquotient (|fetch| (region height) |of| region) + 2)))) (VKBD.POSITION-IS-IN-KEY-REGION + (LAMBDA (KEY POSITION WINDOW) (* \; "Edited 27-Feb-96 21:21 by rmk") + (FOR REGION IN (VKBD.GET-KEY-REGIONS KEY (VKBD.GET-CONFIGURATION WINDOW)) + THEREIS (INSIDEP REGION POSITION)))) (vkbd.remove-keyboard-command + (lambda nil (* \; "Edited 15-Dec-87 16:49 by Snow") + + (prog (k) + (setq k (vkbd.pop-up-keyboards-menu "Select keyboard to be removed .")) + (|if| k + |then| (vkbd.undefine-keyboard k) + (printout promptwindow "Keyboard " k + " was removed from the list of known keyboards. "))))) (VKBD.UNION-REGIONS + (LAMBDA (CONFIGURATION) (* \; "Edited 17-Jan-96 13:47 by rmk") + + (* |;;| "Don't let too many arguments pile up on the stack.") + + (LET ((KEYREGS (FETCH KEYREGIONS OF CONFIGURATION))) + (APPLY 'UNIONREGIONS (WHILE KEYREGS + COLLECT (APPLY 'UNIONREGIONS + (WHILE KEYREGS FOR I VAL FROM 1 + TO 50 + DO + + (* |;;| + "CDR because odd-shaped keys (e.g. ENTER) have multiple regions") + + (FOR R + IN (CDR (POP KEYREGS)) + DO (PUSH VAL R)) + FINALLY (RETURN VAL)))))))) (vkbd.upper-half-region + (lambda (region) (* |sm| "13-Aug-85 10:38") + (createregion (|fetch| (region left) |of| region) + (iplus 1 (|fetch| (region bottom) |of| region) + (iquotient (|fetch| (region height) |of| region) + 2)) + (|fetch| (region width) |of| region) + (iquotient (|fetch| (region height) |of| region) + 2)))) ) (DEFINEQ (VKBD.KEY-ASSOC (LAMBDA (KEY ALIST CONFIG) (* \; "Edited 5-Oct-96 16:59 by rmk:") (* \; "Edited 27-Feb-96 21:07 by rmk") (CL:WHEN (SETQ KEY (VKBD.TRANSLATE-KEY-ID KEY CONFIG)) (FIND C IN ALIST SUCHTHAT (EQ (VKBD.TRANSLATE-KEY-ID (CAR C) CONFIG) KEY))))) (VKBD.CHAR-ASSIGNMENTP + (LAMBDA (ASSIGNMENT) (* \; "Edited 26-Feb-96 16:49 by rmk") + (LISTP (CADR ASSIGNMENT)))) (VKBD.COMPLETE-KEYBOARD + (LAMBDA (KEYBOARD) (* \; "Edited 7-Mar-96 13:25 by rmk") + + (* |;;| "Fill in keys that aren't mentioned in the new keyboard, using the configuration's default. Put the parsed results in the COMPLETEKEYASSIGNMENTS field, for future use. This field is not written out by the STORE-KEYBOARD function.") + + (CL:UNLESS (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD) + (LET (COMPLETE-ASSIGNMENTS (CONFIG (VKBD.GET-CONFIGURATION (FETCH (VIRTUALKEYBOARD + + KEYBOARDCONFIGURATION + ) OF KEYBOARD) + ))) + + (* |;;| "The assignment comes from the keyboard (PARTIAL), the configuration default, or the common default assignments.") + + (FOR K A CA IN (FETCH (VIRTUALKEYBOARD KEYASSIGNMENTS) OF KEYBOARD) + DO (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT K CONFIG)) + (IF (NULL (SETQ CA (ASSOC (CAR A) + COMPLETE-ASSIGNMENTS))) + THEN (PUSH COMPLETE-ASSIGNMENTS A) + ELSEIF (EQUAL A CA) + ELSE (ERROR "INCOMPATIBLE ASSIGNMENTS OF KEY NUMBER" + (LIST K A CA)))) + (FOR K A IN (FETCH (KEYBOARDCONFIGURATION DEFAULTASSIGNMENT) OF CONFIG) + DO (SETQ A (VKBD.PARSE-KEY-ASSIGNMENT K CONFIG)) + (CL:UNLESS (ASSOC (CAR A) + COMPLETE-ASSIGNMENTS) + (PUSH COMPLETE-ASSIGNMENTS A))) + + (* |;;| "The configs defaultassignment can override the VKBD.COMMONDEFAULTASSIGNMENT") + + (FOR K A IN VKBD.COMMONDEFAULTASSIGNMENT WHEN (SETQ A ( + VKBD.PARSE-KEY-ASSIGNMENT + K CONFIG T)) + DO (CL:UNLESS (ASSOC (CAR A) + COMPLETE-ASSIGNMENTS) + (PUSH COMPLETE-ASSIGNMENTS A))) + (REPLACE COMPLETEKEYASSIGNMENTS OF KEYBOARD WITH COMPLETE-ASSIGNMENTS))) + KEYBOARD)) (vkbd.ctrl-assignmentp + (lambda (assignment) (* \; "Edited 15-Dec-87 16:33 by Snow") + + (and (eq (cadr assignment) + 'ctrldown) + (eq (cddr assignment) + 'ctrlup)))) (vkbd.event-assignmentp + (lambda (assignment) (* \; "Edited 15-Dec-87 16:34 by Snow") + + (and (eq (cadr assignment) + 'event) + (eq (cddr assignment) + 'event)))) (vkbd.meta-assignmentp + (lambda (assignment) (* \; "Edited 15-Dec-87 16:34 by Snow") + + (and (eq (cadr assignment) + 'metadown) + (eq (cddr assignment) + 'metaup)))) (VKBD.FRAME-KEY + (LAMBDA (KEY WINDOW SHADE BITS) (* \; "Edited 29-Feb-96 11:06 by rmk") + (LET ((CONFIG (VKBD.GET-CONFIGURATION WINDOW)) + KEY-REGIONS) + (SETQ KEY-REGIONS (VKBD.GET-KEY-REGIONS KEY CONFIG)) + (FOR REGION EXTENDED-REGION IN KEY-REGIONS DO (SETQ EXTENDED-REGION + (VKBD.EXTEND-REGION REGION + BITS)) + (BITBLT NIL NIL NIL WINDOW + (FETCH (REGION LEFT) + OF EXTENDED-REGION) + (FETCH (REGION BOTTOM) + OF EXTENDED-REGION) + (FETCH (REGION WIDTH) + OF EXTENDED-REGION) + (FETCH (REGION HEIGHT) + OF EXTENDED-REGION) + 'TEXTURE + 'REPLACE SHADE)) + (VKBD.DISPLAY-EMPTY-KEY-CAP KEY-REGIONS WINDOW) + (VKBD.DISPLAY-KEY KEY WINDOW CONFIG) + (IF (EQ (WINDOWPROP WINDOW 'VKBD.SHADED-KEY) + KEY) + THEN (VKBD.INVERT-KEY KEY WINDOW))))) (VKBD.GET-CURRENT-KEY-ASSIGNMENT + (LAMBDA (KEY WINDOW/CONFIGURATION) (* \; "Edited 7-Mar-96 12:33 by rmk") + (* \; "Edited 15-Dec-87 16:43 by Snow") + (CONS KEY (KEYACTION (OR (VKBD.TRANSLATE-KEY-ID KEY WINDOW/CONFIGURATION) + KEY))))) (vkbd.get-non-char-label + (lambda (key-assignment) (* \; "Edited 15-Dec-87 16:44 by Snow") + + (cond + ((vkbd.shift-assignmentp key-assignment) + "SHIFT") + ((vkbd.lock-assignmentp key-assignment) + "LOCK") + ((vkbd.ctrl-assignmentp key-assignment) + "CTRL") + ((vkbd.lockup-assignmentp key-assignment) + '("LOCK" "UP")) + ((vkbd.lockdown-assignmentp key-assignment) + '("LOCK" "DOWN")) + ((vkbd.meta-assignmentp key-assignment) + "META") + ((vkbd.event-assignmentp key-assignment) + " ") + (t nil)))) (vkbd.iconfn + (lambda (window icon) (* \; "Edited 15-Dec-87 16:44 by Snow") + + (cond + ((null icon) + (setq icon (titlediconw (|create| titledicon + icon _ vkbd.icon + mask _ vkbd.mask + titlereg _ (createregion 5 15 80 50)) + (|fetch| (virtualkeyboard keyboardname) |of| (windowprop + window + 'vkbd.keyboard)) + (fontcreate 'gacha 8))))) + icon)) (VKBD.INVERT-LOCK-KEYS + (LAMBDA (WINDOW) (* \; "Edited 26-Feb-96 17:04 by rmk") + (FOR KEY-ASSIGNMENT IN (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) + OF (WINDOWPROP WINDOW 'VKBD.KEYBOARD)) + WHEN (VKBD.LOCK-ASSIGNMENTP KEY-ASSIGNMENT) DO (VKBD.INVERT-KEY (CAR + KEY-ASSIGNMENT + ) + WINDOW)))) (VKBD.INVERT-SHIFT-KEYS + (LAMBDA (WINDOW) (* \; "Edited 27-Feb-96 21:13 by rmk") + (FOR KEY-ASSIGNMENT IN (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) + OF (WINDOWPROP WINDOW 'VKBD.KEYBOARD)) + WHEN (VKBD.SHIFT-ASSIGNMENTP KEY-ASSIGNMENT) DO (VKBD.INVERT-KEY (CAR + KEY-ASSIGNMENT + ) + WINDOW)))) (VKBD.TRANSLATE-KEY-ID + (LAMBDA (KEY-ID CONFIG) (* \; "Edited 7-Mar-96 12:28 by rmk") + + (* |;;| "Assumes that KEY-ID's that look like key numbers ARE key numbers. Thus, integers in the range [0,\\NKEYS) can't be used as ID's. Returns NIL if the KEY-ID doesn't exist") + + (OR (KEYNUMBERP KEY-ID) + (LET ((NUM (CADR (ASSOC KEY-ID (FETCH KEYNAMESMAPPING OF CONFIG))))) + + (* |;;| + "If result is not a keynumber, then try recursing. Introduces a synonym facility") + + (OR (KEYNUMBERP NUM) + (AND NUM (VKBD.TRANSLATE-KEY-ID NUM CONFIG))))))) (vkbd.key-id-to-key-names + (lambda (key-id window/configuration) (* \; "Edited 15-Dec-87 16:46 by Snow") + + (setq window/configuration (vkbd.get-configuration window/configuration)) + (|for| name-id-pair |in| (|fetch| (keyboardconfiguration keynamesmapping) + |of| window/configuration) + |when| (eq (cadr name-id-pair) + key-id) |collect| (car name-id-pair)))) (VKBD.KEYBOARD-IS-KEYBOARDTYPE-KEYBOARD (LAMBDA (KEYBOARD) (* \; "Edited 24-May-95 15:25 by rmk:") (* |;;| "T if this keyboard is configured for the current physical keyboardtype.") (MEMB (FETCH (KEYBOARDCONFIGURATION KEYBOARDTYPE) OF (VKBD.GET-CONFIGURATION (FETCH KEYBOARDCONFIGURATION OF KEYBOARD))) (ASSOC (KEYBOARDTYPE) KEYBOARDCONFIGCOERCIONS)))) (VKBD.LOCK-ASSIGNMENTP + (LAMBDA (ASSIGNMENT) (* \; "Edited 28-Feb-96 14:33 by rmk") + (* \; "Edited 15-Dec-87 16:47 by Snow") + (SELECTQ (CADR ASSIGNMENT) + (LOCKDOWN (EQ (CDDR ASSIGNMENT) + 'LOCKUP)) + (LOCKTOGGLE (MEMB (CDDR ASSIGNMENT) + '(NIL IGNORE))) + NIL))) (VKBD.LOCK-KEYP + (LAMBDA (KEY WINDOW) (* \; "Edited 26-Feb-96 17:05 by rmk") + (VKBD.LOCK-ASSIGNMENTP (FASSOC KEY (|fetch| (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) + |of| (WINDOWPROP WINDOW 'VKBD.KEYBOARD)))))) (vkbd.lock/nolock + (lambda (key-action) (* \; "Edited 15-Dec-87 16:47 by Snow") + + (caddr (cadr key-action)))) (vkbd.lockdown-assignmentp + (lambda (assignment) (* \; "Edited 15-Dec-87 16:47 by Snow") + + (and (eq (cadr assignment) + 'lockdown) + (or (null (cddr assignment)) + (eq (cddr assignment) + 'ignore))))) (vkbd.lockup-assignmentp + (lambda (assignment) (* \; "Edited 15-Dec-87 16:48 by Snow") + + (and (eq (cadr assignment) + 'lockup) + (or (null (cddr assignment)) + (eq (cddr assignment) + 'ignore))))) (VKBD.PARSE-CHAR-CODE + (LAMBDA (CHARSPEC) (* \; "Edited 29-Feb-96 10:29 by rmk") + + (* |;;| + "Does the coercion to a character code, causing error if not possible. NIL is passed through.") + + (COND + ((AND (SMALLP CHARSPEC) + (IGEQ CHARSPEC 0) + (ILEQ CHARSPEC 65535)) + CHARSPEC) + ((CHARCODE.DECODE CHARSPEC T)) + (CHARSPEC (ERROR "ILLEGAL CHARACTER SPECIFICATION" CHARSPEC))))) (VKBD.PARSE-KEY-ASSIGNMENT (LAMBDA (KEY-ASSIGNMENT CONFIG UNKNOWNOK) (* \; "Edited 27-Apr-2018 22:38 by rmk:") (* \; "Edited 27-Mar-2018 12:02 by rmk:") (* \; "Edited 27-Mar-2018 12:00 by rmk:") (* \; "Edited 13-Dec-96 17:26 by rmk:") (* \; "Edited 7-Mar-96 12:29 by rmk") (* |;;| "Parses a key assignment using information in CONFIG. Value returned is an image of the key assignment with the key coerced to a keynumber and also the character specifications coerced to codes. This is what goes into the COMPLETEKEYASSIGNMENTS field. If UNKNOWNOK, returns NIL as the keyid if it isn't found in the CONFIG (or if the CONFIG isn't given (on calls from LOADKEYBOARDDISPLAYFONTS).") (PROG (KEY TRKEY UNSHIFTED-CHAR SHIFTED-CHAR LOCK/NOLOCK DOWN UP) (CL:UNLESS (CDR (LISTP KEY-ASSIGNMENT)) (ERROR "ILLEGAL KEY ASSIGNMENT" KEY-ASSIGNMENT)) (SETQ KEY (CAR KEY-ASSIGNMENT)) (CL:UNLESS (SETQ TRKEY (VKBD.TRANSLATE-KEY-ID KEY CONFIG)) (CL:UNLESS UNKNOWNOK (ERROR (CONCAT "KEY NOT KNOWN IN CONFIGURATION " (FETCH CONFIGURATIONNAME OF CONFIG)) KEY-ASSIGNMENT))) (OR T (CL:UNLESS (VKBD.CHAR-ASSIGNMENTP KEY-ASSIGNMENT) (* |;;| "Not sure what else it should be. Perhaps cause an error?") (RETURN NIL))) (CL:WHEN (LISTP (SETQ DOWN (CADR KEY-ASSIGNMENT))) (SETQ UNSHIFTED-CHAR (VKBD.PARSE-CHAR-CODE (CAR DOWN))) (* \;  "RMK: LOCKSHIFT is in CADDDR not CADDR") (SETQ DOWN (LIST (VKBD.PARSE-CHAR-CODE (CAR DOWN)) (IF (CADR DOWN) THEN (VKBD.PARSE-CHAR-CODE (CADR DOWN)) ELSE UNSHIFTED-CHAR) (SELECTQ (CADDR DOWN) ((NIL LOCKSHIFT LS) 'LOCKSHIFT) ((NLS NOLOCKSHIFT) 'NOLOCKSHIFT) (ERROR "INVALID LOCKSHIFT SPECIFICATION" KEY-ASSIGNMENT))))) (CL:WHEN (LISTP (SETQ UP (CDDR KEY-ASSIGNMENT))) (SETQ UNSHIFTED-CHAR (VKBD.PARSE-CHAR-CODE (CAR UP))) (SETQ UP (LIST (VKBD.PARSE-CHAR-CODE (CAR UP)) (IF (CADR UP) THEN (VKBD.PARSE-CHAR-CODE (CADR UP)) ELSE UNSHIFTED-CHAR) (SELECTQ (CADDR UP) ((NIL LOCKSHIFT LS) 'LOCKSHIFT) ((NLS NOLOCKSHIFT) 'NOLOCKSHIFT) (ERROR "INVALID LOCKSHIFT SPECIFICATION" KEY-ASSIGNMENT))))) (RETURN `(,TRKEY ,DOWN ,@UP))))) (VKBD.RESET-KEYBOARD-WINDOW + (LAMBDA (WINDOW) (* \; "Edited 27-Feb-96 21:22 by rmk") + (LET (SHADED-KEY) + (IF (SETQ SHADED-KEY (WINDOWPROP WINDOW 'VKBD.SHADED-KEY)) + THEN (VKBD.INVERT-KEY SHADED-KEY WINDOW) + (WINDOWPROP WINDOW 'VKBD.SHADED-KEY NIL)) + (IF (WINDOWPROP WINDOW 'VKBD.SHIFT-DOWN) + THEN (VKBD.INVERT-SHIFT-KEYS WINDOW) + (WINDOWPROP WINDOW 'VKBD.SHIFT-DOWN NIL)) + (WINDOWPROP WINDOW 'VKBD.LAST-MOUSE-STATE NIL)))) (VKBD.SEND-CHARACTER + (LAMBDA (KEY WINDOW) (* \; "Edited 28-Feb-96 14:35 by rmk") + (LET (KEY-ASSIGNMENT CHAR-CODE (CONFIG (VKBD.GET-CONFIGURATION WINDOW))) + (SETQ KEY (VKBD.TRANSLATE-KEY-ID KEY CONFIG)) + (COND + ((VKBD.LOCK-KEYP KEY WINDOW) + (WINDOWPROP WINDOW 'VKBD.LOCKED (NOT (WINDOWPROP WINDOW 'VKBD.LOCKED))) + (VKBD.INVERT-LOCK-KEYS WINDOW)) + (T (SETQ KEY-ASSIGNMENT (FASSOC KEY (FETCH (VIRTUALKEYBOARD COMPLETEKEYASSIGNMENTS) + OF (WINDOWPROP WINDOW 'VKBD.KEYBOARD)))) + (COND + ((VKBD.CHAR-ASSIGNMENTP KEY-ASSIGNMENT) + (SETQ CHAR-CODE (COND + ((OR (KEYDOWNP 'RSHIFT) + (KEYDOWNP 'LSHIFT) + (WINDOWPROP WINDOW 'VKBD.SHIFT-DOWN) + (AND (EQ (VKBD.LOCK/NOLOCK KEY-ASSIGNMENT) + 'LOCKSHIFT) + (WINDOWPROP WINDOW 'VKBD.LOCKED))) + (VKBD.SHIFTED-CHAR KEY-ASSIGNMENT)) + (T (VKBD.UNSHIFTED-CHAR KEY-ASSIGNMENT)))) + (COND + (CHAR-CODE (BKSYSBUF (CHARACTER CHAR-CODE))))))))))) (vkbd.shift-assignmentp + (lambda (assignment) (* \; "Edited 15-Dec-87 16:50 by Snow") + + (or (and (eq (cadr assignment) + '1shiftdown) + (eq (cddr assignment) + '1shiftup)) + (and (eq (cadr assignment) + '2shiftdown) + (eq (cddr assignment) + '2shiftup))))) (vkbd.shifted-char + (lambda (key-assignment) (* \; "Edited 15-Dec-87 16:50 by Snow") + + (cadadr key-assignment))) (VKBD.UNDEFINE-KEYBOARD (LAMBDA (KEYBOARD-NAME) (* \; "Edited 25-May-95 11:45 by rmk:") (IF (EQ KEYBOARD-NAME 'DEFAULT) THEN (PROMPTPRINT "Cannot delete the default keyboard. ") ELSE (SETQ VKBD.KNOWN-KEYBOARDS (REMOVE (FINDVIRTUALKEYBOARD KEYBOARD-NAME) VKBD.KNOWN-KEYBOARDS))))) (vkbd.unshifted-char + (lambda (key-assignment) (* \; "Edited 15-Dec-87 16:50 by Snow") + + (caadr key-assignment))) ) (ADDTOVAR CHARACTERNAMES (BREAK 2) (HOME 524) (PGUP 525) (END 527) (PGDN 528) (INS 529) (HELP 517) (SCRL 521) (NUMLK 522) (CLEAR 523) (DOIT 555) (CENTER 577) (NOTCENTER 609) (BOLD 578) (NOTBOLD 610) (ITALIC 579) (NOTITALIC 611) (UCASE 580) (LCASE 612) (STRIKEOUT 581) (NOTSTRIKEOUT 613) (UNDERLINE 582) (NOTUNDERLINE 614) (SUBSCRIPT 583) (SUPERSCRIPT 615) (SMALLER 584) (LARGER 616) (MARGINS 585) (NOTMARGINS 617) (LOOKS 587) (NOTLOOKS 619) (F11 588) (NOTF11 620) (F12 589) (NOTF12 621)) (DECLARE\: EVAL@COMPILE (RECORD KEYBOARDCONFIGURATION (CONFIGURATIONNAME KBCDUMMY1 KEYREGIONS KBCDUMMY2 DEFAULTASSIGNMENT KEYNAMESMAPPING KEYBOARDTYPE KEYLABELS KEYLABELSFONT BACKGROUNDSHADE KEYBOARDDISPLAYFONT CHARLABELS) (* |;;| "Dummy fields so length test still works") (TYPE? (EQLENGTH DATUM (CONSTANT (LENGTH (RECORDFIELDNAMES ' KEYBOARDCONFIGURATION ))))) KEYBOARDTYPE _ (KEYBOARDTYPE) KEYLABELSFONT _ DEFAULTKEYBOARDLABELSFONT BACKGROUNDSHADE _ 23130 KEYBOARDDISPLAYFONT _ DEFAULTKEYBOARDDISPLAYFONT) (RECORD VIRTUALKEYBOARD (KEYBOARDNAME KEYASSIGNMENTS KEYBOARDCONFIGURATION KEYBOARDDISPLAYFONT) (HASHLINK VIRTUALKEYBOARD (COMPLETEKEYASSIGNMENTS VKBDHASHARRAY 20))) ) (DECLARE\: EVAL@COMPILE (GLOBALVARS VKBDHASHARRAY)) (SETUPHASHARRAY 'VKBDHASHARRAY 20) (RPAQ? VKBD.KNOWN-KEYBOARDS NIL) (FILESLOAD (SOURCE) KEYBOARDCONFIGS) (RPAQQ VKBD.BACKGROUND-MENU-SUBITEMS (SUBITEMS ("Switch keyboard" '(ADD.PROCESS '(SWITCHKEYBOARDS T)) "Switches the key actions of the keyborad.") ("Switch and display" '(ADD.PROCESS '(SWITCHKEYBOARDS T T)) "Switches the key actions of the keyboards and displays the new keyboard. the displayed keyboard can be used as a menu." ) ("Display only" '(ADD.PROCESS '(SWITCHKEYBOARDS NIL T)) "Displays the new keyboard. The displayed keyboard can be used as a menu.") ("Store keyboards" '(ADD.PROCESS '(VKBD.STORE-FILE-COMMAND) 'WINDOW PROMPTWINDOW) "Stores the current known keyboards") ("Load keyboards file" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND) 'WINDOW PROMPTWINDOW) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " (SUBITEMS ("Replace" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND NIL T) 'WINDOW PROMPTWINDOW) "Removes the current known definitions and loads predefined keyboards ." ) ("Add, don't redefine" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND NIL NIL) 'WINDOW PROMPTWINDOW) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " ) ("Add, redefine" '(ADD.PROCESS '(VKBD.LOAD-FILE-COMMAND T NIL) 'WINDOW PROMPTWINDOW) "Adds definitions of keyboards found on file. If a keyboard with the same name is already known to the system, REDEFINE ir" ))) ("Remove keyboard" '(ADD.PROCESS '(VKBD.REMOVE-KEYBOARD-COMMAND)) "Removes a keyboard from the list of known keyboards") ("Edit" (ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will use the default keyboard as the initial keyboard" (SUBITEMS ("New Keyboard, default initial" '(ADD.PROCESS '( VKBD.EDIT-KEYBOARD-COMMAND T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will use the default keyboard as the initial keyboard" ) ("New keyboard, other initial" '(ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND T T)) "Calls the keyboard editor. Will prompt for name for the new keyboard, and will pop up a menu of the current known keyboards. The selected one will be used as the initial keyboard" ) ("Existing keyboard" '(ADD.PROCESS '(VKBD.EDIT-KEYBOARD-COMMAND)) "Will let you select a keyboard from list of the known keyboards, and will calls the keyboard editor on the selected keyboard." ))))) (RPAQQ VKBD.NON-CHAR-ASSIGNMENTS-LABELS ((SHIFT SHIFT) (CTRL CTRL) (META META) (LOCK LOCK) (LOCKUP LOCKUP) (LOCKDOWN LOCKDOWN))) (RPAQQ VKBD.WINDOW-MENU-SUBITEMS (SUBITEMS ("Switch keyboard" (FUNCTION (LAMBDA (W) (SWITCHKEYBOARDS T NIL W))) "Switches the key actions of the keyborad.") ("Switch and display" (FUNCTION (LAMBDA (W) (SWITCHKEYBOARDS T T W))) "Switches the key actions of the keyboards and displays the new keyboard. the displayed keyboard can be used as a menu." ) ("Display only" (FUNCTION (LAMBDA (W) (SWITCHKEYBOARDS NIL T W))) "Displays the new keyboard. The displayed keyboard can be used as a menu.") ("Store keyboards" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION (VKBD.STORE-FILE-COMMAND)) 'WINDOW PROMPTWINDOW))) "Stores the current known keyboards") ("Load keyboards file" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION (VKBD.LOAD-FILE-COMMAND) ) 'WINDOW PROMPTWINDOW))) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " (SUBITEMS ("Replace" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION ( VKBD.LOAD-FILE-COMMAND NIL T)) 'WINDOW PROMPTWINDOW))) "Removes the current known definitions and loads predefined keyboards ." ) ("Add, don't redefine" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION ( VKBD.LOAD-FILE-COMMAND )) 'WINDOW PROMPTWINDOW))) "Adds definition of keyboards found on file. If a keyboard with the same name is already known to the system DO NOT redefine it. " ) ("Add, redefine" (FUNCTION (LAMBDA (W) (ADD.PROCESS (FUNCTION ( VKBD.LOAD-FILE-COMMAND T NIL)) 'WINDOW PROMPTWINDOW))) "Adds definitions of keyboards found on file. If a keyboard with the same name is already known to the system, REDEFINE ir" ))) ("Remove keyboard" (FUNCTION (LAMBDA (W) (ADD.PROCESS '(VKBD.REMOVE-KEYBOARD-COMMAND)))) "Removes a keyboard from the list of known keyboards"))) (RPAQQ VKBD.ICON #*(93 50)OOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHLGOOOOOOOOOOOOOOOOOOOOAHLGOOOOOOOOOOOOOOOOOOOOAHLG@HDBA@HDBA@HDBA@HD@GAHLG@HDBA@HDBA@HDBA@HD@GAHLG@HDBA@HDBA@HDBA@HDNGAHLG@HDBA@HDBA@HDBA@HD@GAHLGOOOOOOOOOOOOOOOOOOOOAHLG@BA@HDBA@HDBA@HDBA@GAHLGGBA@HDBA@HDBA@HDBA@GAHLGGBA@HDBA@HDBA@HDBAFGAHLG@BA@HDBA@HDBA@HDBA@GAHLGOOOOOOOOOOOOOOOOOOHGAHLG@AHDBA@HDBA@HDBA@HIGAHLG@AHDBA@HDBA@HDBA@HIGAHLG@AHDBA@HDBA@HDBA@HIGAHLG@AHDBA@HDBA@HDBA@HHGAHLGOOOOOOOOOOOOOOOOOOOOAHLG@@@HDBA@HDBA@HDBA@@GAHLG@@@HDBA@HDBA@HDBA@@GAHLG@@@HDBA@HDBA@HDBA@@GAHLG@@@HDBA@HDBA@HDBA@@GAHLGOOOOOOOOOOOOOOOOOOOOAHLGOOOOOOOOOOOOOOOOOOOOAHLGOOOOOOOOOOOOOOOOOOOOAHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHL@@@@@@@@@@@@@@@@@@@@@AHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOH ) (RPAQQ VKBD.MASK #*(93 50)OOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOOOOOH ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS VKBD.BACKGROUND-MENU-SUBITEMS VKBD.DEFAULT-CONFIGURATION-NAME VKBD.KNOWN-KEYBOARDS VKBD.NON-CHAR-ASSIGNMENTS-LABELS VKBD.ICON VKBD.MASK CURRENTKEYBOARDCONFIG VKBD.CONFIGURATIONS VKBD.COMMONCODELABELS VKBD.COMMONKEYLABELS VKBD.COMMONDEFAULTASSIGNMENT) ) (DECLARE\: FIRST (MOVD? '\\KEYBOARDEVENTFN '\\OLDKEYBOARDEVENTFN) ) (RPAQ? \\ORIGINALDEFAULTKEYACTION ) (DEFINEQ (VKBD.\\KEYBOARDEVENTFN + (LAMBDA (FDEV EVENT EXTRA) (* \; "Edited 1-Mar-96 23:27 by rmk") + + (* |;;| "call the old keyboard event function, then make sure to reset the Virtual keyboard keyaction tables. ") + + (\\OLDKEYBOARDEVENTFN FDEV EVENT EXTRA) + (SELECTQ EVENT + ((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT BEFORESAVEVM) + (SETQ \\VKBD.KEYBOARD.BEFORETYPE (KEYBOARDTYPE))) + ((AFTERLOGOUT AFTERMAKESYS AFTERSYSOUT AFTERSAVEVM) + (CL:UNLESS (EQ (KEYBOARDTYPE) + \\VKBD.KEYBOARD.BEFORETYPE) + (SETQ VKBD.DEFAULT-CONFIGURATION-NAME (KEYBOARDTYPE)) + (SETQ CURRENTKEYBOARDCONFIG (VKBD.GET-CONFIGURATION (KEYBOARDTYPE))) + + (* |;;| "If keyboardtype has changed, we start by setting default keyaction table to the settings it had at the time that virtualkeyboards was originally loaded.") + + (RESETKEYACTION \\DEFAULTKEYACTION \\ORIGINALDEFAULTKEYACTION T) + (VKBD.ADD-DEFAULT-KEYBOARD VKBD.DEFAULT-CONFIGURATION-NAME) + (VKBD.RESETKEYACTIONTABLES))) + NIL))) (VKBD.RESETKEYACTIONTABLES + (LAMBDA NIL (* \; "Edited 4-Mar-96 13:49 by rmk") + (* \; "Edited 16-Feb-95 18:23 by rmk:") + + (* |;;| "Reinstantiate/recomplete all keyboards that were previously operational, and insure that there is a DEFAULT for the new type. Probably should also redraw any open keyboard windows...later.") + + (CL:UNLESS (FINDVIRTUALKEYBOARD 'DEFAULT) + + (* |;;| "This will look for new keyboard files whenever real keyboard changes.") + + (VKBD.INIT)) + (CLRHASH VKBDHASHARRAY) + + (* |;;| "Throw away any cached information, including COMPLETEKEYASSIGNMENTS") + + (FOR KEYBOARD TABLE IN VKBD.KNOWN-KEYBOARDS + DO (CL:WHEN (SETQ TABLE (GETPROP (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) OF KEYBOARD + ) + 'KEYACTIONTABLE)) + (VKBD.CREATE-KEYACTION-TABLE (FETCH (VIRTUALKEYBOARD KEYBOARDNAME) + OF KEYBOARD) + TABLE))))) ) (MOVD 'VKBD.\\KEYBOARDEVENTFN '\\KEYBOARDEVENTFN) (DECLARE\: FIRST (MOVD? 'KEYACTION 'OLDKEYACTION) ) (DEFINEQ (NEWKEYACTION + (LAMBDA (KEYNAME ACTIONS TABLE) (* \; "Edited 7-Mar-96 11:10 by rmk") + + (* |;;| "\\NKEYS is a constant from LLKEY.") + + (PROG (KEYBOARD (KEYNUM (OR (VKBD.TRANSLATE-KEY-ID KEYNAME CURRENTKEYBOARDCONFIG) + (\\KEYNAMETONUMBER KEYNAME)))) + + (* |;;| "Handle the NIL-TABLE cases.") + + (COND + ((AND (NULL TABLE) + (LISTP ACTIONS) + (OR (FMEMB (CAR ACTIONS) + MODEACTIONS) + (FMEMB (CDR ACTIONS) + MODEACTIONS))) + + (* |;;| "If we are setting a mode (as opposed to a character) key, assume that it is intended to be set in all keyboards where that key is still an appropriate mode") + + (FOR KEYBOARD KEYACTION (ORIGKEYACTION _ (CDR (FASSOC KEYNUM \\ORIGKEYACTIONS))) + (MODEACTION _ (CDR (FASSOC KEYNUM MODEKEYS))) IN VKBD.KNOWN-KEYBOARDS + DO (SETQ KEYACTION (CDR (FASSOC KEYNUM (FETCH COMPLETEKEYASSIGNMENTS + OF KEYBOARD)))) + (COND + ((EQUAL KEYACTION ACTIONS)) + ((OR (NULL KEYACTION) + (EQUAL KEYACTION ORIGKEYACTION) + (EQUAL KEYACTION MODEACTION)) + (NEWKEYACTION KEYNAME ACTIONS KEYBOARD))) + FINALLY (RPLACD (OR (FASSOC KEYNUM MODEKEYS) + (CAR (PUSH MODEKEYS (CONS KEYNUM)))) + ACTIONS)) + (RETURN T) (* \; + "This will cause an error if we try to pass it back in. What else can we do?") + )) + +(* |;;;| "get the keyboard or key action table.") + + (COND + ((NULL TABLE) + (SETQ TABLE \\CURRENTKEYACTION)) + ((LITATOM TABLE) + (COND + ((SETQ KEYBOARD (FASSOC TABLE VKBD.KNOWN-KEYBOARDS)) + (SETQ TABLE (GETPROP TABLE 'KEYACTIONTABLE))) + (T (ERROR TABLE "is not a defined keyboard.")))) + ((LISTP TABLE) + (COND + ((FMEMB TABLE VKBD.KNOWN-KEYBOARDS) + (SETQ KEYBOARD TABLE) + (SETQ TABLE (GETPROP (FETCH KEYBOARDNAME OF TABLE) + 'KEYACTIONTABLE))) + (T (ERROR TABLE "is not a defined keyboard.")))) + (T (FOR VKBD IN VKBD.KNOWN-KEYBOARDS + WHEN (EQ TABLE (GETPROP (FETCH KEYBOARDNAME OF VKBD) + 'KEYACTIONTABLE)) DO (SETQ KEYBOARD VKBD)))) + + (* |;;| "If TABLE is NIL, means that we are setting a virtual keyboard for which a keyaction table hasn't yet been created.") + + (RETURN + (PROG1 + (COND + (TABLE (OLDKEYACTION KEYNUM ACTIONS TABLE)) + (KEYBOARD (* \; + "virtual keyboard package allows incomplete keyboards with defaults from \\ORIGKEYACTIONS.") + (CDR (IF (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD) + THEN (FASSOC KEYNUM (FETCH COMPLETEKEYASSIGNMENTS + OF KEYBOARD)) + ELSE (LET (A) + (IF (SETQ A (OR (VKBD.KEY-ASSOC KEYNAME + (FETCH KEYASSIGNMENTS + OF KEYBOARD) + CURRENTKEYBOARDCONFIG) + (VKBD.KEY-ASSOC KEYNAME + (FETCH DEFAULTASSIGNMENT + OF + CURRENTKEYBOARDCONFIG + ) + CURRENTKEYBOARDCONFIG) + (VKBD.KEY-ASSOC KEYNAME + VKBD.COMMONDEFAULTASSIGNMENT + CURRENTKEYBOARDCONFIG))) + THEN (VKBD.PARSE-KEY-ASSIGNMENT A + CURRENTKEYBOARDCONFIG) + ELSE (FASSOC KEYNUM \\ORIGKEYACTIONS)))))) + (T (SHOULDNT))) + (COND + ((AND KEYBOARD ACTIONS) + + (* |;;| +"Set the keyaction in the virtual keyboard, which keeps it consistent with the corresponding table.") + + (CL:WHEN (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD) + (PUTASSOC KEYNUM (CDR (VKBD.PARSE-KEY-ASSIGNMENT (CONS KEYNUM ACTIONS) + CURRENTKEYBOARDCONFIG)) + (FETCH COMPLETEKEYASSIGNMENTS OF KEYBOARD))) + (IF (FETCH KEYASSIGNMENTS OF KEYBOARD) + THEN (PUTASSOC KEYNAME ACTIONS (FETCH KEYASSIGNMENTS OF KEYBOARD)) + ELSE (PUSH (FETCH KEYASSIGNMENTS OF KEYBOARD) + (CONS KEYNAME ACTIONS)))))))))) ) (MOVD 'NEWKEYACTION 'KEYACTION) (RPAQ? MODEKEYS ) (RPAQQ MODEACTIONS (EVENT CTRLUP CTRLDOWN 1SHIFTUP 1SHIFTDOWN 2SHIFTUP 2SHIFTDOWN LOCKUP LOCKDOWN LOCKTOGGLE METAUP METADOWN FONTUP FONTDOWN FONTTOGGLE USERMODE1UP USERMODE1DOWN USERMODE1TOGGLE USERMODE2UP USERMODE2DOWN USERMODE2TOGGLE USERMODE3UP USERMODE3DOWN USERMODE3TOGGLE)) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MODEKEYS MODEACTIONS) ) (ADDTOVAR BREAKRESETFORMS ((LAMBDA (K) (PROCESS.KEYBOARD NIL K)) 'DEFAULT)) (DEFINEQ (FIXKEYBOARD + (LAMBDA (KBD) (* \; "Edited 28-Feb-96 13:36 by rmk") + + (* |;;| "This is a function use to coerce existing keyboards into a more reasonable format. It makes the keynames be names from the KEYNAMES mapping instead of key numbers, makes the characters be readable characters instead of codes, and eliminates actions that duplicate the keyboards defaultassignment actions. Only reasonable codes are mapped to characters--8-bit non-control range plus the Latin rendering (charset 241)") + + (LET ((KC (VKBD.GET-CONFIGURATION (FETCH KEYBOARDCONFIGURATION OF KBD)))) + + (* |;;| "Fix keyassignments and then remove duplicates of default keyassignments") + + (REPLACE KEYASSIGNMENTS OF KBD + WITH (SORT (FOR KA (DEF _ (FETCH DEFAULTASSIGNMENT OF KC)) + IN (FIXKEYASSIGNMENTS (FETCH KEYASSIGNMENTS OF KBD) + KC) UNLESS (MEMBER KA DEF) COLLECT KA) + T))))) (FIXKEYBOARDCONFIG + (LAMBDA (CONFIG) (* \; "Edited 29-Feb-96 13:27 by rmk") + + (* |;;| "Makes sure that CONFIG obeys keynaming conventions that force all reference to be by name and insure that names are not digits.") + + (LET (KEYNUMBERTONAME) + (FOR KN NAME FNAME FOUND IN (FETCH KEYNAMESMAPPING OF CONFIG) + DO (SETQ NAME (IF (AND (SMALLP (CAR KN)) + (IGEQ (CAR KN) + 0) + (ILEQ (CAR KN) + 9)) + THEN (CL:INTERN (CONCAT (CAR KN)) + 'INTERLISP) + ELSE (CAR KN))) + (IF (NULL (SETQ FOUND (ASSOC (CADR KN) + KEYNUMBERTONAME))) + THEN (PUSH KEYNUMBERTONAME (LIST (CADR KN) + NAME)) + ELSEIF (OR (EQ NAME (SETQ FNAME (CADR FOUND))) + (AND (EQ 1 (NCHARS FNAME)) + (OR (AND (IGEQ (CHCON1 FNAME) + (CHARCODE 0)) + (ILEQ (CHCON1 FNAME) + (CHARCODE 9))) + (EQ FNAME (U-CASE NAME))))) + ELSE + + (* |;;| + "This is the preferred name. We prefer digit-names and upper-case equivalents") + + (RPLACA (CDR FOUND) + NAME))) + + (* |;;| "Coerce digit keynames to atoms") + + (FOR K IN (FETCH KEYNAMESMAPPING OF CONFIG) + WHEN (AND (SMALLP (CAR K)) + (IGEQ (CAR K) + 0) + (ILEQ (CAR K) + 9)) DO (RPLACA K (CL:INTERN (CONCAT (CAR K)) + 'INTERLISP))) + + (* |;;| "Introduce ZERO, ONE... synonyms for digit keys") + + (NCONC (FETCH KEYNAMESMAPPING OF CONFIG) + (FOR I FROM 0 AS N + IN '(ZERO ONE TWO THREE FOUR FIVE SIX SEVEN EIGHT NINE) + UNLESS (ASSOC N (FETCH KEYNAMESMAPPING OF CONFIG)) + COLLECT (LIST N (CL:INTERN (CONCAT I) + 'INTERLISP)))) + (REPLACE KEYREGIONS OF CONFIG + WITH (IF (FOR K IN (FETCH KEYREGIONS OF CONFIG) + ALWAYS (KEYNUMBERP (CAR K))) + THEN (FOR K IN (FETCH KEYREGIONS OF CONFIG) + COLLECT (CONS (OR (CADR (ASSOC (CAR K) + KEYNUMBERTONAME)) + (HELP "UNNAMED KEYREGION KEY" K)) + (CDR K))) + ELSE (FOR K KN IN (FETCH KEYREGIONS OF CONFIG) + COLLECT (SETQ KN (CAR K)) + (CONS (IF (AND (SMALLP KN) + (IGEQ KN 0) + (ILEQ KN 9)) + THEN (CL:INTERN (CONCAT KN) + 'INTERLISP) + ELSE KN) + (CDR K))))) + (REPLACE DEFAULTASSIGNMENT OF CONFIG + WITH (SORT (IF (FOR K IN (FETCH DEFAULTASSIGNMENT OF CONFIG) + ALWAYS (KEYNUMBERP (CAR K))) + THEN (FOR K IN (FETCH DEFAULTASSIGNMENT OF CONFIG) + COLLECT (CONS (OR (CADR (ASSOC (CAR K) + KEYNUMBERTONAME)) + (HELP "UNNAMED KEYREGION KEY" K)) + (CDR K))) + ELSE (FOR K KN IN (FETCH DEFAULTASSIGNMENT OF CONFIG + ) + COLLECT (SETQ KN (CAR K)) + (CONS (IF (AND (SMALLP KN) + (IGEQ KN 0) + (ILEQ KN 9)) + THEN (CL:INTERN (CONCAT KN) + 'INTERLISP) + ELSE KN) + (CDR K)))) + T)) + + (* |;;| "Convert char-codes to characters, more or less.") + + (FIXKEYASSIGNMENTS (FETCH DEFAULTASSIGNMENT OF CONFIG) + CONFIG) + (REPLACE KEYLABELS OF CONFIG + WITH (SORT (IF (FOR K IN (FETCH KEYLABELS OF CONFIG) + ALWAYS (KEYNUMBERP (CAR K))) + THEN (FOR K IN (FETCH KEYLABELS OF CONFIG) + COLLECT (CONS (OR (CADR (ASSOC (CAR K) + KEYNUMBERTONAME)) + (HELP "UNNAMED KEYREGION KEY" K)) + (CDR K))) + ELSE (FOR K KN IN (FETCH KEYLABELS OF CONFIG) + COLLECT (SETQ KN (CAR K)) + (CONS (IF (AND (SMALLP KN) + (IGEQ KN 0) + (ILEQ KN 9)) + THEN (CL:INTERN (CONCAT KN) + 'INTERLISP) + ELSE KN) + (CDR K)))) + T))) + CONFIG)) (FIXKEYASSIGNMENTS + (LAMBDA (KALIST CONFIG) (* \; "Edited 7-Mar-96 11:20 by rmk") + + (* |;;| "Fix keynames and convert char-codes to characters, more or less. It makes the keynames be names from the KEYNAMES mapping instead of key numbers, makes the characters be readable characters instead of codes, and eliminates actions that duplicate the keyboards defaultassignment actions. Only reasonable codes are mapped to characters--8-bit non-control range plus the Latin rendering (charset 241)") + + (* |;;| "NOTE: This uses names and character labels from CONFIG, so it should only be run with key assignments that are already CONFIG compatible.") + + (FOR KA CODE LAB (CHARLABELS _ (APPEND (FETCH CHARLABELS OF CONFIG) + VKBD.COMMONCHARLABELS)) + (KNM _ (FETCH KEYNAMESMAPPING OF CONFIG)) IN KALIST + DO + + (* |;;| "First make keynames be the ones that are used in he keymapping") + + (RPLACA KA (FOR KN FOUND IN KNM + DO + + (* |;;| "Give preference to digit-labels") + + (IF (NEQ (CAR KA) + (CADR KN)) + ELSEIF (AND (SMALLP (CAR KN)) + (IGEQ (CAR KN) + 0) + (ILEQ (CAR KN) + 9)) + THEN (RETURN (CL:INTERN (CONCAT (CAR KN) + 'INTERLISP))) + ELSEIF (AND (EQ 1 (NCHARS (CAR KN))) + (SMALLP (NTHCHAR (CAR KN) + 1))) + THEN (RETURN (CAR KN)) + ELSEIF (NOT FOUND) + THEN (SETQ FOUND (CAR KN))) + FINALLY (RETURN (OR FOUND (CAR KA))))) + + (* |;;| "Shift to actions") + + (SETQ KA (CDR KA)) + + (* |;;| "Get rid of gratuitous uptransition ignores") + + (CL:WHEN (EQ 'IGNORE (CDR KA)) + (RPLACD KA)) + + (* |;;| "Shift to down transition") + + (SETQ KA (CAR KA)) + + (* |;;| + "Make keyactions use characters in the ascii range instead of codes. 241 is Latin rendering") + + (CL:WHEN (LISTP KA) + + (* |;;| "Eliminate unnecessary NOLOCKSHIFT when lower and upper are the same") + + (IF (AND (EQ (CAR KA) + (CADR KA)) + (MEMB (CADDR KA) + '(NOLOCKSHIFT NLS))) + THEN (RPLACD (CDR KA)) + ELSE + + (* |;;| "Introduce a shorter abbreviation") + + (SELECTQ (CADDR KA) + (LOCKSHIFT (RPLACD (CDR KA) + 'LS)) + (NOLOCKSHIFT (RPLACD (CDR KA) + 'NLS)) + NIL)) + (SETQ CODE (CAR KA)) + (IF (SMALLP CODE) + THEN (RPLACA KA (IF (SMALLP CODE) + THEN (IF (SETQ LAB (CADR (ASSOC CODE CHARLABELS) + )) + ELSEIF (OR (AND (IGREATERP CODE 32) + (ILESSP CODE 255)) + (EQ (LRSH CODE 8) + 241)) + THEN (SETQ LAB (CHARACTER CODE)) + (CL:IF (SMALLP LAB) + (CL:INTERN (CONCAT LAB) + 'INTERLISP) + LAB) + ELSE (MKATOM (CHARCODESTRING CODE))) + ELSEIF (STRINGP CODE) + THEN (SETQ LAB (MKATOM CODE)) + (CL:IF (SMALLP LAB) + (CL:INTERN (CONCAT LAB) + 'INTERLISP) + LAB) + ELSE CODE))) + + (* |;;| "Shift to shift code") + + (SETQ KA (CDR KA)) + (SETQ CODE (CAR KA)) + (IF (SMALLP CODE) + THEN (RPLACA KA (IF (SMALLP CODE) + THEN (IF (SETQ LAB (CADR (ASSOC CODE CHARLABELS) + )) + ELSEIF (OR (AND (IGREATERP CODE 32) + (ILESSP CODE 255)) + (EQ (LRSH CODE 8) + 241)) + THEN (SETQ LAB (CHARACTER CODE)) + (CL:IF (SMALLP LAB) + (CL:INTERN (CONCAT LAB) + 'INTERLISP) + LAB) + ELSE + + (* |;;| + "Coerce to octal cset,ccode format") + + (MKATOM (CHARCODESTRING CODE))) + ELSEIF (STRINGP CODE) + THEN (SETQ LAB (MKATOM CODE)) + (CL:IF (SMALLP LAB) + (CL:INTERN (CONCAT LAB) + 'INTERLISP) + LAB) + ELSE CODE))))) + + (* |;;| "Remove duplicates, leaving the head of the list unchanged, and keeping first occurrences of duplicates") + + (RPLACD KALIST (FOR XTAIL X ON (CDR KALIST) EACHTIME (SETQ X (CAR XTAIL)) + UNLESS (THEREIS YTAIL ON KALIST UNTIL (EQ YTAIL XTAIL) + SUCHTHAT (EQUAL X (CAR YTAIL))) COLLECT (CAR XTAIL))) + KALIST)) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (VKBD.INIT) ) (DEFINEQ (METASHIFT + (LAMBDA FLG (* \; "Edited 16-Jun-92 08:44 by rmk:") + + (* |;;| "Sets interpretation of swat key to first arg, where T means meta-shift, NIL means original setting. Returns previous setting. This differs from LLKEY version in that it changes the \\DORADOKEYACTIONS and \\DEFAULTKEYACTION table to insure that the metashift remains in effect across keyboard switches.") + + (PROG* ((METASTATUS '(METADOWN . METAUP)) + (ARGUMENT (AND (IGREATERP FLG 0) + (COND + ((EQ (ARG FLG 1) + T) + METASTATUS) + (T (OR (ARG FLG 1) + (CDR (ASSOC 'BLANK-BOTTOM \\ORIGKEYACTIONS))))))) + OLDSETTING) + (SETQ OLDSETTING (KEYACTION 'BLANK-BOTTOM ARGUMENT)) + + (* |;;| + "Update \\doradokeyactions table so we don't lose the change when we repalce the keyaction table.") + + (AND (EQ (MACHINETYPE) + 'DORADO) + (COND + (ARGUMENT (PUTASSOC 'BLANK-BOTTOM ARGUMENT \\DORADOKEYACTIONS) + (KEYACTION 'BLANK-BOTTOM ARGUMENT \\DEFAULTKEYACTION)) + (T (SETQ \\DORADOKEYACTIONS (|for| X |in| \\DORADOKEYACTIONS + |join| (AND (NEQ (CAR X) + 'BLANK-BOTTOM) + (LIST X)))) + (KEYACTION 'BLANK-BOTTOM NIL \\DEFAULTKEYACTION)))) + (RETURN (COND + ((EQUAL OLDSETTING METASTATUS) + T) + (T OLDSETTING)))))) ) (* \; "Call new definition if the old one had been called") (AND (MEMB (MACHINETYPE) '(MAIKO DORADO)) (EQUAL (KEYACTION 'BLANK-BOTTOM) '(METADOWN . METAUP)) (METASHIFT T)) (FILESLOAD ICONW) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA METASHIFT) ) (PUTPROPS VIRTUALKEYBOARDS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1992 1993 1995 1996 2017 2018)) (DECLARE\: DONTCOPY (FILEMAP (NIL (5486 14142 (FINDVIRTUALKEYBOARD 5496 . 8650) (PROCESS.KEYBOARD 8652 . 11328) ( VKBD.CREATE-KEYACTION-TABLE 11330 . 13246) (VKBD.WINDOWMENUFN 13248 . 13515) (VKBD.WINDOWMENUINIT 13517 . 14140)) (14143 19504 (LOADKEYBOARDDISPLAYFONTS 14153 . 19502)) (19613 20837 (DEFINEKEYBOARD 19623 . 20835)) (20838 25256 (VKBD.ADD-ITEM-TO-BACKGROUND-MENU 20848 . 21256) (VKBD.INIT 21258 . 23796 ) (VKBD.CREATE-DEFAULT-KEYBOARD 23798 . 24390) (VKBD.ADD-DEFAULT-KEYBOARD 24392 . 25254)) (25257 31597 (VKBD.LOAD-FILE-COMMAND 25267 . 25721) (VKBD.LOAD-KEYBOARD-FILE 25723 . 29558) ( VKBD.STORE-FILE-COMMAND 29560 . 29901) (VKBD.STORE-KEYBOARD-FILE 29903 . 31595)) (31598 40899 ( SWITCHKEYBOARDS 31608 . 33086) (VKBD.POP-MENU-AND-SWITCH-KEYBOARDS 33088 . 33458) ( VKBD.POP-UP-KEYBOARDS-MENU 33460 . 34842) (VKBD.GET-CONFIGURATION 34844 . 35762) ( VKBD.SUBCONFIGURATION 35764 . 40897)) (40900 81185 (VKBD.BUTTONEVENTFN 40910 . 43817) ( VKBD.CENTER-BITMAP-IN-REGION 43819 . 45343) (VKBD.CLEAR-KEY-DISPLAY 45345 . 47476) ( VKBD.CREATE-KEYBOARD-BITMAP 47478 . 49522) (VKBD.CREATE-KEYBOARD-DISPLAY 49524 . 52653) ( VKBD.CURSORMOVEDFN 52655 . 54559) (VKBD.DISPLAY-CHARACTER 54561 . 56519) (VKBD.DISPLAY-EMPTY-KEY-CAP 56521 . 67059) (VKBD.DISPLAY-KEY 67061 . 70268) (VKBD.DISPLAY-KEY-CHARACTERS 70270 . 71463) ( VKBD.DRAW-KEY-CAPS 71465 . 73653) (VKBD.ERASE-FRAME 73655 . 73978) (VKBD.EXTEND-REGION 73980 . 74569) (VKBD.GET-KEY-AND-REGIONS-OF-CURSOR-POSITION 74571 . 75186) (VKBD.GET-KEY-REGIONS 75188 . 75444) ( VKBD.INVERT-KEY 75446 . 75736) (VKBD.INVERT-REGION 75738 . 76429) (VKBD.KEYBOARD-WINDOW-REPAINTFN 76431 . 78388) (VKBD.LOWER-HALF-REGION 78390 . 78790) (VKBD.POSITION-IS-IN-KEY-REGION 78792 . 79076) ( VKBD.REMOVE-KEYBOARD-COMMAND 79078 . 79535) (VKBD.UNION-REGIONS 79537 . 80682) (VKBD.UPPER-HALF-REGION 80684 . 81183)) (81186 100744 (VKBD.KEY-ASSOC 81196 . 81696) (VKBD.CHAR-ASSIGNMENTP 81698 . 81862) ( VKBD.COMPLETE-KEYBOARD 81864 . 84523) (VKBD.CTRL-ASSIGNMENTP 84525 . 84768) (VKBD.EVENT-ASSIGNMENTP 84770 . 85010) (VKBD.META-ASSIGNMENTP 85012 . 85255) (VKBD.FRAME-KEY 85257 . 87134) ( VKBD.GET-CURRENT-KEY-ASSIGNMENT 87136 . 87505) (VKBD.GET-NON-CHAR-LABEL 87507 . 88162) (VKBD.ICONFN 88164 . 88900) (VKBD.INVERT-LOCK-KEYS 88902 . 89580) (VKBD.INVERT-SHIFT-KEYS 89582 . 90264) ( VKBD.TRANSLATE-KEY-ID 90266 . 90945) (VKBD.KEY-ID-TO-KEY-NAMES 90947 . 91433) ( VKBD.KEYBOARD-IS-KEYBOARDTYPE-KEYBOARD 91435 . 92033) (VKBD.LOCK-ASSIGNMENTP 92035 . 92482) ( VKBD.LOCK-KEYP 92484 . 92802) (VKBD.LOCK/NOLOCK 92804 . 92963) (VKBD.LOCKDOWN-ASSIGNMENTP 92965 . 93259) (VKBD.LOCKUP-ASSIGNMENTP 93261 . 93551) (VKBD.PARSE-CHAR-CODE 93553 . 94052) ( VKBD.PARSE-KEY-ASSIGNMENT 94054 . 97510) (VKBD.RESET-KEYBOARD-WINDOW 97512 . 98105) ( VKBD.SEND-CHARACTER 98107 . 99616) (VKBD.SHIFT-ASSIGNMENTP 99618 . 100012) (VKBD.SHIFTED-CHAR 100014 . 100172) (VKBD.UNDEFINE-KEYBOARD 100174 . 100581) (VKBD.UNSHIFTED-CHAR 100583 . 100742)) (113812 116258 (VKBD.\\KEYBOARDEVENTFN 113822 . 115025) (VKBD.RESETKEYACTIONTABLES 115027 . 116256)) (116364 122515 (NEWKEYACTION 116374 . 122513)) (123170 139358 (FIXKEYBOARD 123180 . 124300) (FIXKEYBOARDCONFIG 124302 . 131526) (FIXKEYASSIGNMENTS 131528 . 139356)) (139411 141267 (METASHIFT 139421 . 141265))))) STOP \ No newline at end of file diff --git a/library/VMEM b/library/VMEM new file mode 100644 index 00000000..41aaee8f --- /dev/null +++ b/library/VMEM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "20-Jan-93 15:04:46" {DSK}lde>lispcore>library>VMEM.;2 17754 changes to%: (RECORDS REMOTEPOINTER) previous date%: " 9-Nov-92 16:30:26" {DSK}lde>lispcore>library>VMEM.;1) (* ; " Copyright (c) 1982, 1984, 1985, 1986, 1990, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT VMEMCOMS) (RPAQQ VMEMCOMS [(FNS INITVMEM REOPENVMFILE VVAG2) (INITVARS (VMEMFILE)) (FNS VGETBASE0 VPUTBASE0 VGETBASEPTR0 VPUTBASEPTR0 INVALIDADDR) (COMS (FNS PRINTVM ENDVMPRINT) (DECLARE%: DONTCOPY (CONSTANTS NOPAGE))) (FNS OPENVMFILE UNMAPVM CLOSEVMEMFILE MAPVMPAGE VBIN1 VBOUT1 VBIN2 VBOUT2) (FNS SETVMPTR VMPAGEP) [DECLARE%: EVAL@COMPILE DONTCOPY (MACROS * VMACROS) (RECORDS REMOTEPOINTER) DONTEVAL@LOAD (P (OR (SELECTQ (AND (GETD 'COMPILEMODE) (COMPILEMODE)) ((ALTO D) T) NIL) (FILESLOAD (LOADCOMP) DCODEFOR10] [COMS (FNS VTYPEDPOINTER \REMOTEPOINTER.DEFPRINT) (INITRECORDS REMOTEPOINTER) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'REMOTEPOINTER '\REMOTEPOINTER.DEFPRINT] (ADDVARS (VMEMVARS (PGEMPTY (FIXPARRAY 256)) (PGTAB (POINTERARRAY 256 PGEMPTY)) (RDSYSINIT T))) (GLOBALVARS PGTAB PGEMPTY VMEMFILEX VMEMFILE FIRSTPMT) (COMS (FNS POINTERARRAY WORDARRAY FIXPARRAY) (P (MAPC '((ELT FASTELT FASTELTN FASTELTW) (SETA FASTSETA FASTSETAN FASTSETAW) (GETHASH IGETHASH) (PUTHASH IPUTHASH)) (FUNCTION (LAMBDA (X) (MAPC (CDR X) (FUNCTION (LAMBDA (Y) (MOVD? (CAR X) Y]) (DEFINEQ (INITVMEM (LAMBDA (FILE WRITEABLE) (* bvm%: "13-Sep-86 17:40") (COND (VMEMFILE (CLOSEVMEMFILE))) (COND ((NLISTP FILE) (SETQ FILE (OPENVMFILE (OR FILE 'LISP.SYSOUT) WRITEABLE)) (SETQ VMOUTFILEX (AND WRITEABLE VMEMFILE)) (for X in VMEMVARS do (OR (BOUNDP (CAR X)) (SET (CAR X) (EVAL (CADR X))))) (UNMAPVM) (* Read the pagemap pages and record  the page addresses.) (VREADPAGEMAP)) (T (OPENREMOTEVMEMFILE (CAR FILE)))))) (REOPENVMFILE (LAMBDA (FILE WRITEABLE) (* bvm%: "13-Sep-86 17:40") (* * VMEMFILEX soon to be obsolete) (SETQ VMEMFILE (SETQ VMEMFILEX (OPENSTREAM FILE (COND (WRITEABLE 'BOTH) (T 'INPUT)) 'OLD 8))))) (VVAG2 (LAMBDA (HI LO) (* lmm " 9-MAR-81 09:34") (* DOESN'T BELONG HERE, BUT ON MEM! INCLUDED BECAUSE REMOTE-PRINTCODE CALLS  VVAG2 BUT DIDN'T IMPORT MEM) ((LAMBDA (X) (DECLARE (LOCALVARS . T)) (COND ((ZEROP X) NIL) (T X))) (IPLUS (LLSH HI 16) LO)))) ) (RPAQ? VMEMFILE ) (DEFINEQ (VGETBASE0 (LAMBDA (PTR) (* lmm "20-AUG-81 16:43") (COND ((NLISTP VMEMFILE) (SETVMPTR PTR) (VBIN2)) (T (WORDCONTENTS (WORDOFFSET (VMAPPAGE (LRSH PTR 8)) (LOGAND PTR 255))))))) (VPUTBASE0 (LAMBDA (PTR VALUE) (* lmm "20-AUG-81 16:43") (COND ((NLISTP VMEMFILE) (SETVMPTR PTR) (VBOUT2 VALUE)) (T (SETWORDCONTENTS (WORDOFFSET (VMAPPAGE (LRSH PTR 8)) (LOGAND PTR 255)) VALUE) (REMOTESETWORD PTR VALUE))) VALUE)) (VGETBASEPTR0 (LAMBDA (PTR) (* lmm " 8-SEP-81 23:12") (AND (NOT (ZEROP (SETQ PTR (COND ((NLISTP VMEMFILE) (SETVMPTR PTR) (VBIN1) (VVAG2 (VBIN1) (VBIN2))) (T (VVAG2 (LOGAND 255 (WORDCONTENTS (SETQ PTR (WORDOFFSET (VMAPPAGE (LRSH PTR 8)) (LOGAND 255 PTR))))) (WORDCONTENTS (WORDOFFSET PTR 1)))))))) PTR))) (VPUTBASEPTR0 (LAMBDA (PTR VALUE) (* lmm "20-AUG-81 16:43") (COND ((NLISTP VMEMFILE) (SETVMPTR PTR) (VBOUT2 (VHILOC VALUE)) (VBOUT2 (VLOLOC VALUE))) (T (PROG (WORD) (SETWORDCONTENTS (SETQ WORD (WORDOFFSET (VMAPPAGE (LRSH PTR 8)) (LOGAND PTR 255))) (VHILOC VALUE)) (SETWORDCONTENTS (WORDOFFSET WORD 1) (VLOLOC VALUE)) (REMOTESETWORD PTR (VHILOC VALUE)) (REMOTESETWORD (ADD1 PTR) (VLOLOC VALUE)) (RETURN VALUE)))))) (INVALIDADDR [LAMBDA (PTR) (* ;  "Edited 9-Nov-92 15:22 by sybalsky:mv:envos") (* ;; "Handle Invalid addresses in Teleraid and INIT building. For INIT building, I changed the ERROR! to ERROR so we can do diagnosis. JDS 11/9/92") (printout T "Invalid Address: ") (VPRINTVA PTR) (TERPRI T) (* ERROR!) (ERROR "Invalid address"]) ) (DEFINEQ (PRINTVM (LAMBDA NIL (* lmm " 4-MAY-82 21:09") (PROG ((LASTSEG NOPAGE) (LASTPAGE NOPAGE) LASTE FIRSTE) (for SEG from 0 to 255 bind P do (OR (EQ (SETQ P (FASTELT PGTAB SEG)) PGEMPTY) (for PAGE from 0 to 255 bind E do (COND ((NEQ (SETQ E (FASTELTN P PAGE)) 0) (COND ((NOT (IEQ SEG LASTSEG)) (ENDVMPRINT) (printout T T "segment " (SETQ LASTSEG SEG) T))) (COND ((OR (NOT (IEQ (SUB1 PAGE) LASTPAGE)) (NOT (IEQ (SUB1 E) LASTE))) (ENDVMPRINT) (printout T PAGE) (SETQ FIRSTE E))) (SETQ LASTPAGE PAGE) (SETQ LASTE E)))))) (ENDVMPRINT)))) (ENDVMPRINT (LAMBDA NIL (* lmm " 4-MAY-82 21:47") (COND ((NOT (IEQ LASTPAGE NOPAGE)) (COND ((IEQ FIRSTE LASTE) (printout T 10 (COND ((IGEQ FIRSTE 32768) (SETQ FIRSTE (LOGAND FIRSTE 32767)) (SETQ LASTE (LOGAND LASTE 32767)) "*") (T " ")) FIRSTE T)) (T (printout T "-" LASTPAGE 10 (COND ((IGEQ FIRSTE 32768) (SETQ FIRSTE (LOGAND FIRSTE 32767)) (SETQ LASTE (LOGAND LASTE 32767)) "*") (T " ")) FIRSTE "-" LASTE T))) (SETQ LASTPAGE NOPAGE))))) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ NOPAGE -2) (CONSTANTS NOPAGE) ) ) (DEFINEQ (OPENVMFILE (LAMBDA (NAME WRITEABLE) (* lmm "19-DEC-81 00:21") (WHENCLOSE (REOPENVMFILE NAME WRITEABLE) 'CLOSEALL 'NO 'AFTER 'CLOSEVMEMFILE 'STATUS (FUNCTION (LAMBDA (FILE) (LIST 'REOPENVMFILE FILE (OPENP FILE 'BOTH))))))) (UNMAPVM (LAMBDA NIL (* lmm " 3-AUG-80 22:12") (for I from 0 to 255 bind P do (OR (EQ (SETQ P (FASTELT PGTAB I)) PGEMPTY) (for J from 0 to 255 do (FASTSETAN P J 0)))))) (CLOSEVMEMFILE (LAMBDA NIL (* bvm%: "13-Jul-84 17:22") (COND ((NLISTP VMEMFILE) (CLOSEF? VMEMFILE)) (T (CLOSEREMOTEVMEMFILE))) (SETQ VMEMFILE))) (MAPVMPAGE (LAMBDA (VP PAGE) (* lmm "21-AUG-81 22:38") (* Associate virtual page VP with page PAGE of the vmem file) (PROG ((A (LRSH VP 8)) (B (LOGAND VP 255)) D) (COND ((EQ (SETQ D (FASTELT PGTAB A)) PGEMPTY) (FASTSETA PGTAB A (SETQ D (FIXPARRAY 256))))) (FASTSETAN D B PAGE)))) (VBIN1 (LAMBDA NIL (* bvm%: "13-Sep-86 17:38") (\BIN VMEMFILE))) (VBOUT1 (LAMBDA (BYTE) (* lmm "16-MAY-81 16:52") (\BOUT (OR VMOUTFILEX (ERROR "Can't write on " VMEMFILE)) BYTE))) (VBIN2 (LAMBDA NIL (IPLUS (LLSH (VBIN1) 8) (VBIN1)))) (VBOUT2 (LAMBDA (VALUE) (* lmm "19-MAR-81 12:24") (VBOUT1 (LRSH VALUE 8)) (VBOUT1 (LOGAND VALUE 255)) VALUE)) ) (DEFINEQ (SETVMPTR (LAMBDA (PTR) (* lmm " 4-MAY-82 20:42") (* Positions VMEMFILE to start reading at virtual address PTR, and sets  VMBYTESLEFT to the number of bytes left on the page.) (PROG ((A (FASTELT PGTAB (VHILOC PTR))) (J (LRSH (VLOLOC PTR) 8))) (* The multiple FASTELTNs are to avoid  boxing) (COND ((IEQP (FASTELTN A J) 0) (INVALIDADDR (IPLUS PTR 0)))) (SETFILEPTR VMEMFILE (IPLUS (LLSH (LOGAND (FASTELTN A J) 32767) 9) (LLSH (LOGAND (VLOLOC PTR) 255) 1)))))) (VMPAGEP (LAMBDA (VP) (* bvm%: "10-Dec-84 12:46") (NOT (IEQP (.LOOKUPMAP. VP) 0)))) ) (DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ VMACROS (VPAGEBASE VADDBASE VHILOC VVAG2 VGETBASEBYTE VLOLOC VPAGELOC VGETBASE VPUTBASE VGETBASEPTR VPUTBASEPTR VBIN1 VBIN2 .LOOKUPMAP.)) (DECLARE%: EVAL@COMPILE (PUTPROPS VPAGEBASE MACRO ((PTR) (LOGAND PTR -256))) (PUTPROPS VADDBASE MACRO ((PTR D) (IPLUS PTR D))) (PUTPROPS VHILOC MACRO ((PTR) (LRSH (OR PTR 0) 16))) (PUTPROPS VVAG2 MACRO ((HI LO) (IPLUS (LLSH HI 16) LO))) [PUTPROPS VGETBASEBYTE MACRO (LAMBDA (PTR N) (* lmm " 9-MAR-81 09:49") (COND ((ZEROP (LOGAND N 1)) (LRSH (VGETBASE PTR (LRSH N 1)) 8)) (T (LOGAND 255 (VGETBASE PTR (LRSH N 1] (PUTPROPS VLOLOC MACRO ((PTR) (LOGAND (OR PTR 0) 65535))) (PUTPROPS VPAGELOC MACRO ((PTR) (LRSH (OR PTR 0) 8))) [PUTPROPS VGETBASE MACRO ((PTR D) (VGETBASE0 (VADDBASE PTR D] (PUTPROPS VPUTBASE MACRO ((PTR D VAL) (VPUTBASE0 (VADDBASE PTR D) VAL))) [PUTPROPS VGETBASEPTR MACRO ((PTR D) (VGETBASEPTR0 (VADDBASE PTR D] (PUTPROPS VPUTBASEPTR MACRO ((PTR D VALUE) (VPUTBASEPTR0 (VADDBASE PTR D) VALUE))) (PUTPROPS VBIN1 MACRO (NIL (\BIN VMEMFILE))) [PUTPROPS VBIN2 MACRO (NIL (IPLUS (LLSH (VBIN1) 8) (VBIN1] [PUTPROPS .LOOKUPMAP. MACRO ((VP) (FASTELTN (FASTELT PGTAB (LRSH VP 8)) (LOGAND VP 255] ) (DECLARE%: EVAL@COMPILE (DATATYPE REMOTEPOINTER ((RPTYPE POINTER) (RPHILOC WORD) (RPLOLOC WORD))) ) (/DECLAREDATATYPE 'REMOTEPOINTER '(POINTER WORD WORD) '((REMOTEPOINTER 0 POINTER) (REMOTEPOINTER 2 (BITS . 15)) (REMOTEPOINTER 3 (BITS . 15))) '4) DONTEVAL@LOAD (OR (SELECTQ (AND (GETD 'COMPILEMODE) (COMPILEMODE)) ((ALTO D) T) NIL) (FILESLOAD (LOADCOMP) DCODEFOR10)) ) (DEFINEQ (VTYPEDPOINTER (LAMBDA (TYPE POINTER) (* bvm%: "15-Feb-85 18:06") (* Produces a local object that represents a remote POINTER with type  information. Used for visual presentation to teleraid user) (create REMOTEPOINTER RPTYPE _ TYPE RPHILOC _ (VHILOC POINTER) RPLOLOC _ (VLOLOC POINTER)))) (\REMOTEPOINTER.DEFPRINT (LAMBDA (RPTR) (* bvm%: "15-Feb-85 18:11") (* How to print a REMOTEPOINTER) (LIST (CONCAT '{ (OR (ffetch RPTYPE of (\DTEST RPTR 'REMOTEPOINTER)) "") "}#" (OCTALSTRING (ffetch RPHILOC of RPTR)) '%, (OCTALSTRING (ffetch RPLOLOC of RPTR)))))) ) (/DECLAREDATATYPE 'REMOTEPOINTER '(POINTER WORD WORD) '((REMOTEPOINTER 0 POINTER) (REMOTEPOINTER 2 (BITS . 15)) (REMOTEPOINTER 3 (BITS . 15))) '4) (DECLARE%: DONTEVAL@LOAD DOCOPY (DEFPRINT 'REMOTEPOINTER '\REMOTEPOINTER.DEFPRINT) ) (ADDTOVAR VMEMVARS (PGEMPTY (FIXPARRAY 256)) (PGTAB (POINTERARRAY 256 PGEMPTY)) (RDSYSINIT T)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PGTAB PGEMPTY VMEMFILEX VMEMFILE FIRSTPMT) ) (DEFINEQ (POINTERARRAY (LAMBDA (N INIT) (* lmm " 4-DEC-80 16:58") (ARRAY N 'POINTER INIT 0))) (WORDARRAY (LAMBDA (N) (* lmm " 4-DEC-80 16:58") (ARRAY N 'SMALLPOSP 0 0))) (FIXPARRAY (LAMBDA (N) (* lmm " 4-DEC-80 16:58") (ARRAY N 'FIXP 0 0))) ) [MAPC '((ELT FASTELT FASTELTN FASTELTW) (SETA FASTSETA FASTSETAN FASTSETAW) (GETHASH IGETHASH) (PUTHASH IPUTHASH)) (FUNCTION (LAMBDA (X) (MAPC (CDR X) (FUNCTION (LAMBDA (Y) (MOVD? (CAR X) Y] (PUTPROPS VMEM COPYRIGHT ("Venue & Xerox Corporation" 1982 1984 1985 1986 1990 1992 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2716 4346 (INITVMEM 2726 . 3495) (REOPENVMFILE 3497 . 3925) (VVAG2 3927 . 4344)) (4370 7179 (VGETBASE0 4380 . 4687) (VPUTBASE0 4689 . 5078) (VGETBASEPTR0 5080 . 5953) (VPUTBASEPTR0 5955 . 6675) (INVALIDADDR 6677 . 7177)) (7180 9537 (PRINTVM 7190 . 8552) (ENDVMPRINT 8554 . 9535)) (9632 11667 (OPENVMFILE 9642 . 10009) (UNMAPVM 10011 . 10362) (CLOSEVMEMFILE 10364 . 10599) (MAPVMPAGE 10601 . 11056) (VBIN1 11058 . 11187) (VBOUT1 11189 . 11376) (VBIN2 11378 . 11477) (VBOUT2 11479 . 11665)) ( 11668 12841 (SETVMPTR 11678 . 12675) (VMPAGEP 12677 . 12839)) (15413 16355 (VTYPEDPOINTER 15423 . 15843) (\REMOTEPOINTER.DEFPRINT 15845 . 16353)) (16862 17297 (POINTERARRAY 16872 . 17016) (WORDARRAY 17018 . 17158) (FIXPARRAY 17160 . 17295))))) STOP \ No newline at end of file diff --git a/library/VT100KP b/library/VT100KP new file mode 100644 index 00000000..e1ca8022 --- /dev/null +++ b/library/VT100KP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "13-Jun-90 01:19:15" {DSK}local>lde>lispcore>library>VT100KP.;2 21739 changes to%: (VARS VT100KPCOMS) previous date%: " 7-Dec-87 15:46:07" {DSK}local>lde>lispcore>library>VT100KP.;1) (* ; " Copyright (c) 1985, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT VT100KPCOMS) (RPAQQ VT100KPCOMS ((FNS BOTTOMHALFREGION BOXKEYPAD GETEDTKEYPAD GETKEYPAD GRIDBOXREGION INVERTPRINT KPCHARFROMXY TOPHALFREGION VT100KPCODE VT100KPFN VTCHAT.KPAPPLMODE) (BITMAPS KPARROWSBM) (ARRAY KPCHARARRAY) (VARS EDTKPH EDTKPHI) (ADDVARS (CHATMENUITEMS ("VT100 Keypad" (GETKEYPAD) "Brings up a VT100 keypad"))) (* ;; "Nuke CHATMENU so CHATMENUITEMS will reflect this change") (VARS CHATMENU))) (DEFINEQ (BOTTOMHALFREGION [LAMBDA (REGION) (* ejs%: "19-APR-83 12:13") (* * Function to return upper half of a region) (create REGION LEFT _ (fetch (REGION LEFT) of REGION) WIDTH _ (fetch (REGION WIDTH) of REGION) HEIGHT _ (LRSH (fetch (REGION HEIGHT) of REGION) 1) BOTTOM _ (fetch (REGION BOTTOM) of REGION]) (BOXKEYPAD [LAMBDA (WINDOW GRIDSPEC) (* ejs%: "19-APR-83 13:41") (* * Box the VT100 keypad) (PROG (TY TX) (for Y from 2 to 5 do (SETQ TY (BOTTOMOFGRIDCOORD Y GRIDSPEC)) (DRAWLINE 0 TY 168 TY 1 'REPLACE WINDOW)) (SETQ TY (BOTTOMOFGRIDCOORD 1 GRIDSPEC)) (DRAWLINE 0 TY (LEFTOFGRIDCOORD 3 GRIDSPEC) TY 1 'REPLACE WINDOW) (SETQ TX (LEFTOFGRIDCOORD 1 GRIDSPEC)) (DRAWLINE TX (BOTTOMOFGRIDCOORD 1 GRIDSPEC) TX 248 1 'REPLACE WINDOW) (SETQ TX (LEFTOFGRIDCOORD 2 GRIDSPEC)) (DRAWLINE TX 0 TX 248 1 'REPLACE WINDOW) (SETQ TX (LEFTOFGRIDCOORD 3 GRIDSPEC)) (DRAWLINE TX 0 TX 248 1 'REPLACE WINDOW]) (GETEDTKEYPAD [LAMBDA (WINDOW) (* ejs%: "19-APR-83 14:16") (* * Function to make an EDT keypad) (PROG ((GRIDSPEC (create REGION LEFT _ 1 BOTTOM _ 1 WIDTH _ 40 HEIGHT _ 40)) [FONT (FONTCREATE '(HELVETICA 8] TMP TMP1 BR) (CLEARW WINDOW) (DSPFONT FONT WINDOW) (for LABEL in EDTKPH do (CENTERPRINTINREGION (CAR LABEL) (TOPHALFREGION (GRIDBOXREGION (CAADR LABEL) (CDADR LABEL) GRIDSPEC)) WINDOW)) (CENTERPRINTINREGION "Line" [TOPHALFREGION (SETQ TMP (UNIONREGIONS (GRIDBOXREGION 0 0 GRIDSPEC) (GRIDBOXREGION 1 0 GRIDSPEC] WINDOW) (CENTERPRINTINREGION "Enter" [TOPHALFREGION (SETQ TMP1 (UNIONREGIONS (GRIDBOXREGION 3 0 GRIDSPEC) (GRIDBOXREGION 3 1 GRIDSPEC] WINDOW) (CENTERPRINTINREGION "Help" (GRIDBOXREGION 1 4 GRIDSPEC) WINDOW) (INVERTPRINT (WINDOWPROP WINDOW 'DSP) T) (for LABEL in EDTKPHI do (SETQ BR (BOTTOMHALFREGION (GRIDBOXREGION (CAADR LABEL) (CDADR LABEL) GRIDSPEC))) [BITBLT WINDOW NIL NIL WINDOW NIL NIL NIL NIL 'INVERT 'REPLACE NIL (create REGION LEFT _ (IPLUS (fetch (REGION LEFT) of BR) 1) BOTTOM _ (IPLUS (LRSH (IDIFFERENCE (fetch (REGION HEIGHT) of BR) (FONTPROP FONT 'HEIGHT)) 1) (fetch (REGION BOTTOM) of BR)) WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of BR) 2) HEIGHT _ (FONTPROP FONT 'HEIGHT] (CENTERPRINTINREGION (CAR LABEL) BR WINDOW)) (SETQ BR (BOTTOMHALFREGION TMP)) [BITBLT WINDOW NIL NIL WINDOW NIL NIL NIL NIL 'INVERT 'REPLACE NIL (create REGION LEFT _ (ADD1 (fetch (REGION LEFT) of BR)) BOTTOM _ (IPLUS (fetch (REGION BOTTOM) of BR) (LRSH (IDIFFERENCE (fetch (REGION HEIGHT) of BR) (FONTPROP FONT 'HEIGHT)) 1)) WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of BR) 2) HEIGHT _ (FONTPROP FONT 'HEIGHT] (CENTERPRINTINREGION "Open Line" BR WINDOW) (SETQ BR (BOTTOMHALFREGION TMP1)) [BITBLT WINDOW NIL NIL WINDOW NIL NIL NIL NIL 'INVERT 'REPLACE NIL (create REGION LEFT _ (ADD1 (fetch (REGION LEFT) of BR)) BOTTOM _ (IPLUS (fetch (REGION BOTTOM) of BR) (LRSH (IDIFFERENCE (fetch (REGION HEIGHT) of BR) (FONTPROP FONT 'HEIGHT)) 1)) WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of BR) 2) HEIGHT _ (FONTPROP FONT 'HEIGHT] (CENTERPRINTINREGION "Subs" BR WINDOW) (SETQ BR (GRIDBOXREGION 0 4 GRIDSPEC)) (BITBLT WINDOW NIL NIL WINDOW NIL NIL NIL NIL 'INVERT 'REPLACE NIL (create REGION LEFT _ (IPLUS (fetch (REGION LEFT) of BR) 2) BOTTOM _ (IPLUS (fetch (REGION BOTTOM) of BR) 2) WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of BR) 4) HEIGHT _ (IDIFFERENCE (fetch (REGION HEIGHT) of BR) 4))) (CENTERPRINTINREGION "Gold" BR WINDOW) (INVERTPRINT (WINDOWPROP WINDOW 'DSP) NIL) (BITBLT KPARROWSBM 0 0 WINDOW (LEFTOFGRIDCOORD 0 GRIDSPEC) (BOTTOMOFGRIDCOORD 5 GRIDSPEC) NIL NIL 'INPUT 'REPLACE) (BOXKEYPAD WINDOW GRIDSPEC]) (GETKEYPAD [LAMBDA (WINDOW) (* ejs%: "13-May-85 16:27") (* * Function to return a window containing a VT100 keypad) (PROG [GRIDSPEC [BFONT (FONTCREATE '(HELVETICA 18 BRR] [LFONT (FONTCREATE '(HELVETICA 10 BRR] (KPWINDOW (OR WINDOW (LET [(POS (GETBOXPOSITION (WIDTHIFWINDOW 160) (HEIGHTIFWINDOW 240 T] (CREATEW (create REGION LEFT _ (fetch (POSITION XCOORD) of POS) BOTTOM _ (fetch (POSITION YCOORD) of POS) WIDTH _ (WIDTHIFWINDOW 160) HEIGHT _ (HEIGHTIFWINDOW 240 T)) "VT100 Keypad"] (GRID (SETQ GRIDSPEC (create REGION LEFT _ 1 BOTTOM _ 1 WIDTH _ 40 HEIGHT _ 40)) 4 6 0 KPWINDOW) (CLEARW KPWINDOW) (DSPFONT BFONT KPWINDOW) (for J from 0 to 2 do (for I from 1 to 3 do (CENTERPRINTINREGION (MKSTRING (IPLUS (ITIMES J 3) I)) (GRIDBOXREGION (SUB1 I) (ADD1 J) GRIDSPEC) KPWINDOW))) (CENTERPRINTINREGION "0" (UNIONREGIONS (GRIDBOXREGION 0 0 GRIDSPEC) (GRIDBOXREGION 1 0 GRIDSPEC)) KPWINDOW) (CENTERPRINTINREGION "--" (GRIDBOXREGION 3 3 GRIDSPEC) KPWINDOW) (CENTERPRINTINREGION "." (GRIDBOXREGION 2 0 GRIDSPEC) KPWINDOW) (CENTERPRINTINREGION "," (GRIDBOXREGION 3 2 GRIDSPEC) KPWINDOW) (DSPFONT LFONT KPWINDOW) (for I from 0 to 3 do (CENTERPRINTINREGION (CONCAT "PF" (ADD1 I)) (GRIDBOXREGION I 4 GRIDSPEC) KPWINDOW)) (CENTERPRINTINREGION "ENTER" (UNIONREGIONS (GRIDBOXREGION 3 0 GRIDSPEC) (GRIDBOXREGION 3 1 GRIDSPEC)) KPWINDOW) (BITBLT KPARROWSBM 0 0 KPWINDOW (LEFTOFGRIDCOORD 0 GRIDSPEC) (BOTTOMOFGRIDCOORD 5 GRIDSPEC) NIL NIL 'INPUT 'REPLACE) (OR WINDOW (WINDOWPROP KPWINDOW 'BUTTONEVENTFN 'VT100KPFN)) (BOXKEYPAD KPWINDOW GRIDSPEC]) (GRIDBOXREGION [LAMBDA (GRIDX GRIDY GRIDSPEC) (* ejs%: "18-APR-83 09:53") (* * Function to return the source system region of a grid box) (create REGION LEFT _ (LEFTOFGRIDCOORD GRIDX GRIDSPEC) BOTTOM _ (BOTTOMOFGRIDCOORD GRIDY GRIDSPEC) WIDTH _ (fetch (REGION WIDTH) of GRIDSPEC) HEIGHT _ (fetch (REGION HEIGHT) of GRIDSPEC]) (INVERTPRINT [LAMBDA (DSP FLG) (* ejs%: "19-APR-83 13:18") (COND (FLG (DSPSOURCETYPE 'INVERT DSP)) (T (DSPSOURCETYPE 'INPUT DSP]) (KPCHARFROMXY [LAMBDA (X Y) (* ejs%: "19-APR-83 14:17") (* * Function to convert a mouse click to a VT100 keypad character) (PROG ((GRIDSPEC (create REGION LEFT _ 1 BOTTOM _ 1 WIDTH _ 40 HEIGHT _ 40))) (RETURN (ELT KPCHARARRAY (IPLUS (GRIDXCOORD X GRIDSPEC) (ITIMES 4 (GRIDYCOORD Y GRIDSPEC]) (TOPHALFREGION [LAMBDA (REGION) (* ejs%: "19-APR-83 12:13") (* * Function to return upper half of a region) (create REGION LEFT _ (fetch (REGION LEFT) of REGION) WIDTH _ (fetch (REGION WIDTH) of REGION) HEIGHT _ (LRSH (fetch (REGION HEIGHT) of REGION) 1) BOTTOM _ (IPLUS (fetch (REGION BOTTOM) of REGION) (LRSH (fetch (REGION HEIGHT) of REGION) 1]) (VT100KPCODE [LAMBDA (CHAT.STATE VT100.STATE VALUE) (* ejs%: "13-May-85 16:29") (* * Function to return string for keypad hit) (PROG ((KPMODE (fetch (VT100.STATE KEYPADMODE) of VT100.STATE)) (CMODE (fetch (VT100.STATE CURSORMODE) of VT100.STATE))) (RETURN (COND [(FMEMB VALUE '(UP DOWN LEFT RIGHT)) (COND (CMODE (SELECTQ VALUE (UP "OA") (DOWN "OB") (RIGHT "OC") (LEFT "OD") "")) (T (SELECTQ VALUE (UP "") (DOWN "") (RIGHT "") (LEFT "") ""] (T (COND (KPMODE (SELECTQ VALUE (0 "Op") (1 "Oq") (2 "Or") (3 "Os") (4 "Ot") (5 "Ou") (6 "Ov") (7 "Ow") (8 "Ox") (9 "Oy") (- "Om") (%, "Ol") (%. "On") (ENTER "OM") (PF1 "OP") (PF2 "OQ") (PF3 "OR") (PF4 "OS") "")) (T (SELECTQ VALUE (0 "0") (1 "1") (2 "2") (3 "3") (4 "4") (5 "5") (6 "6") (7 "7") (8 "8") (9 "9") (- "-") (%. ".") (%, ",") (ENTER " ") (PF1 "OP") (PF2 "OQ") (PF3 "OR") (PF4 "OS") ""]) (VT100KPFN [LAMBDA (WINDOW) (* ejs%: "18-Nov-85 14:15") (PROG ((X (LASTMOUSEX WINDOW)) (Y (LASTMOUSEY WINDOW)) (GRIDSPEC (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ 40 HEIGHT _ 40)) (CHAT.STATE (WINDOWPROP (PROCESS.WINDOW (TTY.PROCESS)) 'CHATSTATE)) VT100.STATE REGION VALUE GX GY) (COND ((MOUSESTATE UP) (RETURN)) ((NOT (INSIDEP (DSPCLIPPINGREGION NIL WINDOW) X Y)) (MENU (create MENU ITEMS _ '(("EDT Keypad" (GETEDTKEYPAD WINDOW) "Put up an EDT Keypad") ("Plain Keypad" (GETKEYPAD WINDOW) "Put up a Plain keypad")) CENTERFLG _ T)) (RETURN))) (COND [(type? CHAT.STATE CHAT.STATE) (SETQ VT100.STATE (fetch (CHAT.STATE TERM.STATE) of CHAT.STATE)) (COND ((NOT (type? VT100.STATE VT100.STATE)) (RETURN] (T (RETURN))) (SETQ GX (GRIDXCOORD X GRIDSPEC)) (SETQ GY (GRIDYCOORD Y GRIDSPEC)) [SETQ REGION (COND ((OR (AND (EQ GX 0) (EQ GY 0)) (AND (EQ GX 1) (EQ GY 0))) (UNIONREGIONS (GRIDBOXREGION 0 0 GRIDSPEC) (GRIDBOXREGION 1 0 GRIDSPEC))) ((OR (AND (EQ GX 3) (EQ GY 0)) (AND (EQ GX 3) (EQ GY 1))) (UNIONREGIONS (GRIDBOXREGION 3 0 GRIDSPEC) (GRIDBOXREGION 3 1 GRIDSPEC))) (T (GRIDBOXREGION GX GY GRIDSPEC] (BITBLT WINDOW NIL NIL WINDOW NIL NIL NIL NIL 'INVERT 'REPLACE NIL REGION) (SETQ VALUE (KPCHARFROMXY X Y)) (UNTILMOUSESTATE UP) (BITBLT WINDOW NIL NIL WINDOW NIL NIL NIL NIL 'INVERT 'REPLACE NIL REGION) (BKSYSBUF (VT100KPCODE CHAT.STATE VT100.STATE VALUE]) (VTCHAT.KPAPPLMODE [LAMBDA (CHAT.STATE VT100.STATE FLG) (* ejs%: "13-May-85 16:08") (* * Set or reset keypad application mode) (replace (VT100.STATE KEYPADMODE) of VT100.STATE with FLG]) ) (RPAQQ KPARROWSBM #*(160 40)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CH@@@@@@@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@GL@@@@@@@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@ON@@@@@@@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@AOO@@@@@@@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@CH@@@@@@@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@CH@@@@@@@@CH@@@@@@@B@@@@@@@@@@@@H@@@@@@@CH@@@@@@@@CH@@@@@@@F@@@@@@@@@@@@L@@@@@@@CH@@@@@@@@CH@@@@@@@N@@@@@@@@@@@@N@@@@@@@CH@@@@@@@@CH@@@@@@AOOOOH@@@@COOOO@@@@@@@CH@@@@@@@@CH@@@@@@COOOOH@@@@COOOOH@@@@@@CH@@@@@@@@CH@@@@@@AOOOOH@@@@COOOO@@@@@@@CH@@@@@@@@CH@@@@@@@N@@@@@@@@@@@@N@@@@@@@CH@@@@@@@@CH@@@@@@@F@@@@@@@@@@@@L@@@@@@@CH@@@@@@@AOO@@@@@@@B@@@@@@@@@@@@H@@@@@@@CH@@@@@@@@ON@@@@@@@@@@@@@@@@@@@@@@@@@@@@CH@@@@@@@@GL@@@@@@@@@@@@@@@@@@@@@@@@@@@@CH@@@@@@@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ) (RPAQ KPCHARARRAY (READARRAY-FROM-LIST 24 (QUOTE POINTER) 0 (QUOTE (0 0 %. ENTER 1 2 3 ENTER 4 5 6 %, 7 8 9 - PF1 PF2 PF3 PF4 UP DOWN LEFT RIGHT NIL)))) (RPAQQ EDTKPH (("Select" (2 . 0)) ("Word" (0 . 1)) ("Eol" (1 . 1)) ("Char" (2 . 1)) ("Advance" (0 . 2)) ("Backup" (1 . 2)) ("Cut" (2 . 2)) ("Del C" (3 . 2)) ("Page" (0 . 3)) ("Sect" (1 . 3)) ("Append" (2 . 3)) ("Del W" (3 . 3)) ("Fndnxt" (2 . 4)) ("Del L" (3 . 4)))) (RPAQQ EDTKPHI (("Reset" (2 . 0)) ("Case" (0 . 1)) ("Del Eol" (1 . 1)) ("Specins" (2 . 1)) ("Bottom" (0 . 2)) ("Top" (1 . 2)) ("Paste" (2 . 2)) ("Und C" (3 . 2)) ("Cmnd" (0 . 3)) ("Fill" (1 . 3)) ("Replace" (2 . 3)) ("Und W" (3 . 3)) ("Find" (2 . 4)) ("Und L" (3 . 4)))) (ADDTOVAR CHATMENUITEMS ("VT100 Keypad" (GETKEYPAD) "Brings up a VT100 keypad")) (* ;; "Nuke CHATMENU so CHATMENUITEMS will reflect this change") (RPAQQ CHATMENU NIL) (PUTPROPS VT100KP COPYRIGHT ("Venue & Xerox Corporation" 1985 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (940 18860 (BOTTOMHALFREGION 950 . 1443) (BOXKEYPAD 1445 . 2281) (GETEDTKEYPAD 2283 . 8102) (GETKEYPAD 8104 . 11361) (GRIDBOXREGION 11363 . 11824) (INVERTPRINT 11826 . 12028) (KPCHARFROMXY 12030 . 12579) (TOPHALFREGION 12581 . 13189) (VT100KPCODE 13191 . 16062) (VT100KPFN 16064 . 18592) ( VTCHAT.KPAPPLMODE 18594 . 18858))))) STOP \ No newline at end of file diff --git a/library/VTCHAT b/library/VTCHAT new file mode 100644 index 00000000..085e9519 --- /dev/null +++ b/library/VTCHAT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "20-Jan-93 15:06:01" {DSK}lde>lispcore>library>VTCHAT.;2 21782 changes to%: (RECORDS VT100SAVE VT100.STATE) previous date%: "13-Jun-90 01:22:35" {DSK}lde>lispcore>library>VTCHAT.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT VTCHATCOMS) (RPAQQ VTCHATCOMS [ (* ;; "VT100 emulator") (FNS VTCHAT.STATE VTCHAT.HANDLECHARACTER VTCHAT.SEQUENCE VTCHAT.DOCOMMAND) (FNS VTCHAT.ADDRESS VTCHAT.REVERSE.INDEX VTCHAT.ATTRIBUTES VTCHAT.DECLFONT VTCHAT.CLEARMODES VTCHAT.SAVE VTCHAT.RESTORE VTCHAT.SETMODE VTCHAT.SETMARGINS VTCHAT.REPORT VTCHAT.STATUS) (INITVARS (VTCHAT.DEBUGGING.FLG) (VTCHAT.TERM.IDENTITY.STRING "[?1;0c")) (GLOBALVARS VTCHAT.DEBUGGING.FLG CHATFONT GRAPHICSFONT VTCHAT.TERM.IDENTITY.STRING) (ADDVARS (CHAT.DRIVERTYPES (VT100 VTCHAT.HANDLECHARACTER VTCHAT.STATE))) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T) (FILES (LOADCOMP) CHATDECLS) (RECORDS VT100SAVE VT100.STATE)) (INITRECORDS VT100.STATE) (SYSRECORDS VT100.STATE) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) VT100KP) (ADDVARS (CHAT.DISPLAYTYPES ( "Replace this string with NIL to prefer vt100" NIL VT100]) (* ;; "VT100 emulator") (DEFINEQ (VTCHAT.STATE (LAMBDA (CHAT.STATE) (* ; "Edited 15-Feb-90 18:44 by bvm") (replace (CHAT.STATE TERM.IDENTITY.STRING) of CHAT.STATE with VTCHAT.TERM.IDENTITY.STRING) (replace (CHAT.STATE TERM.TAB.STOPS) of CHAT.STATE with (QUOTE (8 16 24 32 40 48 56 64 72 80 88 96 104 112 120 128 136))) (replace (CHAT.STATE WRAPMODE) of CHAT.STATE with T) (TERM.RESET.DISPLAY.PARMS CHAT.STATE) (replace (CHAT.STATE CLEARMODEFN) of CHAT.STATE with (FUNCTION VTCHAT.CLEARMODES)) (TERM.HOME CHAT.STATE) (create VT100.STATE)) ) (VTCHAT.HANDLECHARACTER (LAMBDA (CHAR CHAT.STATE VT100.STATE) (* ; "Edited 11-Aug-88 17:19 by drc:") (DECLARE (GLOBALVARS VTCHAT.DEBUGGING.FLG \MACHINETYPE)) (\DTEST CHAT.STATE (QUOTE CHAT.STATE)) (\DTEST VT100.STATE (QUOTE VT100.STATE)) (* ;; "Here and/or below") (COND (VTCHAT.DEBUGGING.FLG (COND ((ILESSP CHAR (CHARCODE SPACE)) (PRINTOUT PROMPTWINDOW "[" CHAR "]")) (T (\OUTCHAR (GETSTREAM PROMPTWINDOW) CHAR))))) (PROG NIL (COND ((EQ CHAR (CHARCODE BELL)) (RETURN (COND ((NEQ \MACHINETYPE \DORADO) (* ; "Modern machines have audible bells") (BOUT (ffetch (CHAT.STATE DSP) of CHAT.STATE) 7)) ((NOT (FFETCH (VT100.STATE DINGED) OF VT100.STATE)) (CL:FUNCALL INVERTWINDOWFN (FFETCH (CHAT.STATE WINDOW) OF CHAT.STATE)) (* ; "Complement window") (FREPLACE (VT100.STATE DINGED) OF VT100.STATE WITH T)))))) (COND ((FFETCH (VT100.STATE DINGED) OF VT100.STATE) (* ; "Last character was a bell, with which we complemented screen. Now back to normal") (CL:FUNCALL INVERTWINDOWFN (FFETCH (CHAT.STATE WINDOW) OF CHAT.STATE)) (FREPLACE (VT100.STATE DINGED) OF VT100.STATE WITH NIL))) (COND ((EQ CHAR (CHARCODE ESC)) (FREPLACE (VT100.STATE AUTOLF) OF VT100.STATE WITH NIL))) (COND ((>= CHAR (CHARCODE SPACE)) (* ; "Normal char") (COND ((FFETCH (VT100.STATE ESCAPESEQUENCE) OF VT100.STATE) (VTCHAT.SEQUENCE CHAT.STATE VT100.STATE CHAR)) (T (FREPLACE (VT100.STATE EATLF) OF VT100.STATE WITH (FREPLACE (VT100.STATE EATCRLF) OF VT100.STATE WITH NIL)) (RETURN (COND ((AND (NEQ CHAR (CHARCODE DEL)) (NOT (FFETCH (VT100.STATE EATTOCRLF) OF VT100.STATE))) (* ; "Print the char") (TERM.PRINTCHAR CHAT.STATE CHAR))))))) (T (SELCHARQ CHAR ((LF FF ^K) (* ; "Line Feed") (COND ((NOT (FFETCH (VT100.STATE EATLF) OF VT100.STATE)) (TERM.DOWN CHAT.STATE)) (T (FREPLACE (VT100.STATE EATLF) OF VT100.STATE WITH NIL)))) (^I (* ; "Tab") (TERM.TAB CHAT.STATE)) (CR (* ; "Carriage return") (MOVETO (freplace (CHAT.STATE XPOS) of CHAT.STATE with 0) (FFETCH (CHAT.STATE YPOS) OF CHAT.STATE) (FFETCH (CHAT.STATE DSP) OF CHAT.STATE))) (BS (* ; "Back space") (TERM.LEFT CHAT.STATE 1)) ((^X ^Z) (* ; "Cancel --resets modes") (VTCHAT.CLEARMODES CHAT.STATE VT100.STATE)) (^N (* ; "SO --- character set switch") (DSPFONT (FFETCH (VT100.STATE SOFONT) OF VT100.STATE) (FFETCH (CHAT.STATE WINDOW) OF CHAT.STATE))) (^O (* ; "SI --- character set switch") (DSPFONT (FFETCH (VT100.STATE SIFONT) OF VT100.STATE) (FFETCH (CHAT.STATE WINDOW) OF CHAT.STATE))) (ESC (* ; "Start of ESC sequence") (FREPLACE (VT100.STATE ESCAPESEQUENCE) OF VT100.STATE WITH 0) (FREPLACE (VT100.STATE CSTERM) OF VT100.STATE WITH 48)) NIL))))) ) (VTCHAT.SEQUENCE (LAMBDA (CHAT.STATE VT100.STATE CHAR) (* ; "Edited 18-Dec-86 15:14 by amd") (* ;; "Here when an ESC has been seen") (COND ((> CHAR (ffetch (VT100.STATE CSTERM) of (\DTEST VT100.STATE (QUOTE VT100.STATE)))) (VTCHAT.DOCOMMAND CHAT.STATE VT100.STATE CHAR)) (T (LET ((ESCAPESEQUENCE (ffetch (VT100.STATE ESCAPESEQUENCE) of VT100.STATE))) (COND ((EQ ESCAPESEQUENCE 0) (SELCHARQ CHAR ("(" (freplace (VT100.STATE CHARSET0) of VT100.STATE with T) (freplace (VT100.STATE ESCAPESEQUENCE) of VT100.STATE with 1) (freplace (VT100.STATE CSTERM) of VT100.STATE with (CHARCODE B))) (")" (freplace (VT100.STATE CHARSET1) of VT100.STATE with T) (freplace (VT100.STATE ESCAPESEQUENCE) of VT100.STATE with 1) (freplace (VT100.STATE CSTERM) of VT100.STATE with (CHARCODE B))) (printout PROMPTWINDOW "Bad ESCAPESEQUENCE--CHAR is " (CHARACTER CHAR) T))) ((OR (ffetch (VT100.STATE CHARSET0) of VT100.STATE) (ffetch (VT100.STATE CHARSET1) of VT100.STATE)) (VTCHAT.DECLFONT CHAT.STATE VT100.STATE CHAR)) (T (LET ((PARAMARRAY (ffetch (VT100.STATE PARAMARRAY) of VT100.STATE)) TEMP) (IF (AND (>= CHAR (CHARCODE 0)) (<= CHAR (CHARCODE 9))) THEN (* ; "Continue building current numeric argument") (SETQ TEMP (+ (ITIMES 10 (ELT PARAMARRAY ESCAPESEQUENCE)) (- CHAR (CHARCODE 0)))) (COND ((< TEMP MAX.SMALLP) (SETA PARAMARRAY ESCAPESEQUENCE TEMP))) ELSEIF (EQ CHAR (CHARCODE ";")) THEN (* ; "Param separator--start a new one") (freplace (VT100.STATE ESCAPESEQUENCE) of VT100.STATE with (add ESCAPESEQUENCE 1)) (SETA PARAMARRAY ESCAPESEQUENCE 0))))))))) ) (VTCHAT.DOCOMMAND (LAMBDA (CHAT.STATE VT100.STATE CHAR) (* ; "Edited 18-Dec-86 15:08 by amd") (* ;; "Function called when an escape or control sequence has been terminated by CHAR") (\DTEST CHAT.STATE (QUOTE CHAT.STATE)) (PROG ((PARAMARRAY (ffetch (VT100.STATE PARAMARRAY) of (\DTEST VT100.STATE (QUOTE VT100.STATE)))) (ESCAPESEQUENCE (ffetch (VT100.STATE ESCAPESEQUENCE) of VT100.STATE)) PARAM1 PARAM2 STAYESCAPE) (if (> ESCAPESEQUENCE 0) then (if (EQ (SETQ PARAM1 (ELT PARAMARRAY 1)) 0) then (* ; "Param = 0 is same as omitted") (SETQ PARAM1 NIL)) (if (> ESCAPESEQUENCE 1) then (if (EQ (SETQ PARAM2 (ELT PARAMARRAY 2)) 0) then (SETQ PARAM2 NIL)))) (SELCHARQ CHAR (%[ (* ; "ESC-LeftBracket is the control sequence introducer") (freplace (VT100.STATE CSTERM) of VT100.STATE with 64) (freplace (VT100.STATE ESCAPESEQUENCE) of VT100.STATE with 1) (SETQ STAYESCAPE T) (SETA PARAMARRAY 1 0)) (7 (* ; "ESC 7 -> Save parameters") (VTCHAT.SAVE CHAT.STATE VT100.STATE)) (8 (* ; "ESC 8 -> Restore parameters") (VTCHAT.RESTORE CHAT.STATE VT100.STATE)) (A (* ; "ESC [ Pn A -> Move up; param1 indicates how far") (TERM.UP CHAT.STATE (OR PARAM1 1))) (B (* ; "ESC [ Pn B -> Move down; param1 indicates how far") (TERM.GODOWN CHAT.STATE (OR PARAM1 1))) (C (* ; "ESC [ Pn C -> Move right; param1 indicates how far") (TERM.RIGHT CHAT.STATE (OR PARAM1 1))) (D (if (EQ 0 ESCAPESEQUENCE) then (* ; "ESC D -> index") (TERM.DOWN CHAT.STATE) else (* ; "ESC [ Pn D -> cursor backwards") (TERM.LEFT CHAT.STATE (OR PARAM1 1)))) (E (* ; "ESC E -> Do CRLF") (TERM.NEWLINE CHAT.STATE)) ((H f) (if (AND (EQ CHAR (CHARCODE H)) (EQ ESCAPESEQUENCE 0)) then (* ; "ESC H -> Set tab at position") (TERM.SET.TAB CHAT.STATE (IQUOTIENT (ffetch (CHAT.STATE XPOS) of CHAT.STATE) (ffetch (CHAT.STATE FONTWIDTH) of CHAT.STATE))) elseif (NEQ ESCAPESEQUENCE 0) then (* ; "ESC [ Pn H -> Cursor addressing. Default coord is 1") (VTCHAT.ADDRESS CHAT.STATE VT100.STATE (OR PARAM1 1) (OR PARAM2 1)))) (J (* ; "Erase in display; param1 indicates mode") (TERM.ERASE.IN.DISPLAY CHAT.STATE (OR PARAM1 0))) (K (* ; "Erase in line; param1 indicates mode") (TERM.ERASE.IN.LINE CHAT.STATE (OR PARAM1 0))) (M (* ; "Reverse Index") (VTCHAT.REVERSE.INDEX CHAT.STATE VT100.STATE)) (Z (* ; "What are you?") (TERM.IDENTIFY.SELF CHAT.STATE)) (= (* ; "Enter keypad application mode") (VTCHAT.KPAPPLMODE CHAT.STATE VT100.STATE T)) (> (* ; "Leave keypad application mode") (VTCHAT.KPAPPLMODE CHAT.STATE VT100.STATE NIL)) (c (* ; "What are you?") (TERM.IDENTIFY.SELF CHAT.STATE)) ((h l) (* ; "Set or clear modes") (VTCHAT.SETMODE CHAT.STATE VT100.STATE PARAMARRAY ESCAPESEQUENCE (EQ CHAR (CHARCODE h)))) (m (* ; "Set char attributes") (VTCHAT.ATTRIBUTES CHAT.STATE VT100.STATE PARAMARRAY ESCAPESEQUENCE)) (n (* ; "Status report") (VTCHAT.STATUS CHAT.STATE VT100.STATE (OR PARAM1 0))) (r (* ; "Set scrolling margins. Default is whole screen") (VTCHAT.SETMARGINS CHAT.STATE VT100.STATE (OR PARAM1 1) (OR PARAM2 (LET ((FONTHEIGHT (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE))) (ITIMES (IQUOTIENT (ffetch (CHAT.STATE TTYHEIGHT) of CHAT.STATE) FONTHEIGHT) FONTHEIGHT))))) (x (VTCHAT.REPORT CHAT.STATE VT100.STATE)) (\) (PROGN (* ;; "(COND ((ZEROP ESCAPESEQUENCE) (printout PROMPTWINDOW 'ESC ' (CHARACTER CHAR) T)) (T (printout PROMPTWINDOW 'ESC[' PARAM1 ';' PARAM2 ' ' (CHARACTER CHAR) T)))") NIL)) (OR STAYESCAPE (freplace (VT100.STATE ESCAPESEQUENCE) of VT100.STATE with NIL)))) ) ) (DEFINEQ (VTCHAT.ADDRESS (LAMBDA (CHAT.STATE VT100.STATE ROW COLUMN) (* ; "Edited 18-Dec-86 15:06 by amd") (* ;; "Do absolute positioning") (COND ((fetch (VT100.STATE RELORIGIN) of VT100.STATE) (LET ((TOPMARGIN (ffetch (CHAT.STATE TOPMARGIN) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (BOTTOMMARGIN (ffetch (CHAT.STATE BOTTOMMARGIN) of CHAT.STATE))) (add ROW TOPMARGIN) (COND ((< ROW TOPMARGIN) (SETQ ROW TOPMARGIN)) ((> ROW BOTTOMMARGIN) (SETQ ROW BOTTOMMARGIN)))))) (TERM.MOVETO CHAT.STATE (SUB1 COLUMN) (SUB1 ROW)) T) ) (VTCHAT.REVERSE.INDEX (LAMBDA (CHAT.STATE VT100.STATE) (* ejs%: "18-Nov-85 12:58") (LET* ((YPOS (ffetch (CHAT.STATE YPOS) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (FONTHEIGHT (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE)) (TOPMARGIN (ffetch (CHAT.STATE TOPMARGIN) of CHAT.STATE)) (TOPLINE (- TOPMARGIN FONTHEIGHT))) (COND ((< YPOS TOPLINE) (MOVETO (ffetch (CHAT.STATE XPOS) of CHAT.STATE) (freplace (CHAT.STATE YPOS) of CHAT.STATE with (IMIN TOPLINE (+ YPOS FONTHEIGHT))) (ffetch (CHAT.STATE DSP) of CHAT.STATE))) (T (TERM.SCROLLDOWN CHAT.STATE TOPMARGIN))))) ) (VTCHAT.ATTRIBUTES (LAMBDA (CHAT.STATE VT100.STATE ATTRARRAY ATTRCOUNT) (* ; "Edited 18-Dec-86 15:06 by amd") (* ;; "Function to do character attribute setting") (TERM.MODIFY.ATTRIBUTES CHAT.STATE (for I from 1 to ATTRCOUNT bind A when (SETQ A (CASE (ELT ATTRARRAY I) (0 (QUOTE NORMAL)) (1 (QUOTE BRIGHT)) (4 (QUOTE BLINK)) (5 (QUOTE UNDERLINE)) (7 (QUOTE INVERSE)))) collect A))) ) (VTCHAT.DECLFONT (LAMBDA (CHAT.STATE VT100.STATE CHAR) (* ejs%: "20-Mar-86 14:41") (freplace (VT100.STATE CHARSET1) of VT100.STATE with NIL) (freplace (VT100.STATE CHARSET0) of VT100.STATE with NIL) (freplace (VT100.STATE ESCAPESEQUENCE) of VT100.STATE with NIL)) ) (VTCHAT.CLEARMODES (LAMBDA (CHAT.STATE VT100.STATE) (* ; "Edited 18-Dec-86 15:09 by amd") (COND ((OR (ffetch (VT100.STATE BLINKMODE) of (\DTEST VT100.STATE (QUOTE VT100.STATE))) (ffetch (VT100.STATE BRIGHTMODE) of VT100.STATE)) (DSPFONT (ffetch (CHAT.STATE PLAINFONT) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE))) (ffetch (CHAT.STATE DSP) of CHAT.STATE)) (* ; "Restore normal font") (freplace (VT100.STATE BRIGHTMODE) of VT100.STATE with (freplace (VT100.STATE BLINKMODE) of VT100.STATE with NIL))))) ) (VTCHAT.SAVE (LAMBDA (CHAT.STATE VT100.STATE) (* ; "Edited 18-Dec-86 15:14 by amd") (* ;; "Function to save current curpos position, graphic rendition, and character set") (LET ((VT100MEM (OR (ffetch (VT100.STATE VT100MEM) of (\DTEST VT100.STATE (QUOTE VT100.STATE))) (freplace (VT100.STATE VT100MEM) of VT100.STATE with (create VT100SAVE)))) (DSP (ffetch (CHAT.STATE DSP) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE))))) (replace (VT100SAVE CURSORPOS) of VT100MEM with (create POSITION XCOORD _ (ffetch (CHAT.STATE XPOS) of CHAT.STATE) YCOORD _ (ffetch (CHAT.STATE YPOS) of CHAT.STATE))) (replace (VT100SAVE CHARATTR) of VT100MEM with (LIST (DSPFONT NIL DSP) (ffetch (CHAT.STATE UNDERLINEMODE) of CHAT.STATE) (DSPSOURCETYPE NIL DSP))))) ) (VTCHAT.RESTORE (LAMBDA (CHAT.STATE VT100.STATE) (* ; "Edited 18-Dec-86 15:13 by amd") (* ;; "Function to restor cursor, etc from storage") (LET ((DSP (ffetch (CHAT.STATE DSP) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (VT100MEM (ffetch (VT100.STATE VT100MEM) of (\DTEST VT100.STATE (QUOTE VT100.STATE))))) (if VT100MEM then (LET ((ATTRS (fetch (VT100SAVE CHARATTR) of VT100MEM)) (CURSOR (fetch (VT100SAVE CURSORPOS) of VT100MEM))) (MOVETO (freplace (CHAT.STATE XPOS) of CHAT.STATE with (CAR CURSOR)) (freplace (CHAT.STATE YPOS) of CHAT.STATE with (CDR CURSOR)) DSP) (DSPFONT (CAR ATTRS) DSP) (freplace (CHAT.STATE UNDERLINEMODE) of CHAT.STATE with (CADR ATTRS)) (DSPSOURCETYPE (CADDR ATTRS) DSP))))) ) (VTCHAT.SETMODE (LAMBDA (CHAT.STATE VT100.STATE MODEARRAY SETCOUNT ON?) (* ; "Edited 8-Dec-87 12:16 by jrb:") (* ;; "Does mode setting. Set indicated modes on (on? = T) or off (on? = NIL).") (\DTEST VT100.STATE (QUOTE VT100.STATE)) (\DTEST CHAT.STATE (QUOTE CHAT.STATE)) (for M from 1 to SETCOUNT do (CASE (ELT MODEARRAY M) (1 (replace (VT100.STATE CURSORMODE) of VT100.STATE with ON?)) (4 (freplace (VT100.STATE SMOOTHSCROLL) of VT100.STATE with ON?)) (5 (COND ((NEQ (ffetch (VT100.STATE INVERTFLG) of VT100.STATE) ON?) (freplace (VT100.STATE INVERTFLG) of VT100.STATE with ON?) (INVERTW (ffetch (CHAT.STATE WINDOW) of CHAT.STATE)) (LET ((DSP (ffetch (CHAT.STATE DSP) of CHAT.STATE))) (IF ON? THEN (* ; "White on black display") (DSPSOURCETYPE (QUOTE INVERT) DSP) (DSPTEXTURE BLACKSHADE DSP) ELSE (* ; "Normal black on white") (DSPTEXTURE WHITESHADE DSP) (DSPSOURCETYPE (QUOTE INPUT) DSP)))))) (6 (freplace (VT100.STATE RELORIGIN) of VT100.STATE with ON?) (VTCHAT.ADDRESS CHAT.STATE VT100.STATE 1 1)) (7 (freplace (CHAT.STATE WRAPMODE) of CHAT.STATE with ON?))))) ) (VTCHAT.SETMARGINS (LAMBDA (CHAT.STATE VT100.STATE TOP BOTTOM) (* ; "Edited 18-Dec-86 15:15 by amd") (* ;; "Function to set top and bottom margins") (LET ((FONTHEIGHT (ffetch (CHAT.STATE FONTHEIGHT) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE)))) (HOMEPOS (ffetch (CHAT.STATE HOMEPOS) of CHAT.STATE))) (freplace (CHAT.STATE TOPMARGIN) of CHAT.STATE with (IMAX 0 (- HOMEPOS (ITIMES (- TOP 2) FONTHEIGHT)))) (freplace (CHAT.STATE BOTTOMMARGIN) of CHAT.STATE with (IMAX 0 (- HOMEPOS (ITIMES (SUB1 BOTTOM) FONTHEIGHT) (ffetch (CHAT.STATE FONTDESCENT) of CHAT.STATE)))) (TERM.HOME CHAT.STATE))) ) (VTCHAT.REPORT (LAMBDA (CHAT.STATE VTCHAT.STATE) (* ; "Edited 18-Dec-86 15:12 by amd") (* ;; "Report terminal parameters -- DECREPTPARM") (LET ((OUTSTREAM (fetch (CHAT.STATE OUTSTREAM) of CHAT.STATE))) (PRIN4 "[2;1;1;" OUTSTREAM) (COND ((EQ (fetch (STREAM DEVICE) of OUTSTREAM) \RS232C.FDEV) (LET ((BAUD (CDR (FASSOC (CDR (FASSOC (QUOTE LINE.SPEED) (RS232C.GET.PARAMETERS (QUOTE (LINE.SPEED))))) (QUOTE ((50 . 0) (75 . 8) (110 . 16) (150 . 32) (200 . 40) (300 . 48) (600 . 56) (1200 . 64) (1800 . 72) (2000 . 80) (2400 . 88) (3600 . 96) (4800 . 104) (9600 . 112) (19200 . 120))))))) (COND (BAUD (printout OUTSTREAM BAUD ";" BAUD ";")) (T (printout OUTSTREAM "0;0;"))))) (T (printout OUTSTREAM "0;0;"))) (PRIN1 "1;0x" OUTSTREAM) (FORCEOUTPUT OUTSTREAM))) ) (VTCHAT.STATUS (LAMBDA (CHAT.STATE VT100.STATE TYPE) (* ; "Edited 18-Dec-86 15:16 by amd") (* ;; "Returns VT100 status info") (LET ((OUTSTREAM (ffetch (CHAT.STATE OUTSTREAM) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE))))) (SELECTQ TYPE (5 (* ; "Host wants device status") (PRIN1 "" OUTSTREAM)) (6 (* ; "Host wants cursor coords") (BOUT OUTSTREAM (CHARCODE ESC)) (BOUT OUTSTREAM (CHARCODE %[)) (BOUT OUTSTREAM (MKSTRING (ADD1 (IQUOTIENT (ffetch (CHAT.STATE YPOS) of CHAT.STATE) (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE))))) (BOUT OUTSTREAM (CHARCODE ;)) (BOUT OUTSTREAM (MKSTRING (ADD1 (IQUOTIENT (ffetch (CHAT.STATE XPOS) of CHAT.STATE) (ffetch (CHAT.STATE FONTWIDTH) of CHAT.STATE))))) (BOUT OUTSTREAM (CHARCODE R))) NIL) (FORCEOUTPUT OUTSTREAM))) ) ) (RPAQ? VTCHAT.DEBUGGING.FLG ) (RPAQ? VTCHAT.TERM.IDENTITY.STRING "[?1;0c") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS VTCHAT.DEBUGGING.FLG CHATFONT GRAPHICSFONT VTCHAT.TERM.IDENTITY.STRING) ) (ADDTOVAR CHAT.DRIVERTYPES (VT100 VTCHAT.HANDLECHARACTER VTCHAT.STATE)) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (FILESLOAD (LOADCOMP) CHATDECLS) (DECLARE%: EVAL@COMPILE (RECORD VT100SAVE (CURSORPOS CHARATTR CHARSET)) (DATATYPE VT100.STATE ((DINGED FLAG) (EATLF FLAG) (EATCRLF FLAG) (EATTOCRLF FLAG) (AUTOLF FLAG) (BLINKMODE FLAG) (BRIGHTMODE FLAG) (SMOOTHSCROLL FLAG) (SIFONT POINTER) (KEYPADMODE FLAG) (CURSORMODE FLAG) (CHARSET0 FLAG) (CHARSET1 FLAG) (SOFONT POINTER) (PARAMCOUNT WORD) (ADDRESSING WORD) ESCAPESEQUENCE VT100MEM PARAMARRAY RELORIGIN INVERTFLG CSTERM) VT100MEM _ (create VT100SAVE CURSORPOS _ (create POSITION XCOORD _ 1 YCOORD _ 1)) PARAMARRAY _ (ARRAY 12 'SMALLP 0 1)) ) (/DECLAREDATATYPE 'VT100.STATE '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER) '((VT100.STATE 0 (FLAGBITS . 0)) (VT100.STATE 0 (FLAGBITS . 16)) (VT100.STATE 0 (FLAGBITS . 32)) (VT100.STATE 0 (FLAGBITS . 48)) (VT100.STATE 0 (FLAGBITS . 64)) (VT100.STATE 0 (FLAGBITS . 80)) (VT100.STATE 0 (FLAGBITS . 96)) (VT100.STATE 0 (FLAGBITS . 112)) (VT100.STATE 2 POINTER) (VT100.STATE 2 (FLAGBITS . 0)) (VT100.STATE 2 (FLAGBITS . 16)) (VT100.STATE 2 (FLAGBITS . 32)) (VT100.STATE 2 (FLAGBITS . 48)) (VT100.STATE 4 POINTER) (VT100.STATE 1 (BITS . 15)) (VT100.STATE 6 (BITS . 15)) (VT100.STATE 8 POINTER) (VT100.STATE 10 POINTER) (VT100.STATE 12 POINTER) (VT100.STATE 14 POINTER) (VT100.STATE 16 POINTER) (VT100.STATE 18 POINTER)) '20) ) (/DECLAREDATATYPE 'VT100.STATE '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER) '((VT100.STATE 0 (FLAGBITS . 0)) (VT100.STATE 0 (FLAGBITS . 16)) (VT100.STATE 0 (FLAGBITS . 32)) (VT100.STATE 0 (FLAGBITS . 48)) (VT100.STATE 0 (FLAGBITS . 64)) (VT100.STATE 0 (FLAGBITS . 80)) (VT100.STATE 0 (FLAGBITS . 96)) (VT100.STATE 0 (FLAGBITS . 112)) (VT100.STATE 2 POINTER) (VT100.STATE 2 (FLAGBITS . 0)) (VT100.STATE 2 (FLAGBITS . 16)) (VT100.STATE 2 (FLAGBITS . 32)) (VT100.STATE 2 (FLAGBITS . 48)) (VT100.STATE 4 POINTER) (VT100.STATE 1 (BITS . 15)) (VT100.STATE 6 (BITS . 15)) (VT100.STATE 8 POINTER) (VT100.STATE 10 POINTER) (VT100.STATE 12 POINTER) (VT100.STATE 14 POINTER) (VT100.STATE 16 POINTER) (VT100.STATE 18 POINTER)) '20) (ADDTOVAR SYSTEMRECLST (DATATYPE VT100.STATE ((DINGED FLAG) (EATLF FLAG) (EATCRLF FLAG) (EATTOCRLF FLAG) (AUTOLF FLAG) (BLINKMODE FLAG) (BRIGHTMODE FLAG) (SMOOTHSCROLL FLAG) (SIFONT POINTER) (KEYPADMODE FLAG) (CURSORMODE FLAG) (CHARSET0 FLAG) (CHARSET1 FLAG) (SOFONT POINTER) (PARAMCOUNT WORD) (ADDRESSING WORD) ESCAPESEQUENCE VT100MEM PARAMARRAY RELORIGIN INVERTFLG CSTERM)) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILESLOAD (SYSLOAD) VT100KP) (ADDTOVAR CHAT.DISPLAYTYPES ("Replace this string with NIL to prefer vt100" NIL VT100)) ) (PUTPROPS VTCHAT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1995 10061 (VTCHAT.STATE 2005 . 2515) (VTCHAT.HANDLECHARACTER 2517 . 5091) ( VTCHAT.SEQUENCE 5093 . 6636) (VTCHAT.DOCOMMAND 6638 . 10059)) (10062 16968 (VTCHAT.ADDRESS 10072 . 10590) (VTCHAT.REVERSE.INDEX 10592 . 11161) (VTCHAT.ATTRIBUTES 11163 . 11549) (VTCHAT.DECLFONT 11551 . 11820) (VTCHAT.CLEARMODES 11822 . 12325) (VTCHAT.SAVE 12327 . 13066) (VTCHAT.RESTORE 13068 . 13775) (VTCHAT.SETMODE 13777 . 14849) (VTCHAT.SETMARGINS 14851 . 15442) (VTCHAT.REPORT 15444 . 16204) ( VTCHAT.STATUS 16206 . 16966))))) STOP \ No newline at end of file diff --git a/library/WHERE-IS b/library/WHERE-IS new file mode 100644 index 00000000..c951288c --- /dev/null +++ b/library/WHERE-IS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL") (IL:FILECREATED "13-Jun-90 01:24:39" IL:|{DSK}local>lde>lispcore>library>WHERE-IS.;2| 17489 IL:|changes| IL:|to:| (IL:VARS IL:WHERE-ISCOMS) IL:|previous| IL:|date:| " 6-Jun-88 18:42:35" IL:|{DSK}local>lde>lispcore>library>WHERE-IS.;1|) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:WHERE-ISCOMS) (IL:RPAQQ IL:WHERE-ISCOMS ((IL:P (PROVIDE "WHERE-IS") (REQUIRE "HASH-FILE" "HASH-FILE.DFASL") (REQUIRE "CASH-FILE" "CASH-FILE.DFASL")) (IL:COMS (IL:* IL:|;;| "run time code") (IL:FUNCTIONS HASH-FILE-WHERE-IS HASH-FILE-TYPES-OF GET-WHERE-IS-ENTRIES WHERE-IS-READ-FN ADD-WHERE-IS-DATABASES ADD-WHERE-IS-DATABASE DEL-WHERE-IS-DATABASE SAME-WHERE-IS-DATABASE CLOSE-WHERE-IS-FILES) (IL:ADDVARS (IL:AROUNDEXITFNS CLOSE-WHERE-IS-FILES)) (IL:VARIABLES *WHERE-IS-CASH-FILES* *WHERE-IS-CASH-SIZE*)) (IL:COMS (IL:* IL:|;;| "notice time code") (IL:FUNCTIONS WHERE-IS-NOTICE WHERE-IS-NOTICE-INTERNAL WHERE-IS-FILES WHERE-IS-DEFAULT-DEFINE-TYPES WHERE-IS-NAMESTRING WHERE-IS-READ-COMS WHERE-IS-SET-WRITE-DATE WHERE-IS-GET-WRITE-DATE) (IL:VARIABLES *WHERE-IS-HASH-FILE-SIZE* *WHERE-IS-IGNORE-DEFINE-TYPES*)) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:WHERE-IS))) (PROVIDE "WHERE-IS") (REQUIRE "HASH-FILE" "HASH-FILE.DFASL") (REQUIRE "CASH-FILE" "CASH-FILE.DFASL") (IL:* IL:|;;| "run time code") (DEFUN HASH-FILE-WHERE-IS (NAME TYPE) (IL:* IL:|;;| "return a list of file names containing NAME of TYPE ") (REMOVE-DUPLICATES (MAPCAN #'(LAMBDA (ENTRY) (CDR (ASSOC TYPE ENTRY))) (GET-WHERE-IS-ENTRIES NAME)) :TEST 'STRING=)) (DEFUN HASH-FILE-TYPES-OF (NAME &OPTIONAL (POSSIBLE-TYPES (WHERE-IS-DEFAULT-DEFINE-TYPES))) (LET ((ENTRIES (GET-WHERE-IS-ENTRIES NAME)) (TYPES NIL)) (DOLIST (TYPE POSSIBLE-TYPES) (DOLIST (ENTRY ENTRIES) (WHEN (ASSOC TYPE ENTRY) (PUSH TYPE TYPES) (RETURN)))) (REMOVE-DUPLICATES TYPES))) (DEFUN GET-WHERE-IS-ENTRIES (NAME) (IL:* IL:|;;| "return a list of all entries for name in *WHERE-IS-CASH-FILES*") (MAPLIST #'(LAMBDA (TAIL) (LET ((DATABASE (CAR TAIL))) (PROCEED-CASE (CASH-FILE:GET-CASH-FILE NAME (IF (CASH-FILE:CASH-FILE-P DATABASE) DATABASE (LET* ((CASH-FILE (CASH-FILE:OPEN-CASH-FILE DATABASE *WHERE-IS-CASH-SIZE*)) (HASH-FILE (CASH-FILE:CASH-FILE-HASH-FILE CASH-FILE))) (IL:* IL:|;;|  "install our read function in hash file") (SETF (HASH-FILE::HASH-FILE-KEY-READ-FN HASH-FILE) #'WHERE-IS-READ-FN) (SETF (HASH-FILE::HASH-FILE-VALUE-READ-FN HASH-FILE) #'WHERE-IS-READ-FN) (IL:* IL:|;;|  "smash CASH-FILE into *WHERE-IS-CASH-FILES*") (SETF (CAR TAIL) CASH-FILE)))) (NIL NIL :REPORT "Delete from the databases known to WHERE-IS?" (DEL-WHERE-IS-DATABASE DATABASE) NIL)))) *WHERE-IS-CASH-FILES*)) (DEFUN WHERE-IS-READ-FN (STREAM) (IL:* IL:|;;;| "the :KEY-READ-FN & :VALUE-READ-FN for WHERE-IS hash files.") (HANDLER-CASE (IL:* IL:|;;| "use the default read function") (HASH-FILE::DEFAULT-READ-FN STREAM) (IL:* IL:|;;| "Quietly handle MISSING-PACKAGE errors by returning the condition.") (IL:* IL:|;;| "This allows us to have files in our database which we havn't loaded.") (MISSING-PACKAGE (CONDITION) CONDITION))) (DEFUN ADD-WHERE-IS-DATABASES (&REST PATHNAMES) "add each PATHNAME to the databases known to WHERE-IS" (MAPCAR #'ADD-WHERE-IS-DATABASE PATHNAMES)) (DEFUN ADD-WHERE-IS-DATABASE (PATHNAME) "add PATHNAME to the databases known to WHERE-IS" (LET ((NEW-PATHNAME (PATHNAME PATHNAME))) (IL:* IL:|;;| "first delete & close the old one (if any)") (DEL-WHERE-IS-DATABASE NEW-PATHNAME) (IL:* IL:|;;| "now add the new one") (PUSH NEW-PATHNAME *WHERE-IS-CASH-FILES*) NEW-PATHNAME)) (DEFUN DEL-WHERE-IS-DATABASE (DATABASE) (LET ((FOUND (FIND-IF #'(LAMBDA (ELEMENT) (SAME-WHERE-IS-DATABASE DATABASE ELEMENT)) *WHERE-IS-CASH-FILES*))) (WHEN FOUND (SETQ *WHERE-IS-CASH-FILES* (DELETE FOUND *WHERE-IS-CASH-FILES* :TEST 'EQ)) (IF (CASH-FILE:CASH-FILE-P FOUND) (HASH-FILE:CLOSE-HASH-FILE (CASH-FILE:CASH-FILE-HASH-FILE FOUND)) FOUND)))) (DEFUN SAME-WHERE-IS-DATABASE (X Y) (FLET ((COERCE-TO-PATHAME (CASH-FILE-OR-FILE-NAME) (PATHNAME (IF (CASH-FILE:CASH-FILE-P CASH-FILE-OR-FILE-NAME) (HASH-FILE::HASH-FILE-STREAM (CASH-FILE:CASH-FILE-HASH-FILE CASH-FILE-OR-FILE-NAME)) CASH-FILE-OR-FILE-NAME)))) (LET ((PATHNAME-X (COERCE-TO-PATHAME X)) (PATHNAME-Y (COERCE-TO-PATHAME Y))) (IL:* IL:|;;| "do a case & version insensitive comparison") (AND (EQUALP (PATHNAME-HOST PATHNAME-X) (PATHNAME-HOST PATHNAME-Y)) (EQUALP (PATHNAME-DEVICE PATHNAME-X) (PATHNAME-DEVICE PATHNAME-Y)) (EQUALP (PATHNAME-DIRECTORY PATHNAME-X) (PATHNAME-DIRECTORY PATHNAME-Y)) (EQUALP (PATHNAME-NAME PATHNAME-X) (PATHNAME-NAME PATHNAME-Y)) (EQUALP (PATHNAME-TYPE PATHNAME-X) (PATHNAME-TYPE PATHNAME-Y)))))) (DEFUN CLOSE-WHERE-IS-FILES (EVENT) (CASE EVENT ((NIL IL:BEFORELOGOUT IL:BEFORESYSOUT IL:BEFOREMAKESYS) (IL:NLSETQ (MAPLIST #'(LAMBDA (TAIL) (LET ((CASH-FILE:CASH-FILE (FIRST TAIL))) (IF (CASH-FILE:CASH-FILE-P CASH-FILE:CASH-FILE) (IL:* IL:|;;|  "make sure we'll get latest version on re-boot") (SETF (FIRST TAIL) (MAKE-PATHNAME :VERSION :NEWEST :DEFAULTS (HASH-FILE:CLOSE-HASH-FILE ( CASH-FILE:CASH-FILE-HASH-FILE CASH-FILE:CASH-FILE ))))))) *WHERE-IS-CASH-FILES*))))) (IL:ADDTOVAR IL:AROUNDEXITFNS CLOSE-WHERE-IS-FILES) (DEFVAR *WHERE-IS-CASH-FILES* NIL "list of pathnames or CASH-FILEs") (DEFVAR *WHERE-IS-CASH-SIZE* 100 "size of the CACHE-FILE cache to use") (IL:* IL:|;;| "notice time code") (DEFUN WHERE-IS-NOTICE (DATABASE-FILE &KEY (FILES "*.;") (NEW NIL) (DEFINE-TYPES (WHERE-IS-DEFAULT-DEFINE-TYPES)) (HASH-FILE-SIZE *WHERE-IS-HASH-FILE-SIZE*) (QUIET NIL) (TEMP-FILE NIL)) (LET* ((FILE (IF TEMP-FILE (IF NEW TEMP-FILE (IL:COPYFILE DATABASE-FILE TEMP-FILE)) DATABASE-FILE)) (HASH-FILE:HASH-FILE (IF NEW (HASH-FILE:MAKE-HASH-FILE FILE HASH-FILE-SIZE) (HASH-FILE:OPEN-HASH-FILE FILE :DIRECTION :IO))) (HASH-FILE::*DELETE-OLD-VERSION-ON-REHASH* T)) (UNWIND-PROTECT (DOLIST (PATHNAME (WHERE-IS-FILES FILES)) (UNLESS QUIET (FORMAT T ";;; ~A ." (NAMESTRING PATHNAME))) (LET ((NAMESTRING (WHERE-IS-NAMESTRING PATHNAME))) (IF (AND (NOT NEW) (LET ((OLD-WRITE-DATE (WHERE-IS-GET-WRITE-DATE NAMESTRING HASH-FILE:HASH-FILE))) (AND OLD-WRITE-DATE (= (FILE-WRITE-DATE PATHNAME) OLD-WRITE-DATE)))) (UNLESS QUIET (FORMAT T " up to date.~%")) (MULTIPLE-VALUE-BIND (FILE-VARS VALUES) (WHERE-IS-READ-COMS PATHNAME) (WHEN FILE-VARS (IL:* IL:|;;| "bind the filevars s.t. IL:INFILECOMS? will find them") (PROGV FILE-VARS VALUES (UNLESS QUIET (PRINC ".")) (DOLIST (TYPE DEFINE-TYPES) (LET ((NAMES (IL:INFILECOMS? NIL TYPE (FIRST FILE-VARS)))) (WHEN (CONSP NAMES) (IL:* IL:|;;| "IL:INFILECOMS? sometimes returns T.") (DOLIST (NAME NAMES) (WHERE-IS-NOTICE-INTERNAL NAME TYPE NAMESTRING HASH-FILE:HASH-FILE)))))) (WHERE-IS-SET-WRITE-DATE NAMESTRING PATHNAME HASH-FILE:HASH-FILE) (UNLESS QUIET (PRINC ". done.") (TERPRI))))))) (HASH-FILE:CLOSE-HASH-FILE HASH-FILE:HASH-FILE)) (LET ((PATHNAME (PATHNAME (HASH-FILE::HASH-FILE-STREAM HASH-FILE:HASH-FILE)))) (COND (TEMP-FILE (UNLESS QUIET (FORMAT T ";;; Renaming ~A ... " (NAMESTRING PATHNAME))) (MULTIPLE-VALUE-BIND (MERGED TRUE-NAME REAL-TRUE-NAME) (RENAME-FILE PATHNAME DATABASE-FILE) (UNLESS QUIET (FORMAT T "~A~%" (NAMESTRING REAL-TRUE-NAME))) REAL-TRUE-NAME)) (T PATHNAME))))) (DEFUN WHERE-IS-NOTICE-INTERNAL (NAME TYPE FILE-NAME HASH-FILE:HASH-FILE) (IL:* IL:|;;| "note that NAME is defined as TYPE on FILE-NAME in HASH-FILE ") (IL:* IL:|;;| "we keep an ALIST for each name, indexed by type") (LET* ((ALIST (HASH-FILE:GET-HASH-FILE NAME HASH-FILE:HASH-FILE)) (OLD-ENTRY (ASSOC TYPE ALIST :TEST 'EQUAL)) (OLD-FILES (CDR OLD-ENTRY))) (UNLESS (MEMBER FILE-NAME OLD-FILES) (IL:* IL:|;;| "this optimization helps a lot when re-noticing a file ") (SETF (HASH-FILE:GET-HASH-FILE NAME HASH-FILE:HASH-FILE) (CONS (CONS TYPE (CONS FILE-NAME OLD-FILES)) (DELETE OLD-ENTRY ALIST :TEST 'EQ :COUNT 1)))))) (DEFUN WHERE-IS-FILES (FILES) (IL:* IL:|;;| "expand the FILES argument to WHERE-IS-NOTICE") (IL:* IL:|;;| "allow: non-LIST, file names & file patterns") (MAPCAN #'(LAMBDA (PATTERN) (LET ((PATHNAME (PROBE-FILE PATTERN))) (IF PATHNAME (LIST PATHNAME) (CASE IL:MAKESYSNAME (:LYRIC (IL:* IL:|;;| "CL:DIRECTORY is broken in Lyric") (IL:DIRECTORY PATTERN)) (OTHERWISE (DIRECTORY PATTERN)))))) (IF (LISTP FILES) FILES (LIST FILES)))) (DEFUN WHERE-IS-DEFAULT-DEFINE-TYPES () (MAPCAN #'(LAMBDA (TYPE) (IL:* IL:|;;| "ignore aliases and types on *WHERE-IS-IGNORE-DEFINE-TYPES*") (UNLESS (OR (CONSP TYPE) (MEMBER TYPE *WHERE-IS-IGNORE-DEFINE-TYPES*)) (LIST TYPE))) IL:FILEPKGTYPES)) (DEFUN WHERE-IS-NAMESTRING (PATHNAME) (IL:* IL:|;;| "return a namestring for PATHNAME containing only the NAME & TYPE fields ") (NAMESTRING (MAKE-PATHNAME :HOST NIL :NAME (PATHNAME-NAME PATHNAME) :TYPE (IF (EQUAL (PATHNAME-TYPE PATHNAME) "") NIL (PATHNAME-TYPE PATHNAME))))) (DEFUN WHERE-IS-READ-COMS (PATHNAME) (IL:* IL:|;;;| "returns as first value a list of the filevars on PATHNAME, as second value a list of the values for these filevars.") (IL:RESETLST (IL:* IL:|;;| "make sure all IL:LOADVARS get undone") (IL:RESETSAVE (IL:RESETUNDO)) (DO ((IL:LOAD-VERBOSE-STREAM 'NIL) (ALL-FILE-VARS) (QUEUE (LIST (IL:FILECOMS (STRING-UPCASE (PATHNAME-NAME PATHNAME)))) (COND ((CONSP (IL:NLSETQ (IL:LOADVARS QUEUE PATHNAME NIL))) (MAPCAN #'(LAMBDA (FILE-VAR) (IF (BOUNDP FILE-VAR) (LET ((FILE-VARS (IL:INFILECOMS? NIL 'IL:FILEVARS FILE-VAR))) (PUSH FILE-VAR ALL-FILE-VARS) (WHEN (CONSP FILE-VARS) FILE-VARS)) (PROG1 NIL (WARN "Couldn't find ~S on ~A." FILE-VAR (NAMESTRING PATHNAME)))) ) QUEUE)) (T (WARN "Error attempting to LOADVARS ~S from ~A." QUEUE (NAMESTRING PATHNAME) ) 'NIL)))) ((NULL QUEUE) (SETQ ALL-FILE-VARS (NREVERSE ALL-FILE-VARS)) (VALUES ALL-FILE-VARS (MAPCAR #'SYMBOL-VALUE ALL-FILE-VARS))) (DECLARE (SPECIAL IL:LOAD-VERBOSE-STREAM)) (DOLIST (FILE-VAR QUEUE) (IF (MEMBER FILE-VAR ALL-FILE-VARS :TEST 'EQ) (IL:* IL:|;;| "don't want to load any twice") (SETF QUEUE (DELETE FILE-VAR QUEUE :TEST 'EQ))))))) (DEFUN WHERE-IS-SET-WRITE-DATE (NAMESTRING PATHNAME HASH-FILE:HASH-FILE) (IL:* IL:|;;| "store the write date as a bogus entry on the file") (WHERE-IS-NOTICE-INTERNAL NAMESTRING 'SI::WRITE-DATE (FILE-WRITE-DATE PATHNAME) HASH-FILE:HASH-FILE)) (DEFUN WHERE-IS-GET-WRITE-DATE (NAMESTRING HASH-FILE:HASH-FILE) (IL:* IL:|;;| "retrieve write date stored for NAMESTRING in HASH-FILE:HASH-FILE") (CADR (ASSOC 'SI::WRITE-DATE (HASH-FILE:GET-HASH-FILE NAMESTRING HASH-FILE:HASH-FILE)))) (DEFVAR *WHERE-IS-HASH-FILE-SIZE* 10000 "initial size to create WHERE-IS hash files") (DEFVAR *WHERE-IS-IGNORE-DEFINE-TYPES* '(IL:FILES IL:EXPRESSIONS IL:FILEVARS IL:ALISTS)) (IL:PUTPROPS IL:WHERE-IS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL")) (IL:PUTPROPS IL:WHERE-IS IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:WHERE-IS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/library/XCCS b/library/XCCS new file mode 100644 index 00000000..864d035c --- /dev/null +++ b/library/XCCS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 4-Aug-2020 22:36:36" {DSK}kaplan>Local>medley3.5>lispcore>library>XCCS.;4 23636 changes to%: (VARS XCCSCOMS) (FNS HEXCODE BINTOUMAPPING HEXSTRING X2U.BIN) previous date%: "30-Jul-2020 13:55:47" {DSK}kaplan>Local>medley3.5>lispcore>library>XCCS.;1) (PRETTYCOMPRINT XCCSCOMS) (RPAQQ XCCSCOMS ((COMS (FNS X2U.WIKI XCCS2UNICODE.PARSECELL)) (COMS (FNS X2U.BIN XCCORD GETUCODE WIN FINDUCODE)) (FNS SHOWMAPPINGS SHOWMAPPING) (FNS COMPAREMAPPINGS COMPARECHARSETS) (FNS MERGEMAPPINGS PRINTMERGED READMERGED) (FNS TRANSLATECHARSET) (FNS CONVERTU2X) (FNS UTF8TOHEXSTRING HEXSTRING HEXCODE BINTOUMAPPING))) (DEFINEQ (X2U.WIKI [LAMBDA (WIKIFILE) (* ; "Edited 24-Jul-2020 11:11 by rmk:") (* ;; "This scrapes the XCCS to Unicode mappings from the XCCS Wikipedia page.") (* ;; "However, that page does not seem to correspond to the version of XCCS that Interlisp has internalized.") (CL:WITH-OPEN-FILE (STREAM (OR WIKIFILE "/Users/kaplan/Desktop/Editing Xerox Character Code Standard - Wikipedia.html" ) :DIRECTION :INPUT) (BIND CSET CSSTRING WHILE (FILEPOS "{{chset-table-header|XCCS (prefixed with " STREAM NIL NIL NIL T) COLLECT (CL:UNLESS (AND (EQ 0 (READC STREAM)) (EQ 'x (READC STREAM))) (HELP "no 0x")) [SETQ CSSTRING (OCTALSTRING (HEXCODE (CONCAT (READC STREAM) (READC STREAM] (CONS CSSTRING (FOR I UC FROM 0 TO 255 WHEN (AND (FILEPOS "{{chset-color-" STREAM NIL NIL NIL T) (SETQ UC (XCCS2UNICODE.PARSECELL STREAM))) COLLECT (LIST (CONCAT CSSTRING "," (OCTALSTRING I)) UC]) (XCCS2UNICODE.PARSECELL [LAMBDA (STREAM) (* ; "Edited 21-Jul-2020 14:13 by rmk:") (CL:UNLESS (STREQUAL "undef" (CONCATLIST (BIND C UNTIL (EQ '} (SETQ C (READC STREAM))) COLLECT C))) (FILEPOS "chset-" STREAM NIL NIL NIL T) (FILEPOS "|" STREAM NIL NIL NIL T) (CONCATLIST (BIND C UNTIL (EQ '%| (SETQ C (READC STREAM))) COLLECT C)))]) ) (DEFINEQ (X2U.BIN [LAMBDA (BINFILE) (* ; "Edited 4-Aug-2020 21:13 by rmk:") (* ; "Edited 21-Jul-2020 13:49 by rmk:") (* ;; "This reads the binary file that maps from XCCS character-code ordinal positions to the corresponding Unicode code. Result is a list of (octal-xccs-codes hex-unicodes) pairs.") (* ;; "The file is a sequence of 2-byte UC hex codes. Each UC code corresponds to the XC code that you would get if you took out all the undefined code-spaces in all of the preceding character sets. The first 128-code panel of a code chart hasa 33 unused control slots at the beginning (although for charset 0 the last %"unused%" control slot is the ascii space, which is not represented in the file). The last cell of each 128-code panel is also not used.") (* ;; "So, the UC code at the first ordinal position in the file corresponds to XC code 33 (octal 41), then we run up to 126, skip 127, then skip another 33 to start the second 128-code panel. And we skip the last cell of that before we move on to the next character set.") (* ;; "But also, the next character set after charset 0 is charset 41 octal (33). So we have to skip 256*32 positions.") (* ;; "Finally, there are unused cells in the middle of some panels. Those are represented in the file by the sequence %"FFFD%", which maps to the unicode black-box with a ?. There is no need to include those.") (CL:WITH-OPEN-FILE (STREAM (OR BINFILE (PACK* (CAR UNICODEDIRECTORIES) '/XCCStoUni)) :DIRECTION :INPUT) (* ;; "XC is the XC code corresponding to the current UC hex string. I keeps track of the number of hex strings we have read within this panel, before we have to increment by 34") (BIND UC CSSTRING [CHARSETFIX _ '(("57" "341" Hebrew) ("56" "340" Arabic] (CHARSET _ 0) (LASTFP _ 0) UNTIL (EOFP STREAM) COLLECT (SETQ CSSTRING (OCTALSTRING CHARSET)) (CL:WHEN (SASSOC CSSTRING CHARSETFIX) (SETQ CSSTRING (CADR (SASSOC CSSTRING CHARSETFIX)))) (CONS CSSTRING (PROG1 [NCONC [FOR XC UC FROM 33 TO 126 UNTIL (EOFP STREAM) UNLESS (MEMBER (SETQ UC (HEXSTRING (WIN STREAM) 4)) '("FFFD" "FFFF")) COLLECT (PROG1 (LIST (CONCAT CSSTRING "," (OCTALSTRING XC)) UC LASTFP) (SETQ LASTFP (GETFILEPTR STREAM)))] (FOR XC UC FROM (PLUS 128 33) TO (PLUS 128 126) UNTIL (EOFP STREAM) UNLESS (MEMBER (SETQ UC (HEXSTRING (WIN STREAM) 4)) '("FFFD" "FFFF")) COLLECT (PROG1 (LIST (CONCAT CSSTRING "," (OCTALSTRING XC)) UC LASTFP) (SETQ LASTFP (GETFILEPTR STREAM)))] (ADD CHARSET (CL:IF (EQ CHARSET 0) 33 1)))]) (XCCORD [LAMBDA (XCODE) (* ; "Edited 17-Jul-2020 08:11 by rmk:") (* ;; "Returns the ordinal position of XCODE in the Xerox Character Code standard, removing all not-used slots.") (* ;; "The first 32 of every 256 block is unused, and 34 are unused int he middle of the block (127 to 160)") (* ;; "Also, character sets 1-32 do not exist") (CL:UNLESS (AND (SMALLP XCODE) (ILESSP XCODE (CHARCODE 0)) (IGREATERP XCODE (CHARCODE 9))) (SETQ XCODE (CHARCODE.DECODE XCODE))) (LET ((CHARSET (IQUOTIENT XCODE 256)) (PERCHARSET (- 256 (+ 32 34))) (CHARSETORD 0) (CHARINSET (IREMAINDER XCODE 256))) (CL:UNLESS (EQ CHARSET 0) (* ; "33 (41Q) -> 1") (SETQ CHARSETORD (- CHARSET 32))) (CL:WHEN (ILESSP CHARSETORD 0) (ERROR "UNUSED CHARACTER SET" CHARSET)) (CL:WHEN [OR (ILESSP CHARINSET 32) (AND (IGEQ CHARINSET 127) (ILEQ CHARINSET (PLUS 128 33] (ERROR "UNUSED CHARACTER" XCODE)) (SETQ PRECHARSET (TIMES PERCHARSET CHARSETORD)) (IPLUS PRECHARSET (- CHARINSET (IF (ILEQ CHARINSET 127) THEN 32 ELSE (PLUS 32 34]) (GETUCODE [LAMBDA (XCODE STREAM) (* ; "Edited 22-Jul-2020 12:07 by rmk:") (* ; "Edited 16-Jul-2020 23:37 by rmk:") (LET ((XCODE (OR (SMALLP XCODE) (CHARCODE.DECODE XCODE))) SKIP UCODE) [SETQ SKIP (TIMES 33 (ADD1 (IQUOTIENT XCODE 128] (SETFILEPTR STREAM (TIMES 2 (IDIFFERENCE XCODE SKIP))) (SETQ UCODE (LOGOR (LLSH (BIN STREAM) 8) (BIN STREAM))) (HEXSTRING UCODE]) (WIN [LAMBDA (STREAM) (* ; "Edited 16-Jul-2020 23:22 by rmk:") (LOGOR (LLSH (BIN STREAM) 8) (BIN STREAM]) (FINDUCODE [LAMBDA (UC BINFILE) (* ; "Edited 22-Jul-2020 17:13 by rmk:") (CL:WITH-OPEN-FILE (STREAM (OR BINFILE "{DSK}kaplan>Local>dict>unicode>xerox>XCCStoUni") :DIRECTION :INPUT) (FILEPOS (CONCAT (CHARACTER (LRSH (HEXCODE UC) 8)) (CHARACTER (LOGAND (HEXCODE UC) 255))) STREAM]) ) (DEFINEQ (SHOWMAPPINGS [LAMBDA (MAPPINGS) (* ; "Edited 24-Jul-2020 11:06 by rmk:") (FOR M IN MAPPINGS DO (SHOWMAPPING MAPPINGS (CAR M)) (TERPRI T]) (SHOWMAPPING [LAMBDA (MAPPINGS CHARSET) (* ; "Edited 24-Jul-2020 11:08 by rmk:") (CL:WHEN (STRPOS "," CHARSET) (SETQ CHARSET (SUBSTRING CHARSET 1 (STRPOS "," CHARSET)))) (PRINTOUT T "Character set " (CAR M) T) (FOR Y IN (CDR (SASSOC CHARSET MAPPINGS)) DO (PRINTOUT T (CAR Y) 8 (CHARACTER (CHARCODE.DECODE (CAR Y))) " " (CADR Y)) (CL:WHEN (CDDR Y) (PRINTOUT T " " (CADDR Y))) (TERPRI T]) ) (DEFINEQ (COMPAREMAPPINGS [LAMBDA (MAP1 MAP2) (* ; "Edited 24-Jul-2020 13:39 by rmk:") (LET [(CHARSETS1 (FOR M1 IN MAP1 COLLECT (CAR M1))) (CHARSETS2 (FOR M2 IN MAP2 COLLECT (CAR M2] (LIST [FOR COMMON IN (INTERSECTION CHARSETS1 CHARSETS2) COLLECT (CONS COMMON (COMPARECHARSETS (SASSOC COMMON MAP1) (SASSOC COMMON MAP2] (LDIFFERENCE CHARSETS1 CHARSETS2) (LDIFFERENCE CHARSETS2 CHARSETS1]) (COMPARECHARSETS [LAMBDA (CS1 CS2) (* ; "Edited 24-Jul-2020 20:21 by rmk:") (CL:UNLESS (STREQUAL (CAR CS1) (CAR CS2)) (ERROR "CHARSETS DON'T CORRESPONG")) (FOR XC U1 U2 IN [SORT (UNION (FOR M1 IN (CDR CS1) COLLECT (CAR M1)) (FOR M2 IN (CDR CS2) COLLECT (CAR M2))) (FUNCTION (LAMBDA (X1 X2) (ILEQ (CHARCODE.DECODE X1) (CHARCODE.DECODE X2] EACHTIME [SETQ U1 (CADR (SASSOC XC (CDR CS1] [SETQ U2 (CADR (SASSOC XC (CDR CS2] WHEN (IF (AND U1 U2) THEN (NOT (IEQP (CHARCODE.DECODE U1) (CHARCODE.DECODE U2))) ELSE (OR U1 U2)) COLLECT (LIST XC U1 U2 (CHARACTER (CHARCODE.DECODE XC]) ) (DEFINEQ (MERGEMAPPINGS [LAMBDA (MAP1 MAP2) (* ; "Edited 25-Jul-2020 15:36 by rmk:") (FOR CSET CS1 CS2 IN [SORT (UNION (FOR M1 IN MAP1 COLLECT (CAR M1)) (FOR M2 IN MAP2 COLLECT (CAR M2))) (FUNCTION (LAMBDA (CS1 CS2) (ILEQ (CL:PARSE-INTEGER CS1 :RADIX 8) (CL:PARSE-INTEGER CS2 :RADIX 8] COLLECT (SETQ CS1 (SASSOC CSET MAP1)) (SETQ CS2 (SASSOC CSET MAP2)) (CONS CSET (FOR XC UCODE1 UCODE2 UCHAR1 UCHAR2 IN [SORT (UNION (FOR M1 IN (CDR CS1) COLLECT (CAR M1)) (FOR M2 IN (CDR CS2) COLLECT (CAR M2))) (FUNCTION (LAMBDA (XC1 XC2) (ILEQ (CHARCODE.DECODE XC1) (CHARCODE.DECODE XC2] COLLECT [SETQ UCODE1 (CADR (SASSOC XC (CDR CS1] [SETQ UCHAR1 (CL:WHEN UCODE1 (CHARACTER (CHARCODE.DECODE UCODE1)))] [SETQ UCODE2 (CADR (SASSOC XC (CDR CS2] [SETQ UCHAR2 (CL:WHEN UCODE2 (CHARACTER (CHARCODE.DECODE UCODE2)))] (CONS XC (IF UCHAR1 THEN (IF (AND UCODE2 (NEQ UCHAR1 UCHAR2)) THEN (LIST UCHAR1 UCHAR2 UCODE1 UCODE2 ) ELSE (LIST UCHAR1 UCODE1)) ELSEIF UCHAR2 THEN (LIST UCHAR2 UCODE2) ELSE (HELP "XC WITHOUT UC'S" XC]) (PRINTMERGED [LAMBDA (MERGED CHARSETS FILE) (* ; "Edited 25-Jul-2020 16:08 by rmk:") [SELECTQ CHARSETS (NOJIS (SETQ MERGED (FOR M IN MERGED UNLESS (AND (IGEQ (CL:PARSE-INTEGER (CAR M) :RADIX 8) (CL:PARSE-INTEGER "60" :RADIX 8)) (ILESSP (CL:PARSE-INTEGER (CAR M) :RADIX 8) (CL:PARSE-INTEGER "340" :RADIX 8))) COLLECT M)) (CL:UNLESS FILE (SETQ FILE 'MERGED-NOJIS))) ((ALL NIL) (CL:UNLESS FILE (SETQ FILE 'MERGED-ALL))) (PROGN (SETQ CHARSETS (MKLIST CHARSETS)) [SETQ MERGED (FOR CS IN CHARSETS COLLECT (OR (SASSOC CS MERGED) (ERROR CS "does not exist"] (CL:UNLESS FILE (SETQ FILE (PACK* FILE "-" (CAR CHARSETS))))] (SETQ FILE (PACKFILENAME 'BODY FILE 'EXTENSION 'TXT)) (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :EXTERNAL-FORMAT :UTF8 :IF-EXISTS :NEW-VERSION ) (PRINTOUT STREAM "(") (FOR CSET IN MERGED DO (PRINTOUT STREAM "(" .P2 (CAR CSET) T) (FOR MAP IN (CDR CSET) DO (PRINTOUT STREAM 3 .P2 MAP T)) (PRINTOUT STREAM ")" T)) (PRINTOUT STREAM ")") (CLOSEF STREAM]) (READMERGED [LAMBDA (FILE) (* ; "Edited 30-Jul-2020 13:40 by rmk:") (* ;; "Reads UTF8 without translation to XCCS") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :EXTERNAL-FORMAT :UTF8-RAW) (* (READC STREAM) (BIND SET UNTIL  (EOFP STREAM) COLLECT  (SETQ SET (READ STREAM))  (PRINTOUT T (CAR) " "))) (READ STREAM]) ) (DEFINEQ (TRANSLATECHARSET [LAMBDA (MAPPINGS FROMCS TOCS) (* ; "Edited 26-Jul-2020 19:35 by rmk:") (CL:WHEN (SMALLP FROMCS) (SETQ FROMCS (CONCAT FROMCS))) (CL:WHEN (SMALLP TOCS) (SETQ TOCS (CONCAT TOCS))) (LET ((CSETMAP (SASSOC FROMCS MAPPINGS)) (NEWCSETMAP)) (CL:UNLESS CSETMAP (ERROR "FROM CHARACTER SET NOT FOUND" FROMCS)) (SETQ NEWCSMAP (CONS TOCS (FOR CM IN (CDR CSETMAP) COLLECT (CONS [CONCAT TOCS (OR (SUBSTRING (CAR CM) (STRPOS "," (CAR CM))) (HELP "INVALID CHARCODE" (CAR CM] (CDR CM]) ) (DEFINEQ (CONVERTU2X [LAMBDA NIL (* ; "Edited 27-Jul-2020 14:40 by rmk:") (FOR X IN CBUNICODETOXEROXRENDERING COLLECT (LIST [CHARCODESTRING (OR (FIXP (CADR X)) (CHARCODE.DECODE (CADR X] [CHARACTER (OR (FIXP (CADR X)) (CHARCODE.DECODE (CADR X] (HEXSTRING (CAR X) 4]) ) (DEFINEQ (UTF8TOHEXSTRING [LAMBDA (UTF8STRING) (* ; "Edited 28-Jul-2020 17:32 by rmk:") (* ;; "Converts from a UTF8 encoding of a number to the hex string that represents that number") (LET (BYTE1 BYTE1 BYTE2 BYTE3 BYTE4) (SETQ BYTE1 (HEXCODE (SUBSTRING UTF8STRING 1 2))) (* ;; "Distinguish on header byte, extract number of bytes so we don't read too far") (HEXSTRING (IF (ILESSP BYTE1 128) THEN (* ;; "Test first: Ascii is the common case") BYTE1 ELSEIF (IGEQ BYTE1 (LLSH 15 4)) THEN (* ; "4 bytes") (SETQ BYTE2 (HEXCODE (SUBSTRING UTF8STRING 3 4))) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (HEXCODE (SUBSTRING UTF8STRING 5 6))) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (SETQ BYTE4 (HEXCODE (SUBSTRING UTF8STRING 7 8))) (CL:WHEN (ILESSP BYTE4 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4))) (LOGOR (LLSH (LOADBYTE BYTE1 0 3) 18) (LLSH (LOADBYTE BYTE2 0 6) 12) (LLSH (LOADBYTE BYTE3 0 6) 6) (LOADBYTE BYTE4 0 6)) ELSEIF (IGEQ BYTE1 (LLSH 7 5)) THEN (* ; "3 bytes") (SETQ BYTE2 (HEXCODE (SUBSTRING UTF8STRING 3 4))) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (SETQ BYTE3 (HEXCODE (SUBSTRING UTF8STRING 5 6))) (CL:WHEN (ILESSP BYTE3 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3))) (LOGOR (LLSH (LOADBYTE BYTE1 0 4) 12) (LLSH (LOADBYTE BYTE2 0 6) 6) (LOADBYTE BYTE3 0 6)) ELSE (* ; "Must be 2 bytes") (SETQ BYTE2 (HEXCODE (SUBSTRING UTF8STRING 3 4))) (CL:WHEN (ILESSP BYTE2 128) (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2))) (LOGOR (LLSH (LOADBYTE BYTE1 0 5) 6) (LOADBYTE BYTE2 0 6]) (HEXSTRING [LAMBDA (N) (* ; "Edited 4-Aug-2020 21:19 by rmk:") (CL:FORMAT NIL "~4,'0X" N]) (HEXCODE [LAMBDA (HEXSTRING) (* ; "Edited 4-Aug-2020 21:28 by rmk:") (CL:PARSE-INTEGER HEXSTRING :RADIX 16]) (BINTOUMAPPING [LAMBDA (BINLIST) (* ; "Edited 4-Aug-2020 21:28 by rmk:") (FOR CS IN BINLIST JOIN (FOR CM IN (CDR CS) COLLECT (LIST (CHARCODE.DECODE (CAR CM)) (HEXCODE (CADR CM]) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (801 2795 (X2U.WIKI 811 . 2310) (XCCS2UNICODE.PARSECELL 2312 . 2793)) (2796 9601 ( X2U.BIN 2806 . 6854) (XCCORD 6856 . 8283) (GETUCODE 8285 . 8894) (WIN 8896 . 9084) (FINDUCODE 9086 . 9599)) (9602 10870 (SHOWMAPPINGS 9612 . 9856) (SHOWMAPPING 9858 . 10868)) (10871 12765 ( COMPAREMAPPINGS 10881 . 11468) (COMPARECHARSETS 11470 . 12763)) (12766 17927 (MERGEMAPPINGS 12776 . 15003) (PRINTMERGED 15005 . 17277) (READMERGED 17279 . 17925)) (17928 18901 (TRANSLATECHARSET 17938 . 18899)) (18902 19723 (CONVERTU2X 18912 . 19721)) (19724 23613 (UTF8TOHEXSTRING 19734 . 22929) ( HEXSTRING 22931 . 23082) (HEXCODE 23084 . 23245) (BINTOUMAPPING 23247 . 23611))))) STOP \ No newline at end of file