Rooms built for Medley 3.5

rooms/BACKGROUND-MENU-BUTTONS

@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER")

rooms/LAFITE-WINDOW-TYPES

@@ -0,0 +1,192 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
+
(IL:FILECREATED "17-Aug-90 14:43:18" 
+IL:|{DSK}<python>RELEASE>rooms>current>users-src>LAFITE-WINDOW-TYPES.;3|
 8873   
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:LAFITE-WINDOW-TYPESCOMS)
+
+      IL:|previous| IL:|date:| "27-Jul-90 06:11:06" 
+IL:|{DSK}<python>RELEASE>rooms>current>users-src>LAFITE-WINDOW-TYPES.;2|)
+
+
+; Copyright (c) 1988, 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:LAFITE-WINDOW-TYPESCOMS)
+
+(IL:RPAQQ IL:LAFITE-WINDOW-TYPESCOMS

+          (
+           (IL:* IL:|;;| "window types for Lafite")

+
+           (FILE-ENVIRONMENTS IL:LAFITE-WINDOW-TYPES)
+           (IL:P (REQUIRE "ROOMS"))
+           (EVAL-WHEN (COMPILE EVAL)
+                  (IL:FILES (IL:LOADCOMP T)
+                         IL:LAFITEDECLS))
+           (IL:WINDOW-TYPES :LAFITE-STATUS-WINDOW :LAFITE-BROWSER)
+           (IL:FUNCTIONS ABSTRACT-LAFITE-BROWSER RECONSTITUTE-LAFITE-BROWSER)
+           
+           (IL:* IL:|;;| "keep il:shapew from hanging")

+
+           (IL:P (IL:CHANGENAME 'IL:LAB.RESHAPEFN 'IL:OBTAIN.MONITORLOCK 'TRUE)
+                 (IL:CHANGENAME 'IL:LAB.REPAINTFN 'IL:OBTAIN.MONITORLOCK 'TRUE))
+           (IL:GLOBALVARS IL:LAFITESTATUSWINDOW IL:DEFAULTMAILFOLDERNAME IL:\\LAFITE.ACTIVE 
+                  IL:LAFITEBROWSERREGION)))
+
+
+
+(IL:* IL:|;;| "window types for Lafite")

+
+
+(DEFINE-FILE-ENVIRONMENT IL:LAFITE-WINDOW-TYPES
 :COMPILER :COMPILE-FILE
+   :READTABLE "XCL"
+   :PACKAGE "ROOMS")
+
+(REQUIRE "ROOMS")
+(EVAL-WHEN (COMPILE EVAL)
+
+(IL:FILESLOAD (IL:LOADCOMP T)
+       IL:LAFITEDECLS)
+)
+
+(DEF-WINDOW-TYPE :LAFITE-STATUS-WINDOW
 :RECOGNIZER (LAMBDA (WINDOW)
+                                                              (EQ WINDOW IL:LAFITESTATUSWINDOW))
+   :ABSTRACTER (LAMBDA (WINDOW)
+                      NIL)
+   :RECONSTITUTER (LAMBDA (IGNORE)
+                         (WHEN (FBOUNDP 'IL:LAFITE)
+                             (OR IL:LAFITESTATUSWINDOW (PROGN (IL:LAFITE 'IL:ON NIL)
+                                                              (IL:BLOCK)
+                                                              IL:LAFITESTATUSWINDOW))))
+   :UPDATER (LAMBDA (PLACEMENT)
+                   (IF IL:\\LAFITE.OUTBOX
+
+                       (IL:* IL:|;;| "note the height of the outbox")

+
+                       (PLACEMENT-PROP PLACEMENT :OUTBOX-HEIGHT (REGION-HEIGHT (IL:WINDOWPROP
+                                                                                (FIRST 
+                                                                                   IL:\\LAFITE.OUTBOX
+                                                                                       )
+                                                                                'IL:REGION)))
+                       (REMF (PLACEMENT-PROPS PLACEMENT)
+                             :OUTBOX-HEIGHT)))
+   :PLACER (LAMBDA (PLACEMENT)
+
+                  (IL:* IL:|;;| "adjust placement as outbox might have appeared or been removed since we were last here & we don't want status window creeping around.")

+
+                  (IL:RELMOVEW (PLACEMENT-WINDOW PLACEMENT)
+                         (MAKE-POSITION 0 (- (GETF (PLACEMENT-PROPS PLACEMENT)
+                                                   :OUTBOX-HEIGHT 0)
+                                             (IF IL:\\LAFITE.OUTBOX
+                                                 (REGION-HEIGHT (IL:WINDOWPROP (FIRST 
+                                                                                   IL:\\LAFITE.OUTBOX
+                                                                                      )
+                                                                       'IL:REGION))
+                                                 0)))))
+   :TITLE (LAMBDA (PLACEMENT REGION DSP)
+                 (PRINT-PEP-TITLE-STRING "Lafite" REGION DSP :NO-TITLE-BAR? T))
+   :FILES 
+
+(IL:* IL:|;;;| "we don't load Lafite on demand.")

+
+   (IL:LAFITE-WINDOW-TYPES))
+
+(DEF-WINDOW-TYPE :LAFITE-BROWSER
 :RECOGNIZER (LAMBDA (WINDOW)
+                                                        (TYPEP (IL:WINDOWPROP WINDOW 'IL:MAILFOLDER)
+                                                               'IL:MAILFOLDER))
+   :ABSTRACTER ABSTRACT-LAFITE-BROWSER
+   :RECONSTITUTER RECONSTITUTE-LAFITE-BROWSER
+   :TITLE (LAMBDA (PLACEMENT REGION DSP)
+                 (LET* ((FOLDER (IL:WINDOWPROP (PLACEMENT-WINDOW PLACEMENT)
+                                       'IL:MAILFOLDER)))
+                       (PRINT-PEP-TITLE-STRING (IF FOLDER
+                                                   (IL:|fetch|
 (IL:MAILFOLDER IL:SHORTFOLDERNAME)
+                                                      IL:|of|
 FOLDER)
+                                                   "Lafite Browser")
+                              REGION DSP :NO-TITLE-BAR? (PLACEMENT-SHRUNKEN? PLACEMENT))))
+   :FILES 
+
+(IL:* IL:|;;;| "we don't load Lafite on demand")

+
+   (IL:LAFITE-WINDOW-TYPES))
+
+(DEFUN ABSTRACT-LAFITE-BROWSER
 (WINDOW)
+   (LET ((FOLDER (IL:WINDOWPROP WINDOW 'IL:MAILFOLDER))
+         (MOVE-TO-WINDOW (IL:WINDOWPROP WINDOW 'IL:LAFITE.AUTO.MOVE.MENU)))
+        (LIST :FOLDER-NAME (IL:|fetch|
 (IL:MAILFOLDER IL:SHORTFOLDERNAME) IL:|of|
 FOLDER)
+              :LAYOUT
+              (LET ((FOLDER-REGION (WINDOW-REGION WINDOW))
+                    (ICON-POSITION (ICON-POSITION WINDOW))
+                    (DISPLAY-REGION (IL:|fetch|
 (IL:MAILFOLDER IL:FOLDERDISPLAYREGION)
+                                       IL:|of|
 FOLDER)))
+                   (WHEN MOVE-TO-WINDOW
+
+                       (IL:* IL:|;;| "knock off portion of FOLDER-REGION which includes MoveTo menu window so tht FOLDER-REGION is right for passing to LAFITE.BROWSE.FOLDER (which won't create the MoveTo menu for us).")

+
+                       (DECF (REGION-WIDTH FOLDER-REGION)
+                             (REGION-WIDTH (IL:WINDOWPROP MOVE-TO-WINDOW 'IL:REGION))))
+                   (LIST (EXTERNALIZE-REGION FOLDER-REGION)
+                         (WHEN ICON-POSITION (EXTERNALIZE-POSITION ICON-POSITION))
+                         (WHEN DISPLAY-REGION (EXTERNALIZE-REGION DISPLAY-REGION))))
+              :OPTIONS
+              (WHEN (IL:|fetch|
 (IL:MAILFOLDER IL:FOLDERGETSMAIL) IL:|of|
 FOLDER)
+                    (LIST :ACTIVE))
+              :MOVE-TO-FOLDERS
+              (WHEN MOVE-TO-WINDOW
+                  (MAPCAR #'IL:LA.SHORTFILENAME (IL:WINDOWPROP WINDOW 'IL:LAFITE.AUTO.MOVE.NAMES))))))
+
+(DEFUN RECONSTITUTE-LAFITE-BROWSER
 (PLIST)
+
+   (IL:* IL:|;;| "pass if lafite is not loaded")

+
+   (WHEN (FBOUNDP 'IL:LAFITE)
+
+       (IL:* IL:|;;| "first make sure lafite is turned on")

+
+       (UNLESS (EQ IL:\\LAFITE.ACTIVE T)
+           (IL:LAFITE 'IL:ON NIL)
+           (LOOP (IL:BLOCK)
+                 (WHEN (EQ IL:\\LAFITE.ACTIVE T)
+                       (RETURN)))
+
+           (IL:* IL:|;;| "don't want to add windows to current room")

+
+           (HIDE-WINDOW IL:LAFITESTATUSWINDOW))
+       (LET* ((EXTERNALIZED-REGION (GETF PLIST :REGION))
+              (EXTERNALIZED-LAYOUT (GETF PLIST :LAYOUT (LIST IL:LAFITEBROWSERREGION)))
+              (LAYOUT (IF EXTERNALIZED-REGION
+
+                          (IL:* IL:|;;| "for back compatability")

+
+                          (LIST (INTERNALIZE-REGION EXTERNALIZED-REGION))
+                          (LIST (INTERNALIZE-REGION (FIRST EXTERNALIZED-LAYOUT))
+                                (WHEN (SECOND EXTERNALIZED-LAYOUT)
+                                    (INTERNALIZE-POSITION (SECOND EXTERNALIZED-LAYOUT)))
+                                (WHEN (THIRD EXTERNALIZED-LAYOUT)
+                                    (INTERNALIZE-REGION (THIRD EXTERNALIZED-LAYOUT))))))
+              (FOLDER (IL:LAFITE.BROWSE.FOLDER (GETF PLIST :FOLDER-NAME IL:DEFAULTMAILFOLDERNAME)
+                             LAYOUT
+                             (GETF PLIST :OPTIONS)))
+              (MOVE-TO-FOLDERS (GETF PLIST :MOVE-TO-FOLDERS)))
+             (WHEN FOLDER
+                 (WHEN MOVE-TO-FOLDERS
+                     (IL:WINDOWPROP (IL:FETCH
 (IL:MAILFOLDER IL:BROWSERWINDOW) IL:OF
 FOLDER)
+                            'IL:LAFITE.AUTO.MOVE.NAMES MOVE-TO-FOLDERS)
+                     (IL:\\LAFITE.UPDATE.MOVE.MENU FOLDER T))
+                 (IL:FETCH
 (IL:MAILFOLDER IL:BROWSERWINDOW) IL:OF
 FOLDER)))))
+
+
+
+(IL:* IL:|;;| "keep il:shapew from hanging")

+
+
+(IL:CHANGENAME 'IL:LAB.RESHAPEFN 'IL:OBTAIN.MONITORLOCK 'TRUE)
+
+(IL:CHANGENAME 'IL:LAB.REPAINTFN 'IL:OBTAIN.MONITORLOCK 'TRUE)
+(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
+
+(IL:GLOBALVARS IL:LAFITESTATUSWINDOW IL:DEFAULTMAILFOLDERNAME IL:\\LAFITE.ACTIVE 
+       IL:LAFITEBROWSERREGION)
+)
+(IL:PUTPROPS IL:LAFITE-WINDOW-TYPES IL:COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP

rooms/NEW-LAFITE-WINDOW-TYPES

@@ -0,0 +1,24 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
+
(IL:FILECREATED "17-Aug-90 14:44:10" 
+IL:|{DSK}<python>RELEASE>rooms>current>users-src>NEW-LAFITE-WINDOW-TYPES.;3|
 911    
+
+      IL:|changes| IL:|to:|  (IL:FILES IL:LAFITE-WINDOW-TYPES)
+                             (IL:VARS IL:NEW-LAFITE-WINDOW-TYPESCOMS)
+
+      IL:|previous| IL:|date:| "27-Jul-90 06:12:07" 
+IL:|{DSK}<python>RELEASE>rooms>current>users-src>NEW-LAFITE-WINDOW-TYPES.;2|)
+
+
+; Copyright (c) 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:NEW-LAFITE-WINDOW-TYPESCOMS)
+
+(IL:RPAQQ IL:NEW-LAFITE-WINDOW-TYPESCOMS
 ((IL:FILES (IL:SYSLOAD)
+                                                     IL:LAFITE-WINDOW-TYPES)))
+
+(IL:FILESLOAD (IL:SYSLOAD)
+       IL:LAFITE-WINDOW-TYPES)
+(IL:PUTPROPS IL:NEW-LAFITE-WINDOW-TYPES IL:COPYRIGHT ("Venue & Xerox Corporation" 1988 1990))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP

rooms/NOTECARDS-WINDOW-TYPES

@@ -0,0 +1,72 @@
+(DEFINE-FILE-INFO PACKAGE "XCL-USER" READTABLE "XCL" BASE 10)
+
(IL:FILECREATED "17-Aug-90 14:44:29" 
+IL:|{DSK}<python>RELEASE>rooms>current>users-src>NOTECARDS-WINDOW-TYPES.;3|
 3563   
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:NOTECARDS-WINDOW-TYPESCOMS)
+
+      IL:|previous| IL:|date:| "27-Jul-90 06:12:54" 
+IL:|{DSK}<python>RELEASE>rooms>current>users-src>NOTECARDS-WINDOW-TYPES.;2|)
+
+
+; Copyright (c) 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:NOTECARDS-WINDOW-TYPESCOMS)
+
+(IL:RPAQQ IL:NOTECARDS-WINDOW-TYPESCOMS
 ((IL:WINDOW-TYPES :NOTECARDS-ICON)
+                                             
+                                             (IL:* IL:|;;| "")

+
+                                             (IL:DECLARE\: IL:DONTCOPY (IL:PROPS (
+                                                                            IL:NOTECARDS-WINDOW-TYPES
+                                                                                  
+                                                                              IL:MAKEFILE-ENVIRONMENT
+                                                                                  )
+                                                                              (
+                                                                            IL:NOTECARDS-WINDOW-TYPES
+                                                                               IL:FILETYPE)))))
+
+(ROOMS:DEF-WINDOW-TYPE :NOTECARDS-ICON
 :RECOGNIZER (LAMBDA (ROOMS::WINDOW)
+                                                              (EQ (IL:WINDOWPROP ROOMS::WINDOW
+                                                                         'IL:BUTTONEVENTFN)
+                                                                  
+                                                                  'IL:|NC.NoteCardsIconButtonEventFn|
+                                                                  ))
+   :ABSTRACTER (LAMBDA (ROOMS::WINDOW)
+                      (DECLARE
 (IGNORE ROOMS::WINDOW))
+                      NIL)
+   :RECONSTITUTER (LAMBDA (ROOMS::DATA)
+                         (DECLARE
 (IGNORE ROOMS::DATA))
+                         (WHEN (FBOUNDP 'IL:|NC.BringUpNoteCardsIcon|)
+                             (WHEN (NOT (IL:OPENWP IL:|NC.NoteCardsIconWindow|))
+                                 (IL:|NC.BringUpNoteCardsIcon| (IL:CREATEPOSITION 0 0))
+
+                                 (IL:* IL:|;;| 
+
                 "(il:closew (il:shrinkw il:|NC.NoteCardsIconWindow| nil (il:createposition 0 0)))")

+
+                                 (IL:* IL:|;;| "So it doesn't come up in the current room.")

+
+                                 (IL:CLOSEW IL:|NC.NoteCardsIconWindow|))
+
+                             (IL:* IL:|;;| "")

+
+                             IL:|NC.NoteCardsIconWindow|))
+   :TITLE (LAMBDA (PLACEMENT REGION DSP)
+                 (ROOMS:PRINT-PEP-TITLE-STRING "NoteCards" REGION DSP :NO-TITLE-BAR? T))
+   :FILES (IL:NOTECARDS-WINDOW-TYPES))
+
+
+
+(IL:* IL:|;;| "")

+
+(IL:DECLARE\: IL:DONTCOPY 
+
+(IL:PUTPROPS IL:NOTECARDS-WINDOW-TYPES
 IL:MAKEFILE-ENVIRONMENT
 (:PACKAGE "XCL-USER" 
+                                                                              :READTABLE "XCL" :BASE
+                                                                              10))
+
+(IL:PUTPROPS IL:NOTECARDS-WINDOW-TYPES
 IL:FILETYPE
 :COMPILE-FILE)
+)
+(IL:PUTPROPS IL:NOTECARDS-WINDOW-TYPES IL:COPYRIGHT ("Venue & Xerox Corporation" 1988 1990))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP

rooms/OFFICE.SUITE

@@ -0,0 +1,25 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "ROOMS" (USE "LISP" "XCL") (SHADOW CLROOM))
+)
+
(il:filecreated " 5-Aug-88 11:01:04" il:|{POGO:AISNORTH:XEROX}<ROOMS>MEDLEY>USERS>OFFICE.SUITE;2|
 2617   
+
+      il:|changes| il:|to:|  (il:suites "OFFICE")
+
+      il:|previous| il:|date:| " 8-Mar-88 16:13:34" 
+il:|{POGO:AISNORTH:XEROX}<ROOMS>MEDLEY>USERS>OFFICE.SUITE;1|)
+
+
+; Copyright (c) 1987, 1988 by Xerox Corporation.  All rights reserved.
+
+(il:prettycomprint il:officecoms)
+
+(il:rpaqq il:officecoms ((il:files il:rooms) (file-environments il:office.suite) (il:suites "OFFICE")))
+
+(il:filesload il:rooms)
+
+(define-file-environment il:office.suite :package (defpackage "ROOMS" (:use "LISP" "XCL") (:shadow cl:room)) :readtable "XCL" :compiler :compile-file)
+
+(defsuite "OFFICE" (:version 1) (:files) (:window 0 :type :button :text "Go to Room" :action (interactive-go-to-room :allow-new? t) :help "Go to a room, possibly new.") (:window 1 :type :button :text "Overview" :action (go-to-overview) :help "Enter the overview") (:window 2 :type :prompt-window) (:window 3 :type :button :text-form (symbol-value (quote *back-door-room-name*)) :action (interactive-go-to-room-named *back-door-room-name*) :help "Go to the previous room" :type :door :inverted? t) (:window 4 :type :exec :region (271/512 7/101 119/256 141/808) :package "XCL-USER" :readtable "XCL") (:room "Mail" :placements nil :inclusions ("Office Panel") :background ((:region (0 1/4 1.0 3/4) :shade (:eval squares-bitmap) :border 2) (:text "Mail" :position (10 . 10) :font (il:helvetica 36 il:bold))) :file-watch-on? nil) (:room "Office" :placements nil :inclusions ("Office Panel") :background ((:region (0 1/4 1.0 3/4) :shade (:eval tile-bitmap) :border 2) (:text "Office" :font (il:helvetica 36 il:bold) :position (10 . 10))) :file-watch-on? nil) (:room "Office Panel" :placements ((0 :region (77/1024 137/808 41/512 11/404)) (1 :region (77/1024 167/808 35/512 11/404)) (2 :region (271/512 1/808 239/512 13/202) :font (il:helvetica 10 (il:medium il:regular il:regular)) :border 2 :shade 65535 :title nil :operation il:erase) (3 :region (5/512 95/808 59/1024 99/808)) (4 :region (271/512 7/101 119/256 141/808))) :inclusions nil :background ((:whole-screen 33825 :border 2)) :file-watch-on? nil) (:room "Project" :placements nil :inclusions ("Office Panel") :background ((:region (0 1/4 1.0 3/4) :shade (:eval renaissance-bitmap) :border 2) (:text "Project" :font (il:helvetica 36 il:bold) :position (10 . 10))) :file-watch-on? nil))
+(il:putprops il:office.suite il:copyright ("Xerox Corporation" 1987 1988))
+(il:declare\: il:dontcopy
+  (il:filemap (nil)))
+il:stop

rooms/ROOMS

@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "ROOMS" (USE "LISP" "XCL") (SHADOW CLROOM))

rooms/SCREENPAPER

@@ -0,0 +1,168 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED " 5-Dec-2020 16:36:45" 
+{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>SCREENPAPER.;3
 12813  
+
+      previous date%: "17-Aug-90 14:46:25" 
+{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>SCREENPAPER.;1)
+
+
+(* ; "
+Copyright (c) 1901, 1986, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT SCREENPAPERCOMS)
+
+(RPAQQ SCREENPAPERCOMS

+       ((FNS SCREENPAPER SCREENPAPERNEWREGIONFN KALSHOW DOPOINT MAPN)
+        [ADDVARS (IDLE.FUNCTIONS ("Screen wallpaper" 'SCREENPAPER]
+        
+
+(* ;;; "faster versions of editbitmap functions")

+
+        (FNS INVERT.BITMAP.HORIZONTALLY INVERT.BITMAP.VERTICALLY ROTATE.BITMAP)
+        (VARS SCREENPAPERSIZE SCREENPERIOD SCREENREPEAT)))
+(DEFINEQ
+
+(SCREENPAPER

+  [LAMBDA (WINDOW REGION.OR.SIZE OPTION)
                 (* ; "Edited  9-Sep-88 17:05 by bmw")

+    (OR WINDOW (SETQ WINDOW (CREATEW)))
+    (OR REGION.OR.SIZE (SETQ REGION.OR.SIZE (if
 (EQ OPTION 'PICK)
+                                                then
 (GETREGION 16 16 NIL (FUNCTION 
+                                                                               SCREENPAPERNEWREGIONFN
+                                                                               ))
+                                              else
 SCREENPAPERSIZE)))
+    (LET ((SIZE (if
 (REGIONP REGION.OR.SIZE)
+                    then
 (fetch
 (REGION WIDTH)
+                                    REGION.OR.SIZE)
+                  else
 REGION.OR.SIZE))
+          TRIANGLE STREAM BUF1 2SIZE BIGBUF PBT BUF1A BUF2 BUF3 BUF4 CX CY (CNT SCREENPERIOD))
+         (DECLARE
 (SPECVARS TRIANGLE STREAM BUF1 2SIZE BIGBUF PBT BUF1A BUF2 BUF3 BUF4 CX CY CNT)
+                )
+         (SETQ TRIANGLE (BITMAPCREATE SIZE SIZE))
+         (SETQ BUF1 (BITMAPCREATE SIZE SIZE))
+         (SETQ STREAM (DSPCREATE TRIANGLE))
+         (FILLPOLYGON (LIST '(-1 . -1)
+                            (CONS SIZE SIZE)
+                            (CONS -1 SIZE))
+                BLACKSHADE STREAM)
+         (SETQ BUF2 (BITMAPCREATE SIZE SIZE))
+         (SETQ BUF3 (BITMAPCREATE SIZE SIZE))
+         (SETQ 2SIZE (PLUS SIZE SIZE))
+         (SETQ BIGBUF (BITMAPCREATE 2SIZE 2SIZE))
+         (SETQ PBT (create
 PILOTBBT))
+         (DSPDESTINATION BUF1 STREAM)
+         (if
 (EQ OPTION 'PICK)
+             then
 (bind
 POS do
 [RESETFORM (CURSOR CROSSHAIRS)
+                                                  (until
 (MOUSESTATE (OR LEFT MIDDLE RIGHT]
+                                          (if
 (LASTMOUSESTATE (ONLY MIDDLE))
+                                              then
 (RETURN BIGBUF)
+                                            elseif
 (LASTMOUSESTATE (ONLY RIGHT))
+                                              then
 (RETURN NIL)
+                                            elseif
 (REGIONP REGION.OR.SIZE)
+                                              then
 (SETQ POS (CONS (fetch
 (REGION LEFT)
+                                                                              REGION.OR.SIZE)
+                                                                       (fetch
 (REGION BOTTOM)
+                                                                              REGION.OR.SIZE)))
+                                                    (SETQ REGION.OR.SIZE)
+                                            else
 (SETQ POS (GETBOXPOSITION SIZE SIZE)))
+                                          (BITBLT (SCREENBITMAP)
+                                                 (CAR POS)
+                                                 (CDR POS)
+                                                 BUF1 0 0 SIZE SIZE)
+                                          (KALSHOW
 BUF1 WINDOW SIZE
+                                                 (if
 (SHIFTDOWNP 'SHIFT)
+                                                     then
 'INVERT
+                                                   else
 NIL)))
+           else
 (MAPN
 WINDOW (FUNCTION (LAMBDA (X Y)
+                                                 (BITBLT (WINDOWPROP WINDOW 'IMAGECOVERED)
+                                                        X Y BUF1 0 0 SIZE SIZE)
+                                                 (DRAWLINE (SUB1 SIZE)
+                                                        0
+                                                        (RAND 0 (SUB1 SIZE))
+                                                        (RAND 0 (SUB1 SIZE))
+                                                        1
+                                                        'INVERT STREAM)
+                                                 (KALSHOW
 BUF1 WINDOW SIZE
+                                                        (if
 (VIDEOCOLOR)
+                                                            then
 NIL
+                                                          else
 'INVERT))
+                                                 (if
 (LEQ (add
 CNT -1)
+                                                              0)
+                                                     then
 (SETQ CNT SCREENPERIOD)
+                                                           (to
 SCREENREPEAT
+                                                              do
 (BITBLT WINDOW 0 0 BUF1)
+                                                                    (KALSHOW
 BUF1 WINDOW SIZE])
+
+(SCREENPAPERNEWREGIONFN

+(LAMBDA (FP MP) (* BN "17-Sep-84 10:40") (COND (MP (with POSITION MP (PROG ((DX (IDIFFERENCE XCOORD (fetch (POSITION XCOORD) of FP))) (DY (IDIFFERENCE YCOORD (fetch (POSITION YCOORD) of FP)))) (COND ((IGREATERP (IABS DX) (IABS DY)) (SETQ YCOORD (IPLUS (fetch (POSITION YCOORD) of FP) (ITIMES DX (COND ((MINUSP (ITIMES DX DY)) -1) (T 1)))))) (T (SETQ XCOORD (IPLUS (fetch (POSITION XCOORD) of FP) (ITIMES DY (COND ((MINUSP (ITIMES DX DY)) -1) (T 1))))))) (RETURN MP)))) (T FP)))
+)
+
+(KALSHOW

+(LAMBDA (BUF1 WINDOW SIZE MODE) (* ; "Edited  5-Aug-88 11:54 by drc:") (BITBLT TRIANGLE NIL NIL BUF1 NIL NIL NIL NIL NIL (QUOTE ERASE)) (* THAT ERASED ALL BUT THE TRIANGLE) (ROTATE.BITMAP BUF1 BUF2 PBT) (INVERT.BITMAP.VERTICALLY BUF2 BUF3 PBT) (BITBLT BUF3 NIL NIL BUF1 NIL NIL NIL NIL NIL (QUOTE PAINT)) (LET (CX CY) (BITBLT BUF1 NIL NIL BIGBUF 0 SIZE) (INVERT.BITMAP.HORIZONTALLY BUF1 BUF2 PBT) (BITBLT BUF2 NIL NIL BIGBUF SIZE SIZE) (INVERT.BITMAP.VERTICALLY BUF1 BUF3 PBT) (BITBLT BUF3 NIL NIL BIGBUF 0 0) (INVERT.BITMAP.HORIZONTALLY BUF3 BUF2 PBT) (BITBLT BUF2 NIL NIL BIGBUF SIZE 0) (SETQ CX (QUOTIENT (WINDOWPROP WINDOW (QUOTE WIDTH)) 2)) (SETQ CY (QUOTIENT (WINDOWPROP WINDOW (QUOTE HEIGHT)) 2)) (for I from 0 while (LESSP I (QUOTIENT (PLUS 2SIZE (MAX CX CY)) 2SIZE)) do (for J from 0 while (LEQ J I) do (DOPOINT (FUNCTION (LAMBDA (X Y) (BITBLT BIGBUF NIL NIL WINDOW (PLUS CX (TIMES X 2SIZE)) (PLUS CY (TIMES Y 2SIZE)) NIL NIL MODE (QUOTE REPLACE)))) J I))) (BLOCK)))
+)
+
+(DOPOINT

+  [LAMBDA (FN X Y)
                                           (* edited%: "31-Dec-00 16:08")

+    (if
 (LESSP X Y)
+        then
 (DOPOINT
 FN Y X))
+    (APPLY* FN X Y 1)
+    (APPLY* FN (DIFFERENCE -1 X)
+           Y 1)
+    (APPLY* FN X (DIFFERENCE -1 Y)
+           1)
+    (APPLY* FN (DIFFERENCE -1 X)
+           (DIFFERENCE -1 Y)
+           1])
+
+(MAPN

+  [LAMBDA (WINDOW FN)
                                        (* edited%: " 1-Jan-01 00:09")

+    (LET ((MAXX (DIFFERENCE (WINDOWPROP WINDOW 'WIDTH)
+                       SIZE))
+          (MAXY (DIFFERENCE (WINDOWPROP WINDOW 'HEIGHT)
+                       SIZE))
+          X Y NX NY STEPS)
+         (SETQ X (RAND 0 MAXX))
+         (SETQ Y (RAND 0 MAXY))
+         (while
 T do
 (SETQ NX (RAND 0 MAXX))
+                     (SETQ NY (RAND 0 MAXY))
+                     (SETQ STEPS (QUOTIENT (PLUS (ABS (DIFFERENCE NX X))
+                                                 (ABS (DIFFERENCE NY Y)))
+                                        4))
+                     (if
 (NEQ STEPS 0)
+                         then
 [for
 I from
 1 to
 STEPS
+                                 do
 (APPLY* FN (PLUS X (QUOTIENT (TIMES (DIFFERENCE NX X)
+                                                                        I)
+                                                              STEPS))
+                                           (PLUS Y (QUOTIENT (TIMES (DIFFERENCE NY Y)
+                                                                    I)
+                                                          STEPS]
+                              (SETQ X NX)
+                              (SETQ Y NY])
+)
+
+(ADDTOVAR IDLE.FUNCTIONS
 ("Screen wallpaper" 'SCREENPAPER))
+
+
+
+(* ;;; "faster versions of editbitmap functions")

+
+(DEFINEQ
+
+(INVERT.BITMAP.HORIZONTALLY

+  [LAMBDA (BITMAP BM2 PBT)
                                   (* edited%: "31-Dec-00 17:15")

+    (OR BM2 (SETQ BM2 (BITMAPCOPY BITMAP)))
+    (OR PBT (SETQ PBT (create
 PILOTBBT)))
+    (with
 PILOTBBT PBT (SETQ PBTDESTLO (ffetch
 BitMapLoLoc BM2))
+          (SETQ PBTDESTHI (ffetch
 BitMapHiLoc BM2))
+          (SETQ PBTSOURCELO (ffetch
 BitMapLoLoc BITMAP))
+          (SETQ PBTSOURCEHI (ffetch
 BitMapHiLoc BITMAP))
+          (SETQ PBTDESTBPL (TIMES 16 (ffetch
 BITMAPRASTERWIDTH BM2)))
+          (SETQ PBTSOURCEBPL (TIMES 16 (ffetch
 BITMAPRASTERWIDTH BITMAP)))
+          (SETQ PBTFLAGS 16384)                              (* by experiment, disjoint replace)

+          (SETQ PBTHEIGHT (ffetch
 BITMAPHEIGHT BITMAP))
+          (SETQ PBTWIDTH 1)
+          (for
 I from
 0 while
 (LESSP I (ffetch
 BITMAPWIDTH BITMAP))
+             do
 (SETQ PBTSOURCEBIT I)
+                (SETQ PBTDESTBIT (DIFFERENCE (SUB1 (ffetch
 BITMAPWIDTH BITMAP))
+                                        I))
+                (\PILOTBITBLT PBT 0)))

rooms/UN-HIDE-TTY

@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")

rooms/WALLPAPER

@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")