diff --git a/rooms/APPENDIXATEMPLATE.TEDIT b/rooms/APPENDIXATEMPLATE.TEDIT
new file mode 100644
index 00000000..1e04dca4
Binary files /dev/null and b/rooms/APPENDIXATEMPLATE.TEDIT differ
diff --git a/rooms/BACKGROUND-MENU-BUTTONS b/rooms/BACKGROUND-MENU-BUTTONS
new file mode 100644
index 00000000..89819f8a
--- /dev/null
+++ b/rooms/BACKGROUND-MENU-BUTTONS
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER")
(IL:FILECREATED " 5-Dec-2020 16:38:10" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>BACKGROUND-MENU-BUTTONS.;2| 4018   

      IL:|previous| IL:|date:| "17-Aug-90 14:42:07" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>BACKGROUND-MENU-BUTTONS.;1|
)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:BACKGROUND-MENU-BUTTONSCOMS)

(IL:RPAQQ IL:BACKGROUND-MENU-BUTTONSCOMS
          ((IL:FILES (IL:SYSLOAD)
                  IL:ROOMS)
           (FILE-ENVIRONMENTS IL:BACKGROUND-MENU-BUTTONS)
           (IL:FUNCTIONS MAKE-BACKGROUND-MENU-BUTTON BACKGROUND-ITEM)
           (IL:P (EVAL-WHEN (LOAD)
                        (ROOMS:MAKE-BUTTON-WINDOW (ROOMS:MAKE-BUTTON :TEXT "Make Background Button" 
                                                         :ACTION '(MAKE-BACKGROUND-MENU-BUTTON)
                                                         :HELP 
                         "make a button which does the same thing as an entry on the background menu"
                                                         ))))))

(IL:FILESLOAD (IL:SYSLOAD)
       IL:ROOMS)

(DEFINE-FILE-ENVIRONMENT IL:BACKGROUND-MENU-BUTTONS :PACKAGE "XCL-USER"
   :READTABLE "XCL"
   :COMPILER :COMPILE-FILE)

(DEFUN MAKE-BACKGROUND-MENU-BUTTON ()
   (LET ((ITEM (BACKGROUND-ITEM)))
        (WHEN ITEM
            (ROOMS:MAKE-BUTTON-WINDOW (ROOMS:MAKE-BUTTON :TEXT (PRINC-TO-STRING (FIRST ITEM))
                                             :HELP
                                             (THIRD ITEM)
                                             :ACTION
                                             `(IL:EVAL ,(SECOND ITEM)))))))

(DEFUN BACKGROUND-ITEM ()

   (IL:* IL:|;;| "return a menu item from the background menu")

   (IL:* IL:|;;| "labels of sub-items are coerced to show where they came from")

   (DECLARE (GLOBAL IL:|BackgroundMenuCommands|))
   (LET ((ITEM (IL:MENU (IL:CREATE IL:MENU
                               IL:ITEMS IL:_ IL:|BackgroundMenuCommands|
                               IL:CENTERFLG IL:_ T
                               IL:WHENSELECTEDFN IL:_ #'VALUES))))
        (WHEN ITEM
            (LABELS ((ITEM-PATH (ITEMS)

                            (IL:* IL:|;;| 
                          "construct a list of the names of the items in ITEMS on the path to ITEM")

                            (DOLIST (I ITEMS)
                                (WHEN (EQ I ITEM)
                                    (RETURN (LIST (FIRST I))))
                                (LET ((FOUND (ITEM-PATH (CDR (FOURTH I)))))
                                     (WHEN FOUND
                                         (RETURN (CONS (FIRST I)
                                                       FOUND)))))))
                   (LET ((PATH (ITEM-PATH IL:|BackgroundMenuCommands|)))
                        (IF (REST PATH)

                            (IL:* IL:|;;| "it's a subitem - coerce the label")

                            (LIST* (LET ((*PRINT-CASE* :UPCASE))
                                        (FORMAT NIL "~A~{ > ~A~}" (FIRST PATH)
                                               (REST PATH)))
                                   (REST ITEM))

                            (IL:* IL:|;;| "it's a top-level item - just return it")

                            ITEM))))))

(EVAL-WHEN (LOAD)
       (ROOMS:MAKE-BUTTON-WINDOW (ROOMS:MAKE-BUTTON :TEXT "Make Background Button" :ACTION
                                        '(MAKE-BACKGROUND-MENU-BUTTON)
                                        :HELP 
                         "make a button which does the same thing as an entry on the background menu"
                                        )))
(IL:PUTPROPS IL:BACKGROUND-MENU-BUTTONS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020)
)
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (1386 1817 (MAKE-BACKGROUND-MENU-BUTTON 1386 . 1817)) (1819 3506 (BACKGROUND-ITEM 
1819 . 3506)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/BACKGROUND-MENU-BUTTONS.DFASL b/rooms/BACKGROUND-MENU-BUTTONS.DFASL
new file mode 100644
index 00000000..5069d18c
Binary files /dev/null and b/rooms/BACKGROUND-MENU-BUTTONS.DFASL differ
diff --git a/rooms/BACKGROUND-MENU-BUTTONS.TEDIT b/rooms/BACKGROUND-MENU-BUTTONS.TEDIT
new file mode 100644
index 00000000..c71d3376
Binary files /dev/null and b/rooms/BACKGROUND-MENU-BUTTONS.TEDIT differ
diff --git a/rooms/COVER-LETTER.TEDIT b/rooms/COVER-LETTER.TEDIT
new file mode 100644
index 00000000..cef9afc0
Binary files /dev/null and b/rooms/COVER-LETTER.TEDIT differ
diff --git a/rooms/EASYTEMPLATE.TEDIT b/rooms/EASYTEMPLATE.TEDIT
new file mode 100644
index 00000000..ec4ca7e3
Binary files /dev/null and b/rooms/EASYTEMPLATE.TEDIT differ
diff --git a/rooms/LAFITE-WINDOW-TYPES b/rooms/LAFITE-WINDOW-TYPES
new file mode 100644
index 00000000..b5df5d2f
--- /dev/null
+++ b/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
diff --git a/rooms/LAFITE-WINDOW-TYPES.TEDIT b/rooms/LAFITE-WINDOW-TYPES.TEDIT
new file mode 100644
index 00000000..17d9f2ae
Binary files /dev/null and b/rooms/LAFITE-WINDOW-TYPES.TEDIT differ
diff --git a/rooms/NEW-LAFITE-WINDOW-TYPES b/rooms/NEW-LAFITE-WINDOW-TYPES
new file mode 100644
index 00000000..bb2ee2e2
--- /dev/null
+++ b/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
diff --git a/rooms/NOTECARDS-WINDOW-TYPES b/rooms/NOTECARDS-WINDOW-TYPES
new file mode 100644
index 00000000..7caa09f4
--- /dev/null
+++ b/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
diff --git a/rooms/OFFICE.SUITE b/rooms/OFFICE.SUITE
new file mode 100644
index 00000000..9fb4f995
--- /dev/null
+++ b/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
diff --git a/rooms/OFFICE.TEDIT b/rooms/OFFICE.TEDIT
new file mode 100644
index 00000000..a244928f
Binary files /dev/null and b/rooms/OFFICE.TEDIT differ
diff --git a/rooms/RANDOM-WINDOW-TYPES b/rooms/RANDOM-WINDOW-TYPES
new file mode 100644
index 00000000..d1a3cec4
--- /dev/null
+++ b/rooms/RANDOM-WINDOW-TYPES
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:38:32" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>RANDOM-WINDOW-TYPES.;2| 14251  

      IL:|previous| IL:|date:| "17-Aug-90 14:45:06" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>RANDOM-WINDOW-TYPES.;1|)


; Copyright (c) 1988, 1989, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:RANDOM-WINDOW-TYPESCOMS)

(IL:RPAQQ IL:RANDOM-WINDOW-TYPESCOMS
          (
           (IL:* IL:|;;| "Window types for various LispUsers modules")

           (FILE-ENVIRONMENTS IL:RANDOM-WINDOW-TYPES)
           (IL:P (REQUIRE "ROOMS"))
           
           (IL:* IL:|;;| "Window type for WHO-LINE")

           (IL:WINDOW-TYPES :WHO-LINE)
           
           (IL:* IL:|;;| "Window types for the CALENDAR program")

           (IL:WINDOW-TYPES :CALENDAR-YEAR :CALENDAR-MONTH)
           
           (IL:* IL:|;;| "Window type for the PRINTERMENU program")

           (IL:WINDOW-TYPES :PRINTER-MENU-WINDOW)
           
           (IL:* IL:|;;| "Window type for some clocks")

           (IL:WINDOW-TYPES :CROCK-WINDOW :BICLOCK)
           
           (IL:* IL:|;;| "Window types for AddressBook and PhoneDirectory")

           (IL:COMS (IL:WINDOW-TYPES :ADDRESSBOOK :PHONE-DIRECTORY)
                  (IL:FUNCTIONS ADDRESS-BOOK-WINDOW-P PHONE-DIRECTORY-WINDOW-P FIND-WINDOW))
           
           (IL:* IL:|;;| "Window type for GRID-ICONS")

           (IL:WINDOW-TYPES :GRID-ICON-COMS-EDITOR)
           (IL:COMS 

                  (IL:* IL:|;;| "special handlers for FILEWATCH.  these are somewhat broken")

                  (IL:WINDOW-TYPES :FILE-WATCH)
                  (IL:FUNCTIONS FILE-WATCH-EXIT-FUNCTION FILE-WATCH-ENTRY-FUNCTION)
                  (IL:P (PUSHNEW 'FILE-WATCH-EXIT-FUNCTION *ROOM-EXIT-FUNCTIONS*)
                        (PUSHNEW 'FILE-WATCH-ENTRY-FUNCTION *ROOM-ENTRY-FUNCTIONS*)))))



(IL:* IL:|;;| "Window types for various LispUsers modules")


(DEFINE-FILE-ENVIRONMENT IL:RANDOM-WINDOW-TYPES :COMPILER :COMPILE-FILE
   :READTABLE "XCL"
   :PACKAGE "ROOMS")

(REQUIRE "ROOMS")



(IL:* IL:|;;| "Window type for WHO-LINE")


(DEF-WINDOW-TYPE :WHO-LINE :RECOGNIZER (LAMBDA (WINDOW)
                                                  (DECLARE (GLOBAL IL:*WHO-LINE*))
                                                  (EQ WINDOW IL:*WHO-LINE*))
   :ABSTRACTER (LAMBDA (WINDOW)
                      NIL)
   :RECONSTITUTER (LAMBDA (PROPS)
                         (DECLARE (GLOBAL IL:*WHO-LINE*))
                         (IL:INSTALL-WHO-LINE-OPTIONS)
                         IL:*WHO-LINE*)
   :NO-SHAPE T                                               (IL:* IL:\; "don't scale placements")
   :TITLE ""
   :FILES (IL:WHO-LINE IL:RANDOM-WINDOW-TYPES))



(IL:* IL:|;;| "Window types for the CALENDAR program")


(DEF-WINDOW-TYPE :CALENDAR-YEAR :RECOGNIZER (LAMBDA (W)
                                                       (EQ (IL:WINDOWPROP W 'IL:REPAINTFN)
                                                           'IL:REPAINTYEAR))
   :ABSTRACTER (LAMBDA (W)
                      (LIST (IL:WINDOWPROP W 'IL:YEAR#)))
   :RECONSTITUTER (LAMBDA
                   (DATA)
                   (DESTRUCTURING-BIND
                    (YEAR)
                    DATA
                    (FLET ((FIND-CALENDAR-YEAR NIL
                                  (FIND-IF #'(LAMBDA (W)
                                                    (AND (EQ (IL:WINDOWPROP W 'IL:REPAINTFN)
                                                             'IL:REPAINTYEAR)
                                                         (EQL (IL:WINDOWPROP W 'IL:YEAR#)
                                                              YEAR)))
                                         (IL:OPENWINDOWS))))
                          (OR (FIND-CALENDAR-YEAR)
                              (PROGN (IL:CALENDAR NIL NIL YEAR)
                                     (FIND-CALENDAR-YEAR))))))
   :TITLE (LAMBDA (PLACEMENT REGION DSP)
                 (PRINT-PEP-TITLE-STRING (OR (IL:WINDOWPROP (PLACEMENT-WINDOW PLACEMENT)
                                                    'IL:YEAR#)
                                             "YEAR")
                        REGION DSP :NO-TITLE-BAR? T))
   :FILES (IL:CALENDAR IL:RANDOM-WINDOW-TYPES))

(DEF-WINDOW-TYPE :CALENDAR-MONTH :RECOGNIZER (LAMBDA (W)
                                                        (EQ (IL:WINDOWPROP W 'IL:REPAINTFN)
                                                            'IL:REPAINTMONTH))
   :ABSTRACTER (LAMBDA (W)
                      (LIST (IL:WINDOWPROP W 'IL:YEAR#)
                            (IL:WINDOWPROP W 'IL:MONTH#)))
   :RECONSTITUTER (LAMBDA
                   (DATA)
                   (DESTRUCTURING-BIND
                    (YEAR MONTH)
                    DATA
                    (FLET ((FIND-CALENDAR-MONTH
                            NIL
                            (FIND-IF #'(LAMBDA (W)
                                              (AND (EQ (IL:WINDOWPROP W 'IL:REPAINTFN)
                                                       'IL:REPAINTYEAR)
                                                   (EQL (IL:WINDOWPROP W 'IL:YEAR#)
                                                        YEAR)
                                                   (EQL (IL:WINDOWPROP W 'IL:MONTH#)
                                                        MONTH)))
                                   (IL:OPENWINDOWS))))
                          (OR (FIND-CALENDAR-MONTH)
                              (PROGN (IL:CALENDAR MONTH NIL YEAR)
                                     (FIND-CALENDAR-MONTH))))))
   :TITLE (LAMBDA (PLACEMENT REGION DSP)
                 (PRINT-PEP-TITLE-STRING (LET ((MONTH-NUMBER (IL:WINDOWPROP (PLACEMENT-WINDOW 
                                                                                   PLACEMENT)
                                                                    'IL:MONTH#)))
                                              (IF MONTH-NUMBER
                                                  (NTH (1- MONTH-NUMBER)
                                                       '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" 
                                                               "Aug" "Sep" "Oct" "Nov" "Dec"))
                                                  "MONTH"))
                        REGION DSP :NO-TITLE-BAR? T))
   :FILES (IL:CALENDAR IL:RANDOM-WINDOW-TYPES))



(IL:* IL:|;;| "Window type for the PRINTERMENU program")


(DEF-WINDOW-TYPE :PRINTER-MENU-WINDOW :RECOGNIZER (LAMBDA (W)
                                                             (AND (BOUNDP 'IL:PRINTERMENU.WINDOW)
                                                                  (EQ W IL:PRINTERMENU.WINDOW)))
   :RECONSTITUTER (LAMBDA (DATA)
                         (DECLARE (IGNORE DATA))
                         (UNLESS (AND (BOUNDP 'IL:PRINTERMENU.WINDOW)
                                      IL:PRINTERMENU.WINDOW)
                                (IL:PRINTERMENU))
                         IL:PRINTERMENU.WINDOW)
   :ABSTRACTER (LAMBDA (W)
                      (DECLARE (IGNORE W))
                      NIL)
   :TITLE "PrinterMenu"
   :FILES (IL:PRINTERMENU IL:RANDOM-WINDOW-TYPES))



(IL:* IL:|;;| "Window type for some clocks")


(DEF-WINDOW-TYPE :CROCK-WINDOW :RECOGNIZER (LAMBDA (W)
                                                      (AND (BOUNDP 'IL:CROCKWINDOW)
                                                           (EQ W IL:CROCKWINDOW)))
   :RECONSTITUTER (LAMBDA (DATA)
                         (DECLARE (IGNORE DATA))
                         (UNLESS (AND (BOUNDP 'IL:CROCKWINDOW)
                                      (IL:WINDOWP IL:CROCKWINDOW))
                             (IL:CROCK (IL:CREATEREGION 0 0 100 100)))
                         IL:CROCKWINDOW)
   :ABSTRACTER (LAMBDA (W)
                      (DECLARE (IGNORE W))
                      NIL)
   :TITLE "Crock"
   :FILES (IL:CROCK IL:RANDOM-WINDOW-TYPES))

(DEF-WINDOW-TYPE :BICLOCK :RECOGNIZER (LAMBDA (WINDOW)
                                                 (EQ (IL:WINDOWPROP WINDOW 'IL:RESHAPEFN)
                                                     'IL:BICLOCKRSFN))
   :ABSTRACTER (LAMBDA (WINDOW)
                      (DECLARE (IGNORE WINDOW))
                      NIL)
   :RECONSTITUTER (LAMBDA (DATA)
                         (DECLARE (IGNORE DATA)
                                (GLOBAL IL:BICLOCKWINDOW))
                         (IF (BOUNDP 'IL:BICLOCKWINDOW)
                             IL:BICLOCKWINDOW
                             (IL:BICLOCK)))
   :TITLE (LAMBDA (PLACEMENT REGION DSP)
                 (PRINT-PEP-TITLE-STRING "Clock" REGION DSP :NO-TITLE-BAR? T))
   :FILES (IL:BICLOCK IL:RANDOM-WINDOW-TYPES))



(IL:* IL:|;;| "Window types for AddressBook and PhoneDirectory")


(DEF-WINDOW-TYPE :ADDRESSBOOK :DEPENDENCIES (:TEXTSTREAM)
   :RECOGNIZER ADDRESS-BOOK-WINDOW-P
   :ABSTRACTER (LAMBDA (WINDOW)
                      (DECLARE (IGNORE WINDOW))
                      NIL)
   :RECONSTITUTER (LAMBDA (DATA)
                         (DECLARE (IGNORE DATA))
                         (OR (FIND-WINDOW #'ADDRESS-BOOK-WINDOW-P T)
                             (IL:|MakeAddressBook|)))
   :TITLE "Address"
   :FILES (IL:ADDRESSBOOK IL:RANDOM-WINDOW-TYPES))

(DEF-WINDOW-TYPE :PHONE-DIRECTORY :RECOGNIZER PHONE-DIRECTORY-WINDOW-P
   :ABSTRACTER (LAMBDA (WINDOW)
                      (DECLARE (IGNORE WINDOW))
                      NIL)
   :RECONSTITUTER (LAMBDA (DATA)
                         (DECLARE (IGNORE DATA))
                         (OR (FIND-WINDOW #'PHONE-DIRECTORY-WINDOW-P T)
                             (IL:|Let-your-fingers-do-the-walking|)))
   :TITLE "Phone"
   :FILES (IL:PHONE-DIRECTORY IL:RANDOM-WINDOW-TYPES))

(DEFUN ADDRESS-BOOK-WINDOW-P (WINDOW)
   (EQ (IL:WINDOWPROP WINDOW 'IL:|ProcessName|)
       'IL:|Address Book|))

(DEFUN PHONE-DIRECTORY-WINDOW-P (WINDOW)
   (EQ (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN)
       'IL:|Phone-Window-ButtonEventFn|))

(DEFUN FIND-WINDOW (TEST &OPTIONAL INCLUDE-HIDDEN-P)
   (DOLIST (WINDOW (ALL-WINDOWS INCLUDE-HIDDEN-P))
       (WHEN (FUNCALL TEST WINDOW)
             (RETURN WINDOW))))



(IL:* IL:|;;| "Window type for GRID-ICONS")


(DEF-WINDOW-TYPE :GRID-ICON-COMS-EDITOR :RECOGNIZER (LAMBDA (WINDOW)
                                                               (EQ (IL:WINDOWPROP WINDOW 
                                                                          'IL:BUTTONEVENTFN)
                                                                   
                                                                   '
                                                            IL:LOADED-FILES-ICON-WINDOW-BUTTONEVENTFN
                                                                   ))
   :ABSTRACTER (LAMBDA (WINDOW)
                      (DECLARE (IGNORE WINDOW))
                      NIL)
   :RECONSTITUTER (LAMBDA (DATA)
                         (DECLARE (IGNORE DATA)
                                (GLOBAL IL:LOADED-FILES-ICON-WINDOW))
                         IL:LOADED-FILES-ICON-WINDOW)
   :FILES (IL:GRID-ICONS IL:RANDOM-WINDOW-TYPES))



(IL:* IL:|;;| "special handlers for FILEWATCH.  these are somewhat broken")


(DEF-WINDOW-TYPE :FILE-WATCH :RECOGNIZER (LAMBDA (WINDOW)
                                                    (EQ (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN)
                                                        'IL:FW-BUTTONEVENTFN)))

(DEFUN FILE-WATCH-EXIT-FUNCTION (ROOM)
   (DECLARE (GLOBAL IL:|FW-Running?| IL:|FW-Anchor| IL:|FW-Position|))
   (WHEN (FBOUNDP 'IL:FILEWATCH)
       (COND
          (IL:|FW-Running?| (ROOM-PROP ROOM :FILE-WATCH-ON? T)
                 (ROOM-PROP ROOM :FILE-WATCH-ANCHOR IL:|FW-Anchor|)
                 (ROOM-PROP ROOM :FILE-WATCH-POSITION (EXTERNALIZE-POSITION IL:|FW-Position|))
                 (LET* ((CHANGED? NIL)
                        (NEW-PLACEMENTS (DELETE-IF #'(LAMBDA (PLACEMENT)
                                                            (AND (EQ (IL:WINDOWPROP (PLACEMENT-WINDOW
                                                                                     PLACEMENT)
                                                                            'IL:BUTTONEVENTFN)
                                                                     'IL:FW-BUTTONEVENTFN)
                                                                 (SETQ CHANGED? T)))
                                               (ROOM-PLACEMENTS ROOM))))
                       (WHEN CHANGED?
                           (SETF (ROOM-PLACEMENTS ROOM)
                                 NEW-PLACEMENTS)
                           (ROOM-CHANGED ROOM :PLACEMENTS)))
                 (IL:FILEWATCH :OFF)
                 (IL:PROCESS.RESULT (IL:FIND.PROCESS "FileWatcher")
                        T))
          (T (ROOM-PROP ROOM :FILE-WATCH-ON? NIL)
             (REMF (ROOM-PROPS ROOM)
                   :FILE-WATCH-ANCHOR)
             (REMF (ROOM-PROPS ROOM)
                   :FILE-WATCH-POSITION)))))

(DEFUN FILE-WATCH-ENTRY-FUNCTION (ROOM)
   (DECLARE (GLOBAL IL:|FW-Properties|))
   (WHEN (FBOUNDP 'IL:FILEWATCH)
       (LET ((POS (ROOM-PROP ROOM :FILE-WATCH-POSITION))
             (ANCHOR (ROOM-PROP ROOM :FILE-WATCH-ANCHOR)))
            (WHEN POS
                (SETF (GETF IL:|FW-Properties| 'IL:POSITION)
                      (INTERNALIZE-POSITION POS)))
            (WHEN ANCHOR
                (SETF (GETF IL:|FW-Properties| 'IL:ANCHOR)
                      ANCHOR))
            (WHEN (ROOM-PROP ROOM :FILE-WATCH-ON?)
                (IL:FILEWATCH :ON)
                (IL:BLOCK)))))

(PUSHNEW 'FILE-WATCH-EXIT-FUNCTION *ROOM-EXIT-FUNCTIONS*)

(PUSHNEW 'FILE-WATCH-ENTRY-FUNCTION *ROOM-ENTRY-FUNCTIONS*)
(IL:PUTPROPS IL:RANDOM-WINDOW-TYPES IL:COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (10066 10183 (ADDRESS-BOOK-WINDOW-P 10066 . 10183)) (10185 10319 (
PHONE-DIRECTORY-WINDOW-P 10185 . 10319)) (10321 10495 (FIND-WINDOW 10321 . 10495)) (11809 13397 (
FILE-WATCH-EXIT-FUNCTION 11809 . 13397)) (13399 14002 (FILE-WATCH-ENTRY-FUNCTION 13399 . 14002)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/RANDOM-WINDOW-TYPES.DFASL b/rooms/RANDOM-WINDOW-TYPES.DFASL
new file mode 100644
index 00000000..687804db
Binary files /dev/null and b/rooms/RANDOM-WINDOW-TYPES.DFASL differ
diff --git a/rooms/RANDOM-WINDOW-TYPES.LISTING b/rooms/RANDOM-WINDOW-TYPES.LISTING
new file mode 100644
index 00000000..1c580c2a
Binary files /dev/null and b/rooms/RANDOM-WINDOW-TYPES.LISTING differ
diff --git a/rooms/RANDOM-WINDOW-TYPES.TEDIT b/rooms/RANDOM-WINDOW-TYPES.TEDIT
new file mode 100644
index 00000000..370f8e17
Binary files /dev/null and b/rooms/RANDOM-WINDOW-TYPES.TEDIT differ
diff --git a/rooms/RELEASEEASYTEMPLATE.TEDIT b/rooms/RELEASEEASYTEMPLATE.TEDIT
new file mode 100644
index 00000000..107e5176
Binary files /dev/null and b/rooms/RELEASEEASYTEMPLATE.TEDIT differ
diff --git a/rooms/ROOMS b/rooms/ROOMS
new file mode 100644
index 00000000..e19a55fb
--- /dev/null
+++ b/rooms/ROOMS
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "ROOMS" (USE "LISP" "XCL") (SHADOW CLROOM))
)
(IL:FILECREATED " 5-Dec-2020 16:12:54" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS.;3| 2513   

      IL:|previous| IL:|date:| "17-Aug-90 12:28:18" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS.;1|)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMSCOMS)

(IL:RPAQQ IL:ROOMSCOMS
          ((IL:P (PROVIDE "ROOMS")
                 (EXPORT '(*ROOMS-SYSTEM-DATE*)
                        "ROOMS"))
           (FILE-ENVIRONMENTS IL:ROOMS)
           (IL:COMS (IL:P (PROCLAIM '(GLOBAL *ROOMS-SYSTEM-DATE*)))
                  (IL:E (SETQ *ROOMS-SYSTEM-DATE* (IL:DATE)))
                  (IL:VARS *ROOMS-SYSTEM-DATE*))
           (IL:FILES (IL:SYSLOAD)
                  
                  (IL:* IL:|;;| "load Rooms modules")

                  IL:ROOMS-D IL:ROOMS-CORE IL:ROOMS-WINDOW-HIDER IL:ROOMS-GEOMETRY IL:ROOMS-TEXT 
                  IL:ROOMS-WINDOW-TYPES IL:ROOMS-BUTTONS IL:ROOMS-BIOS IL:ROOMS-SUITES 
                  IL:ROOMS-INTERACTIVE IL:ROOMS-BACKGROUNDS IL:ROOMS-PLACEMENT-EDITOR 
                  IL:ROOMS-OVERVIEW 

                  (IL:* IL:|;;| "load appropriate window types")

                  IL:ROOMS-MEDLEY-WINDOW-TYPES)
           (IL:P (EVAL-WHEN (LOAD)
                        (UNLESS *CURRENT-ROOM*
                            
                            (IL:* IL:|;;| "bootstrap")

                            (RESET))))))

(PROVIDE "ROOMS")

(EXPORT '(*ROOMS-SYSTEM-DATE*)
       "ROOMS")

(DEFINE-FILE-ENVIRONMENT IL:ROOMS :COMPILER :COMPILE-FILE
   :PACKAGE (DEFPACKAGE "ROOMS" (:USE "LISP" "XCL")
                   (:SHADOW CL:ROOM))
   :READTABLE "XCL")

(PROCLAIM '(GLOBAL *ROOMS-SYSTEM-DATE*))

(IL:RPAQQ *ROOMS-SYSTEM-DATE* " 5-Dec-2020 16:12:54")

(IL:FILESLOAD (IL:SYSLOAD)
       IL:ROOMS-D IL:ROOMS-CORE IL:ROOMS-WINDOW-HIDER IL:ROOMS-GEOMETRY IL:ROOMS-TEXT 
       IL:ROOMS-WINDOW-TYPES IL:ROOMS-BUTTONS IL:ROOMS-BIOS IL:ROOMS-SUITES IL:ROOMS-INTERACTIVE 
       IL:ROOMS-BACKGROUNDS IL:ROOMS-PLACEMENT-EDITOR IL:ROOMS-OVERVIEW IL:ROOMS-MEDLEY-WINDOW-TYPES)

(EVAL-WHEN (LOAD)
       (UNLESS *CURRENT-ROOM*

           (IL:* IL:|;;| "bootstrap")

           (RESET)))
(IL:PUTPROPS IL:ROOMS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL)))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-BACKGROUNDS b/rooms/ROOMS-BACKGROUNDS
new file mode 100644
index 00000000..26fde0ca
--- /dev/null
+++ b/rooms/ROOMS-BACKGROUNDS
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:35:40" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-BACKGROUNDS.;2| 16393  

      IL:|previous| IL:|date:| "17-Aug-90 12:29:44" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-BACKGROUNDS.;1|)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMS-BACKGROUNDSCOMS)

(IL:RPAQQ IL:ROOMS-BACKGROUNDSCOMS
          (
           (IL:* IL:|;;| "code for painting background")

           (FILE-ENVIRONMENTS IL:ROOMS-BACKGROUNDS)
           (IL:P (EXPORT '(MAKE-BACKGROUND BACKGROUND-INTERNAL-FORM *DEFAULT-BACKGROUND-TEXT-FONT* 
                                 RENAISSANCE-BITMAP SQUARES-BITMAP TILE-BITMAP 
                                 INTERNALIZE-ALL-BACKGROUNDS))
                 (REQUIRE "ROOMS"))
           (IL:STRUCTURES BACKGROUND)
           (IL:FUNCTIONS MAKE-BACKGROUND INTERNALIZE-BACKGROUND INTERNALIZE-BACKGROUND-TEXT 
                  INTERNALIZE-ALL-BACKGROUNDS)
           (EVAL-WHEN (LOAD)
                  (IL:P (PUSHNEW 'INTERNALIZE-ALL-BACKGROUNDS *SCREEN-CHANGED-FUNCTIONS*)))
           (IL:VARIABLES *DEFAULT-BACKGROUND* *DEFAULT-BACKGROUND-TEXT-FONT*)
           (IL:FUNCTIONS PAINT-BACKGROUND FIND-BACKGROUNDS DRAW&FILL-BOX-WITHIN)
           (IL:VARIABLES *SCREEN-BITMAP*)
           (IL:VARIABLES RENAISSANCE-BITMAP SQUARES-BITMAP TILE-BITMAP)
           (IL:GLOBALVARS IL:WINDOWBACKGROUNDSHADE IL:WHOLESCREEN)))



(IL:* IL:|;;| "code for painting background")


(DEFINE-FILE-ENVIRONMENT IL:ROOMS-BACKGROUNDS :COMPILER :COMPILE-FILE
   :PACKAGE "ROOMS"
   :READTABLE "XCL")

(EXPORT '(MAKE-BACKGROUND BACKGROUND-INTERNAL-FORM *DEFAULT-BACKGROUND-TEXT-FONT* 
                RENAISSANCE-BITMAP SQUARES-BITMAP TILE-BITMAP INTERNALIZE-ALL-BACKGROUNDS))

(REQUIRE "ROOMS")

(DEFSTRUCT (BACKGROUND (:CONSTRUCTOR MAKE-BACKGROUND-INTERNAL))
   (EXTERNAL-FORM NIL :TYPE LIST :READ-ONLY T)

   (IL:* IL:|;;| "what the user sees")

   (INTERNAL-FORM NIL :TYPE LIST)

   (IL:* IL:|;;| "what PAINT-BACKGROUND operates on")

   )

(DEFUN MAKE-BACKGROUND (EXTERNAL-FORM)
   (MAKE-BACKGROUND-INTERNAL :EXTERNAL-FORM EXTERNAL-FORM :INTERNAL-FORM (INTERNALIZE-BACKGROUND
                                                                          EXTERNAL-FORM)))

(DEFUN INTERNALIZE-BACKGROUND (BACKGROUND)

   (IL:* IL:|;;| "internalize BACKGROUND")

   (MAPCAR #'(LAMBDA (PROP-LIST)
                    (CASE (CAR PROP-LIST)
                        (:WHOLE-SCREEN 
                           (CHECK-TYPE (SECOND PROP-LIST)
                                  (OR BITMAP TEXTURE))
                           (CHECK-TYPE (GETF PROP-LIST :BORDER)
                                  (OR NULL INTEGER))
                           (CHECK-TYPE (GETF PROP-LIST :BORDER-SHADE)
                                  (OR NULL TEXTURE))
                           `(:WHOLE-SCREEN ,(SECOND PROP-LIST)
                                   ,@(WHEN (GETF PROP-LIST :BORDER)
                                         `(:BORDER ,(GETF PROP-LIST :BORDER)))
                                   ,@(WHEN (GETF PROP-LIST :BORDER-SHADE)
                                         `(:BORDER-SHADE ,(GETF PROP-LIST :BORDER-SHADE)))))
                        (:REGION 
                           (CHECK-TYPE (GETF PROP-LIST :SHADE)
                                  (OR NULL BITMAP TEXTURE))
                           (CHECK-TYPE (GETF PROP-LIST :BORDER)
                                  (OR NULL INTEGER))
                           (CHECK-TYPE (GETF PROP-LIST :BORDER-SHADE)
                                  (OR NULL TEXTURE))
                           `(:REGION ,(INTERNALIZE-REGION (SECOND PROP-LIST))
                                   ,@(WHEN (GETF PROP-LIST :SHADE)
                                         `(:SHADE ,(GETF PROP-LIST :SHADE)))
                                   ,@(WHEN (GETF PROP-LIST :BORDER)
                                         `(:BORDER ,(GETF PROP-LIST :BORDER)))
                                   ,@(WHEN (GETF PROP-LIST :BORDER-SHADE)
                                         `(:BORDER-SHADE ,(GETF PROP-LIST :BORDER-SHADE)))))
                        (:TEXT (LIST :TEXT (LET ((*DEFAULT-TEXT-FONT* *DEFAULT-BACKGROUND-TEXT-FONT*)
                                                 )
                                                (INTERNALIZE-BACKGROUND-TEXT PROP-LIST))))))
          (EVAL-WALK BACKGROUND)))

(DEFUN INTERNALIZE-BACKGROUND-TEXT (PROP-LIST)
   (MAKE-TEXT :STRING (GETF PROP-LIST :TEXT)
          :POSITION
          (INTERNALIZE-POSITION (OR (GETF PROP-LIST :POSITION)
                                    (MAKE-POSITION 0 0)))
          :ALIGNMENT
          (OR (GETF PROP-LIST :ALIGNMENT)
              :LEFT-BOTTOM)
          :FONT
          (LET ((FONT (GETF PROP-LIST :FONT)))
               (IF FONT
                   (IL:FONTCREATE FONT)
                   *DEFAULT-TEXT-FONT*))
          :SHADOWS
          (GETF PROP-LIST :SHADOWS T)))

(DEFUN INTERNALIZE-ALL-BACKGROUNDS ()

   (IL:* IL:|;;| "do all the named rooms")

   (DO-ROOMS (ROOM)
          (LET ((BACKGROUND (ROOM-BACKGROUND ROOM)))
               (SETF (BACKGROUND-INTERNAL-FORM BACKGROUND)
                     (INTERNALIZE-BACKGROUND (BACKGROUND-EXTERNAL-FORM BACKGROUND)))))

   (IL:* IL:|;;| "do the Overview too (yes, this is ugly)")

   (LET ((BACKGROUND (ROOM-BACKGROUND *OVERVIEW-ROOM*)))
        (SETF (BACKGROUND-INTERNAL-FORM BACKGROUND)
              (INTERNALIZE-BACKGROUND (BACKGROUND-EXTERNAL-FORM BACKGROUND))))
   NIL)
(EVAL-WHEN (LOAD)

(PUSHNEW 'INTERNALIZE-ALL-BACKGROUNDS *SCREEN-CHANGED-FUNCTIONS*)
)

(DEFGLOBALPARAMETER *DEFAULT-BACKGROUND* (MAKE-BACKGROUND `((:WHOLE-SCREEN 
                                                                           ,IL:WINDOWBACKGROUNDSHADE)
                                                                    )))

(DEFPARAMETER *DEFAULT-BACKGROUND-TEXT-FONT* (IL:FONTCREATE 'IL:TIMESROMAND 36))

(DEFUN PAINT-BACKGROUND (ROOM DSP &KEY (SCALE *ONE-TO-ONE*)
                                  NO-TEXT CLIPPING-REGION)
   (DOLIST (BACKGROUND (FIND-BACKGROUNDS ROOM))
       (DOLIST (SPEC (BACKGROUND-INTERNAL-FORM BACKGROUND))
           (CASE (FIRST SPEC)
               (:WHOLE-SCREEN (DRAW&FILL-BOX-WITHIN (SCALE-REGION IL:WHOLESCREEN SCALE)
                                     DSP :SHADE (SECOND SPEC)
                                     :BORDER-WIDTH
                                     (SCALE-WIDTH (GETF SPEC :BORDER 0)
                                            SCALE)
                                     :BORDER-SHADE
                                     (GETF SPEC :BORDER-SHADE IL:BLACKSHADE)
                                     :CLIPPING-REGION CLIPPING-REGION))
               (:REGION (DRAW&FILL-BOX-WITHIN (SCALE-REGION (GETF SPEC :REGION)
                                                         SCALE)
                               DSP :SHADE (GETF SPEC :SHADE)
                               :BORDER-WIDTH
                               (SCALE-WIDTH (GETF SPEC :BORDER 0)
                                      SCALE)
                               :BORDER-SHADE
                               (GETF SPEC :BORDER-SHADE IL:BLACKSHADE)
                               :CLIPPING-REGION CLIPPING-REGION))
               (:TEXT (UNLESS NO-TEXT
                          (DISPLAY-TEXT (SECOND SPEC)
                                 DSP :SCALE SCALE)))))))

(DEFUN FIND-BACKGROUNDS (ROOM)

(IL:* IL:|;;;| "returns the list of backgrounds which apply to ROOM")

   (LET (BACKGROUNDS FOUND-WHOLE-SCREEN?)
        (DO-INCLUSIONS (ROOM ROOM)
               (LET ((BACKGROUND (ROOM-BACKGROUND ROOM)))
                    (PUSH BACKGROUND BACKGROUNDS)

                    (IL:* IL:|;;| "stop when we see one which paints the whole background")

                    (WHEN (ASSOC :WHOLE-SCREEN BACKGROUND :TEST 'EQ)
                        (SETQ FOUND-WHOLE-SCREEN? T)
                        (RETURN-FROM DO-INCLUSIONS))))
        (UNLESS FOUND-WHOLE-SCREEN? (PUSH *DEFAULT-BACKGROUND* BACKGROUNDS))
        BACKGROUNDS))

(DEFUN DRAW&FILL-BOX-WITHIN (REGION DSP &KEY (SHADE IL:WHITESHADE)
                                       (BORDER-WIDTH 0)
                                       CLIPPING-REGION
                                       (BORDER-SHADE IL:BLACKSHADE))
   (LET ((LEFT (REGION-LEFT REGION))
         (BOTTOM (REGION-BOTTOM REGION))
         (WIDTH (REGION-WIDTH REGION))
         (HEIGHT (REGION-HEIGHT REGION)))
        (IF (OR (NULL BORDER-WIDTH)
                (ZEROP BORDER-WIDTH))
            (PAINT-REGION DSP REGION SHADE CLIPPING-REGION)
            (LET ((TOP (+ BOTTOM HEIGHT))
                  (RIGHT (+ LEFT WIDTH))
                  (INSIDE-LEFT (+ LEFT BORDER-WIDTH))
                  (INSIDE-WIDTH (- WIDTH BORDER-WIDTH)))
                 (PAINT-REGION DSP (MAKE-REGION :LEFT INSIDE-LEFT :BOTTOM (+ BOTTOM BORDER-WIDTH)
                                          :WIDTH INSIDE-WIDTH :HEIGHT (- HEIGHT BORDER-WIDTH))
                        SHADE CLIPPING-REGION)

                 (IL:* IL:|;;| "up left")

                 (IL:BLTSHADE BORDER-SHADE DSP LEFT BOTTOM BORDER-WIDTH HEIGHT BORDER-WIDTH NIL 
                        CLIPPING-REGION)

                 (IL:* IL:|;;| "across top")

                 (IL:BLTSHADE BORDER-SHADE DSP INSIDE-LEFT (- TOP BORDER-WIDTH)
                        INSIDE-WIDTH BORDER-WIDTH NIL CLIPPING-REGION)

                 (IL:* IL:|;;| "up the right")

                 (IL:BLTSHADE BORDER-SHADE DSP (- RIGHT BORDER-WIDTH)
                        BOTTOM BORDER-WIDTH (- HEIGHT BORDER-WIDTH)
                        NIL CLIPPING-REGION)

                 (IL:* IL:|;;| "across the bottom")

                 (IL:BLTSHADE BORDER-SHADE DSP INSIDE-LEFT BOTTOM INSIDE-WIDTH BORDER-WIDTH NIL 
                        CLIPPING-REGION)))))

(DEFGLOBALVAR *SCREEN-BITMAP* (IL:SCREENBITMAP))

(DEFGLOBALVAR RENAISSANCE-BITMAP 
                                     '#*(74 73)JJJJJJJJJJJJJJJJJJH@EEEEEEEEEEEEEEEEEED@JJJJJJJJJJJJJJJJJJH@EEEEEEEEEEEEEEEEEED@JOOOOOOOOOOOOOOOONH@EGOOOOOOOOOOOOOOOMD@JOOOOOOOOOOOOOOOOFH@EGOOOOOOOOOOOOOONED@JOJJJJJJJJJJJJJJLFH@EGMEEEEEEEEEEEEEDED@JOJJJJJJJJJJJJJJLFH@EGMEEEEEEEEEEEEEDED@JOJJJJJJJJJJJJJJLFH@EGMEEEEEEEEEEEEEDED@JOJJJJJJJJJJJJJJLFH@EGMEEEEEEEEEEEEEDED@JOJJOOOOOOOOOONJLFH@EGMEGOOOOOOOOOMEDED@JOJJOOOOOOOOOOFJLFH@EGMEGOOOOOOOONEEDED@JOJJOJJJJJJJJLFJLFH@EGMEGMEEEEEEEDEEDED@JOJJOJJJJJJJJLFJLFH@EGMEGMEEEEEEEDEEDED@JOJJOJJJJJJJJLFJLFH@EGMEGMEEEEEEEDEEDED@JOJJOJJJJJJJJLFJLFH@EGMEGMEEEEEEEDEEDED@JOJJOJJOOOOJJLFJLFH@EGMEGMEOOOOMEDEEDED@JOJJOJJOOONJJLFJLFH@EGMEGMEOOOLMEDEEDED@JOJJOJJOJJHJJLFJLFH@EGMEGMEOEEHMEDEEDED@JOJJOJJOJJHJJLFJLFH@EGMEGMEOEEHMEDEEDED@JOJJOJJOJJHJJLFJLFH@EGMEGMEOEEHMEDEEDED@JOJJOJJOJJHJJLFJLFH@EGMEGMEOEEHMEDEEDED@JOJJOJJOOOHJJLFJLFH@EGMEGMEO@@DMEDEEDED@JOJJOJJN@@BJJLFJLFH@EGMEGMEL@@@MEDEEDED@JOJJOJJOOOOJJLFJLFH@EGMEGMEEEEEEEDEEDED@JOJJOJJJJJJJJLFJLFH@EGMEGMEEEEEEEDEEDED@JOJJOJJJJJJJJLFJLFH@EGMEGMEEEEEEEDEEDED@JOJJOJJJJJJJJLFJLFH@EGMEGMEEEEEEEDEEDED@JOJJOOOOOOOOOLFJLFH@EGMEGH@@@@@@@BEEDED@JOJJO@@@@@@@@AFJLFH@EGMEF@@@@@@@@@EEDED@JOJJOOOOOOOOOONJLFH@EGMEEEEEEEEEEEEEDED@JOJJJJJJJJJJJJJJLFH@EGMEEEEEEEEEEEEEDED@JOJJJJJJJJJJJJJJLFH@EGMEEEEEEEEEEEEEDED@JOJJJJJJJJJJJJJJLFH@EGMEEEEEEEEEEEEEDED@JOOOOOOOOOOOOOOOLFH@EGH@@@@@@@@@@@@@BED@JO@@@@@@@@@@@@@@AFH@EF@@@@@@@@@@@@@@@ED@JOOOOOOOOOOOOOOOONH@EEEEEEEEEEEEEEEEEED@JJJJJJJJJJJJJJJJJJH@EEEEEEEEEEEEEEEEEED@JJJJJJJJJJJJJJJJJJH@
)

(DEFGLOBALPARAMETER SQUARES-BITMAP 
                                       '#*(72 72)JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@GOOOMOOOOGOOOMOOOO@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@OOKOOONOOOOKOOONOO@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@GOOOMOOOOGOOOMOOOO@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@OOKOOONOOOOKOOONOO@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@GOOOMOOOOGOOOMOOOO@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@OOKOOONOOOOKOOONOO@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@GOOOMOOOOGOOOMOOOO@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@MEEEGEEEEMEEEGEEEE@@JJNJJJKJJJJNJJJKJJ@@OOKOOONOOOOKOOONOO@@
)

(DEFGLOBALPARAMETER TILE-BITMAP 
                                    '#*(100 100)@@@@@@@@@@@@D@@@@@@@@@@@A@@@@@@@@@@@@@@@L@@@@@@@@@@@C@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@COOOOOOOOOOOLOOOOOOOOOOOO@@@GOOOOOOOOOOOMOOOOOOOOOOOO@@@@@@@@@@@@@@@D@@@@@@@@@@@A@@@@@@@@@@@@@@@D@@@@@@@@@@@A@@@@@@@@@@@@@@@L@@@@@@@@@@@C@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@BJJJJJJJJJJJLJJJJJJJJJJJK@@@AEEEEEEEEEEELEEEEEEEEEEEG@@@COOOOOOOOOOOLOOOOOOOOOOOO@@@GOOOOOOOOOOOMOOOOOOOOOOOO@@@@@@@@@@@@@@@D@@@@@@@@@@@A@@@
)
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY

(IL:GLOBALVARS IL:WINDOWBACKGROUNDSHADE IL:WHOLESCREEN)
)
(IL:PUTPROPS IL:ROOMS-BACKGROUNDS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (2211 2445 (MAKE-BACKGROUND 2211 . 2445)) (2447 4605 (INTERNALIZE-BACKGROUND 2447 . 
4605)) (4607 5161 (INTERNALIZE-BACKGROUND-TEXT 4607 . 5161)) (5163 5742 (INTERNALIZE-ALL-BACKGROUNDS 
5163 . 5742)) (6176 7664 (PAINT-BACKGROUND 6176 . 7664)) (7666 8335 (FIND-BACKGROUNDS 7666 . 8335)) (
8337 10138 (DRAW&FILL-BOX-WITHIN 8337 . 10138)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-BACKGROUNDS.DFASL b/rooms/ROOMS-BACKGROUNDS.DFASL
new file mode 100644
index 00000000..2bfa2ca5
Binary files /dev/null and b/rooms/ROOMS-BACKGROUNDS.DFASL differ
diff --git a/rooms/ROOMS-BIOS b/rooms/ROOMS-BIOS
new file mode 100644
index 00000000..5862387e
--- /dev/null
+++ b/rooms/ROOMS-BIOS
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:35:15" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-BIOS.;2| 7337   

      IL:|previous| IL:|date:| "17-Aug-90 12:31:56" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-BIOS.;1|)


; Copyright (c) 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMS-BIOSCOMS)

(IL:RPAQQ IL:ROOMS-BIOSCOMS
          (
           (IL:* IL:|;;| "button image objects")

           (IL:FILES (IL:SYSLOAD)
                  IL:ROOMS-BUTTONS)
           (FILE-ENVIRONMENTS IL:ROOMS-BIOS)
           (IL:P (EXPORT '(MAKE-BIO *BIO-SELECTION-BORDER*)
                        "ROOMS"))
           (IL:VARIABLES *BIO-SELECTION-BORDER*)
           (IL:FUNCTIONS MAKE-BIO BIO-BUTTON BIO-COPYFN BIO-IMAGEBOXFN BIO-PUTFN IL:BIO-GETFN 
                  BIO-DISPLAYFN BIO-BUTTONEVENTINFN BIO-BUTTONEVENTINFN-INTERNAL)
           (IL:VARIABLES *BIO-IMAGEFNS*)))



(IL:* IL:|;;| "button image objects")


(IL:FILESLOAD (IL:SYSLOAD)
       IL:ROOMS-BUTTONS)

(DEFINE-FILE-ENVIRONMENT IL:ROOMS-BIOS :COMPILER :COMPILE-FILE
   :PACKAGE "ROOMS"
   :READTABLE "XCL")

(EXPORT '(MAKE-BIO *BIO-SELECTION-BORDER*)
       "ROOMS")

(DEFGLOBALVAR *BIO-SELECTION-BORDER* 4
   "Width of mouse-insensitive strip around outside edge of button image objects")

(DEFUN MAKE-BIO (BUTTON)
   (CHECK-TYPE BUTTON BUTTON)
   (IL:IMAGEOBJCREATE BUTTON *BIO-IMAGEFNS*))

(DEFMACRO BIO-BUTTON (BIO)
   `(IL:IMAGEOBJPROP ,BIO 'IL:OBJECTDATUM))

(DEFUN BIO-COPYFN (BIO SOURCE DESTINATION)
   (MAKE-BIO (COPY-BUTTON (BIO-BUTTON BIO))))

(DEFUN BIO-IMAGEBOXFN (BIO IMAGE-STREAM CURRENT-X RIGHT-MARGIN)
   (LET ((BUTTON (BIO-BUTTON BIO))
         (SCALE (IL:DSPSCALE NIL IMAGE-STREAM)))
        (UPDATE-BUTTON BUTTON)
        (IL:|create| IL:IMAGEBOX
               IL:XSIZE IL:_ (* (BUTTON-WIDTH BUTTON)
                                SCALE)
               IL:YSIZE IL:_ (* (BUTTON-HEIGHT BUTTON)
                                SCALE)
               IL:YDESC IL:_ (* (IL:FONTDESCENT (TEXT-FONT (BUTTON-TEXT BUTTON)))
                                SCALE)
               IL:XKERN IL:_ 0)))

(DEFUN BIO-PUTFN (BIO FILE-STREAM)
   (LET ((*PRINT-PRETTY* NIL)
         (*PRINT-ARRAY* T)
         (*PRINT-STRUCTURE* T)
         (*PACKAGE* (FIND-PACKAGE "USER"))
         (*PRINT-BASE* 10)
         (*READTABLE* (IL:FIND-READTABLE "LISP")))
        (PRINT (EXTERNALIZE-BUTTON (BIO-BUTTON BIO))
               FILE-STREAM)))

(DEFUN IL:BIO-GETFN (FILE-STREAM)

   (IL:* IL:|;;| "TEdit presumes GETFNS are in package IL.  sigh.")

   (MAKE-BIO (APPLY #'MAKE-BUTTON (LET ((*PACKAGE* (FIND-PACKAGE "USER"))
                                            (*READ-BASE* 10)
                                            (*READTABLE* (IL:FIND-READTABLE "LISP")))
                                           (READ FILE-STREAM)))))

(DEFUN BIO-DISPLAYFN (BIO IMAGE-STREAM IMAGE-STREAM-TYPE HOST-STREAM)
   (LET ((BUTTON (BIO-BUTTON BIO)))
        (UPDATE-BUTTON BUTTON)
        (LET* ((WIDTH (BUTTON-WIDTH BUTTON))
               (HEIGHT (BUTTON-HEIGHT BUTTON))
               (SCRATCH (IL:DSPCREATE (IL:BITMAPCREATE WIDTH HEIGHT))))

              (IL:* IL:|;;| "this rather crude approach solves lots of scaling & offset problems")

              (DISPLAY-BUTTON BUTTON SCRATCH :NO-UPDATE T :WIDTH WIDTH :HEIGHT HEIGHT)
              (IL:BITBLT SCRATCH 0 0 IMAGE-STREAM (IL:DSPXPOSITION NIL IMAGE-STREAM)

                     (IL:* IL:|;;| "adjust for descent")

                     (- (IL:DSPYPOSITION NIL IMAGE-STREAM)
                        (* (IL:FONTDESCENT (TEXT-FONT (BUTTON-TEXT BUTTON)))
                           (IL:DSPSCALE NIL IMAGE-STREAM)))))))

(DEFUN BIO-BUTTONEVENTINFN (BIO DSP)
   (LET ((BUTTON (BIO-BUTTON BIO)))
        (IF (UPDATE-BUTTON BUTTON)
            'IL:CHANGED
            (LET ((X-OFFSET (IL:DSPXOFFSET NIL DSP))
                  (Y-OFFSET (IL:DSPYOFFSET NIL DSP))
                  (CLIPPING-REGION (IL:DSPCLIPPINGREGION NIL DSP)))

                 (IL:* IL:|;;| "applications don't always adjust coordinates so we're at 0,0 but they are good about setting the clipping region.  we move 0,0 to the bottom-left of the clipping region.")

                 (UNWIND-PROTECT
                     (PROGN (IL:DSPXOFFSET (+ X-OFFSET (REGION-LEFT CLIPPING-REGION))
                                   DSP)
                            (IL:DSPYOFFSET (+ Y-OFFSET (REGION-BOTTOM CLIPPING-REGION))
                                   DSP)
                            (IL:DSPCLIPPINGREGION (IL:CREATEREGION 0 0 (REGION-WIDTH CLIPPING-REGION)
                                                         (REGION-HEIGHT CLIPPING-REGION))
                                   DSP)
                            (WHEN (AND (IL:LASTMOUSESTATE (OR IL:LEFT IL:MIDDLE))
                                       (IL:INSIDEP (MAKE-REGION :LEFT *BIO-SELECTION-BORDER* :BOTTOM
                                                          *BIO-SELECTION-BORDER* :WIDTH
                                                          (- (BUTTON-WIDTH BUTTON)
                                                             (* *BIO-SELECTION-BORDER* 2))
                                                          :HEIGHT
                                                          (- (BUTTON-HEIGHT BUTTON)
                                                             (* *BIO-SELECTION-BORDER* 2)))
                                              (IL:LASTMOUSEX DSP)
                                              (IL:LASTMOUSEY DSP)))
                                  (BIO-BUTTONEVENTINFN-INTERNAL BIO DSP)))
                     (IL:DSPXOFFSET X-OFFSET DSP)
                     (IL:DSPYOFFSET Y-OFFSET DSP)
                     (IL:DSPCLIPPINGREGION CLIPPING-REGION DSP))))))

(DEFUN BIO-BUTTONEVENTINFN-INTERNAL (BIO DSP)
   (LET ((BUTTON (BIO-BUTTON BIO)))
        (IF (AND (IL:LASTMOUSESTATE (IL:ONLY IL:MIDDLE))
                 (NOT (BUTTON-PROP BUTTON :PROTECTED?)))
            (CASE (MENU '(("Edit Button" :EDIT "Edit this button")
                          ("Copy to Screen" :COPY "Copy this button to the screen ")))
                (:EDIT (LET ((NEW-BUTTON (EDIT-BUTTON BUTTON)))
                            (UNLESS (EQ NEW-BUTTON BUTTON)
                                (IL:IMAGEOBJPROP BIO 'IL:OBJECTDATUM NEW-BUTTON)
                                'IL:CHANGED)))
                (:COPY 
                   (MAKE-BUTTON-WINDOW (COPY-BUTTON BUTTON))
                   NIL))
            (WHEN (AND (BUTTON-TRACK-MOUSE BUTTON DSP)
                       (UPDATE-BUTTON BUTTON))

                (IL:* IL:|;;| "button's action caused it to need redisplay")

                'IL:CHANGED))))

(DEFGLOBALPARAMETER *BIO-IMAGEFNS* (IL:IMAGEFNSCREATE 'BIO-DISPLAYFN 'BIO-IMAGEBOXFN 'BIO-PUTFN
                                              'IL:BIO-GETFN
                                              'BIO-COPYFN
                                              'BIO-BUTTONEVENTINFN))
(IL:PUTPROPS IL:ROOMS-BIOS IL:COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (1445 1549 (MAKE-BIO 1445 . 1549)) (1627 1727 (BIO-COPYFN 1627 . 1727)) (1729 2294 (
BIO-IMAGEBOXFN 1729 . 2294)) (2296 2630 (BIO-PUTFN 2296 . 2630)) (2632 3034 (IL:BIO-GETFN 2632 . 3034)
) (3036 3884 (BIO-DISPLAYFN 3036 . 3884)) (3886 5997 (BIO-BUTTONEVENTINFN 3886 . 5997)) (5999 6934 (
BIO-BUTTONEVENTINFN-INTERNAL 5999 . 6934)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-BIOS.DFASL b/rooms/ROOMS-BIOS.DFASL
new file mode 100644
index 00000000..e78f8c06
Binary files /dev/null and b/rooms/ROOMS-BIOS.DFASL differ
diff --git a/rooms/ROOMS-BUTTONS b/rooms/ROOMS-BUTTONS
new file mode 100644
index 00000000..f76a5acc
--- /dev/null
+++ b/rooms/ROOMS-BUTTONS
@@ -0,0 +1,2 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "ROOMS" (USE "LISP" "XCL") (SHADOW CLROOM))
)
(IL:FILECREATED " 5-Dec-2020 16:35:05" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-BUTTONS.;3| 58830  

      IL:|previous| IL:|date:| "17-Aug-90 12:33:51" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-BUTTONS.;2|)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMS-BUTTONSCOMS)

(IL:RPAQQ IL:ROOMS-BUTTONSCOMS
          ((FILE-ENVIRONMENTS IL:ROOMS-BUTTONS)
           (IL:FILES (IL:SYSLOAD)
                  IL:ROOMS-D IL:ROOMS-TEXT IL:ROOMS-BIOS)
           (IL:P (EXPORT '(BUTTON *DEFAULT-BUTTON-TYPE* DEF-BUTTON-TYPE MAKE-BUTTON BUTTON-PROP 
                                 *BUTTON-HELP-DELAY* *BUTTON-SELECTION-SHADE* MAKE-BUTTON-WINDOW 
                                 SET-BUTTON-WINDOW-TEXT-STRING WITH-BUTTON *DEFAULT-BUTTON-SHADOWS* 
                                 MAKE-EAST-WEST-BITMAP MAKE-NORTH-SOUTH-BITMAP MAKE-NSEW-BITMAP)
                        "ROOMS"))
           (IL:COMS                                          (IL:* IL:\; "button types")
                  (IL:DEFINE-TYPES IL:BUTTON-TYPES)
                  (IL:STRUCTURES BUTTON-TYPE)
                  (IL:VARIABLES *BUTTON-TYPES* *DEFAULT-BUTTON-TYPE*)
                  (IL:FUNCTIONS DEF-BUTTON-TYPE BUTTON-TYPE-PROP SELECT-BUTTON-TYPE BUTTON-TYPE-NAMED
                         )
                  (IL:SEDIT-FORMATS DEF-BUTTON-TYPE))
           (IL:COMS                                          (IL:* IL:\; "the button object")
                  (IL:STRUCTURES BUTTON UPDATED-BUTTON MARGINS)
                  (IL:VARIABLES *DEFAULT-BUTTON-SHADOWS*)
                  (IL:FUNCTIONS                              (IL:* IL:\; "core code")
                         MAKE-BUTTON COPY-BUTTON DISPLAY-BUTTON UPDATE-BUTTON SET-BUTTON-TEXT-STRING
                         BUTTON-PROP)
                  (IL:FUNCTIONS                              (IL:* IL:\; "text")
                         SET-BUTTON-TEXT-STRING COMPUTE-BUTTON-TEXT-POSITION BUTTON-TEXT-X-COORD 
                         BUTTON-TEXT-Y-COORD TEXT-FROM-TEXT-FORM)
                  (IL:FUNCTIONS                              (IL:* IL:\; "mouse code")
                         BUTTON-TRACK-MOUSE PERFORM-BUTTON-ACTION EDIT-BUTTON BUTTON-COPY-SELECTED 
                         SHADE-BUTTON PRINT-BUTTON-HELP))
           (IL:COMS                                          (IL:* IL:\; "button windows")
                  (IL:VARIABLES *BUTTON-HELP-DELAY* *BUTTON-SELECTION-SHADE*)
                  (IL:FUNCTIONS MAKE-BUTTON-WINDOW BW-REPAINTFN BW-TOTOPFN BW-BUTTONEVENTFN 
                         BW-BUTTONEVENTFN-INTERNAL SET-BUTTON-WINDOW-TEXT-STRING 
                         MAYBE-RESIZE-BUTTON-WINDOW BW-SCREEN-CHANGED-FUNCTION)
                  (IL:VARIABLES 

                         (IL:* IL:|;;| 
          "this variable also on ROOMS-CORE, but here so we can be loaded w/o loading all of rooms")

                         *SCREEN-CHANGED-FUNCTIONS*)
                  (IL:P (PUSHNEW 'BW-SCREEN-CHANGED-FUNCTION *SCREEN-CHANGED-FUNCTIONS*)))
           (IL:COMS                                          (IL:* IL:\; "button bitmaps")
                  (IL:STRUCTURES NORTH-SOUTH-BITMAP EAST-WEST-BITMAP NSEW-BITMAP)
                  (IL:FUNCTIONS DISPLAY-BUTTON-IMAGE DISPLAY-BUTTON-MASK BUTTON-WIDTH BUTTON-HEIGHT 
                         BUTTON-BITMAP-BITBLT EW-BITBLT NS-BITBLT NSEW-BITBLT PAINT-REGION))
                                                             (IL:* IL:\; "externalization")
           (IL:FUNCTIONS EDIT-BUTTON-WINDOW EXTERNALIZE-BUTTON EXTERNALIZE-FONT)
           (IL:FUNCTIONS WITH-BUTTON)
           (IL:BUTTON-TYPES :DOOR :SHADOWED :TRANSPARENT :PORTHOLE :ARK :ROUND-ARK :STRETCHY-ARK 
                  :STRETCHY-ROUND-ARK)
           (IL:GLOBALVARS IL:MENUHELDWAIT)))

(DEFINE-FILE-ENVIRONMENT IL:ROOMS-BUTTONS :COMPILER :COMPILE-FILE
   :PACKAGE (DEFPACKAGE "ROOMS" (:USE "LISP" "XCL")
                   (:SHADOW CL:ROOM))
   :READTABLE "XCL")

(IL:FILESLOAD (IL:SYSLOAD)
       IL:ROOMS-D IL:ROOMS-TEXT IL:ROOMS-BIOS)

(EXPORT '(BUTTON *DEFAULT-BUTTON-TYPE* DEF-BUTTON-TYPE MAKE-BUTTON BUTTON-PROP *BUTTON-HELP-DELAY* 
                *BUTTON-SELECTION-SHADE* MAKE-BUTTON-WINDOW SET-BUTTON-WINDOW-TEXT-STRING WITH-BUTTON
                *DEFAULT-BUTTON-SHADOWS* MAKE-EAST-WEST-BITMAP MAKE-NORTH-SOUTH-BITMAP 
                MAKE-NSEW-BITMAP)
       "ROOMS")



(IL:* IL:\; "button types")


(DEF-DEFINE-TYPE IL:BUTTON-TYPES "Button types"
   :UNDEFINER (LAMBDA (NAME)
                     (REMHASH NAME *BUTTON-TYPES*)))

(DEFSTRUCT BUTTON-TYPE
   NAME

   (IL:* IL:|;;| "name of the type")

   IMAGE-BITMAP

   (IL:* IL:|;;| "the background for the text")

   MASK-BITMAP

   (IL:* IL:|;;| "to allow non-rectangular buttons.  should be a bitmap the same size as IMAGE-BITMAP.  designates the set of bits of IMAGE-BITMAP which are the region to be displayed. ")

   (MARGINS (MAKE-MARGINS))

   (IL:* IL:|;;| "a MARGINS record.")

   PROPS)

(DEFGLOBALVAR *BUTTON-TYPES* (MAKE-HASH-TABLE :TEST 'EQ))

(DEFPARAMETER *DEFAULT-BUTTON-TYPE* :SHADOWED)

(DEFDEFINER DEF-BUTTON-TYPE IL:BUTTON-TYPES (NAME &REST REST-KEYS &KEY IMAGE MASK (MARGINS (
                                                                                         MAKE-MARGINS
                                                                                                ))
                                                      &ALLOW-OTHER-KEYS)
   `(SETF (GETHASH ',NAME *BUTTON-TYPES*)
          (MAKE-BUTTON-TYPE :NAME ',NAME :IMAGE-BITMAP ',IMAGE :MASK-BITMAP ',MASK :MARGINS
                 ',MARGINS :PROPS ',(LET ((PROPS (COPY-LIST REST-KEYS)))
                                         (DOLIST (KEYWORD '(:IMAGE :MASK :MARGINS))
                                             (REMF PROPS KEYWORD))
                                         PROPS))))

(DEFMACRO BUTTON-TYPE-PROP (BUTTON-TYPE PROP &OPTIONAL (NEW-VALUE NIL NEW-VALUE-SUPPLIED))
   (IF NEW-VALUE-SUPPLIED
       `(SETF (GETF (BUTTON-TYPE-PROPS ,BUTTON-TYPE)
                    ,PROP)
              ,NEW-VALUE)
       `(GETF (BUTTON-TYPE-PROPS ,BUTTON-TYPE)
              ,PROP)))

(DEFUN SELECT-BUTTON-TYPE (&OPTIONAL (REASON "Select Button Type"))

   (IL:* IL:|;;| "returns the name of a button type or NIL")

   (MENU
    (WITH-COLLECTION
     (DOLIST (TYPE (SORT (WITH-COLLECTION (MAPHASH #'(LAMBDA (NAME TYPE)
                                                            (COLLECT TYPE))
                                                 *BUTTON-TYPES*))
                         #'STRING-LESSP :KEY #'BUTTON-TYPE-NAME))
         (LET ((NAME (BUTTON-TYPE-NAME TYPE)))
              (COLLECT `(,(OR (BUTTON-TYPE-PROP TYPE :SAMPLE-IMAGE)

                              (IL:* IL:|;;| "cache sample images on button type")

                              (LET* ((BUTTON (MAKE-BUTTON :TYPE NAME :TEXT
                                                    (LET ((*PRINT-CASE* :CAPITALIZE)
                                                          (*READTABLE* (IL:FIND-READTABLE "XCL")))
                                                         (PRINC-TO-STRING NAME))))
                                     (IMAGE (IL:BITMAPCREATE (BUTTON-WIDTH BUTTON)
                                                   (BUTTON-HEIGHT BUTTON))))
                                    (DISPLAY-BUTTON BUTTON IMAGE)
                                    (BUTTON-TYPE-PROP TYPE :SAMPLE-IMAGE IMAGE)
                                    IMAGE))
                         ',NAME)))))
    REASON))

(DEFMACRO BUTTON-TYPE-NAMED (TYPE-NAME)
   `(GETHASH ,TYPE-NAME *BUTTON-TYPES*))

(SEDIT:DEF-LIST-FORMAT DEF-BUTTON-TYPE :ARGS (NIL :KEYWORD NIL)
   :INDENT (1))



(IL:* IL:\; "the button object")


(DEFSTRUCT (BUTTON (:CONSTRUCTOR MAKE-BUTTON-INTERNAL)
                       (:PRINT-FUNCTION (LAMBDA (BUTTON STREAM DEPTH)
                                               (LET ((TYPE (BUTTON-TYPE BUTTON))
                                                     (TEXT (BUTTON-TEXT BUTTON)))
                                                    (FORMAT STREAM "#<~A button ~S>"
                                                           (TYPECASE TYPE
                                                               (BUTTON-TYPE (BUTTON-TYPE-NAME TYPE))
                                                               (T TYPE))
                                                           (TYPECASE (BUTTON-TEXT BUTTON)
                                                               (TEXT (TEXT-STRING TEXT))
                                                               (T TEXT))))))
                       (:COPIER COPY-BUTTON-INTERNAL))
   (TYPE *DEFAULT-BUTTON-TYPE* :TYPE BUTTON-TYPE)

   (IL:* IL:|;;| "a BUTTON-TYPE structure")

   (TEXT NIL :TYPE TEXT)

   (IL:* IL:|;;| "a TEXT structure")

   (ACTION NIL :TYPE LIST)

   (IL:* IL:|;;| "form to EVAL when this button is pressed")

   (HELP-STRING NIL :TYPE STRING)

   (IL:* IL:|;;| "printed when button is held")

   (INVERTED? NIL :TYPE (MEMBER T NIL))

   (IL:* IL:|;;| "if true, button image will be inverted")

   (%SELECTED? NIL :TYPE (MEMBER T NIL))

   (IL:* IL:|;;| "non-nil when button appears selected")

   %MASK %IMAGE 

   (IL:* IL:|;;| "caches used by redisplay")

   (PROPS NIL :TYPE LIST))

(DEFSTRUCT (UPDATED-BUTTON (:INCLUDE BUTTON)
                               (:PRINT-FUNCTION (LAMBDA (BUTTON STREAM DEPTH)
                                                       (FORMAT STREAM "#<Updated ~A button ~S>"
                                                              (LET ((TYPE (BUTTON-TYPE BUTTON)))
                                                                   (TYPECASE TYPE
                                                                       (BUTTON-TYPE (BUTTON-TYPE-NAME
                                                                                     TYPE))
                                                                       (T TYPE)))
                                                              (UPDATED-BUTTON-TEXT-FORM BUTTON)))))
   (TEXT-FORM NIL :TYPE T))

(DEFSTRUCT (MARGINS (:TYPE LIST))

(IL:* IL:|;;;| "defines the region within a button intended for the text.  We cannot use a region, as buttons may be strechable.")

   (LEFT 0 :TYPE INTEGER)
   (BOTTOM 0 :TYPE INTEGER)
   (RIGHT 0 :TYPE INTEGER)
   (TOP 0 :TYPE INTEGER))

(DEFVAR *DEFAULT-BUTTON-SHADOWS* NIL
   "Default for :SHADOWS arg to MAKE-BUTTON.\
+Overridden when button type has default shadows.")

(DEFUN MAKE-BUTTON (&REST REST-KEYS &KEY (TYPE *DEFAULT-BUTTON-TYPE*)
                              (TEXT NIL TEXT-PROVIDED)
                              (TEXT-FORM NIL TEXT-FORM-PROVIDED)
                              (SHADOWS NIL SHADOWS-PROVIDED)
                              ACTION HELP FONT INVERTED? &ALLOW-OTHER-KEYS)

(IL:* IL:|;;;| "make & return a button.  use MAKE-BUTTON-WINDOW to put this button in a window.")

   (LET* ((BUTTON-TYPE (OR (IF (BUTTON-TYPE-P TYPE)
                               TYPE)
                           (BUTTON-TYPE-NAMED TYPE)
                           (ERROR "No button type named ~S exists." TYPE)))
          (TEXT (MAKE-TEXT :STRING (IF (AND (NOT TEXT-PROVIDED)
                                            TEXT-FORM-PROVIDED)
                                       (TEXT-FROM-TEXT-FORM TEXT-FORM)
                                       TEXT)
                       :ALIGNMENT :CENTER :FONT (IF FONT
                                                    (IL:FONTCREATE FONT)
                                                    *DEFAULT-TEXT-FONT*)
                       :SHADOWS
                       (IF SHADOWS-PROVIDED
                           SHADOWS

                           (IL:* IL:|;;| "default shadows per button type")

                           (GETF (BUTTON-TYPE-PROPS BUTTON-TYPE)
                                 :DEFAULT-SHADOWS *DEFAULT-BUTTON-SHADOWS*))))
          (BUTTON (APPLY (IF TEXT-FORM-PROVIDED
                             #'MAKE-UPDATED-BUTTON
                             #'MAKE-BUTTON-INTERNAL)
                         :TYPE BUTTON-TYPE :TEXT TEXT :ACTION ACTION :HELP-STRING HELP :INVERTED? 
                         INVERTED? :PROPS
                         (LET ((PROPS (COPY-LIST REST-KEYS)))
                              (DOLIST (KEYWORD '(:TYPE :TEXT :ACTION :HELP :FONT :SHADOWS :TEXT-FORM
                                                       :INVERTED?))
                                  (REMF PROPS KEYWORD))
                              PROPS)
                         (WHEN TEXT-FORM-PROVIDED
                             `(:TEXT-FORM ,TEXT-FORM)))))
         (COMPUTE-BUTTON-TEXT-POSITION BUTTON)
         BUTTON))

(DEFUN COPY-BUTTON (OLD)
   (LET ((NEW (ETYPECASE OLD
                  (UPDATED-BUTTON (COPY-UPDATED-BUTTON OLD))
                  (BUTTON (COPY-BUTTON-INTERNAL OLD)))))
        (SETF (BUTTON-TEXT NEW)
              (COPY-TEXT (BUTTON-TEXT OLD)))
        NEW))

(DEFUN DISPLAY-BUTTON (BUTTON DSP &KEY NO-UPDATE WIDTH HEIGHT)
   (WHEN (AND (NULL NO-UPDATE)
              (OR WIDTH HEIGHT))
         (ERROR "Illegal to pass WIDTH & HEIGHT unless NO-UPDATE specified"))
   (UNLESS NO-UPDATE (UPDATE-BUTTON BUTTON))
   (LET* ((WIDTH (OR WIDTH (BUTTON-WIDTH BUTTON)))
          (HEIGHT (OR HEIGHT (BUTTON-HEIGHT BUTTON)))
          (TYPE (BUTTON-TYPE BUTTON)))
         (WHEN (OR (BUTTON-TYPE-MASK-BITMAP TYPE)
                   (NOT (BUTTON-TYPE-IMAGE-BITMAP TYPE)))

             (IL:* IL:|;;| "erase what's in the mask (or if button is transparent)")

             (DISPLAY-BUTTON-MASK BUTTON DSP WIDTH HEIGHT))

         (IL:* IL:|;;| "paint the image on")

         (DISPLAY-BUTTON-IMAGE BUTTON DSP WIDTH HEIGHT)
         (WHEN (BUTTON-%SELECTED? BUTTON)

             (IL:* IL:|;;| "rationalize the selection")

             (SETF (BUTTON-%SELECTED? BUTTON)
                   NIL)
             (SHADE-BUTTON BUTTON DSP))))

(DEFUN UPDATE-BUTTON (BUTTON DSP)

(IL:* IL:|;;;| "should really be called BUTTON-NEEDS-REDISPLAY?")

   (WHEN (UPDATED-BUTTON-P BUTTON)

       (IL:* IL:|;;| "set the text string of WINDOW's BUTTON to the value of its TEXT-FORM.")

       (LET ((NEW-TEXT-STRING (TEXT-FROM-TEXT-FORM (UPDATED-BUTTON-TEXT-FORM BUTTON)
                                     DSP BUTTON)))
            (UNLESS (EQUAL NEW-TEXT-STRING (TEXT-STRING (BUTTON-TEXT BUTTON)))

                (IL:* IL:|;;| "optimization: don't bother if string is same")

                (SET-BUTTON-TEXT-STRING BUTTON NEW-TEXT-STRING)

                (IL:* IL:|;;| "return T if things have changed")

                (RETURN-FROM UPDATE-BUTTON T))))

   (IL:* IL:|;;| "a null image cache means button needs redisplay")

   (NULL (BUTTON-%IMAGE BUTTON)))

(DEFUN SET-BUTTON-TEXT-STRING (BUTTON STRING)

(IL:* IL:|;;;| "does everything but redisplay")

   (SET-TEXT-STRING (BUTTON-TEXT BUTTON)
          STRING)
   (COMPUTE-BUTTON-TEXT-POSITION BUTTON)

   (IL:* IL:|;;| "clear caches")

   (SETF (BUTTON-%MASK BUTTON)
         NIL)
   (SETF (BUTTON-%IMAGE BUTTON)
         NIL))

(DEFMACRO BUTTON-PROP (BUTTON PROP &OPTIONAL (NEW-VALUE NIL NEW-VALUE-SUPPLIED))
   (IF NEW-VALUE-SUPPLIED
       `(SETF (GETF (BUTTON-PROPS ,BUTTON)
                    ,PROP)
              ,NEW-VALUE)
       `(GETF (BUTTON-PROPS ,BUTTON)
              ,PROP)))

(DEFUN SET-BUTTON-TEXT-STRING (BUTTON STRING)

(IL:* IL:|;;;| "does everything but redisplay")

   (SET-TEXT-STRING (BUTTON-TEXT BUTTON)
          STRING)
   (COMPUTE-BUTTON-TEXT-POSITION BUTTON)

   (IL:* IL:|;;| "clear caches")

   (SETF (BUTTON-%MASK BUTTON)
         NIL)
   (SETF (BUTTON-%IMAGE BUTTON)
         NIL))

(DEFUN COMPUTE-BUTTON-TEXT-POSITION (BUTTON)
   (SETF (TEXT-POSITION (BUTTON-TEXT BUTTON))
         (MAKE-POSITION (BUTTON-TEXT-X-COORD BUTTON)
                (BUTTON-TEXT-Y-COORD BUTTON))))

(DEFUN BUTTON-TEXT-X-COORD (BUTTON)
   (LET ((TEXT (BUTTON-TEXT BUTTON))
         (MARGINS (BUTTON-TYPE-MARGINS (BUTTON-TYPE BUTTON))))
        (ECASE (TEXT-ALIGNMENT TEXT)
            (:CENTER (+ (MARGINS-LEFT MARGINS)
                        (FLOOR (MAX (TEXT-%WIDTH TEXT)
                                    (- (BUTTON-WIDTH BUTTON)
                                       (MARGINS-LEFT MARGINS)
                                       (MARGINS-RIGHT MARGINS)))
                               2)))
            ((:LEFT-BOTTOM :LEFT-TOP) (MARGINS-LEFT MARGINS))
            ((:RIGHT-BOTTOM :RIGHT-TOP) (MARGINS-RIGHT MARGINS)))))

(DEFUN BUTTON-TEXT-Y-COORD (BUTTON)
   (LET ((TEXT (BUTTON-TEXT BUTTON))
         (MARGINS (BUTTON-TYPE-MARGINS (BUTTON-TYPE BUTTON))))
        (ECASE (TEXT-ALIGNMENT TEXT)
            (:CENTER (+ (MARGINS-BOTTOM MARGINS)
                        (FLOOR (MAX (TEXT-%HEIGHT TEXT)
                                    (- (BUTTON-HEIGHT BUTTON)
                                       (MARGINS-BOTTOM MARGINS)
                                       (MARGINS-TOP MARGINS)))
                               2)))
            ((:LEFT-BOTTOM :RIGHT-BOTTOM) (MARGINS-BOTTOM MARGINS))
            ((:LEFT-TOP :RIGHT-TOP) (MARGINS-TOP MARGINS)))))

(DEFUN TEXT-FROM-TEXT-FORM (TEXT-FORM &OPTIONAL DSP BUTTON)

(IL:* IL:|;;;| "return the text string for an updated button in WINDOW.")

   (TYPECASE TEXT-FORM
       (LIST (EVAL TEXT-FORM))

       (IL:* IL:|;;| "note: when an updated button is first created this is called with WINDOW=NIL.  text form functions are required to handle this condition gracefully. ")

       (T (FUNCALL TEXT-FORM DSP BUTTON))))

(DEFUN BUTTON-TRACK-MOUSE (BUTTON DSP)

(IL:* IL:|;;;| "a mouse key has gone down in BUTTON.  watch the mouse with button shaded 'til either the key goes up or the mouse leaves BUTTON.  if key went up then perform button action & return true.   ")

   (LET ((REGION (MAKE-REGION :LEFT 0 :BOTTOM 0 :WIDTH (BUTTON-WIDTH BUTTON)
                        :HEIGHT
                        (BUTTON-HEIGHT BUTTON)))
         (TIMER (IL:SETUPTIMER *BUTTON-HELP-DELAY*)))
        (UNWIND-PROTECT
            (PROGN (SHADE-BUTTON BUTTON DSP :REGION REGION)
                   (LOOP (IL:GETMOUSESTATE)
                         (UNLESS (IL:INSIDEP REGION (IL:LASTMOUSEX DSP)
                                        (IL:LASTMOUSEY DSP))
                                (RETURN))
                         (UNLESS (IL:LASTMOUSESTATE (OR IL:LEFT IL:MIDDLE))
                             (PERFORM-BUTTON-ACTION BUTTON DSP)

                             (IL:* IL:|;;| "return true if we performed action")

                             (RETURN T))
                         (WHEN (AND TIMER (IL:TIMEREXPIRED? TIMER))
                             (SETQ TIMER NIL)
                             (PRINT-BUTTON-HELP BUTTON))))
            (SHADE-BUTTON BUTTON DSP :REGION REGION :DESELECT T))))

(DEFUN PERFORM-BUTTON-ACTION (BUTTON DSP)
   (LET ((ACTION (BUTTON-ACTION BUTTON)))
        (TYPECASE ACTION
            (LIST (EVAL ACTION))
            (T (FUNCALL ACTION DSP BUTTON)))))

(DEFUN EDIT-BUTTON (BUTTON)
   (IL:ALLOW.BUTTON.EVENTS)
   (LET* ((EXTERNAL-FORM (EXTERNALIZE-BUTTON BUTTON T))
          (COPY (COPY-TREE EXTERNAL-FORM))
          (EDITED (WITH-PROFILE (FIND-PROFILE "XCL")
                         (IL:EDITE EXTERNAL-FORM NIL (TEXT-STRING (BUTTON-TEXT BUTTON))
                                NIL NIL :CLOSE-ON-COMPLETION))))
         (IF (EQUAL EDITED COPY)
             BUTTON
             (APPLY #'MAKE-BUTTON EDITED))))

(DEFUN BUTTON-COPY-SELECTED (BUTTON)
   (IF (FBOUNDP 'MAKE-BIO)

       (IL:* IL:|;;| "if ROOMS-BIO is loaded")

       (LET* ((DESTINATION (IL:WFROMDS (IL:PROCESS.TTY (IL:TTY.PROCESS))))
              (COPYINSERTFN (AND DESTINATION (IL:WINDOWPROP DESTINATION 'IL:COPYINSERTFN))))

             (IL:* IL:|;;| 
           "fake IL:COPYINSERT, but instead of punting to IL:BKSYSBUF punt to copying the window")

             (IF COPYINSERTFN
                 (FUNCALL COPYINSERTFN (MAKE-BIO (COPY-BUTTON BUTTON))
                        DESTINATION)
                 (MAKE-BUTTON-WINDOW (COPY-BUTTON BUTTON))))
       (MAKE-BUTTON-WINDOW (COPY-BUTTON BUTTON))))

(DEFUN SHADE-BUTTON (BUTTON DSP &KEY (REGION (MAKE-REGION :LEFT 0 :BOTTOM 0 :WIDTH (
                                                                                      BUTTON-WIDTH
                                                                                        BUTTON)
                                                        :HEIGHT
                                                        (BUTTON-HEIGHT BUTTON)))
                               DESELECT)

(IL:* IL:|;;;| "called when mouse key down in BUTTON.")

   (IL:* IL:|;;| "DESELECT? tells the intention of the call.")

   (IL:* IL:|;;| "see also DISPLAY-BUTTON")

   (LET ((MASK (BUTTON-%MASK BUTTON))
         (SELECTED? (BUTTON-%SELECTED? BUTTON)))
        (WHEN (EQ DESELECT SELECTED?)

            (IL:* IL:|;;| "invert MASK with *BUTTON-SELECTION-SHADE*")

            (IL:BITBLT MASK NIL NIL DSP 0 0 (REGION-WIDTH REGION)
                   (REGION-HEIGHT REGION)
                   (IF (NULL MASK)
                       'IL:TEXTURE
                       'IL:MERGE)
                   'IL:INVERT *BUTTON-SELECTION-SHADE*)

            (IL:* IL:|;;| "toggle SELECTED? bit")

            (SETF (BUTTON-%SELECTED? BUTTON)
                  (NOT SELECTED?)))))

(DEFUN PRINT-BUTTON-HELP (BUTTON)
   (NOTIFY-USER (OR (BUTTON-HELP-STRING BUTTON)
                    "No help provided for this button.")))



(IL:* IL:\; "button windows")


(DEFGLOBALVAR *BUTTON-HELP-DELAY* IL:MENUHELDWAIT)

(DEFPARAMETER *BUTTON-SELECTION-SHADE* 32768)

(DEFUN MAKE-BUTTON-WINDOW (BUTTON &OPTIONAL POSITION)
   (LET* ((WIDTH (BUTTON-WIDTH BUTTON))
          (HEIGHT (BUTTON-HEIGHT BUTTON))
          (POSITION (OR (IL:POSITIONP POSITION)
                        (IL:GETBOXPOSITION WIDTH HEIGHT)))
          (WINDOW (IL:CREATEW (IL:CREATEREGION (POSITION-X POSITION)
                                     (POSITION-Y POSITION)
                                     WIDTH HEIGHT)
                         NIL 0)))
         (IL:WINDOWPROP WINDOW 'BUTTON BUTTON)
         (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN 'BW-BUTTONEVENTFN)
         (IL:WINDOWPROP WINDOW 'IL:AFTERMOVEFN 'BW-REPAINTFN)
         (IL:WINDOWPROP WINDOW 'IL:OPENFN 'BW-REPAINTFN)
         (IL:WINDOWPROP WINDOW 'IL:TOTOPFN 'BW-TOTOPFN)
         (IL:WINDOWPROP WINDOW 'IL:REPAINTFN 'BW-REPAINTFN)
         (IL:WINDOWPROP WINDOW 'IL:RESHAPEFN 'IL:DON\'T)
         (IL:WINDOWPROP WINDOW 'IL:SHRINKFN 'IL:DON\'T)
         (WHEN (BUTTON-PROP BUTTON :PROTECTED?)
             (IL:WINDOWPROP WINDOW 'IL:RIGHTBUTTONFN 'IL:TOTOPW))
         (BW-REPAINTFN WINDOW)
         WINDOW))

(DEFUN BW-REPAINTFN (WINDOW &REST REST &KEY NO-UPDATE)
   (DECLARE (IGNORE REST))
   (IL:TOTOPW WINDOW T)
   (LET* ((BUTTON (IL:WINDOWPROP WINDOW 'BUTTON))
          (DSP (IL:WINDOWPROP WINDOW 'IL:DSP))
          (TYPE (BUTTON-TYPE BUTTON)))
         (UNLESS NO-UPDATE
             (WHEN (UPDATED-BUTTON-P BUTTON)
                   (UPDATE-BUTTON BUTTON)))
         (LET ((WIDTH (BUTTON-WIDTH BUTTON))
               (HEIGHT (BUTTON-HEIGHT BUTTON)))
              (MAYBE-RESIZE-BUTTON-WINDOW WINDOW BUTTON WIDTH HEIGHT)
              (IF (AND (BUTTON-TYPE-IMAGE-BITMAP TYPE)
                       (NOT (BUTTON-TYPE-MASK-BITMAP TYPE)))

                  (IL:* IL:|;;| "OK to clear - don't care what's behind ")

                  (IL:CLEARW WINDOW)

                  (IL:* IL:|;;| "copy what's behind the window through ")

                  (IL:BITBLT (IL:WINDOWPROP WINDOW 'IL:IMAGECOVERED)
                         0 0 DSP 0 0 WIDTH HEIGHT 'IL:INPUT 'IL:REPLACE))
              (DISPLAY-BUTTON BUTTON DSP :NO-UPDATE T :WIDTH WIDTH :HEIGHT HEIGHT))))

(DEFUN BW-TOTOPFN (WINDOW)

   (IL:* IL:|;;| "called when window is un-hidden or brought to top")

   (LET ((BUTTON (IL:WINDOWPROP WINDOW 'BUTTON)))
        (WHEN (BUTTON-P BUTTON)
            (WHEN (OR 
                      (IL:* IL:|;;| "needs redisplay because of update")

                      (UPDATE-BUTTON BUTTON)

                      (IL:* IL:|;;| "or it has a mask & needs background copied through")

                      (BUTTON-TYPE-MASK-BITMAP (BUTTON-TYPE BUTTON))

                      (IL:* IL:|;;| 
         "or it has no mask and no image, i.e. it's transparent & needs background copied through.")

                      (NULL (BUTTON-TYPE-IMAGE-BITMAP (BUTTON-TYPE BUTTON))))
                  (BW-REPAINTFN WINDOW :NO-UPDATE T)))))

(DEFUN BW-BUTTONEVENTFN (WINDOW)
   (LET ((BUTTON (IL:WINDOWPROP WINDOW 'BUTTON)))
        (IF (IL:MOUSESTATE IL:MIDDLE)
            (COND
               ((BUTTON-PROP BUTTON :PROTECTED?)
                (BW-BUTTONEVENTFN-INTERNAL BUTTON WINDOW))
               ((EDIT-KEY-DOWN-P)
                (EDIT-BUTTON-WINDOW BUTTON WINDOW))
               ((COPY-KEY-DOWN-P)
                (BUTTON-COPY-SELECTED BUTTON))
               ((MOVE-KEY-DOWN-P)
                (IL:MOVEW WINDOW))
               ((DELETE-KEY-DOWN-P)
                (IF (FBOUNDP 'INTERACTIVE-CLOSE-WINDOW)
                    (INTERACTIVE-CLOSE-WINDOW WINDOW)
                    (CLOSE-WINDOW WINDOW)))
               ((HELP-KEY-DOWN-P)
                (PRINT-BUTTON-HELP BUTTON))
               (T (BW-BUTTONEVENTFN-INTERNAL BUTTON WINDOW)))
            (BW-BUTTONEVENTFN-INTERNAL BUTTON WINDOW))))

(DEFUN BW-BUTTONEVENTFN-INTERNAL (WINDOW BUTTON)
   (LET ((WINDOW WINDOW)
         (BUTTON BUTTON))
        (LOOP (WHEN (BUTTON-P BUTTON)
                  (IL:TOTOPW WINDOW)
                  (WHEN (BUTTON-TRACK-MOUSE BUTTON WINDOW)
                      (WHEN (UPDATE-BUTTON BUTTON)

                          (IL:* IL:|;;| "button's action caused it to need redisplay")

                          (BW-REPAINTFN WINDOW :NO-UPDATE T))
                      (RETURN)))
              (UNLESS (IL:MOUSESTATE (OR IL:LEFT IL:MIDDLE))
                     (RETURN))
              (SETQ WINDOW (IL:WHICHW))
              (SETQ BUTTON (WHEN WINDOW
                               (IL:WINDOWPROP WINDOW 'BUTTON))))))

(DEFUN SET-BUTTON-WINDOW-TEXT-STRING (WINDOW STRING)

(IL:* IL:|;;;| "note: this does everything but the redisplay.")

   (LET ((BUTTON (IL:WINDOWPROP WINDOW 'BUTTON)))
        (SET-BUTTON-TEXT-STRING BUTTON STRING)
        (MAYBE-RESIZE-BUTTON-WINDOW WINDOW BUTTON)))

(DEFUN MAYBE-RESIZE-BUTTON-WINDOW (WINDOW BUTTON &OPTIONAL (WIDTH (BUTTON-WIDTH BUTTON))
                                             (HEIGHT (BUTTON-HEIGHT BUTTON)))
   (LET ((OLD-REGION (WINDOW-REGION WINDOW)))
        (UNLESS (AND (= WIDTH (REGION-WIDTH OLD-REGION))
                     (= HEIGHT (REGION-HEIGHT OLD-REGION)))
            (UNWIND-PROTECT
                (PROGN (IL:TOTOPW WINDOW T)
                       (IL:WINDOWPROP WINDOW 'IL:RESHAPEFN 'IL:NILL)
                       (IL:SHAPEW1 WINDOW (MAKE-REGION :LEFT (REGION-LEFT OLD-REGION)
                                                 :BOTTOM
                                                 (REGION-BOTTOM OLD-REGION)
                                                 :WIDTH WIDTH :HEIGHT HEIGHT))

                       (IL:* IL:|;;| "return true if we shaped")

                       T)
                (IL:WINDOWPROP WINDOW 'IL:RESHAPEFN 'IL:DON\'T)))))

(DEFUN BW-SCREEN-CHANGED-FUNCTION ()
   (LET ((OLD-DEFAULT-FONT *DEFAULT-TEXT-FONT*)
         (NEW-DEFAULT-FONT (SET-DEFAULT-TEXT-FONT)))
        (UNLESS (EQ OLD-DEFAULT-FONT NEW-DEFAULT-FONT)
            (DOLIST (WINDOW (ALL-WINDOWS T))
                (LET ((BUTTON (IL:WINDOWPROP WINDOW 'BUTTON)))
                     (WHEN (AND (BUTTON-P BUTTON)
                                (EQ OLD-DEFAULT-FONT (TEXT-FONT (BUTTON-TEXT BUTTON))))

                         (IL:* IL:|;;| "upgrade buttons with default font")

                         (SETF (TEXT-FONT (BUTTON-TEXT BUTTON))
                               NEW-DEFAULT-FONT)
                         (UPDATE-TEXT-CACHES (BUTTON-TEXT BUTTON))
                         (COMPUTE-BUTTON-TEXT-POSITION BUTTON)

                         (IL:* IL:|;;| "force redisplay")

                         (SETF (BUTTON-%IMAGE BUTTON)
                               NIL)
                         (SETF (BUTTON-%MASK BUTTON)
                               NIL)))))))

(DEFGLOBALVAR *SCREEN-CHANGED-FUNCTIONS* (LIST '%INTERNALIZE-ALL-PLACEMENTS))

(PUSHNEW 'BW-SCREEN-CHANGED-FUNCTION *SCREEN-CHANGED-FUNCTIONS*)



(IL:* IL:\; "button bitmaps")


(DEFSTRUCT (NORTH-SOUTH-BITMAP (:CONC-NAME "NS-BITMAP-"))
   NORTH
   CENTER
   SOUTH)

(DEFSTRUCT (EAST-WEST-BITMAP (:CONC-NAME "EW-BITMAP-"))
   EAST
   CENTER
   WEST)

(DEFSTRUCT NSEW-BITMAP
   NORTH
   NW
   NE
   SOUTH
   SW
   SE
   EAST
   CENTER
   WEST)

(DEFUN DISPLAY-BUTTON-IMAGE (BUTTON DSP WIDTH HEIGHT)
   (LET ((CACHED-IMAGE (BUTTON-%IMAGE BUTTON))
         (INVERTED? (BUTTON-INVERTED? BUTTON))
         (MASK? (BUTTON-%MASK BUTTON)))
        (UNLESS CACHED-IMAGE
            (SETQ CACHED-IMAGE (IL:BITMAPCREATE WIDTH HEIGHT))
            (LET ((TYPE-IMAGE (BUTTON-TYPE-IMAGE-BITMAP (BUTTON-TYPE BUTTON))))
                 (WHEN TYPE-IMAGE (BUTTON-BITMAP-BITBLT TYPE-IMAGE CACHED-IMAGE WIDTH HEIGHT)))
            (DISPLAY-TEXT (BUTTON-TEXT BUTTON)
                   CACHED-IMAGE)
            (SETF (BUTTON-%IMAGE BUTTON)
                  CACHED-IMAGE))
        (IL:BITBLT CACHED-IMAGE 0 0 DSP 0 0 WIDTH HEIGHT (IF (AND INVERTED? (NOT MASK?))
                                                             'IL:INVERT
                                                             'IL:SOURCE)
               (IF (AND INVERTED? MASK?)
                   'IL:INVERT
                   'IL:PAINT))))

(DEFUN DISPLAY-BUTTON-MASK (BUTTON DSP WIDTH HEIGHT)
   (LET ((CACHED-MASK (BUTTON-%MASK BUTTON)))
        (UNLESS CACHED-MASK
            (SETQ CACHED-MASK (IL:BITMAPCREATE WIDTH HEIGHT))
            (LET ((TYPE-MASK (BUTTON-TYPE-MASK-BITMAP (BUTTON-TYPE BUTTON))))
                 (WHEN TYPE-MASK (BUTTON-BITMAP-BITBLT TYPE-MASK CACHED-MASK WIDTH HEIGHT)))
            (DISPLAY-TEXT (BUTTON-TEXT BUTTON)
                   CACHED-MASK :MASK-ONLY T)
            (SETF (BUTTON-%MASK BUTTON)
                  CACHED-MASK))
        (IL:BITBLT CACHED-MASK 0 0 DSP 0 0 WIDTH HEIGHT 'IL:SOURCE (IF (BUTTON-INVERTED? BUTTON)
                                                                       'IL:PAINT
                                                                       'IL:ERASE))))

(DEFUN BUTTON-WIDTH (BUTTON)
   (LET* ((BUTTON-TYPE (BUTTON-TYPE BUTTON))
          (MARGINS (BUTTON-TYPE-MARGINS BUTTON-TYPE))
          (BITMAP (BUTTON-TYPE-IMAGE-BITMAP BUTTON-TYPE))
          (TEXT-WIDTH (TEXT-%WIDTH (BUTTON-TEXT BUTTON))))
         (ETYPECASE BITMAP
             (BITMAP (IL:BITMAPWIDTH BITMAP))
             (NULL TEXT-WIDTH)
             (NORTH-SOUTH-BITMAP (IL:BITMAPWIDTH (NS-BITMAP-NORTH BITMAP)))
             ((OR NSEW-BITMAP EAST-WEST-BITMAP) (LET* ((WIDTH (+ TEXT-WIDTH (MARGINS-LEFT MARGINS)
                                                                 (MARGINS-RIGHT MARGINS)))
                                                       (EAST-WIDTH (IL:BITMAPWIDTH
                                                                    (TYPECASE BITMAP
                                                                        (NSEW-BITMAP (
                                                                                     NSEW-BITMAP-EAST
                                                                                      BITMAP))
                                                                        (EAST-WEST-BITMAP 
                                                                           (EW-BITMAP-EAST BITMAP))))
                                                              )
                                                       (CENTER-WIDTH
                                                        (IL:BITMAPWIDTH (TYPECASE BITMAP
                                                                            (NSEW-BITMAP 
                                                                               (NSEW-BITMAP-CENTER
                                                                                BITMAP))
                                                                            (EAST-WEST-BITMAP 
                                                                               (EW-BITMAP-CENTER
                                                                                BITMAP)))))
                                                       (WEST-WIDTH (IL:BITMAPWIDTH
                                                                    (TYPECASE BITMAP
                                                                        (NSEW-BITMAP (
                                                                                     NSEW-BITMAP-WEST
                                                                                      BITMAP))
                                                                        (EAST-WEST-BITMAP 
                                                                           (EW-BITMAP-WEST BITMAP))))
                                                              ))

                                 (IL:* IL:|;;| "we could use WIDTH directly but we'd rather tile in an even number of CENTER bitmaps, in case it's a pattern that needs to blend with the EAST and WEST.")

                                                      (MAX (+ WIDTH
                                                              (- CENTER-WIDTH
                                                                 (MOD (- WIDTH EAST-WIDTH WEST-WIDTH)
                                                                      CENTER-WIDTH)))
                                                           (+ EAST-WIDTH WEST-WIDTH)))))))

(DEFUN BUTTON-HEIGHT (BUTTON)
   (LET* ((BUTTON-TYPE (BUTTON-TYPE BUTTON))
          (MARGINS (BUTTON-TYPE-MARGINS BUTTON-TYPE))
          (BITMAP (BUTTON-TYPE-IMAGE-BITMAP BUTTON-TYPE))
          (TEXT-HEIGHT (TEXT-%HEIGHT (BUTTON-TEXT BUTTON))))
         (ETYPECASE BITMAP
             (BITMAP (IL:BITMAPHEIGHT BITMAP))
             (NULL TEXT-HEIGHT)
             (EAST-WEST-BITMAP (IL:BITMAPHEIGHT (EW-BITMAP-EAST BITMAP)))
             ((OR NSEW-BITMAP NORTH-SOUTH-BITMAP) (LET* ((HEIGHT (+ TEXT-HEIGHT (MARGINS-BOTTOM
                                                                                 MARGINS)
                                                                    (MARGINS-TOP MARGINS)))
                                                         (NORTH-HEIGHT
                                                          (IL:BITMAPHEIGHT (TYPECASE BITMAP
                                                                               (NSEW-BITMAP 
                                                                                  (NSEW-BITMAP-NORTH
                                                                                   BITMAP))
                                                                               (NORTH-SOUTH-BITMAP 
                                                                                  (NS-BITMAP-NORTH
                                                                                   BITMAP)))))
                                                         (CENTER-HEIGHT
                                                          (IL:BITMAPHEIGHT (TYPECASE BITMAP
                                                                               (NSEW-BITMAP 
                                                                                  (NSEW-BITMAP-CENTER
                                                                                   BITMAP))
                                                                               (NORTH-SOUTH-BITMAP 
                                                                                  (NS-BITMAP-CENTER
                                                                                   BITMAP)))))
                                                         (SOUTH-HEIGHT
                                                          (IL:BITMAPHEIGHT (TYPECASE BITMAP
                                                                               (NSEW-BITMAP 
                                                                                  (NSEW-BITMAP-SOUTH
                                                                                   BITMAP))
                                                                               (NORTH-SOUTH-BITMAP 
                                                                                  (NS-BITMAP-SOUTH
                                                                                   BITMAP))))))

                                 (IL:* IL:|;;| "we could use HEIGHT directly but we'd rather tile in an even number of CENTER bitmaps, in case it's a pattern that needs to blend with the EAST and WEST.")

                                                        (MAX (+ HEIGHT
                                                                (- CENTER-HEIGHT
                                                                   (MOD (- HEIGHT NORTH-HEIGHT 
                                                                           SOUTH-HEIGHT)
                                                                        CENTER-HEIGHT)))
                                                             (+ NORTH-HEIGHT SOUTH-HEIGHT)))))))

(DEFUN BUTTON-BITMAP-BITBLT (BITMAP DESTINATION WIDTH HEIGHT)
   (ETYPECASE BITMAP
       (BITMAP (IL:BITBLT BITMAP 0 0 DESTINATION 0 0 WIDTH HEIGHT))
       (EAST-WEST-BITMAP (EW-BITBLT (EW-BITMAP-WEST BITMAP)
                                (EW-BITMAP-CENTER BITMAP)
                                (EW-BITMAP-EAST BITMAP)
                                DESTINATION WIDTH 0))
       (NORTH-SOUTH-BITMAP (NS-BITBLT (NS-BITMAP-SOUTH BITMAP)
                                  (NS-BITMAP-CENTER BITMAP)
                                  (NS-BITMAP-NORTH BITMAP)
                                  DESTINATION HEIGHT 0))
       (NSEW-BITMAP (NSEW-BITBLT BITMAP DESTINATION WIDTH HEIGHT))))

(DEFUN EW-BITBLT (WEST CENTER EAST DESTINATION WIDTH BOTTOM)
   (LET* ((WEST-WIDTH (IL:BITMAPWIDTH WEST))
          (CENTER-WIDTH (IL:BITMAPWIDTH CENTER))
          (EAST-WIDTH (IL:BITMAPWIDTH EAST))
          (EAST-LEFT (- WIDTH EAST-WIDTH))
          (HEIGHT (IL:BITMAPHEIGHT CENTER)))

         (IL:* IL:|;;| "blt the west bitmap down the left ")

         (IL:BITBLT WEST 0 0 DESTINATION 0 BOTTOM WEST-WIDTH HEIGHT)
         (WHEN (> EAST-LEFT WEST-WIDTH)

             (IL:* IL:|;;| "blt in one copy of center")

             (IL:BITBLT CENTER 0 0 DESTINATION WEST-WIDTH BOTTOM CENTER-WIDTH HEIGHT)
             (DO* ((WIDTH CENTER-WIDTH (+ WIDTH WIDTH))
                   (LEFT (+ WEST-WIDTH WIDTH)
                         (+ WEST-WIDTH WIDTH)))
                  ((>= LEFT EAST-LEFT))

                (IL:* IL:|;;| "blt the center bitmap across the middle")

                (IL:BITBLT DESTINATION WEST-WIDTH BOTTOM DESTINATION LEFT BOTTOM
                       (MIN WIDTH (- EAST-LEFT LEFT))
                       HEIGHT)))

         (IL:* IL:|;;| "blt the east bitmap on the right end")

         (IL:BITBLT EAST 0 0 DESTINATION EAST-LEFT BOTTOM EAST-WIDTH HEIGHT)))

(DEFUN NS-BITBLT (SOUTH CENTER NORTH DESTINATION HEIGHT LEFT &OPTIONAL (DO-ENDS? T))
   (LET* ((SOUTH-HEIGHT (IL:BITMAPHEIGHT SOUTH))
          (CENTER-HEIGHT (IL:BITMAPHEIGHT CENTER))
          (NORTH-HEIGHT (IL:BITMAPHEIGHT NORTH))
          (NORTH-BOTTOM (- HEIGHT NORTH-HEIGHT))
          (WIDTH (IL:BITMAPWIDTH CENTER)))
         (WHEN DO-ENDS?

             (IL:* IL:|;;| "blt the south bitmap across the bottom")

             (IL:BITBLT SOUTH 0 0 DESTINATION LEFT 0 WIDTH SOUTH-HEIGHT))
         (WHEN (> NORTH-BOTTOM SOUTH-HEIGHT)

             (IL:* IL:|;;| "blt in one copy of center")

             (IL:BITBLT CENTER 0 0 DESTINATION LEFT SOUTH-HEIGHT WIDTH CENTER-HEIGHT)
             (DO* ((HEIGHT CENTER-HEIGHT (+ HEIGHT HEIGHT))
                   (BOTTOM (+ SOUTH-HEIGHT HEIGHT)
                          (+ SOUTH-HEIGHT HEIGHT)))
                  ((>= BOTTOM NORTH-BOTTOM))

                (IL:* IL:|;;| "blt the center bitmap up the middle")

                (IL:BITBLT DESTINATION LEFT SOUTH-HEIGHT DESTINATION LEFT BOTTOM WIDTH
                       (MIN HEIGHT (- NORTH-BOTTOM BOTTOM)))))
         (WHEN DO-ENDS?

             (IL:* IL:|;;| "blt the north bitmap across the top")

             (IL:BITBLT NORTH 0 0 DESTINATION LEFT NORTH-BOTTOM WIDTH NORTH-HEIGHT))))

(DEFUN NSEW-BITBLT (NSEW-BITMAP DESTINATION WIDTH HEIGHT)
   (LET* ((SW (NSEW-BITMAP-SW NSEW-BITMAP))
          (SE (NSEW-BITMAP-SE NSEW-BITMAP))
          (NW (NSEW-BITMAP-NW NSEW-BITMAP))
          (NE (NSEW-BITMAP-NE NSEW-BITMAP))
          (NORTH-BOTTOM (- HEIGHT (IL:BITMAPHEIGHT NW)))
          (EAST-LEFT (- WIDTH (IL:BITMAPWIDTH SE))))

         (IL:* IL:|;;| "across the bottom")

         (EW-BITBLT SW (NSEW-BITMAP-SOUTH NSEW-BITMAP)
                SE DESTINATION WIDTH 0)

         (IL:* IL:|;;| "across the top")

         (EW-BITBLT NW (NSEW-BITMAP-NORTH NSEW-BITMAP)
                NE DESTINATION WIDTH NORTH-BOTTOM)

         (IL:* IL:|;;| "up the left")

         (NS-BITBLT SW (NSEW-BITMAP-WEST NSEW-BITMAP)
                NW DESTINATION HEIGHT 0 NIL)

         (IL:* IL:|;;| "up the right")

         (NS-BITBLT SE (NSEW-BITMAP-EAST NSEW-BITMAP)
                NE DESTINATION HEIGHT EAST-LEFT NIL)

         (IL:* IL:|;;| "tile the center")

         (PAINT-REGION DESTINATION (LET ((LEFT (IL:BITMAPWIDTH SW))
                                             (BOTTOM (IL:BITMAPHEIGHT SW)))
                                            (MAKE-REGION :LEFT LEFT :BOTTOM BOTTOM :WIDTH
                                                   (- EAST-LEFT LEFT)
                                                   :HEIGHT
                                                   (- NORTH-BOTTOM BOTTOM)))
                (NSEW-BITMAP-CENTER NSEW-BITMAP))))

(DEFUN PAINT-REGION (DESTINATION REGION SHADE &OPTIONAL CLIPPING-REGION)

   (IL:* IL:|;;| "fill REGION of DESTINATION with SHADE")

   (TYPECASE SHADE
       (BITMAP 

          (IL:* IL:|;;| "tile the bitmap within REGION")

          (LET* ((REGION-LEFT (REGION-LEFT REGION))
                 (REGION-BOTTOM (REGION-BOTTOM REGION))
                 (REGION-WIDTH (REGION-WIDTH REGION))
                 (REGION-HEIGHT (REGION-HEIGHT REGION))
                 (BITMAP-WIDTH (IL:BITMAPWIDTH SHADE))
                 (BITMAP-HEIGHT (IL:BITMAPHEIGHT SHADE))
                 (REGION-RIGHT (+ REGION-LEFT REGION-WIDTH))
                 (REGION-TOP (+ REGION-BOTTOM REGION-HEIGHT))
                 (CLIPPING-REGION (IF CLIPPING-REGION
                                      (IL:INTERSECTREGIONS CLIPPING-REGION REGION)
                                      REGION)))

                (IL:* IL:|;;| "blt in one copy in lower left corner")

                (IL:BITBLT SHADE 0 0 DESTINATION REGION-LEFT REGION-BOTTOM BITMAP-WIDTH BITMAP-HEIGHT
                       NIL NIL NIL CLIPPING-REGION)

                (IL:* IL:|;;| "blt across bottom, doubling size each time")

                (LET ((LEFT BITMAP-WIDTH))
                     (LOOP (WHEN (>= LEFT REGION-RIGHT)
                                 (RETURN))
                           (IL:BITBLT DESTINATION REGION-LEFT REGION-BOTTOM DESTINATION
                                  (+ LEFT REGION-LEFT)
                                  REGION-BOTTOM LEFT BITMAP-HEIGHT NIL NIL NIL CLIPPING-REGION)
                           (SETF LEFT (+ LEFT LEFT))))

                (IL:* IL:|;;| "blt up, doubling size each time")

                (LET ((BOTTOM BITMAP-HEIGHT))
                     (LOOP (WHEN (>= BOTTOM REGION-TOP)
                                 (RETURN))
                           (IL:BITBLT DESTINATION REGION-LEFT REGION-BOTTOM DESTINATION REGION-LEFT
                                  (+ REGION-BOTTOM BOTTOM)
                                  REGION-WIDTH BOTTOM NIL NIL NIL CLIPPING-REGION)
                           (SETF BOTTOM (+ BOTTOM BOTTOM))))))
       (TEXTURE 

          (IL:* IL:|;;| "squirt the texture onto the screen within REGION")

          (IL:BLTSHADE SHADE DESTINATION (REGION-LEFT REGION)
                 (REGION-BOTTOM REGION)
                 (REGION-WIDTH REGION)
                 (REGION-HEIGHT REGION)
                 NIL CLIPPING-REGION))))



(IL:* IL:\; "externalization")


(DEFUN EDIT-BUTTON-WINDOW (BUTTON WINDOW)
   (UNLESS (IL:WINDOWPROP WINDOW 'BUTTON-BEING-EDITED)
       (UNWIND-PROTECT
           (PROGN (IL:WINDOWPROP WINDOW 'BUTTON-BEING-EDITED T)
                  (LET ((NEW-BUTTON (EDIT-BUTTON BUTTON)))
                       (UNLESS (EQ BUTTON NEW-BUTTON)
                           (IL:WINDOWPROP WINDOW 'BUTTON NEW-BUTTON)
                           (BW-REPAINTFN WINDOW))))
           (IL:REMWINDOWPROP WINDOW 'BUTTON-BEING-EDITED))))

(DEFUN EXTERNALIZE-BUTTON (BUTTON &OPTIONAL VERBOSE)

(IL:* IL:|;;;| "returns a property list to which MAKE-BUTTON can be applied")

   (LET* ((TEXT (BUTTON-TEXT BUTTON))
          (TYPE (BUTTON-TYPE BUTTON))
          (TYPE-NAME (BUTTON-TYPE-NAME TYPE))
          (SHADOWS (TEXT-SHADOWS TEXT))
          (FONT (TEXT-FONT TEXT))
          (INVERTED? (BUTTON-INVERTED? BUTTON)))
         `(,@(ETYPECASE BUTTON
                 (UPDATED-BUTTON `(:TEXT-FORM ,(UPDATED-BUTTON-TEXT-FORM BUTTON)))
                 (BUTTON `(:TEXT ,(TEXT-STRING TEXT))))
           :ACTION
           ,(COPY-TREE (BUTTON-ACTION BUTTON))
           :HELP
           ,(BUTTON-HELP-STRING BUTTON)
           ,@(WHEN (OR VERBOSE (NOT (EQ FONT *DEFAULT-TEXT-FONT*)))
                 (LIST :FONT (EXTERNALIZE-FONT FONT)))
           ,@(WHEN (OR VERBOSE (NOT (EQUAL SHADOWS (GETF (BUTTON-TYPE-PROPS TYPE)
                                                         :DEFAULT-SHADOWS *DEFAULT-BUTTON-SHADOWS*)))
                       )
                 (LIST :SHADOWS (EXTERNALIZE-TEXT-SHADOWS SHADOWS)))
           ,@(WHEN (OR (NULL TYPE-NAME)
                       VERBOSE
                       (NOT (EQUAL TYPE-NAME *DEFAULT-BUTTON-TYPE*)))
                 (LIST :TYPE (IF (NULL TYPE-NAME)
                                 TYPE
                                 TYPE-NAME)))
           ,@(WHEN (OR VERBOSE INVERTED?)
                   (LIST :INVERTED? INVERTED?))
           ,@(COPY-TREE (BUTTON-PROPS BUTTON)))))

(DEFUN EXTERNALIZE-FONT (FONT)
   (LIST (IL:FONTPROP FONT 'IL:FAMILY)
         (IL:FONTPROP FONT 'IL:SIZE)
         (IL:FONTPROP FONT 'IL:FACE)))

(DEFUN WITH-BUTTON (ACTION TEXT HELP)
   (IF (COPY-KEY-DOWN-P)
       (PROG1 NIL
           (MAKE-BUTTON-WINDOW (MAKE-BUTTON :TYPE *DEFAULT-BUTTON-TYPE* :TEXT TEXT :HELP HELP
                                          :ACTION ACTION)
                  TEXT HELP))
       (EVAL ACTION)))

(DEF-BUTTON-TYPE :DOOR :IMAGE #*(59 99)OOOOOOOOOOOOOON@OOOOOOOOOOOOOON@OOOOOOOOOOOOOON@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@OOOOL@OOOOL@N@L@OOOOL@OOOOL@N@L@L@@@L@L@@@L@N@L@NBBBL@NBBBL@N@L@N@@@L@N@@@L@N@L@NHHHL@NHHHL@N@L@N@@@L@N@@@L@N@L@NBBBL@NBBBL@N@L@N@@@L@N@@@L@N@L@NHHHL@NHHHL@N@L@N@@@L@N@@@L@N@L@NBBBL@NBBBL@N@L@N@@@L@N@@@L@N@L@NHHHL@NHHHL@N@L@N@@@L@N@@@L@N@L@NBBBL@NBBBL@N@L@N@@@L@N@@@L@N@L@NHHHL@NHHHL@N@L@N@@@L@N@@@L@N@L@NBBBL@NBBBL@N@L@N@@@L@N@@@L@N@L@NHHHL@NHHHL@N@L@N@@@L@N@@@L@N@L@OOOLL@OOONL@N@L@OOOOL@OOOOL@N@L@OOOOL@OOOOL@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@OOOOL@OOOOL@N@L@OOOOL@OOOOL@N@L@L@@@L@L@@@L@N@L@LBBBL@LBBBL@N@L@N@@@L@N@@CO@N@L@NHHHL@NHHGGHN@L@N@@@L@N@@NCLN@L@NBBBL@NBBLCLN@L@N@@@L@N@@NGLN@L@NHHHL@NHHOOLN@L@N@@@L@N@@OOLN@L@NBBBL@NBBGOHN@L@N@@@L@N@@CO@N@L@NHHHL@NHHHL@N@L@N@@@L@N@@@L@N@L@NBBBL@NBBBL@N@L@N@@@L@N@@@L@N@L@NHHHL@NHHHL@N@L@N@@@L@N@@@L@N@L@NBBBL@NBBBL@N@L@N@@@L@N@@@L@N@L@NHHHL@NHHHL@N@L@N@@@L@N@@@L@N@L@NBBBL@NBBBL@N@L@N@@@L@N@@@L@N@L@NHHHL@NHHHL@N@L@N@@@L@N@@@L@N@L@NBBBL@NBBBL@N@L@N@@@L@N@@@L@N@L@NHHHL@NHHHL@N@L@N@@@L@N@@@L@N@L@NBBBL@NBBBL@N@L@N@@@L@N@@@L@N@L@NHHHL@NHHHL@N@L@N@@@L@N@@@L@N@L@NBBBL@NBBBL@N@L@N@@@L@N@@@L@N@L@NHHHL@NHHHL@N@L@N@@@L@N@@@L@N@L@OOOLL@OOOHL@N@L@OOOOL@OOOOL@N@L@OOOOL@OOOOL@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@L@@@@@@@@@@@@@N@OOOOOOOOOOOOOON@OOOOOOOOOOOOOON@
   :MASK NIL
   :MARGINS (2 18 3 2)
   :DEFAULT-SHADOWS NIL)

(DEF-BUTTON-TYPE :SHADOWED :IMAGE #S(NSEW-BITMAP NORTH #*(2 4)L@@@L@@@@@@@@@@@ NW #*(5 4)CH@@GH@@N@@@L@@@ NE 
#*(7 4)O@@@OH@@CL@@AN@@ SOUTH #*(2 6)@@@@L@@@L@@@D@@@H@@@L@@@ SW #*(5 6)N@@@OH@@GH@@C@@@AH@@@H@@ SE 
#*(7 6)GJ@@OF@@OJ@@EN@@JL@@OH@@ EAST #*(7 2)CF@@CJ@@ CENTER #*(2 2)@@@@@@@@ WEST #*(5 2)L@@@L@@@)
   :MASK #S(NSEW-BITMAP NORTH #*(2 4)L@@@L@@@L@@@L@@@ NW #*(5 4)CH@@GH@@OH@@OH@@ NE #*(7 4)O@@@OH@@OL@@ON@@ SOUTH 
#*(2 6)L@@@L@@@L@@@D@@@H@@@L@@@ SW #*(5 6)OH@@OH@@GH@@C@@@AH@@@H@@ SE #*(7 6)OJ@@OF@@OJ@@EN@@JL@@OH@@ EAST 
#*(7 2)OF@@OJ@@ CENTER #*(2 2)L@@@L@@@ WEST #*(5 2)OH@@OH@@)
   :MARGINS (3 5 7 3))

(DEF-BUTTON-TYPE :TRANSPARENT :IMAGE NIL
   :MASK NIL
   :MARGINS (0 0 0 0)
   :DEFAULT-SHADOWS T)

(DEF-BUTTON-TYPE :PORTHOLE :IMAGE #S(NSEW-BITMAP NORTH #*(15 36)OOONOOON@@@@@@@@L@@FN@@NG@ALCHAHCHAHGHALOH@NO@@FN@@B@@@@@@@@OOONOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ NW 
#*(36 36)@@@@@@@CO@@@@@@@@@GOO@@@@@@@@AON@@@@@@@@@OL@@@@@@@@@CO@@C@@@@@@@GH@@G@@@@@@AN@@@N@@@@@@CL@@@L@@@@@@G@O@@L@@@@@@NAOH@N@@@@@ALCIL@G@@@@@CHC@N@C@@@@@G@C@N@A@@@@@N@CIN@@@@@@AL@AON@@@@@@CH@@OLCO@@@@C@@@GIOO@@@@G@@@@CO@@@@@NCL@@OL@@@@@LGN@AO@@@@@ALNG@CL@@@@@AHLCHGH@@@@@AHLCHO@@@@@@CHNGIN@@@@@@C@GOKL@@@@@@G@COCH@@@@@@F@ANG@@@@@@@F@@@G@@@@@@@F@@@N@@@@@@@F@@@N@@@@@@@N@@AL@@@@@@@L@@AL@@@@@@@LCLAH@@@@@@@LGNAH@@@@@@@LNGAH@@@@@@@LLCIH@@@@@@@ NE 
#*(36 36)OL@@@@@@@@@@OON@@@@@@@@@@GOH@@@@@@@@@@CO@@@@@@@@L@@OL@@@@@@@N@@AN@@@@@@@G@@@GH@@@@@@CH@@CL@@@@@@CHAN@N@@@@@@GHCO@G@@@@@@OHGCHCH@@@@@O@FALAL@@@@@N@FAL@N@@@@@@@GCL@G@@@@@@@COL@CH@@@@OHAOH@AL@@@@OO@O@@@L@@@@@GL@@GHN@@@@@AO@@OLG@@@@@@GHALNC@@@@@@ALAHGCH@@@@@@NAHGAH@@@@@@GALOAH@@@@@@CHOOAL@@@@@@ALGN@L@@@@@@@LCL@N@@@@@@@N@@@F@@@@@@@F@@@F@@@@@@@G@@@F@@@@@@@C@@@F@@@@@@@C@@@G@@@@@@@CH@@C@@@@@@@AHGHC@@@@@@@AHOLC@@@@@@@AILNC@@@@@@@AIHGC@@@ SOUTH 
#*(15 36)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOONOOON@@@@@@@@L@@FN@@NG@ALCHAHCHAHGH@LOH@NO@@FN@@B@@@@@@@@OOONOOON SW 
#*(36 36)LLCIH@@@@@@@LNGIH@@@@@@@LGOIH@@@@@@@LCOAH@@@@@@@LANAH@@@@@@@N@@@L@@@@@@@F@@@L@@@@@@@F@@@N@@@@@@@F@@@F@@@@@@@F@CLG@@@@@@@G@GNC@@@@@@@C@NGCH@@@@@@CHLCIL@@@@@@AHLCHN@@@@@@AHNGHG@@@@@@ALGOHCH@@@@@@LCO@AN@@@@@@NAN@@OH@@@@@G@@@@CO@@@@@C@@@O@OO@@@@CH@AOHAO@@@@AL@CIL@@@@@@@N@C@N@@@@@@@G@C@N@C@@@@@CHCIN@G@@@@@ALAON@N@@@@@@N@OL@L@@@@@@G@GH@L@@@@@@CL@@@N@@@@@@AN@@@G@@@@@@@GH@@C@@@@@@@CO@@A@@@@@@@@OL@@@@@@@@@@AON@@@@@@@@@@GOO@@@@@@@@@@CO@@@ SE 
#*(36 36)@@@@AIHGC@@@@@@@AILOC@@@@@@@AHOOC@@@@@@@AHGNC@@@@@@@AHCLC@@@@@@@C@@@G@@@@@@@C@@@F@@@@@@@G@@@F@@@@@@@F@@@F@@@@@@@NCL@F@@@@@@@LGN@N@@@@@@ALNG@L@@@@@@CHLCIL@@@@@@G@LCIH@@@@@@N@NGIH@@@@@AL@GOKH@@@@@GH@COCH@@@@AO@@ANG@@@@@GL@@@@O@@@@OO@GH@@N@@@@OH@OL@AL@@@@@@ALN@CL@@@@@@AHG@GH@@@@L@AHG@O@@@@@N@ALOAN@@@@@G@@OOCL@@@@@CH@GNGH@@@@@CH@CLO@@@@@@GH@@CN@@@@@@OH@@GL@@@@@@O@@AO@@@@@@@N@@OL@@@@@@@@@COH@@@@@@@@GOL@@@@@@@@OON@@@@@@@@@OL@@@@@@@@@@ EAST 
#*(36 15)@@@@AIHGC@@@@@@@AILOC@@@@@@@AHOOC@@@@@@@AHGNC@@@@@@@AHCLC@@@@@@@AH@@C@@@@@@@AH@@C@@@@@@@AH@@C@@@@@@@AH@@C@@@@@@@AH@@C@@@@@@@AH@@C@@@@@@@AHGHC@@@@@@@AHOLC@@@@@@@AILNC@@@@@@@AIHGC@@@ CENTER 
#*(15 15)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ WEST #*(36 15)LLCIH@@@@@@@LNGIH@@@@@@@LGOIH@@@@@@@LCOAH@@@@@@@LANAH@@@@@@@L@@AH@@@@@@@L@@AH@@@@@@@L@@AH@@@@@@@L@@AH@@@@@@@L@@AH@@@@@@@L@@AH@@@@@@@LCLAH@@@@@@@LGNAH@@@@@@@LNGAH@@@@@@@LLCIH@@@@@@@)
   :MASK #S(NSEW-BITMAP NORTH #*(15 36)OOONOOONOOONOOONOOONOOONOOONOOONOOONOOONOOONOOONOOONOOONOOONOOONOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ NW 
#*(36 36)@@@@@@@CO@@@@@@@@@GOO@@@@@@@@AOOO@@@@@@@@OOOO@@@@@@@COOOO@@@@@@@GOOOO@@@@@@AOOOOO@@@@@@COOOOO@@@@@@GOOOOO@@@@@@OOOOOO@@@@@AOOOOOO@@@@@COOOOOO@@@@@GOOOOOO@@@@@OOOOOOO@@@@AOOOOOOO@@@@COOOOOOO@@@@COOOOOOO@@@@GOOOOOO@@@@@OOOOOOL@@@@@OOOOOO@@@@@AOOOOOL@@@@@AOOOOOH@@@@@AOOOOO@@@@@@COOOON@@@@@@COOOOL@@@@@@GOOOOH@@@@@@GOOOO@@@@@@@GOOOO@@@@@@@GOOON@@@@@@@GOOON@@@@@@@OOOOL@@@@@@@OOOOL@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@ NE 
#*(36 36)OL@@@@@@@@@@OON@@@@@@@@@OOOH@@@@@@@@OOOO@@@@@@@@OOOOL@@@@@@@OOOON@@@@@@@OOOOOH@@@@@@OOOOOL@@@@@@OOOOON@@@@@@OOOOOO@@@@@@OOOOOOH@@@@@OOOOOOL@@@@@OOOOOON@@@@@OOOOOOO@@@@@OOOOOOOH@@@@OOOOOOOL@@@@OOOOOOOL@@@@@GOOOOON@@@@@AOOOOOO@@@@@@GOOOOO@@@@@@AOOOOOH@@@@@@OOOOOH@@@@@@GOOOOH@@@@@@COOOOL@@@@@@AOOOOL@@@@@@@OOOON@@@@@@@OOOON@@@@@@@GOOON@@@@@@@GOOON@@@@@@@COOON@@@@@@@COOOO@@@@@@@COOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@ SOUTH 
#*(15 36)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOONOOONOOONOOONOOONOOONOOONOOONOOONOOONOOONOOONOOONOOONOOONOOONOOON SW 
#*(36 36)OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOL@@@@@@@GOOOL@@@@@@@GOOON@@@@@@@GOOON@@@@@@@GOOOO@@@@@@@GOOOO@@@@@@@COOOOH@@@@@@COOOOL@@@@@@AOOOON@@@@@@AOOOOO@@@@@@AOOOOOH@@@@@@OOOOON@@@@@@OOOOOOH@@@@@GOOOOOO@@@@@COOOOOOO@@@@COOOOOOO@@@@AOOOOOOO@@@@@OOOOOOO@@@@@GOOOOOO@@@@@COOOOOO@@@@@AOOOOOO@@@@@@OOOOOO@@@@@@GOOOOO@@@@@@COOOOO@@@@@@AOOOOO@@@@@@@GOOOO@@@@@@@COOOO@@@@@@@@OOOO@@@@@@@@AOOO@@@@@@@@@GOO@@@@@@@@@@CO@@@ SE 
#*(36 36)@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@COOOO@@@@@@@COOON@@@@@@@GOOON@@@@@@@GOOON@@@@@@@OOOON@@@@@@@OOOON@@@@@@AOOOOL@@@@@@COOOOL@@@@@@GOOOOH@@@@@@OOOOOH@@@@@AOOOOOH@@@@@GOOOOOH@@@@AOOOOOO@@@@@GOOOOOO@@@@OOOOOOON@@@@OOOOOOOL@@@@OOOOOOOL@@@@OOOOOOOH@@@@OOOOOOO@@@@@OOOOOON@@@@@OOOOOOL@@@@@OOOOOOH@@@@@OOOOOO@@@@@@OOOOON@@@@@@OOOOOL@@@@@@OOOOO@@@@@@@OOOOL@@@@@@@OOOOH@@@@@@@OOOL@@@@@@@@OON@@@@@@@@@OL@@@@@@@@@@ EAST 
#*(36 15)@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@@@@@AOOOO@@@ CENTER 
#*(15 15)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ WEST #*(36 15)OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@OOOOH@@@@@@@)
   :MARGINS (17 17 17 17)
   :DEFAULT-SHADOWS T)

(DEF-BUTTON-TYPE :ARK :IMAGE #S(NORTH-SOUTH-BITMAP NORTH #*(86 5)OOOOOOOOOOOOOOOOOOOOOL@@JBBBBBBBBBBBBBBBBBBBBL@@HHHHHHHHHHHHHHHHHHHHID@@JBBBBBBBBBBBBBBBBBBBCL@@HHHHHHHHHHHHHHHHHHHHOD@@ CENTER 
#*(86 2)JEEEEEEEEEEEEEEEEEEEEL@@HJJJJJJJJJJJJJJJJJJJOD@@ SOUTH #*(86 5)JMMMMMMMMMMMMMMMMMMMML@@IGGGGGGGGGGGGGGGGGGGGD@@KMMMMMMMMMMMMMMMMMMMML@@OGGGGGGGGGGGGGGGGGGGGD@@OOOOOOOOOOOOOOOOOOOOOL@@)
   :MARGINS (4 5 5 6)
   :DEFAULT-SHADOWS :ARK)

(DEF-BUTTON-TYPE :ROUND-ARK :IMAGE #*(74 24)@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOH@@@@GAAAAAAAAAAAAAAF@@@AL@DDDDDDDDDDDDDEH@@A@EEEEEEEEEEEEEEAH@@BBJJJJJJJJJJJJJJJL@@BEEEEEEEEEEEEEEEED@@FJJJJJJJJJJJJJJJJJ@@DEEEEEEEEEEEEEEEEF@@FJJJJJJJJJJJJJJJJJ@@EEEEEEEEEEEEEEEEEF@@GJJJJJJJJJJJJJJJJJ@@EEEEEEEEEEEEEEEEEF@@GJJJJJJJJJJJJJJJJN@@EEEEEEEEEEEEEEEEEF@@GJJJJJJJJJJJJJJJKN@@CMEEEEEEEEEEEEEEFL@@CFJJJJJJJJJJJJJJOL@@AMMMMMMMMMMMMMMMKH@@@GGGGGGGGGGGGGGGN@@@@AOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
   :MASK #*(74 24)@@@@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOH@@@@GOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOOH@@AOOOOOOOOOOOOOOOOH@@COOOOOOOOOOOOOOOOL@@COOOOOOOOOOOOOOOOL@@GOOOOOOOOOOOOOOOON@@GOOOOOOOOOOOOOOOON@@GOOOOOOOOOOOOOOOON@@GOOOOOOOOOOOOOOOON@@GOOOOOOOOOOOOOOOON@@GOOOOOOOOOOOOOOOON@@GOOOOOOOOOOOOOOOON@@GOOOOOOOOOOOOOOOON@@GOOOOOOOOOOOOOOOON@@COOOOOOOOOOOOOOOOL@@COOOOOOOOOOOOOOOOL@@AOOOOOOOOOOOOOOOOH@@@GOOOOOOOOOOOOOON@@@@AOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
   :MARGINS (5 4 5 2)
   :DEFAULT-SHADOWS :ARK)

(DEF-BUTTON-TYPE :STRETCHY-ARK :IMAGE #S(NSEW-BITMAP NORTH #*(4 5)O@@@D@@@A@@@D@@@A@@@ NW #*(5 5)OH@@J@@@HH@@J@@@HH@@ NE 
#*(5 5)OH@@EH@@BH@@GH@@NH@@ SOUTH #*(4 5)K@@@N@@@K@@@N@@@O@@@ SW #*(5 5)JH@@I@@@KH@@O@@@OH@@ SE #*(5 5
)KH@@NH@@KH@@NH@@OH@@ EAST #*(5 4)KH@@NH@@KH@@NH@@ CENTER #*(4 4)J@@@E@@@J@@@E@@@ WEST #*(5 4)J@@@HH@@J@@@HH@@)
   :MARGINS (6 6 6 6)
   :DEFAULT-SHADOWS :ARK)

(DEF-BUTTON-TYPE :STRETCHY-ROUND-ARK :IMAGE #S(NSEW-BITMAP NORTH #*(4 6)O@@@D@@@A@@@E@@@J@@@E@@@ NW 
#*(7 6)@B@@@N@@CH@@B@@@DD@@DJ@@ NE #*(9 6)N@@@EH@@AF@@DF@@JK@@EE@@ SOUTH #*(4 6)J@@@E@@@J@@@G@@@M@@@O@@@ SW 
#*(7 6)OD@@GJ@@FL@@CJ@@@N@@@B@@ SE #*(9 6)JOH@EK@@KO@@FN@@OH@@N@@@ EAST #*(9 8)JJH@EEH@JJH@EEH@JJH@EEH@JJH@EEH@ CENTER 
#*(4 8)J@@@E@@@J@@@E@@@J@@@E@@@J@@@E@@@ WEST #*(7 8)OD@@JJ@@OD@@JJ@@OD@@JJ@@OD@@JJ@@)
   :MASK #S(NSEW-BITMAP NORTH #*(4 6)O@@@O@@@O@@@O@@@O@@@O@@@ NW #*(7 6)@B@@@N@@CN@@CN@@GN@@GN@@ NE 
#*(9 6)N@@@OH@@ON@@ON@@OO@@OO@@ SOUTH #*(4 6)O@@@O@@@O@@@O@@@O@@@O@@@ SW #*(7 6)ON@@GN@@GN@@CN@@@N@@@B@@ SE 
#*(9 6)OOH@OO@@OO@@ON@@OH@@N@@@ EAST #*(9 8)OOH@OOH@OOH@OOH@OOH@OOH@OOH@OOH@ CENTER #*(4 8)O@@@O@@@O@@@O@@@O@@@O@@@O@@@O@@@ WEST 
#*(7 8)ON@@ON@@ON@@ON@@ON@@ON@@ON@@ON@@)
   :MARGINS (4 1 4 2)
   :DEFAULT-SHADOWS :ARK)
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY

(IL:GLOBALVARS IL:MENUHELDWAIT)
)
(IL:PUTPROPS IL:ROOMS-BUTTONS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (6457 7875 (SELECT-BUTTON-TYPE 6457 . 7875)) (10909 13146 (MAKE-BUTTON 10909 . 13146)
) (13148 13414 (COPY-BUTTON 13148 . 13414)) (13416 14419 (DISPLAY-BUTTON 13416 . 14419)) (14421 15264 
(UPDATE-BUTTON 14421 . 15264)) (15266 15604 (SET-BUTTON-TEXT-STRING 15266 . 15604)) (15874 16212 (
SET-BUTTON-TEXT-STRING 15874 . 16212)) (16214 16417 (COMPUTE-BUTTON-TEXT-POSITION 16214 . 16417)) (
16419 17055 (BUTTON-TEXT-X-COORD 16419 . 17055)) (17057 17697 (BUTTON-TEXT-Y-COORD 17057 . 17697)) (
17699 18120 (TEXT-FROM-TEXT-FORM 17699 . 18120)) (18122 19426 (BUTTON-TRACK-MOUSE 18122 . 19426)) (
19428 19620 (PERFORM-BUTTON-ACTION 19428 . 19620)) (19622 20088 (EDIT-BUTTON 19622 . 20088)) (20090 
20785 (BUTTON-COPY-SELECTED 20090 . 20785)) (20787 22056 (SHADE-BUTTON 20787 . 22056)) (22058 22202 (
PRINT-BUTTON-HELP 22058 . 22202)) (22349 23450 (MAKE-BUTTON-WINDOW 22349 . 23450)) (23452 24543 (
BW-REPAINTFN 23452 . 24543)) (24545 25335 (BW-TOTOPFN 24545 . 25335)) (25337 26238 (BW-BUTTONEVENTFN 
25337 . 26238)) (26240 26967 (BW-BUTTONEVENTFN-INTERNAL 26240 . 26967)) (26969 27253 (
SET-BUTTON-WINDOW-TEXT-STRING 26969 . 27253)) (27255 28200 (MAYBE-RESIZE-BUTTON-WINDOW 27255 . 28200))
 (28202 29222 (BW-SCREEN-CHANGED-FUNCTION 28202 . 29222)) (29688 30643 (DISPLAY-BUTTON-IMAGE 29688 . 
30643)) (30645 31439 (DISPLAY-BUTTON-MASK 30645 . 31439)) (31441 34832 (BUTTON-WIDTH 31441 . 34832)) (
34834 38509 (BUTTON-HEIGHT 34834 . 38509)) (38511 39213 (BUTTON-BITMAP-BITBLT 38511 . 39213)) (39215 
40415 (EW-BITBLT 39215 . 40415)) (40417 41728 (NS-BITBLT 40417 . 41728)) (41730 43230 (NSEW-BITBLT 
41730 . 43230)) (43232 45698 (PAINT-REGION 43232 . 45698)) (45739 46229 (EDIT-BUTTON-WINDOW 45739 . 
46229)) (46231 47729 (EXTERNALIZE-BUTTON 46231 . 47729)) (47731 47880 (EXTERNALIZE-FONT 47731 . 47880)
) (47882 48179 (WITH-BUTTON 47882 . 48179)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-BUTTONS.DFASL b/rooms/ROOMS-BUTTONS.DFASL
new file mode 100644
index 00000000..795bc6ca
Binary files /dev/null and b/rooms/ROOMS-BUTTONS.DFASL differ
diff --git a/rooms/ROOMS-CORE b/rooms/ROOMS-CORE
new file mode 100644
index 00000000..12f33b4b
--- /dev/null
+++ b/rooms/ROOMS-CORE
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:26:01" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-CORE.;2| 38390  

      IL:|previous| IL:|date:| "17-Aug-90 12:39:01" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-CORE.;1|)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMS-CORECOMS)

(IL:RPAQQ IL:ROOMS-CORECOMS
          (
           (IL:* IL:|;;| "core rooms code")

           (FILE-ENVIRONMENTS IL:ROOMS-CORE)
           (IL:P (EXPORT '(ROOM ROOM-P ROOM-NAME ROOM-PLACEMENTS ROOM-INCLUSIONS ROOM-BACKGROUND 
                                ROOM-TTY-PROCESS ROOM-PROPS ROOM-PROP MAKE-ROOM COPY-ROOM DELETE-ROOM
                                RENAME-ROOM ROOM-NAMED ROOM-SORT-FUNCTION))
                 (EXPORT '(*CURRENT-ROOM* *POCKET-ROOM-NAME* *ROOM-ENTRY-FUNCTIONS* 
                                 *ROOM-EXIT-FUNCTIONS* *ROOM-CHANGED-FUNCTIONS*))
                 (EXPORT '(PLACEMENT PLACEMENT-P PLACEMENT-WINDOW PLACEMENT-REGION 
                                 PLACEMENT-SHRUNKEN? PLACEMENT-ICON-POSITION PLACEMENT-PROPS 
                                 PLACEMENT-PROP MAKE-PLACEMENT COPY-PLACEMENT MOVE-PLACEMENT))
                 (EXPORT '(GO-TO-ROOM UPDATE-PLACEMENTS FIND-PLACEMENT ROOM-CHANGED DO-INCLUSIONS 
                                 RESET))
                 (REQUIRE "ROOMS"))
           (IL:COMS 

                  (IL:* IL:|;;| "the room -- a named object")

                  (IL:STRUCTURES ROOM)
                  (IL:VARIABLES *ROOMS* *CURRENT-ROOM*)
                  (IL:FUNCTIONS IN-ROOM? MAKE-ROOM COPY-ROOM RENAME-ROOM ROOM-PROP DO-ROOMS ALL-ROOMS
                         ROOM-SORT-FUNCTION ROOM-NAMED DELETE-ROOM))
           (IL:COMS 

                  (IL:* IL:|;;| "placements")

                  (IL:STRUCTURES PLACEMENT)
                  (IL:FUNCTIONS PLACEMENT-PROP MAKE-PLACEMENT COPY-PLACEMENT MOVE-PLACEMENT 
                         ADD-PLACEMENT DELETE-PLACEMENT))
           
           (IL:* IL:|;;| "going from one room to another")

           (IL:VARIABLES *POCKET-ROOM-NAME* *MONITOR-LOCK* *ROOM-ENTRY-FUNCTIONS* 
                  *ROOM-EXIT-FUNCTIONS*)
           (IL:FUNCTIONS GO-TO-ROOM GO-TO-ROOM-PROCESS GO-TO-ROOM-INTERNAL CALL-ENTRY-FUNCTIONS 
                  CALL-EXIT-FUNCTIONS UPDATE-PLACEMENTS FIND-PLACEMENT FIND-PLACEMENT-IN-ROOM 
                  UPDATE-PLACEMENT PLACE-PLACEMENTS FIND-PLACEMENTS PLACE-PLACEMENT)
           (IL:FUNCTIONS UPDATE-TTY-PROCESS PLACE-TTY-PROCESS)
           
           (IL:* IL:|;;| "other essentials")

           (IL:FUNCTIONS FIND-ROOMS-CONTAINING)
           (IL:COMS (IL:VARIABLES *ROOM-CHANGED-FUNCTIONS*)
                  (IL:FUNCTIONS ROOM-CHANGED))
           (IL:FUNCTIONS DO-INCLUSIONS ROOM-INCLUDERS)
           
           (IL:* IL:|;;| "bootstrapping & resetting")

           (IL:VARIABLES *RESET-FORMS*)
           (IL:FUNCTIONS RESET)
           (IL:VARIABLES OLD-WHOLESCREEN *SCREEN-CHANGED-FUNCTIONS*)
           (IL:FUNCTIONS AROUNDEXITFN %INTERNALIZE-ALL-PLACEMENTS %INTERNALIZE-PLACEMENTS)
           (IL:GLOBALVARS IL:PROMPTWINDOW IL:AROUNDEXITFNS)
           (EVAL-WHEN (LOAD)
                  (IL:P                                      (IL:* IL:\; 
                "smash system code which moves windows around on reboot so we don't fight with it.")
                        (PUSHNEW '(IL:CHANGENAME 'IL:\\STARTDISPLAY 'IL:\\MOVE.WINDOWS.ONTO.SCREEN
                                         'IL:NILL)
                               *RESET-FORMS* :TEST 'EQUAL)))
           
           (IL:* IL:|;;| "random")

           (IL:PROP IL:ARGNAMES GO-TO-ROOM)
           (IL:SEDIT-FORMATS DO-INCLUSIONS DO-ROOMS)))



(IL:* IL:|;;| "core rooms code")


(DEFINE-FILE-ENVIRONMENT IL:ROOMS-CORE :COMPILER :COMPILE-FILE
   :PACKAGE "ROOMS"
   :READTABLE "XCL")

(EXPORT '(ROOM ROOM-P ROOM-NAME ROOM-PLACEMENTS ROOM-INCLUSIONS ROOM-BACKGROUND ROOM-TTY-PROCESS 
               ROOM-PROPS ROOM-PROP MAKE-ROOM COPY-ROOM DELETE-ROOM RENAME-ROOM ROOM-NAMED 
               ROOM-SORT-FUNCTION))

(EXPORT '(*CURRENT-ROOM* *POCKET-ROOM-NAME* *ROOM-ENTRY-FUNCTIONS* *ROOM-EXIT-FUNCTIONS* 
                *ROOM-CHANGED-FUNCTIONS*))

(EXPORT '(PLACEMENT PLACEMENT-P PLACEMENT-WINDOW PLACEMENT-REGION PLACEMENT-SHRUNKEN? 
                PLACEMENT-ICON-POSITION PLACEMENT-PROPS PLACEMENT-PROP MAKE-PLACEMENT COPY-PLACEMENT
                MOVE-PLACEMENT))

(EXPORT '(GO-TO-ROOM UPDATE-PLACEMENTS FIND-PLACEMENT ROOM-CHANGED DO-INCLUSIONS RESET))

(REQUIRE "ROOMS")



(IL:* IL:|;;| "the room -- a named object")


(DEFSTRUCT (ROOM (:CONSTRUCTOR MAKE-ROOM-INTERNAL)
                     (:COPIER COPY-ROOM-INTERNAL)
                     (:PRINT-FUNCTION (LAMBDA (ROOM STREAM DEPTH)
                                             (FORMAT STREAM "#<Room ~S>" (ROOM-NAME ROOM)))))
   (NAME NIL :READ-ONLY T)
   (PLACEMENTS NIL :TYPE LIST)

   (IL:* IL:|;;| "list of PLACEMENT objects")

   (INCLUSIONS NIL :TYPE LIST)

   (IL:* IL:|;;| "list of names of included rooms")

   (BACKGROUND NIL :TYPE BACKGROUND)

   (IL:* IL:|;;| "how to paint the background")

   (TTY-PROCESS NIL)

   (IL:* IL:|;;| "which process has the TTY in this room")

   (PROPS NIL :TYPE LIST)

   (IL:* IL:|;;| "property list")

   )

(DEFVAR *ROOMS* (MAKE-HASH-TABLE :TEST 'EQUAL)
                    "A hash table mapping from room names to rooms.")

(DEFGLOBALVAR *CURRENT-ROOM* NIL
   "The room the user is currently in.")

(DEFUN IN-ROOM? (ROOM)

(IL:* IL:|;;;| "true if ROOM is a sub-room of the current room")

   (DO-INCLUSIONS (INCLUDED-ROOM *CURRENT-ROOM*)
          (WHEN (EQUAL (ROOM-NAME ROOM)
                       (ROOM-NAME INCLUDED-ROOM))
                (RETURN-FROM DO-INCLUSIONS T))))

(DEFUN MAKE-ROOM (NAME &REST REST-KEYS &KEY PLACEMENTS INCLUSIONS (BACKGROUND NIL 
                                                                             BACKGROUND-SPECIFIED?)
                           TTY-PROCESS &ALLOW-OTHER-KEYS)

   (IL:* IL:|;;| "check whether a room with this already exists")

   (WHEN (ROOM-NAMED NAME)
       (CERROR "Delete existing room named ~S (will close windows)" "A room named ~S already exists"
              NAME)
       (DELETE-ROOM (ROOM-NAMED NAME)))

   (IL:* IL:|;;| "check the types of the placements")

   (DOLIST (PLACEMENT PLACEMENTS)
       (CHECK-TYPE PLACEMENT PLACEMENT))

   (IL:* IL:|;;| "default the background to contain the name of the room")

   (UNLESS BACKGROUND-SPECIFIED?
       (SETQ BACKGROUND `((:TEXT ,NAME))))
   (LET ((ROOM (MAKE-ROOM-INTERNAL :NAME NAME :PLACEMENTS PLACEMENTS :INCLUSIONS INCLUSIONS 
                      :BACKGROUND (MAKE-BACKGROUND BACKGROUND)
                      :TTY-PROCESS TTY-PROCESS :PROPS
                      (LET ((PROPS (COPY-LIST REST-KEYS)))
                           (DOLIST (KEYWORD '(:PLACEMENTS :INCLUSIONS :BACKGROUND :TTY-PROCESS))
                               (REMF PROPS KEYWORD))
                           PROPS))))
        (SETF (ROOM-NAMED NAME)
              ROOM)
        (WHEN *CURRENT-ROOM*
            (WHEN (EQUAL NAME (ROOM-NAME *CURRENT-ROOM*))
                  (SETQ *CURRENT-ROOM* ROOM))
            (ROOM-CHANGED ROOM :CREATED))
        ROOM))

(DEFUN COPY-ROOM (ROOM NEW-NAME)
   (UPDATE-PLACEMENTS)
   (APPLY 'MAKE-ROOM NEW-NAME :PLACEMENTS (MAPCAR #'COPY-PLACEMENT (ROOM-PLACEMENTS ROOM))
          :INCLUSIONS
          (COPY-LIST (ROOM-INCLUSIONS ROOM))
          :BACKGROUND
          (LET* ((BACKGROUND (COPY-TREE (BACKGROUND-EXTERNAL-FORM (ROOM-BACKGROUND ROOM))))
                 (OLD-NAME (ROOM-NAME ROOM))
                 (TEXT (FIND-IF #'(LAMBDA (COMMAND)
                                         (AND (EQ (FIRST COMMAND)
                                                  :TEXT)
                                              (EQUAL (SECOND COMMAND)
                                                     OLD-NAME)))
                              BACKGROUND)))
                (WHEN TEXT
                    (SETF (SECOND TEXT)
                          NEW-NAME))
                BACKGROUND)
          (COPY-TREE (ROOM-PROPS ROOM))))

(DEFUN RENAME-ROOM (ROOM NEW-NAME)
   (LET ((OLD-NAME (ROOM-NAME ROOM)))
        (PROG1 (COPY-ROOM ROOM NEW-NAME)
            (DELETE-ROOM ROOM)
            (LET ((SUITE-NAME (FIND-SUITE-CONTAINING OLD-NAME)))

                 (IL:* IL:|;;| "if its in a suite, rename it there too")

                 (WHEN SUITE-NAME
                     (SETF (SUITE-ROOMS SUITE-NAME)
                           (SUBSTITUTE NEW-NAME OLD-NAME (SUITE-ROOMS SUITE-NAME)
                                  :TEST
                                  'EQUAL))))
            (DO-ROOMS (ROOM)

                   (IL:* IL:|;;| "rename it in inclusions of other rooms")

                   (WHEN (MEMBER OLD-NAME (ROOM-INCLUSIONS ROOM)
                                :TEST
                                'EQUAL)

                       (IL:* IL:|;;| 
                 "don't need to call UPDATE-PLACEMENTS as COPY-ROOM has already called it for us. ")

                       (SETF (ROOM-INCLUSIONS ROOM)
                             (SUBSTITUTE NEW-NAME OLD-NAME (ROOM-INCLUSIONS ROOM)
                                    :TEST
                                    'EQUAL))
                       (ROOM-CHANGED ROOM :EDITED))))))

(DEFMACRO ROOM-PROP (ROOM PROP &OPTIONAL (NEW-VALUE NIL NEW-VALUE-SUPPLIED))
   (IF NEW-VALUE-SUPPLIED
       `(SETF (GETF (ROOM-PROPS ,ROOM)
                    ,PROP)
              ,NEW-VALUE)
       `(GETF (ROOM-PROPS ,ROOM)
              ,PROP)))

(DEFMACRO DO-ROOMS ((ROOM-VAR)
                        &BODY BODY)

(IL:* IL:|;;;| "evaluate BODY once for each room with ROOM-VAR bound to the room.")

   `(BLOCK DO-ROOMS
        (MAPHASH #'(LAMBDA (,(GENSYM)
                            ,ROOM-VAR)
                          ,@BODY)
               *ROOMS*)))

(DEFUN ALL-ROOMS (&OPTIONAL SORTED?)

(IL:* IL:|;;;| "return a list of all rooms.  if SORTED? is true, sort them alphabetically by name")

   (LET ((ALL-ROOMS (WITH-COLLECTION (DO-ROOMS (ROOM)
                                                (COLLECT ROOM)))))
        (IF SORTED?
            (SORT ALL-ROOMS #'ROOM-SORT-FUNCTION)
            ALL-ROOMS)))

(DEFUN ROOM-SORT-FUNCTION (ROOM-1 ROOM-2)

(IL:* IL:|;;;| 
"used as the predicate for sorting lists of rooms.  we sort alphabetically by the name of the room.")

   (MACROLET ((STRINGIFY (NAME)
                     `(IF (STRINGP ,NAME)
                          ,NAME
                          (PRINC-TO-STRING ,NAME))))
          (LET ((NAME-1 (ROOM-NAME ROOM-1))
                (NAME-2 (ROOM-NAME ROOM-2)))
               (STRING-LESSP (STRINGIFY NAME-1)
                      (STRINGIFY NAME-2)))))

(DEFMACRO ROOM-NAMED (NAME)
   `(GETHASH ,NAME *ROOMS*))

(DEFUN DELETE-ROOM (ROOM)

   (IL:* IL:|;;| "first close all the windows which only have placements in this room")

   (LET ((ONLY-THIS-ROOM (LIST ROOM)))
        (DOLIST (WINDOW (ALL-WINDOWS T))
            (WHEN (EQUAL (FIND-ROOMS-CONTAINING WINDOW)
                         ONLY-THIS-ROOM)
                (UN-HIDE-WINDOW WINDOW)
                (CLOSE-WINDOW (IF (SHRUNKEN? WINDOW)
                                  (WINDOW-ICON WINDOW)
                                  WINDOW)))))
   (WHEN (DO-ROOMS (RM)
                (WHEN (EQ ROOM RM)
                      (RETURN-FROM DO-ROOMS T)))

       (IL:* IL:|;;| "if it's in the name table, remove it.  this is so deleting an un-named room (like the Overview) doesn't cause a room named \"Overview\" to also disappear.")

       (REMHASH (ROOM-NAME ROOM)
              *ROOMS*))

   (IL:* IL:|;;| "tell the world we've deleted it")

   (ROOM-CHANGED ROOM :DELETED))



(IL:* IL:|;;| "placements")


(DEFSTRUCT (PLACEMENT (:CONSTRUCTOR MAKE-PLACEMENT-INTERNAL)
                          (:COPIER COPY-PLACEMENT-INTERNAL))
   WINDOW
   REGION
   SHRUNKEN?
   ICON-POSITION
   PROPS)

(DEFMACRO PLACEMENT-PROP (PLACEMENT PROP &OPTIONAL (NEW-VALUE NIL NEW-VALUE-SUPPLIED))
   (IF NEW-VALUE-SUPPLIED
       `(SETF (GETF (PLACEMENT-PROPS ,PLACEMENT)
                    ,PROP)
              ,NEW-VALUE)
       `(GETF (PLACEMENT-PROPS ,PLACEMENT)
              ,PROP)))

(DEFUN MAKE-PLACEMENT (WINDOW)
   (LET ((PLACEMENT (MAKE-PLACEMENT-INTERNAL :WINDOW WINDOW)))
        (UPDATE-PLACEMENT PLACEMENT)
        PLACEMENT))

(DEFUN COPY-PLACEMENT (PLACEMENT)

   (IL:* IL:|;;| "make sure PROPS gets copied.  it is not important that REGION & ICON-POSITION are copied, but seems safer.")

   (MAKE-PLACEMENT-INTERNAL :WINDOW (PLACEMENT-WINDOW PLACEMENT)
          :REGION
          (COPY-REGION (PLACEMENT-REGION PLACEMENT))
          :SHRUNKEN?
          (PLACEMENT-SHRUNKEN? PLACEMENT)
          :ICON-POSITION
          (COPY-TREE (PLACEMENT-ICON-POSITION PLACEMENT))
          :PROPS
          (COPY-TREE (PLACEMENT-PROPS PLACEMENT))))

(DEFUN MOVE-PLACEMENT (PLACEMENT FROM-ROOM TO-ROOM &OPTIONAL COPY?)
   (ADD-PLACEMENT (COPY-PLACEMENT PLACEMENT)
          TO-ROOM)
   (UNLESS COPY?
       (DELETE-PLACEMENT PLACEMENT FROM-ROOM)
       (LET* ((WINDOW (PLACEMENT-WINDOW PLACEMENT))
              (INHERITED (FIND-PLACEMENT WINDOW)))
             (HIDE-WINDOW WINDOW)
             (WHEN INHERITED (PLACE-PLACEMENT INHERITED)))))

(DEFUN ADD-PLACEMENT (PLACEMENT ROOM)

(IL:* IL:|;;;| "add PLACEMENT to ROOM's placements.  does not update screen. ")

   (IL:* IL:|;;| "first delete any old placements for same window")

   (SETF (ROOM-PLACEMENTS ROOM)
         (DELETE (PLACEMENT-WINDOW PLACEMENT)
                (ROOM-PLACEMENTS ROOM)
                :TEST
                'EQ :KEY #'PLACEMENT-WINDOW))

   (IL:* IL:|;;| "add it")

   (PUSH PLACEMENT (ROOM-PLACEMENTS ROOM))

   (IL:* IL:|;;| "notify system that ROOM has changed.")

   (ROOM-CHANGED ROOM :PLACEMENTS))

(DEFUN DELETE-PLACEMENT (PLACEMENT ROOM)

   (IL:* IL:|;;| "delete PLACEMENT from ROOM.  does not remove placement from screen.")

   (SETF (ROOM-PLACEMENTS ROOM)
         (DELETE (PLACEMENT-WINDOW PLACEMENT)
                (ROOM-PLACEMENTS ROOM)
                :TEST
                'EQ :KEY #'PLACEMENT-WINDOW))

   (IL:* IL:|;;| "notify system that ROOM has changed.")

   (ROOM-CHANGED ROOM :PLACEMENTS))



(IL:* IL:|;;| "going from one room to another")


(DEFGLOBALVAR *POCKET-ROOM-NAME* NIL
   "The name of the room to be the pockets or NIL.")

(DEFGLOBALVAR *MONITOR-LOCK*)

(DEFVAR *ROOM-ENTRY-FUNCTIONS* NIL
   "A list of functions to be called before a room is entered")

(DEFVAR *ROOM-EXIT-FUNCTIONS* NIL
   "A list of functions to be called before a room is left")

(DEFUN GO-TO-ROOM (&REST ARGS)

(IL:* IL:|;;;| "skip to GO-TO-ROOM-INTERNAL for details...")

   (IL:* IL:|;;| "can't run under mouse, as mouse switches TTY around.  have to spawn our own process, let the mouse return the TTY, then we'll be run.  ")

   (CHECK-TYPE (FIRST ARGS)
          ROOM)
   (IL:RESETVAR IL:\\PROC.RUN.NEXT.FLG T 

    (IL:* IL:|;;| "ensure that we'll be the next process run when the mouse blocks.")

    (IL:ADD.PROCESS `(GO-TO-ROOM-PROCESS ',ARGS)
           'IL:NAME "Go To Room")))

(DEFUN GO-TO-ROOM-PROCESS (ARGS)
   (LET ((OLD-CURSOR (IL:CURSOR)))
        (UNWIND-PROTECT
            (IF (IL:OBTAIN.MONITORLOCK *MONITOR-LOCK* T)
                (PROGN (IL:CURSOR IL:WAITINGCURSOR)
                       (IL:\\CARET.DOWN NIL IL:MAX.FIXP)
                       (APPLY 'GO-TO-ROOM-INTERNAL ARGS))
                (NOTIFY-USER "Can't!  Rooms is busy."))
            (IL:RELEASE.MONITORLOCK *MONITOR-LOCK*)
            (IL:CURSOR OLD-CURSOR)
            (IL:CARET T))))

(DEFUN GO-TO-ROOM-INTERNAL (ROOM &KEY NO-UPDATE BAGGAGE)
   (CHECK-TYPE ROOM ROOM)

(IL:* IL:|;;;| "Leave the current room & enter ROOM.  BAGGAGE is a list of additional placements to be placed in ROOM.")

   (IL:* IL:|;;| "call exit hooks on current room")

   (CALL-EXIT-FUNCTIONS *CURRENT-ROOM*)
   (UNLESS NO-UPDATE

       (IL:* IL:|;;| "update the current room per the screen")

       (UPDATE-PLACEMENTS *CURRENT-ROOM*))

   (IL:* IL:|;;| "note which process has the keyboard")

   (UPDATE-TTY-PROCESS *CURRENT-ROOM*)

   (IL:* IL:|;;| "clear the screen")

   (HIDE-ALL-WINDOWS)
   (UNWIND-PROTECT
       (PROGN 
              (IL:* IL:|;;| "paint the background")

              (PAINT-BACKGROUND ROOM *SCREEN-BITMAP*)

              (IL:* IL:|;;| "call entry hooks")

              (CALL-ENTRY-FUNCTIONS ROOM))

       (IL:* IL:|;;| "set *CURRENT-ROOM*.")

       (SETQ *CURRENT-ROOM* ROOM))

   (IL:* IL:|;;| "place placements from ROOM -- inherited & direct")

   (PLACE-PLACEMENTS ROOM BAGGAGE)

   (IL:* IL:|;;| "place the caret ")

   (PLACE-TTY-PROCESS ROOM))

(DEFUN CALL-ENTRY-FUNCTIONS (ROOM)

   (IL:* IL:|;;| "first call global entry functions")

   (DOLIST (FN *ROOM-ENTRY-FUNCTIONS*)
       (FUNCALL FN ROOM))

   (IL:* IL:|;;| "then call inherited entry functions")

   (DO-INCLUSIONS (SUB-ROOM ROOM)
          (DOLIST (FN (ROOM-PROP SUB-ROOM :BEFORE-ENTRY-FUNCTIONS))
              (FUNCALL FN ROOM))))

(DEFUN CALL-EXIT-FUNCTIONS (ROOM)

   (IL:* IL:|;;| "first call global room exit functions")

   (DOLIST (FN *ROOM-EXIT-FUNCTIONS*)
       (FUNCALL FN ROOM))

   (IL:* IL:|;;| "then call inherited functions on ROOM")

   (DO-INCLUSIONS (SUB-ROOM ROOM)
          (DOLIST (FN (ROOM-PROP SUB-ROOM :BEFORE-EXIT-FUNCTIONS))
              (FUNCALL FN ROOM))))

(DEFUN UPDATE-PLACEMENTS (&OPTIONAL (FOR-ROOM *CURRENT-ROOM*))

(IL:* IL:|;;;| "called when leaving a room to update it's placements")

(IL:* IL:|;;;| "returns the new list of placements ")

   (LET ((NEW-PLACEMENTS NIL)
         (CHANGED-ROOMS NIL)
         (OLD-PLACEMENTS (ROOM-PLACEMENTS FOR-ROOM))
         (ALL-WINDOWS (ALL-WINDOWS)))
        (DOLIST (WINDOW ALL-WINDOWS)
            (MULTIPLE-VALUE-BIND (PLACEMENT IN-ROOM)
                   (FIND-PLACEMENT WINDOW FOR-ROOM)
                   (UNLESS PLACEMENT

                       (IL:* IL:|;;| "new  window in this room - make a placement")

                       (SETQ PLACEMENT (MAKE-PLACEMENT WINDOW))
                       (SETQ IN-ROOM FOR-ROOM)

                       (IL:* IL:|;;| "note change to this room")

                       (PUSHNEW FOR-ROOM CHANGED-ROOMS :TEST 'EQ))

                   (IL:* IL:|;;| "collect placements in this room in top to bottom order.")

                   (WHEN (EQ IN-ROOM FOR-ROOM)
                         (PUSH PLACEMENT NEW-PLACEMENTS))

                   (IL:* IL:|;;| "update the placement")

                   (WHEN (UPDATE-PLACEMENT PLACEMENT)

                       (IL:* IL:|;;| "placement has changed - note it")

                       (PUSHNEW IN-ROOM CHANGED-ROOMS :TEST 'EQ))))
        (DOLIST (PLACEMENT (FIND-PLACEMENTS FOR-ROOM))
            (UNLESS (MEMBER (PLACEMENT-WINDOW PLACEMENT)
                           ALL-WINDOWS :TEST 'EQ)

                (IL:* IL:|;;| "it's a window that's been closed")

                (DO-INCLUSIONS (ROOM FOR-ROOM)
                       (WHEN (MEMBER PLACEMENT (ROOM-PLACEMENTS ROOM)
                                    :TEST
                                    'EQ)

                           (IL:* IL:|;;| "delete its placement")

                           (UNLESS (EQ ROOM FOR-ROOM)

                               (IL:* IL:|;;| "unless we'll delete it below anyway")

                               (DELETE-PLACEMENT PLACEMENT ROOM))

                           (IL:* IL:|;;| "note that this room has changed")

                           (PUSHNEW ROOM CHANGED-ROOMS :TEST 'EQ)
                           (RETURN-FROM DO-INCLUSIONS)))))
        (UNLESS (EQUAL NEW-PLACEMENTS OLD-PLACEMENTS)

            (IL:* IL:|;;| "check if occlusion order of placements has changed")

            (PUSHNEW FOR-ROOM CHANGED-ROOMS :TEST 'EQ))
        (SETF (ROOM-PLACEMENTS FOR-ROOM)
              NEW-PLACEMENTS)
        (DOLIST (ROOM CHANGED-ROOMS)
            (ROOM-CHANGED ROOM :PLACEMENTS))
        T))

(DEFUN FIND-PLACEMENT (WINDOW &OPTIONAL (FROM-ROOM *CURRENT-ROOM*))

(IL:* IL:|;;;| "returns the placement which caused WINDOW to be in ROOM.")

(IL:* IL:|;;;| "does a breadth-first search through ROOM & its inclusions for a placement containing WINDOW.  second value is room placement was found in. ")

   (DO-INCLUSIONS (ROOM FROM-ROOM)
          (LET ((PLACEMENT (FIND-PLACEMENT-IN-ROOM WINDOW ROOM)))
               (WHEN PLACEMENT
                   (RETURN-FROM FIND-PLACEMENT (VALUES PLACEMENT ROOM))))))

(DEFMACRO FIND-PLACEMENT-IN-ROOM (WINDOW ROOM)
   `(LET ((WINDOW ,WINDOW))
         (DOLIST (PLACEMENT (ROOM-PLACEMENTS ,ROOM))
             (WHEN (EQ (PLACEMENT-WINDOW PLACEMENT)
                       WINDOW)
                   (RETURN PLACEMENT)))))

(DEFUN UPDATE-PLACEMENT (PLACEMENT)

(IL:* IL:|;;;| "called when leaving a room on each placement in the room.  returns true if placement has changed since the last time it was updated.")

   (LET* ((WINDOW (PLACEMENT-WINDOW PLACEMENT))
          (ICON-POSITION (ICON-POSITION WINDOW))
          (REGION (WINDOW-REGION WINDOW))
          (SHRUNKEN? (SHRUNKEN? WINDOW))
          (CHANGED? NIL))
         (UNLESS (EQUAL ICON-POSITION (PLACEMENT-ICON-POSITION PLACEMENT))
             (SETF (PLACEMENT-ICON-POSITION PLACEMENT)
                   (COPY-TREE ICON-POSITION))
             (SETQ CHANGED? T))
         (UNLESS (EQUAL REGION (PLACEMENT-REGION PLACEMENT))
             (SETF (PLACEMENT-REGION PLACEMENT)
                   (COPY-REGION REGION))
             (SETQ CHANGED? T))
         (UNLESS (EQ SHRUNKEN? (PLACEMENT-SHRUNKEN? PLACEMENT))
             (SETF (PLACEMENT-SHRUNKEN? PLACEMENT)
                   SHRUNKEN?)
             (SETQ CHANGED? T))

         (IL:* IL:|;;| "call the user hook")

         (LET ((WINDOW-TYPE (WINDOW-TYPE WINDOW T)))
              (WHEN WINDOW-TYPE
                  (LET ((UPDATER (WINDOW-TYPE-UPDATER WINDOW-TYPE)))
                       (WHEN UPDATER
                           (FUNCALL (WINDOW-TYPE-UPDATER WINDOW-TYPE)
                                  PLACEMENT)))))
         CHANGED?))

(DEFUN PLACE-PLACEMENTS (ROOM &OPTIONAL BAGGAGE)
   (DOLIST (PLACEMENT (FIND-PLACEMENTS ROOM))
       (PLACE-PLACEMENT PLACEMENT))
   (DOLIST (PLACEMENT BAGGAGE)
       (PLACE-PLACEMENT PLACEMENT)))

(DEFUN FIND-PLACEMENTS (ROOM)

(IL:* IL:|;;;| "returns the list of placements to be displayed in room, ordered in bottom first (i.e. the order they should be displayed in)")

   (LET (PLACEMENTS)
        (DO-INCLUSIONS (INCLUSION ROOM)
               (DOLIST (PLACEMENT (ROOM-PLACEMENTS INCLUSION))

                   (IL:* IL:|;;| "save one placement for each window on the way down")

                   (IL:* IL:|;;| "optimization: this rather convoluted piece of code is used rather than (pushnew placement placements :key #'placement-window) because pushnew compiles into something really slow in XCL.")

                   (LET ((WINDOW (PLACEMENT-WINDOW PLACEMENT)))
                        (UNLESS (DOLIST (PLACEMENT PLACEMENTS)
                                    (WHEN (EQ (PLACEMENT-WINDOW PLACEMENT)
                                              WINDOW)
                                          (RETURN T)))
                               (PUSH PLACEMENT PLACEMENTS)))))
        PLACEMENTS))

(DEFUN PLACE-PLACEMENT (PLACEMENT)

(IL:* IL:|;;;| "Called on each placement in a room when it's visited to place PLACEMENT's window per the rest of PLACEMENT.")

(IL:* IL:|;;;| "This will probably require a lot of work in a different window system.")

   (LET* ((WINDOW (PLACEMENT-WINDOW PLACEMENT))

          (IL:* IL:|;;| "we copy as window system sometimes seems to smash these")

          (PLACEMENT-REGION (COPY-REGION (PLACEMENT-REGION PLACEMENT)))
          (PLACEMENT-ICON-POSITION (COPY-TREE (PLACEMENT-ICON-POSITION PLACEMENT)))
          (WINDOW-REGION (WINDOW-REGION WINDOW))
          (WINDOW-ICON (WINDOW-ICON WINDOW))
          (WINDOW-TYPE (WINDOW-TYPE WINDOW T)))
         (WHEN (OR (IL:OPENWP WINDOW)
                   (AND WINDOW-ICON (IL:OPENWP WINDOW-ICON)))

             (IL:* IL:|;;| "if it's been closed & we ignore it")

             (UN-HIDE-WINDOW WINDOW)
             (COND
                ((PLACEMENT-SHRUNKEN? PLACEMENT)

                 (IL:* IL:|;;| "ensure the expansion is placed correctly")

                 (UNLESS (EQUAL PLACEMENT-REGION WINDOW-REGION)
                     (SHAPE-WINDOW WINDOW PLACEMENT-REGION :CURRENT-REGION WINDOW-REGION :NO-SHAPE
                            (AND WINDOW-TYPE (WINDOW-TYPE-PROP WINDOW-TYPE :NO-SHAPE))))

                 (IL:* IL:|;;| "place the icon")

                 (COND
                    ((SHRUNKEN? WINDOW)
                     (UNLESS (EQUAL (WINDOW-POSITION WINDOW-ICON)
                                    PLACEMENT-ICON-POSITION)
                         (MOVE-WINDOW WINDOW-ICON PLACEMENT-ICON-POSITION)
                         (OPEN-WINDOW WINDOW-ICON)))
                    (T (MOVE-WINDOW (SHRINK-WINDOW WINDOW PLACEMENT-ICON-POSITION)
                              PLACEMENT-ICON-POSITION))))
                (T (WHEN PLACEMENT-ICON-POSITION

                       (IL:* IL:|;;| "ensure the icon is placed correctly")

                       (UNLESS WINDOW-ICON
                           (SETQ WINDOW-ICON (SHRINK-WINDOW WINDOW PLACEMENT-ICON-POSITION)))
                       (MOVE-WINDOW WINDOW-ICON PLACEMENT-ICON-POSITION)
                       (WHEN (AND (IL:OPENWP WINDOW-ICON)
                                  (NOT (SHRUNKEN? WINDOW)))

                           (IL:* IL:|;;| "we opened the icon by moving it")

                           (IL:\\CLOSEW1 WINDOW-ICON)))

                   (IL:* IL:|;;| "place the window")

                   (WHEN (SHRUNKEN? WINDOW)
                         (EXPAND-WINDOW WINDOW))
                   (UNLESS (EQUAL PLACEMENT-REGION WINDOW-REGION)
                       (SHAPE-WINDOW WINDOW PLACEMENT-REGION :CURRENT-REGION WINDOW-REGION :NO-SHAPE
                              (AND WINDOW-TYPE (WINDOW-TYPE-PROP WINDOW-TYPE :NO-SHAPE))))
                   (OPEN-WINDOW WINDOW)
                   (UNLESS PLACEMENT-ICON-POSITION (DELETE-WINDOW-ICON WINDOW))))

             (IL:* IL:|;;| "call the user hook")

             (WHEN (AND WINDOW-TYPE (WINDOW-TYPE-PLACER WINDOW-TYPE))
                 (FUNCALL (WINDOW-TYPE-PLACER WINDOW-TYPE)
                        PLACEMENT)))))

(DEFUN UPDATE-TTY-PROCESS (ROOM)

(IL:* IL:|;;;| "update ROOM's notion of which process has the keyboard.")

   (SETF (ROOM-TTY-PROCESS ROOM)
         (IL:TTY.PROCESS)))

(DEFUN PLACE-TTY-PROCESS (ROOM)

(IL:* IL:|;;;| "place the keyboard per ROOM's TTY-PROCESS field")

   (LET ((PROCESS (ROOM-TTY-PROCESS ROOM)))
        (IL:TTY.PROCESS (IF (IL:PROCESSP PROCESS)
                            PROCESS

                            (IL:* IL:|;;| "if no process specified, or the specified process is dead, then we give the TTY to the MOUSE process ")

                            (IL:FIND.PROCESS 'IL:MOUSE)))))



(IL:* IL:|;;| "other essentials")


(DEFUN FIND-ROOMS-CONTAINING (WINDOW)

(IL:* IL:|;;;| "return a list of all rooms which directly contain a placement for WINDOW")

   (LET ((ROOMS))
        (DO-ROOMS (ROOM)
               (WHEN (FIND-PLACEMENT-IN-ROOM WINDOW ROOM)
                     (PUSH ROOM ROOMS)))

        (IL:* IL:|;;| "we need a general way of handling un-named rooms, but as there is only one now, we can just special case it.")

        (WHEN (FIND-PLACEMENT-IN-ROOM WINDOW *OVERVIEW-ROOM*)
              (PUSH *OVERVIEW-ROOM* ROOMS))
        ROOMS))

(DEFGLOBALVAR *ROOM-CHANGED-FUNCTIONS* NIL)

(DEFUN ROOM-CHANGED (ROOM REASON)

(IL:* IL:|;;;| "called when we notice a room has changed to ensure display is up to date.")

   (ECASE REASON
       ((:EDITED :CREATED :DELETED) (WHEN (IN-ROOM? ROOM)

                                        (IL:* IL:|;;| 
                                      "if we're in this room, redisplay whole screen")

                                        (IL:* IL:|;;| 
                                      "note: we depend upon our caller to update placements")

                                        (IL:WITH.MONITOR *MONITOR-LOCK* (GO-TO-ROOM-INTERNAL
                                                                         *CURRENT-ROOM* :NO-UPDATE T)
                                               )))
       (:PLACEMENTS 
                    (IL:* IL:|;;| "we presume our caller & the hooks handle these cases")
))
   (IL:* IL:|;;| "call hooks")

   (DOLIST (FN *ROOM-CHANGED-FUNCTIONS*)
       (FUNCALL FN ROOM REASON)))

(DEFMACRO DO-INCLUSIONS ((ROOM-VAR ROOM-FORM)
                             &BODY BODY)

(IL:* IL:|;;;| "descend breadth-first, left to right down the inclusions of a room, performing BODY with ROOM-VAR bound to each room. ")

   `(LET* ((,ROOM-VAR ,ROOM-FORM)
           ($ROOMS$ (LIST ,ROOM-VAR))
           ($QUEUE-HEAD$ $ROOMS$)
           ($QUEUE-TAIL$ $QUEUE-HEAD$)
           ($POCKET-ROOM-NAME$ *POCKET-ROOM-NAME*)
           $INCLUSIONS$ $INCLUSION$)
          (BLOCK DO-INCLUSIONS
              (TAGBODY $LOOP$ ,@BODY (SETQ $INCLUSIONS$ (ROOM-INCLUSIONS ,ROOM-VAR))
                     (UNLESS (LISTP $INCLUSIONS$)
                            (RETURN-FROM DO-INCLUSIONS))
                     (DOLIST (INCLUDED-ROOM-NAME $INCLUSIONS$)
                         (SETQ $INCLUSION$ (ROOM-NAMED INCLUDED-ROOM-NAME))
                         (WHEN (AND $INCLUSION$ (NOT (MEMBER $INCLUSION$ $ROOMS$ :TEST #'EQ)))
                             (RPLACD $QUEUE-TAIL$ (SETQ $QUEUE-TAIL$ (LIST $INCLUSION$)))))
                     (POP $QUEUE-HEAD$)
                     (IF $QUEUE-HEAD$
                         (SETQ ,ROOM-VAR (FIRST $QUEUE-HEAD$))
                         (IF (AND $POCKET-ROOM-NAME$ (SETQ ,ROOM-VAR (ROOM-NAMED 
                                                                            $POCKET-ROOM-NAME$))
                                  (NOT (MEMBER ,ROOM-VAR $ROOMS$ :TEST #'EQ)))
                             (SETQ $POCKET-ROOM-NAME$ NIL)
                             (RETURN-FROM DO-INCLUSIONS)))
                     (GO $LOOP$)))))

(DEFUN ROOM-INCLUDERS (ROOM &OPTIONAL SORTED?)

(IL:* IL:|;;;| "returns the list of rooms which include ROOM.")

(IL:* IL:|;;;| "note that every room implicitly includes itself.  the motivation for this is that most code which wants to map over includers also wants the root.")

   (IF (EQUAL (ROOM-NAME ROOM)
              *POCKET-ROOM-NAME*)

       (IL:* IL:|;;| "special case: all rooms include the pocket room")

       (ALL-ROOMS SORTED?)
       (DO* ((INCLUDERS NIL)                                 (IL:* IL:\; "list of included rooms")
             (QUEUE (LIST ROOM))                             (IL:* IL:\; 
                                                           "list of rooms to examine ")
             (INCLUDER ROOM (POP QUEUE))                     (IL:* IL:\; "room being examined")
             (INCLUDER-NAME (ROOM-NAME INCLUDER)
                    (ROOM-NAME INCLUDER)))
            ((NULL QUEUE)
             (IF SORTED?
                 (SORT INCLUDERS #'ROOM-SORT-FUNCTION)
                 INCLUDERS))
          (UNLESS (MEMBER INCLUDER INCLUDERS :TEST 'EQ)
              (PUSH INCLUDER INCLUDERS)
              (DO-ROOMS (ROOM)
                     (LET ((INCLUSIONS (ROOM-INCLUSIONS ROOM)))
                          (WHEN (AND (LISTP INCLUSIONS)
                                     (MEMBER INCLUDER-NAME INCLUSIONS :TEST 'EQUAL))
                              (PUSHNEW ROOM QUEUE :TEST 'EQ))))))))



(IL:* IL:|;;| "bootstrapping & resetting")


(DEFVAR *RESET-FORMS* NIL
   "List of forms to be EVALled when Rooms is reset.")

(DEFUN RESET ()

   (IL:* IL:|;;| "delete all existing rooms")

   (CLRHASH *ROOMS*)

   (IL:* IL:|;;| "bootstrap *CURRENT-ROOM*")

   (SETQ *CURRENT-ROOM* NIL)
   (SETQ *POCKET-ROOM-NAME* "Pockets")
   (MAKE-ROOM *POCKET-ROOM-NAME* :PLACEMENTS 

          (IL:* IL:|;;| "put promptwindow in pockets")

          (LIST (MAKE-PLACEMENT IL:PROMPTWINDOW))
          :BACKGROUND
          (COPY-TREE '((:WHOLE-SCREEN (:EVAL IL:WINDOWBACKGROUNDSHADE)))))
   (SETQ *CURRENT-ROOM* (MAKE-ROOM "Original"))
   (SETQ *MONITOR-LOCK* (IL:CREATE.MONITORLOCK "Rooms"))
   (IL:WITH.MONITOR *MONITOR-LOCK* (GO-TO-ROOM-INTERNAL *CURRENT-ROOM*))

   (IL:* IL:|;;| "install our aroundexitfn last so it gets called before greet")

   (UNLESS (MEMBER 'AROUNDEXITFN IL:AROUNDEXITFNS)
       (SETQ IL:AROUNDEXITFNS (NCONC IL:AROUNDEXITFNS (LIST 'AROUNDEXITFN))))

   (IL:* IL:|;;| "do reset forms")

   (DOLIST (FORM *RESET-FORMS*)
       (EVAL FORM))

   (IL:* IL:|;;| "may have lost some windows...")

   (CHECK-LOST-WINDOWS))

(DEFGLOBALVAR OLD-WHOLESCREEN (COPY-REGION IL:WHOLESCREEN))

(DEFGLOBALVAR *SCREEN-CHANGED-FUNCTIONS* (LIST '%INTERNALIZE-ALL-PLACEMENTS))

(DEFUN AROUNDEXITFN (EVENT)
   (CASE EVENT
       ((IL:BEFORESAVEVM IL:BEFORELOGOUT IL:BEFORESYSOUT IL:BEFOREMAKESYS) )
       ((IL:AFTERSAVEVM IL:AFTERLOGOUT IL:AFTERSYSOUT IL:AFTERMAKESYS) (UNLESS (EQUAL IL:WHOLESCREEN
                                                                                      OLD-WHOLESCREEN
                                                                                      )
                                                                           (DOLIST 
                                                                                   #'
                                                                           *SCREEN-CHANGED-FUNCTIONS*
                                                                               (FUNCALL FUNCTION))
                                                                           (SETQ OLD-WHOLESCREEN
                                                                                 (COPY-REGION 
                                                                                       IL:WHOLESCREEN
                                                                                        ))))))

(DEFUN %INTERNALIZE-ALL-PLACEMENTS ()

(IL:* IL:|;;;| "called when we re-boot on different sized screen.  re-scales the placement regions & icon-positions of all placements.")

   (LET ((OLD-SCREEN-WIDTH (REGION-WIDTH OLD-WHOLESCREEN))
         (OLD-SCREEN-HEIGHT (REGION-HEIGHT OLD-WHOLESCREEN)))
        (UPDATE-PLACEMENTS)
        (DO-ROOMS (ROOM)

               (IL:* IL:|;;| "do all the named rooms")

               (%INTERNALIZE-PLACEMENTS ROOM OLD-SCREEN-WIDTH OLD-SCREEN-HEIGHT)
               (ROOM-CHANGED ROOM :PLACEMENTS))

        (IL:* IL:|;;| "redisplay the current room.")

        (IL:PROCESS.RESULT (GO-TO-ROOM *CURRENT-ROOM* :NO-UPDATE T)
               T)))

(DEFUN %INTERNALIZE-PLACEMENTS (ROOM OLD-SCREEN-WIDTH OLD-SCREEN-HEIGHT)
   (DOLIST (PLACEMENT (ROOM-PLACEMENTS ROOM))

       (IL:* IL:|;;| "re-scale placements to new size of screen")

       (LET ((REGION (PLACEMENT-REGION PLACEMENT)))
            (SETF (PLACEMENT-REGION PLACEMENT)
                  (INTERNALIZE-REGION (MAKE-REGION :LEFT (EXTERNALIZE-COORDINATE (REGION-LEFT REGION)
                                                                OLD-SCREEN-WIDTH)
                                             :BOTTOM
                                             (EXTERNALIZE-COORDINATE (REGION-BOTTOM REGION)
                                                    OLD-SCREEN-HEIGHT)
                                             :WIDTH
                                             (EXTERNALIZE-COORDINATE (REGION-WIDTH REGION)
                                                    OLD-SCREEN-WIDTH)
                                             :HEIGHT
                                             (EXTERNALIZE-COORDINATE (REGION-HEIGHT REGION)
                                                    OLD-SCREEN-HEIGHT)))))
       (LET ((POSITION (PLACEMENT-ICON-POSITION PLACEMENT)))
            (WHEN POSITION
                (SETF (PLACEMENT-ICON-POSITION PLACEMENT)
                      (INTERNALIZE-POSITION (MAKE-POSITION (EXTERNALIZE-COORDINATE (POSITION-X 
                                                                                          POSITION)
                                                                  OLD-SCREEN-WIDTH)
                                                   (EXTERNALIZE-COORDINATE (POSITION-Y POSITION)
                                                          OLD-SCREEN-HEIGHT))))))))
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY

(IL:GLOBALVARS IL:PROMPTWINDOW IL:AROUNDEXITFNS)
)
(EVAL-WHEN (LOAD)

                                                             (IL:* IL:\; 
                "smash system code which moves windows around on reboot so we don't fight with it.")

(PUSHNEW '(IL:CHANGENAME 'IL:\\STARTDISPLAY 'IL:\\MOVE.WINDOWS.ONTO.SCREEN 'IL:NILL)
       *RESET-FORMS* :TEST 'EQUAL)
)



(IL:* IL:|;;| "random")


(IL:PUTPROPS GO-TO-ROOM IL:ARGNAMES (ROOM &KEY NO-UPDATE BAGGAGE))

(SEDIT:DEF-LIST-FORMAT DO-INCLUSIONS :INDENT (1)
   :ARGS (:KEYWORD :BINDING NIL)
   :SUBLISTS (2))

(SEDIT:DEF-LIST-FORMAT DO-ROOMS :INDENT (1)
   :ARGS (:KEYWORD :BINDING NIL)
   :SUBLISTS (2))
(IL:PUTPROPS IL:ROOMS-CORE IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (5690 5979 (IN-ROOM? 5690 . 5979)) (5981 7495 (MAKE-ROOM 5981 . 7495)) (7497 8405 (
COPY-ROOM 7497 . 8405)) (8407 9647 (RENAME-ROOM 8407 . 9647)) (10224 10594 (ALL-ROOMS 10224 . 10594)) 
(10596 11110 (ROOM-SORT-FUNCTION 10596 . 11110)) (11174 12121 (DELETE-ROOM 11174 . 12121)) (12632 
12790 (MAKE-PLACEMENT 12632 . 12790)) (12792 13313 (COPY-PLACEMENT 12792 . 13313)) (13315 13731 (
MOVE-PLACEMENT 13315 . 13731)) (13733 14297 (ADD-PLACEMENT 13733 . 14297)) (14299 14725 (
DELETE-PLACEMENT 14299 . 14725)) (15117 15646 (GO-TO-ROOM 15117 . 15646)) (15648 16138 (
GO-TO-ROOM-PROCESS 15648 . 16138)) (16140 17282 (GO-TO-ROOM-INTERNAL 16140 . 17282)) (17284 17654 (
CALL-ENTRY-FUNCTIONS 17284 . 17654)) (17656 18029 (CALL-EXIT-FUNCTIONS 17656 . 18029)) (18031 20678 (
UPDATE-PLACEMENTS 18031 . 20678)) (20680 21211 (FIND-PLACEMENT 20680 . 21211)) (21471 22821 (
UPDATE-PLACEMENT 21471 . 22821)) (22823 23037 (PLACE-PLACEMENTS 22823 . 23037)) (23039 24064 (
FIND-PLACEMENTS 23039 . 24064)) (24066 27240 (PLACE-PLACEMENT 24066 . 27240)) (27242 27419 (
UPDATE-TTY-PROCESS 27242 . 27419)) (27421 27871 (PLACE-TTY-PROCESS 27421 . 27871)) (27915 28469 (
FIND-ROOMS-CONTAINING 27915 . 28469)) (28520 29523 (ROOM-CHANGED 28520 . 29523)) (31104 32572 (
ROOM-INCLUDERS 31104 . 32572)) (32711 33760 (RESET 32711 . 33760)) (33910 35084 (AROUNDEXITFN 33910 . 
35084)) (35086 35801 (%INTERNALIZE-ALL-PLACEMENTS 35086 . 35801)) (35803 37536 (
%INTERNALIZE-PLACEMENTS 35803 . 37536)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-CORE.DFASL b/rooms/ROOMS-CORE.DFASL
new file mode 100644
index 00000000..3bcf6974
Binary files /dev/null and b/rooms/ROOMS-CORE.DFASL differ
diff --git a/rooms/ROOMS-D b/rooms/ROOMS-D
new file mode 100644
index 00000000..ec15a42c
--- /dev/null
+++ b/rooms/ROOMS-D
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:24:55" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-D.;2| 14267  

      IL:|previous| IL:|date:| "17-Aug-90 12:43:06" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-D.;1|)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMS-DCOMS)

(IL:RPAQQ IL:ROOMS-DCOMS
          (
           (IL:* IL:|;;| "Rooms' interface to Interlisp-D window system")

           (FILE-ENVIRONMENTS IL:ROOMS-D)
           (IL:P (EXPORT '(*WHO-LINE-ENTRY*)))
           (IL:TYPES BITMAP FONT TEXTURE)
                                                             (IL:* IL:\; "windows")
           (IL:FUNCTIONS MOVE-WINDOW SHAPE-WINDOW OPEN-WINDOW CLOSE-WINDOW)
           (IL:FUNCTIONS WINDOW-REGION MAIN-WINDOW WINDOW-TITLE WINDOW-VISIBLE-P)
                                                             (IL:* IL:\; "regions")
           (IL:STRUCTURES REGION)
           (IL:FUNCTIONS                                     (IL:* IL:\; " positions")
                  MAKE-POSITION POSITION-X POSITION-Y GET-POSITION)
           (IL:FUNCTIONS                                     (IL:* IL:\; "icons")
                  SHRINK-WINDOW EXPAND-WINDOW ICON? SHRUNKEN? ICON-POSITION WINDOW-POSITION 
                  WINDOW-ICON DELETE-WINDOW-ICON)
                                                             (IL:* IL:\; "user interface")
           (IL:FUNCTIONS MENU PROMPT-USER CONFIRM NOTIFY-USER GET-MESSAGE-STREAM SELECT-WINDOW 
                  SELECT-BAGGAGE EXTERNALIZE-FONT)
           (IL:FUNCTIONS                                     (IL:* IL:\; "keyboard interpretation")
                  
                  (IL:* IL:|;;| "these have gotten out of control.  it might be worth converting these to one function which returns a keyword naming the selected operation.  EDITCALLERS, anyone? ")

                  COPY-KEY-DOWN-P HELP-KEY-DOWN-P DELETE-KEY-DOWN-P EDIT-KEY-DOWN-P MOVE-KEY-DOWN-P 
                  EXPAND-KEY-DOWN-P)
           (IL:COMS 

                  (IL:* IL:|;;| "add a lafite form for bug reports")

                  (IL:FUNCTIONS MAKE-ROOMS-SUPPORT-FORM)
                  (IL:VARIABLES IL:ROOMSSUPPORT)
                  (IL:ADDVARS (IL:LAFITESPECIALFORMS ("Rooms Report" (IL:FUNCTION 
                                                                            MAKE-ROOMS-SUPPORT-FORM)
                                                            
                                                         "A form to report a Rooms bug or suggestion"
                                                            )))
                  (IL:P (SETQ IL:LAFITEFORMSMENU NIL))
                  
                  (IL:* IL:|;;| "provide a who line entry")

                  (IL:VARIABLES *WHO-LINE-ENTRY*)
                  (IL:P (WHEN (BOUNDP 'IL:*WHO-LINE-ENTRY-REGISTRY*)
                            (PUSHNEW *WHO-LINE-ENTRY* IL:*WHO-LINE-ENTRY-REGISTRY* :TEST 'EQUAL :KEY
                                   'CAR))))
           (IL:GLOBALVARS IL:PROMPTWINDOW IL:CROSSHAIRS IL:WINDOWBACKGROUNDSHADE IL:WHOLESCREEN 
                  IL:LAFITESPECIALFORMS IL:LAFITEFORMSMENU IL:DEFAULTICONFN 
                  IL:*WHO-LINE-ENTRY-REGISTRY*)))



(IL:* IL:|;;| "Rooms' interface to Interlisp-D window system")


(DEFINE-FILE-ENVIRONMENT IL:ROOMS-D :COMPILER :COMPILE-FILE
   :PACKAGE "ROOMS"
   :READTABLE "XCL")

(EXPORT '(*WHO-LINE-ENTRY*))

(DEFTYPE BITMAP ()
   `(SATISFIES IL:BITMAPP))

(DEFTYPE FONT ()
   `(SATISFIES IL:FONTP))

(DEFTYPE TEXTURE ()
   `(SATISFIES IL:TEXTUREP))



(IL:* IL:\; "windows")


(DEFUN MOVE-WINDOW (WINDOW POS &OPTIONAL (CURRENT-REGION (WINDOW-REGION WINDOW)))
   (UNLESS (IL:EQMEMB 'IL:DON\'T (IL:WINDOWPROP WINDOW 'IL:MOVEFN))
       (LET ((CURRENT-MAIN-WINDOW-REGION (IL:WINDOWPROP WINDOW 'IL:REGION)))

            (IL:* IL:|;;| "have to compensate for (possible) windows attached at left or bottom.  IL:SHAPEW does this for us, but not IL:MOVEW...")

            (IL:MOVEW WINDOW (+ (POSITION-X POS)
                                (- (REGION-LEFT CURRENT-MAIN-WINDOW-REGION)
                                   (REGION-LEFT CURRENT-REGION)))
                   (+ (POSITION-Y POS)
                      (- (REGION-BOTTOM CURRENT-MAIN-WINDOW-REGION)
                         (REGION-BOTTOM CURRENT-REGION)))))))

(DEFUN SHAPE-WINDOW (WINDOW DESIRED-REGION &KEY (CURRENT-REGION (WINDOW-REGION WINDOW))
                               NO-SHAPE)

   (IL:* IL:|;;| "open up IL:SHAPEW a bit")

   (MULTIPLE-VALUE-BIND (VALUE CONDITION)
          (IGNORE-ERRORS (IF (OR 
                                 (IL:* IL:|;;| "if we don't really need to reshape")

                                 (AND (= (REGION-WIDTH DESIRED-REGION)
                                         (REGION-WIDTH CURRENT-REGION))
                                      (= (REGION-HEIGHT DESIRED-REGION)
                                         (REGION-HEIGHT CURRENT-REGION)))

                                 (IL:* IL:|;;| "or we're not supposed to reshape")

                                 (IL:\\USERFNISDON\'T (IL:WINDOWPROP WINDOW 'IL:RESHAPEFN))
                                 NO-SHAPE)

                             (IL:* IL:|;;| "then just move")

                             (MOVE-WINDOW WINDOW (MAKE-POSITION (REGION-LEFT DESIRED-REGION)
                                                            (REGION-BOTTOM DESIRED-REGION))
                                    CURRENT-REGION)

                             (IL:* IL:|;;| "otherwise do the reshape")

                             (FUNCALL (OR (IL:WINDOWPROP WINDOW 'IL:DOSHAPEFN)
                                          'IL:SHAPEW1)
                                    WINDOW
                                    (COPY-REGION DESIRED-REGION))))
          (WHEN CONDITION (NOTIFY-USER "Error reshaping ~A: ~A" WINDOW CONDITION))
          VALUE))

(DEFMACRO OPEN-WINDOW (WINDOW)
   `(IL:OPENW ,WINDOW))

(DEFMACRO CLOSE-WINDOW (WINDOW)
   `(IL:CLOSEW ,WINDOW))

(DEFMACRO WINDOW-REGION (WINDOW)
   `(IL:WINDOWREGION ,WINDOW))

(DEFMACRO MAIN-WINDOW (WINDOW)
   `(LET ((WINDOW ,WINDOW))
         (OR (IL:WINDOWPROP WINDOW 'IL:ICONFOR)
             (IL:MAINWINDOW WINDOW T))))

(DEFMACRO WINDOW-TITLE (WINDOW)
   `(IL:WINDOWPROP ,WINDOW 'IL:TITLE))

(DEFUN WINDOW-VISIBLE-P (WINDOW)
   (AND (IL:OPENWP WINDOW)
        (IL:REGIONSINTERSECTP (WINDOW-REGION WINDOW)
               IL:WHOLESCREEN)))



(IL:* IL:\; "regions")


(DEFSTRUCT (REGION (:TYPE LIST))

(IL:* IL:|;;;| "overlay onto an Interlisp-D region, so we don't have to use il:fetch cruft.")

   LEFT
   BOTTOM
   WIDTH
   HEIGHT)

(DEFMACRO MAKE-POSITION (X Y)
   `(CONS ,X ,Y))

(DEFMACRO POSITION-X (POS)
   `(CAR ,POS))

(DEFMACRO POSITION-Y (POS)
   `(CDR ,POS))

(DEFUN GET-POSITION (MESSAGE &REST MESSAGE-ARGS)
   (APPLY #'NOTIFY-USER MESSAGE MESSAGE-ARGS)
   (IL:GETPOSITION))

(DEFMACRO SHRINK-WINDOW (WINDOW POS)
   `(IL:SHRINKW ,WINDOW NIL ,POS))

(DEFUN EXPAND-WINDOW (WINDOW)
   `(IL:EXPANDW (WINDOW-ICON ,WINDOW)))

(DEFMACRO ICON? (WINDOW)
   `(IL:WINDOWPROP ,WINDOW 'IL:ICONFOR))

(DEFUN SHRUNKEN? (WINDOW)
   (IL:EQMEMB (IL:FUNCTION IL:CLOSEICONWINDOW)
          (IL:WINDOWPROP WINDOW 'IL:OPENFN)))

(DEFUN ICON-POSITION (WINDOW)
   (LET ((ICON-WINDOW (WINDOW-ICON WINDOW)))
        (WHEN ICON-WINDOW (WINDOW-POSITION ICON-WINDOW))))

(DEFUN WINDOW-POSITION (WINDOW)
   (LET ((REGION (WINDOW-REGION WINDOW)))
        (MAKE-POSITION (REGION-LEFT REGION)
               (REGION-BOTTOM REGION))))

(DEFMACRO WINDOW-ICON (WINDOW)
   `(IL:WINDOWPROP ,WINDOW 'IL:ICONWINDOW))

(DEFUN DELETE-WINDOW-ICON (WINDOW)

(IL:* IL:|;;;| "delete the icon for WINDOW, if any.  We know WINDOW is expanded.")

   (IL:WINDOWPROP WINDOW 'IL:ICONWINDOW NIL)
   (IL:WINDOWPROP WINDOW 'IL:ICONPOSITION NIL))



(IL:* IL:\; "user interface")


(DEFUN MENU (ITEMS &OPTIONAL TITLE MESSAGE &REST MESSAGE-ARGS)
   (WHEN MESSAGE
       (APPLY #'NOTIFY-USER MESSAGE MESSAGE-ARGS))
   (IL:MENU (IL:CREATE IL:MENU
                   IL:ITEMS IL:_ ITEMS
                   IL:TITLE IL:_ TITLE
                   IL:CENTERFLG IL:_ T)))

(DEFUN PROMPT-USER (PROMPT &OPTIONAL MESSAGE &REST MESSAGE-ARGS)

(IL:* IL:|;;;| "prompt the user for a string.  input should end when CR is typed.")

   (WHEN MESSAGE
       (APPLY #'NOTIFY-USER MESSAGE MESSAGE-ARGS))
   (IL:RESETFORM (IL:TTYDISPLAYSTREAM (GET-MESSAGE-STREAM))
          (IL:PROMPTFORWORD PROMPT NIL NIL NIL NIL 'IL:TTY (IL:CHARCODE (IL:EOL)))))

(DEFUN CONFIRM (&OPTIONAL MESSAGE &REST MESSAGE-ARGS)

   (IL:* IL:|;;| "make sure prompt-window is un-hidden")

   (LET ((STREAM (GET-MESSAGE-STREAM)))

        (IL:* IL:|;;| "use IL:MOUSECONFIRM")

        (PROG2 (TERPRI STREAM)
               (IL:MOUSECONFIRM (WHEN MESSAGE
                                    (APPLY #'FORMAT NIL MESSAGE MESSAGE-ARGS))
                      NIL STREAM T)
               (TERPRI STREAM))))

(DEFUN NOTIFY-USER (FORMAT-STRING &REST ARGS)
   (LET ((STREAM (GET-MESSAGE-STREAM)))
        (TERPRI STREAM)
        (APPLY #'FORMAT STREAM FORMAT-STRING ARGS)
        (TERPRI STREAM)))

(DEFUN GET-MESSAGE-STREAM ()

(IL:* IL:|;;;| "return an output stream for user messages ")

   (WHEN (%WINDOW-HIDDEN? IL:PROMPTWINDOW)
         (UN-HIDE-WINDOW IL:PROMPTWINDOW))
   (IL:GETSTREAM IL:PROMPTWINDOW))

(DEFUN SELECT-WINDOW (&OPTIONAL MESSAGE &REST MESSAGE-ARGS)

(IL:* IL:|;;;| "get the user to select a window on the screen")

   (WHEN MESSAGE
       (APPLY #'NOTIFY-USER MESSAGE MESSAGE-ARGS))
   (IL:RESETFORM
    (IL:CURSOR IL:CROSSHAIRS)
    (LET
     (WINDOW)
     (LOOP
      (WHEN (IL:MOUSESTATE (OR IL:LEFT IL:MIDDLE))
          (RETURN
           (LET ((WINDOW (IL:WHICHW)))
                (WHEN WINDOW
                    (UNWIND-PROTECT
                        (PROGN (IL:INVERTW WINDOW)
                               (LOOP (WHEN (NOT (IL:MOUSESTATE (OR IL:LEFT IL:MIDDLE)))
                                         (RETURN (LET ((NEW-WINDOW (IL:WHICHW)))
                                                      (WHEN (AND NEW-WINDOW (EQ (MAIN-WINDOW
                                                                                 NEW-WINDOW)
                                                                                (MAIN-WINDOW
                                                                                 WINDOW)))
                                                            (MAIN-WINDOW WINDOW)))))))
                        (IL:INVERTW WINDOW))))))))))

(DEFUN SELECT-BAGGAGE ()

(IL:* IL:|;;;| "returns a list of selected placements.")

(IL:* IL:|;;;| 
"we presume UPDATE-PLACEMENTS has just been called & won't be called again by GO-TO-ROOM.")

   (LET (WINDOW PLACEMENT ROOM BAGGAGE)
        (LOOP (LET ((OP (COND
                           ((MOVE-KEY-DOWN-P)
                            :MOVE)
                           ((COPY-KEY-DOWN-P)
                            :COPY)
                           (T (RETURN)))))
                   (SETQ WINDOW (SELECT-WINDOW "Select placement to ~A" OP))
                   (UNLESS WINDOW (RETURN))
                   (MULTIPLE-VALUE-SETQ (PLACEMENT ROOM)
                          (FIND-PLACEMENT WINDOW))
                   (WHEN PLACEMENT
                       (CASE OP
                           (:MOVE (DELETE-PLACEMENT PLACEMENT ROOM))
                           (:COPY (SETQ PLACEMENT (COPY-PLACEMENT-INTERNAL PLACEMENT))))
                       (PUSHNEW PLACEMENT BAGGAGE :KEY #'PLACEMENT-WINDOW :TEST 'EQ))))
        BAGGAGE))

(DEFUN EXTERNALIZE-FONT (FONT)
   (LIST (IL:FONTPROP FONT 'IL:FAMILY)
         (IL:FONTPROP FONT 'IL:SIZE)
         (IL:FONTPROP FONT 'IL:FACE)))

(DEFMACRO COPY-KEY-DOWN-P ()
   `(OR (IL:KEYDOWNP 'IL:COPY)
        (AND (IL:SHIFTDOWNP 'IL:SHIFT)
             (NOT (OR (IL:SHIFTDOWNP 'IL:CTRL)
                      (IL:SHIFTDOWNP 'IL:META))))))

(DEFMACRO HELP-KEY-DOWN-P ()
   `(OR (IL:KEYDOWNP 'HELP)
        (IL:KEYDOWNP 'IL:DBK-HELP)))

(DEFMACRO DELETE-KEY-DOWN-P ()
   `(OR (IL:KEYDOWNP 'IL:DELETE)
        (AND (IL:SHIFTDOWNP 'IL:CTRL)
             (IL:SHIFTDOWNP 'IL:META)
             (NOT (IL:SHIFTDOWNP 'IL:SHIFT)))))

(DEFMACRO EDIT-KEY-DOWN-P ()
   `(AND (IL:SHIFTDOWNP 'IL:CTRL)
         (NOT (OR (IL:SHIFTDOWNP 'IL:SHIFT)
                  (IL:SHIFTDOWNP 'IL:META)))))

(DEFMACRO MOVE-KEY-DOWN-P ()
   `(OR (IL:KEYDOWNP 'IL:MOVE)
        (AND (IL:SHIFTDOWNP 'IL:CTRL)
             (IL:SHIFTDOWNP 'IL:SHIFT)
             (NOT (IL:SHIFTDOWNP 'IL:META)))))

(DEFMACRO EXPAND-KEY-DOWN-P ()
   `(OR (IL:KEYDOWNP 'IL:EXPAND)
        (IL:KEYDOWNP 'IL:ESCAPE)))



(IL:* IL:|;;| "add a lafite form for bug reports")


(DEFUN MAKE-ROOMS-SUPPORT-FORM ()
   (IL:MAKEXXXSUPPORTFORM "Rooms" IL:ROOMSSUPPORT *ROOMS-SYSTEM-DATE*))

(DEFGLOBALVAR IL:ROOMSSUPPORT "RoomsSupport^.PA")

(IL:ADDTOVAR IL:LAFITESPECIALFORMS ("Rooms Report" (IL:FUNCTION MAKE-ROOMS-SUPPORT-FORM)
                                              "A form to report a Rooms bug or suggestion"))

(SETQ IL:LAFITEFORMSMENU NIL)



(IL:* IL:|;;| "provide a who line entry")


(DEFPARAMETER *WHO-LINE-ENTRY*
   `("Room:" (AND *CURRENT-ROOM* (ROOM-NAME *CURRENT-ROOM*))
           10
           ,#'(LAMBDA NIL (INTERACTIVE-GO-TO-ROOM :ALLOW-NEW? T))))

(WHEN (BOUNDP 'IL:*WHO-LINE-ENTRY-REGISTRY*)
    (PUSHNEW *WHO-LINE-ENTRY* IL:*WHO-LINE-ENTRY-REGISTRY* :TEST 'EQUAL :KEY 'CAR))
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY

(IL:GLOBALVARS IL:PROMPTWINDOW IL:CROSSHAIRS IL:WINDOWBACKGROUNDSHADE IL:WHOLESCREEN 
       IL:LAFITESPECIALFORMS IL:LAFITEFORMSMENU IL:DEFAULTICONFN IL:*WHO-LINE-ENTRY-REGISTRY*)
)
(IL:PUTPROPS IL:ROOMS-D IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (3813 4569 (MOVE-WINDOW 3813 . 4569)) (4571 6175 (SHAPE-WINDOW 4571 . 6175)) (6597 
6750 (WINDOW-VISIBLE-P 6597 . 6750)) (7108 7227 (GET-POSITION 7108 . 7227)) (7306 7383 (EXPAND-WINDOW 
7306 . 7383)) (7456 7578 (SHRUNKEN? 7456 . 7578)) (7580 7725 (ICON-POSITION 7580 . 7725)) (7727 7897 (
WINDOW-POSITION 7727 . 7897)) (7979 8199 (DELETE-WINDOW-ICON 7979 . 8199)) (8239 8528 (MENU 8239 . 
8528)) (8530 8905 (PROMPT-USER 8530 . 8905)) (8907 9348 (CONFIRM 8907 . 9348)) (9350 9544 (NOTIFY-USER
 9350 . 9544)) (9546 9766 (GET-MESSAGE-STREAM 9546 . 9766)) (9768 10965 (SELECT-WINDOW 9768 . 10965)) 
(10967 12022 (SELECT-BAGGAGE 10967 . 12022)) (12024 12173 (EXTERNALIZE-FONT 12024 . 12173)) (13181 
13290 (MAKE-ROOMS-SUPPORT-FORM 13181 . 13290)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-D.DFASL b/rooms/ROOMS-D.DFASL
new file mode 100644
index 00000000..52bf438c
Binary files /dev/null and b/rooms/ROOMS-D.DFASL differ
diff --git a/rooms/ROOMS-GEOMETRY b/rooms/ROOMS-GEOMETRY
new file mode 100644
index 00000000..b1a52700
--- /dev/null
+++ b/rooms/ROOMS-GEOMETRY
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:26:58" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-GEOMETRY.;2| 7129   

      IL:|previous| IL:|date:| "17-Aug-90 12:45:39" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-GEOMETRY.;1|)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMS-GEOMETRYCOMS)

(IL:RPAQQ IL:ROOMS-GEOMETRYCOMS
          ((FILE-ENVIRONMENTS IL:ROOMS-GEOMETRY)
           (IL:P (EXPORT '(EXTERNALIZE-REGION INTERNALIZE-REGION EXTERNALIZE-POSITION 
                                 INTERNALIZE-POSITION))
                 (REQUIRE "ROOMS"))
           (IL:COMS 

                  (IL:* IL:|;;| "externalizing for suites & background text")

                  (IL:FUNCTIONS EXTERNALIZE-REGION INTERNALIZE-REGION EXTERNALIZE-POSITION 
                         INTERNALIZE-POSITION EXTERNALIZE-COORDINATE INTERNALIZE-COORDINATE)
                  (IL:GLOBALVARS IL:SCREENWIDTH IL:SCREENHEIGHT))
           (IL:COMS 

                  (IL:* IL:|;;| "scaling used by placement editor & backgrounds")

                  (IL:STRUCTURES SCALE)
                  (IL:VARIABLES *ONE-TO-ONE*)
                  (IL:FUNCTIONS MAKE-SCALE EQUAL-SCALES)
                  (IL:FUNCTIONS SCALE-WIDTH SCALE-HEIGHT SCALE-X SCALE-Y SCALE-REGION SCALE-POSITION)
                  (IL:FUNCTIONS UN-SCALE-REGION UN-SCALE-POSITION UN-SCALE-HEIGHT UN-SCALE-WIDTH 
                         UN-SCALE-X UN-SCALE-Y))))

(DEFINE-FILE-ENVIRONMENT IL:ROOMS-GEOMETRY :COMPILER :COMPILE-FILE
   :PACKAGE "ROOMS"
   :READTABLE "XCL")

(EXPORT '(EXTERNALIZE-REGION INTERNALIZE-REGION EXTERNALIZE-POSITION INTERNALIZE-POSITION))

(REQUIRE "ROOMS")



(IL:* IL:|;;| "externalizing for suites & background text")


(DEFUN EXTERNALIZE-REGION (REGION)
   (MAKE-REGION :LEFT (EXTERNALIZE-COORDINATE (REGION-LEFT REGION)
                             IL:SCREENWIDTH)
          :BOTTOM
          (EXTERNALIZE-COORDINATE (REGION-BOTTOM REGION)
                 IL:SCREENHEIGHT)
          :WIDTH
          (EXTERNALIZE-COORDINATE (REGION-WIDTH REGION)
                 IL:SCREENWIDTH)
          :HEIGHT
          (EXTERNALIZE-COORDINATE (REGION-HEIGHT REGION)
                 IL:SCREENHEIGHT)))

(DEFUN INTERNALIZE-REGION (REGION)
   (MAKE-REGION :LEFT (INTERNALIZE-COORDINATE (REGION-LEFT REGION)
                             IL:SCREENWIDTH)
          :BOTTOM
          (INTERNALIZE-COORDINATE (REGION-BOTTOM REGION)
                 IL:SCREENHEIGHT)
          :WIDTH
          (INTERNALIZE-COORDINATE (REGION-WIDTH REGION)
                 IL:SCREENWIDTH)
          :HEIGHT
          (INTERNALIZE-COORDINATE (REGION-HEIGHT REGION)
                 IL:SCREENHEIGHT)))

(DEFUN EXTERNALIZE-POSITION (POS)
   (MAKE-POSITION (EXTERNALIZE-COORDINATE (POSITION-X POS)
                         IL:SCREENWIDTH)
          (EXTERNALIZE-COORDINATE (POSITION-Y POS)
                 IL:SCREENHEIGHT)))

(DEFUN INTERNALIZE-POSITION (POS)
   (MAKE-POSITION (INTERNALIZE-COORDINATE (POSITION-X POS)
                         IL:SCREENWIDTH)
          (INTERNALIZE-COORDINATE (POSITION-Y POS)
                 IL:SCREENHEIGHT)))

(DEFUN EXTERNALIZE-COORDINATE (N RANGE)
   (LET ((EXTERNAL (/ N RANGE)))
        (TYPECASE EXTERNAL
            (INTEGER (FLOAT EXTERNAL))
            (OTHERWISE EXTERNAL))))

(DEFUN INTERNALIZE-COORDINATE (N RANGE)
   (ETYPECASE N
       (INTEGER N)
       ((OR FLOAT RATIONAL) (ROUND (* N RANGE)))))
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY

(IL:GLOBALVARS IL:SCREENWIDTH IL:SCREENHEIGHT)
)



(IL:* IL:|;;| "scaling used by placement editor & backgrounds")


(DEFSTRUCT (SCALE (:CONSTRUCTOR MAKE-SCALE-INTERNAL))

(IL:* IL:|;;;| "used to scale coordinates.  X-FACTOR & Y-FACTOR are the scale factor, and X-OFFSET & Y-OFFSET are added after scaling.")

   (X-OFFSET 0 :TYPE INTEGER)
   (X-FACTOR 1 :TYPE (OR INTEGER FLOAT RATIONAL))
   (Y-OFFSET 0 :TYPE INTEGER)
   (Y-FACTOR 1 :TYPE (OR INTEGER FLOAT RATIONAL)))

(DEFGLOBALVAR *ONE-TO-ONE* (MAKE-SCALE-INTERNAL))

(DEFUN MAKE-SCALE (REGION)

(IL:* IL:|;;;| "return a scale which scales the screen into REGION ")

   (MAKE-SCALE-INTERNAL :X-FACTOR (FLOAT (/ (REGION-WIDTH REGION)
                                            IL:SCREENWIDTH))
          :X-OFFSET
          (REGION-LEFT REGION)
          :Y-FACTOR
          (FLOAT (/ (REGION-HEIGHT REGION)
                    IL:SCREENHEIGHT))
          :Y-OFFSET
          (REGION-BOTTOM REGION)))

(DEFUN EQUAL-SCALES (SCALE-1 SCALE-2)
   (AND (= (SCALE-X-FACTOR SCALE-1)
           (SCALE-X-FACTOR SCALE-2))
        (= (SCALE-Y-FACTOR SCALE-1)
           (SCALE-Y-FACTOR SCALE-2))))

(DEFMACRO SCALE-WIDTH (WIDTH SCALE)
   `(ROUND (* ,WIDTH (SCALE-X-FACTOR ,SCALE))))

(DEFMACRO SCALE-HEIGHT (HEIGHT SCALE)
   `(ROUND (* ,HEIGHT (SCALE-Y-FACTOR ,SCALE))))

(DEFINLINE SCALE-X (X SCALE)
   (+ (SCALE-WIDTH X SCALE)
      (SCALE-X-OFFSET SCALE)))

(DEFINLINE SCALE-Y (Y SCALE)
   (+ (SCALE-HEIGHT Y SCALE)
      (SCALE-Y-OFFSET SCALE)))

(DEFUN SCALE-REGION (REGION SCALE)
   (IF (EQ SCALE *ONE-TO-ONE*)
       REGION
       (MAKE-REGION :LEFT (SCALE-X (REGION-LEFT REGION)
                                 SCALE)
              :BOTTOM
              (SCALE-Y (REGION-BOTTOM REGION)
                     SCALE)
              :WIDTH
              (SCALE-WIDTH (REGION-WIDTH REGION)
                     SCALE)
              :HEIGHT
              (SCALE-HEIGHT (REGION-HEIGHT REGION)
                     SCALE))))

(DEFUN SCALE-POSITION (POS SCALE)
   (IF (EQ SCALE *ONE-TO-ONE*)
       POS
       (MAKE-POSITION (SCALE-X (POSITION-X POS)
                             SCALE)
              (SCALE-Y (POSITION-Y POS)
                     SCALE))))

(DEFUN UN-SCALE-REGION (REGION SCALE)
   (MAKE-REGION :LEFT (UN-SCALE-X (REGION-LEFT REGION)
                             SCALE)
          :BOTTOM
          (UN-SCALE-Y (REGION-BOTTOM REGION)
                 SCALE)
          :WIDTH
          (UN-SCALE-WIDTH (REGION-WIDTH REGION)
                 SCALE)
          :HEIGHT
          (UN-SCALE-HEIGHT (REGION-HEIGHT REGION)
                 SCALE)))

(DEFUN UN-SCALE-POSITION (POS SCALE)
   (MAKE-POSITION (UN-SCALE-X (POSITION-X POS)
                         SCALE)
          (UN-SCALE-Y (POSITION-Y POS)
                 SCALE)))

(DEFMACRO UN-SCALE-HEIGHT (HEIGHT SCALE)
   `(ROUND ,HEIGHT (SCALE-Y-FACTOR ,SCALE)))

(DEFMACRO UN-SCALE-WIDTH (WIDTH SCALE)
   `(ROUND ,WIDTH (SCALE-X-FACTOR ,SCALE)))

(DEFUN UN-SCALE-X (X SCALE)
   (UN-SCALE-WIDTH (- X (SCALE-X-OFFSET SCALE))
          SCALE))

(DEFUN UN-SCALE-Y (Y SCALE)
   (UN-SCALE-HEIGHT (- Y (SCALE-Y-OFFSET SCALE))
          SCALE))
(IL:PUTPROPS IL:ROOMS-GEOMETRY IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (1908 2400 (EXTERNALIZE-REGION 1908 . 2400)) (2402 2894 (INTERNALIZE-REGION 2402 . 
2894)) (2896 3128 (EXTERNALIZE-POSITION 2896 . 3128)) (3130 3362 (INTERNALIZE-POSITION 3130 . 3362)) (
3364 3542 (EXTERNALIZE-COORDINATE 3364 . 3542)) (3544 3673 (INTERNALIZE-COORDINATE 3544 . 3673)) (4259
 4699 (MAKE-SCALE 4259 . 4699)) (4701 4890 (EQUAL-SCALES 4701 . 4890)) (5268 5761 (SCALE-REGION 5268
 . 5761)) (5763 6005 (SCALE-POSITION 5763 . 6005)) (6007 6425 (UN-SCALE-REGION 6007 . 6425)) (6427 
6619 (UN-SCALE-POSITION 6427 . 6619)) (6800 6901 (UN-SCALE-X 6800 . 6901)) (6903 7005 (UN-SCALE-Y 6903
 . 7005)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-GEOMETRY.DFASL b/rooms/ROOMS-GEOMETRY.DFASL
new file mode 100644
index 00000000..cdfb83d8
Binary files /dev/null and b/rooms/ROOMS-GEOMETRY.DFASL differ
diff --git a/rooms/ROOMS-INTERACTIVE b/rooms/ROOMS-INTERACTIVE
new file mode 100644
index 00000000..98143f03
--- /dev/null
+++ b/rooms/ROOMS-INTERACTIVE
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:35:32" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-INTERACTIVE.;2| 32009  

      IL:|previous| IL:|date:| "17-Aug-90 12:47:35" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-INTERACTIVE.;1|)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMS-INTERACTIVECOMS)

(IL:RPAQQ IL:ROOMS-INTERACTIVECOMS
          (
           (IL:* IL:|;;| "mostly portable interactive code (joke?)")

           (FILE-ENVIRONMENTS IL:ROOMS-INTERACTIVE)
           (IL:P (EXPORT '(INTERACTIVE-GO-TO-ROOM-NAMED INTERACTIVE-COPY-PLACEMENT 
                                 INTERACTIVE-MOVE-PLACEMENT))
                 (REQUIRE "ROOMS"))
           (IL:VARIABLES *BACKGROUND-ITEM* *MOVE-ITEM* *CLOSE-ITEM*)
           (IL:FUNCTIONS INSTALL-MENU-ITEMS INSTALL-MENU-ITEM)
           (IL:P (PUSHNEW '(INSTALL-MENU-ITEMS)
                        *RESET-FORMS* :TEST 'EQUAL))
           (IL:FUNCTIONS INTERACTIVE-CLOSE-WINDOW INTERACTIVE-GO-TO-ROOM INTERACTIVE-GO-TO-OVERVIEW 
                  INTERACTIVE-GO-TO-ROOM-NAMED INTERACTIVE-EDIT-ROOM EDIT-ROOM 
                  INTERACTIVE-EDIT-PLACEMENTS INTERACTIVE-INCLUDE-ROOM INTERACTIVE-EXCLUDE-ROOM 
                  INTERACTIVE-DELETE-ROOM INTERACTIVE-FIND-PLACEMENT INTERACTIVE-COPY-PLACEMENT 
                  INTERACTIVE-MOVE-PLACEMENT INTERACTIVE-COPY-PLACEMENT-TO-THIS-ROOM 
                  INTERACTIVE-MOVE-PLACEMENT-TO-POCKETS INTERACTIVE-MOVE-OR-COPY-PLACEMENT 
                  INTERACTIVE-RESET SELECT-ROOM INTERACTIVE-MAKE-ROOM INTERACTIVE-COPY-ROOM 
                  INTERACTIVE-RENAME-ROOM INTERACTIVE-MAKE-DOOR MAKE-DOOR RETRIEVE-WINDOWS 
                  CHECK-LOST-WINDOWS EVAL-WALK)
           (IL:COMS 

                  (IL:* IL:|;;| "back doors")

                  (IL:VARIABLES *BACK-DOOR-ROOM-NAME*)
                  (IL:FUNCTIONS MAKE-BACK-DOOR BACK-DOOR-ENTRY-FUNCTION)
                  (IL:P (PUSHNEW 'BACK-DOOR-ENTRY-FUNCTION *ROOM-ENTRY-FUNCTIONS*)))
           (IL:GLOBALVARS IL:PROMPTWINDOW IL:CROSSHAIRS)))



(IL:* IL:|;;| "mostly portable interactive code (joke?)")


(DEFINE-FILE-ENVIRONMENT IL:ROOMS-INTERACTIVE :COMPILER :COMPILE-FILE
   :PACKAGE "ROOMS"
   :READTABLE "XCL")

(EXPORT '(INTERACTIVE-GO-TO-ROOM-NAMED INTERACTIVE-COPY-PLACEMENT INTERACTIVE-MOVE-PLACEMENT))

(REQUIRE "ROOMS")

(DEFGLOBALPARAMETER *BACKGROUND-ITEM*
   `("Rooms" '(WITH-BUTTON '(INTERACTIVE-GO-TO-OVERVIEW)
                     "Overview" "Enter the overview")
           "Enter the overview"
           (IL:SUBITEMS ("Go to Room" '(WITH-BUTTON '(INTERACTIVE-GO-TO-ROOM :ALLOW-NEW? T)
                                              "Go to Room" "Go to a room, possibly new.")
                               "Go to a room, possibly new.")
                  ("Make Room" '(WITH-BUTTON '(INTERACTIVE-MAKE-ROOM)
                                       "Make Room" "Make a new room.")
                         "Make a new room.")
                  ("Edit Room" '(WITH-BUTTON '(INTERACTIVE-EDIT-ROOM)
                                       "Edit Room" "Edit a selected room.")
                         "Edit a selected room."
                         (IL:SUBITEMS ("Edit This Room" '(WITH-BUTTON '(EDIT-ROOM *CURRENT-ROOM*)
                                                                "Edit This Room" 
                                                                "Edit the current room.")
                                             "Edit a selected room.")
                                ("Edit Placements" '(WITH-BUTTON '(INTERACTIVE-EDIT-PLACEMENTS)
                                                           "Edit Placements" 
                                                           "Edit placements of a selected room")
                                       "Edit placements of a selected room")
                                ("Exclude Room" '(WITH-BUTTON '(INTERACTIVE-EXCLUDE-ROOM)
                                                        "Exclude Room" "Exclude a room from another."
                                                        )
                                       "Exclude a room from another."
                                       (IL:SUBITEMS ("From This Room"
                                                     '(WITH-BUTTON '(INTERACTIVE-EXCLUDE-ROOM
                                                                     *CURRENT-ROOM*)
                                                             "Exclude From This Room" 
                                                             "Exclude a room from the current room.")
                                                     "Exclude a room from another.")))
                                ("Include Room" '(WITH-BUTTON '(INTERACTIVE-INCLUDE-ROOM)
                                                        "Include Room" "Include a room in another.")
                                       "Include a room in another."
                                       (IL:SUBITEMS ("In This Room" '(WITH-BUTTON '(
                                                                           INTERACTIVE-INCLUDE-ROOM
                                                                                    *CURRENT-ROOM*)
                                                                            "Include In This Room" 
                                                                "Include a room in the current room."
                                                                            )
                                                           "Include a room in the current room.")))))
                  ("Delete Room" '(WITH-BUTTON '(INTERACTIVE-DELETE-ROOM)
                                         "Delete Room" "Delete a room.")
                         "Delete a room.")
                  ("" NIL "No-op")
                  ("Retrieve Windows" '(WITH-BUTTON '(RETRIEVE-WINDOWS)
                                              "Retrieve Windows" 
                                              "Retrieve windows lost from all rooms.")
                         "Retrieve windows lost from all rooms.")
                  ("Suites" '(WITH-BUTTON '(SUITE-MENU)
                                    "Suites" "Save a set of rooms to a file")
                         "Save a set of rooms to a file"
                         (IL:SUBITEMS ,@*SUITE-MENU-ITEMS*))
                  ("Make Door" '(INTERACTIVE-MAKE-DOOR :ALLOW-NEW? T)
                         "Make a door to a room - a button to enter it."
                         (IL:SUBITEMS ("Make Back Door" '(MAKE-BACK-DOOR)
                                             "Make a back door - a door to the previous room."))))))

(DEFPARAMETER *MOVE-ITEM*
   '(IL:|Move| 'IL:MOVEW "Moves window by a corner" (IL:SUBITEMS ("Move to another room"
                                                                  'INTERACTIVE-MOVE-PLACEMENT 
                                                                "Move this placement to another room"
                                                                  (IL:SUBITEMS ("Move to pockets"
                                                                                
                                                                                '
                                                                INTERACTIVE-MOVE-PLACEMENT-TO-POCKETS
                                                                                
                                                             "Move this placement to the pocket room"
                                                                                )))
                                                           ("Copy to another room"
                                                            'INTERACTIVE-COPY-PLACEMENT 
                                                            "Copy this placement to another room"
                                                            (IL:SUBITEMS ("Copy to this room"
                                                                          
                                                                          '
                                                              INTERACTIVE-COPY-PLACEMENT-TO-THIS-ROOM
                                                                          
                                                                   "Copy this placement to this room"
                                                                          )))
                                                           ("Where is?" 'INTERACTIVE-FIND-PLACEMENT 
                                                              "Find which room this placement is in."
                                                                  ))))

(DEFPARAMETER *CLOSE-ITEM* '(IL:|Close| 'INTERACTIVE-CLOSE-WINDOW "Closes a window"))

(DEFUN INSTALL-MENU-ITEMS ()
   (INSTALL-MENU-ITEM *BACKGROUND-ITEM* 'IL:|BackgroundMenuCommands| 'IL:|BackgroundMenu|)
   (INSTALL-MENU-ITEM *MOVE-ITEM* 'IL:|WindowMenuCommands| 'IL:|WindowMenu|)
   (INSTALL-MENU-ITEM *MOVE-ITEM* 'IL:|IconWindowMenuCommands| 'IL:|IconWindowMenu|)
   (INSTALL-MENU-ITEM *CLOSE-ITEM* 'IL:|WindowMenuCommands| 'IL:|WindowMenu|)
   (INSTALL-MENU-ITEM *CLOSE-ITEM* 'IL:|IconWindowMenuCommands| 'IL:|IconWindowMenu|))

(DEFUN INSTALL-MENU-ITEM (ITEM ITEMS-VAR MENU-VAR)
   (LET* ((ITEMS (COPY-TREE (SYMBOL-VALUE ITEMS-VAR)))
          (OLD-ENTRY (ASSOC (FIRST ITEM)
                            ITEMS :TEST 'EQUAL)))
         (IF OLD-ENTRY
             (SETF (REST OLD-ENTRY)
                   (REST ITEM))
             (NCONC ITEMS (LIST ITEM)))
         (SET ITEMS-VAR ITEMS)

         (IL:* IL:|;;| "force the menu to be rebuilt")

         (SET MENU-VAR 'NIL)))

(PUSHNEW '(INSTALL-MENU-ITEMS)
       *RESET-FORMS* :TEST 'EQUAL)

(DEFUN INTERACTIVE-CLOSE-WINDOW (WINDOW &OPTIONAL (FROM-ROOM *CURRENT-ROOM*))

(IL:* IL:|;;;| "this should probably be called interactive-delete-placement.  it's whats called from the window menu & is used by the placement editor.")

(IL:* IL:|;;;| "we need to catch the case where a room has multiple placements and query the user as to which are to be deleted -- all or just the most immediate.")

   (LET ((MAIN-WINDOW (MAIN-WINDOW WINDOW))
         (WINDOW-TO-CLOSE WINDOW))
        (WHEN (AND (NOT (ICON? WINDOW))
                   (NOT (EQ WINDOW MAIN-WINDOW)))

            (IL:* IL:|;;| "it's an attached window")

            (LET ((PASS-TO-MAIN-COMS (IL:WINDOWPROP WINDOW 'IL:PASSTOMAINCOMS)))

                 (IL:* IL:|;;| "have to simulate IL:DOATTACHEDWINDOWCOM")

                 (UNLESS (OR (EQ PASS-TO-MAIN-COMS T)
                             (MEMBER 'IL:CLOSEW PASS-TO-MAIN-COMS :TEST 'EQ))

                     (IL:* IL:|;;| "this window closes locally")

                     (CLOSE-WINDOW WINDOW)
                     (RETURN-FROM INTERACTIVE-CLOSE-WINDOW))
                 (SETQ WINDOW-TO-CLOSE MAIN-WINDOW)))
        (LET ((ROOMS (FIND-ROOMS-CONTAINING MAIN-WINDOW)))

             (IL:* IL:|;;| 
           "note: this needs to run fairly quickly, so we don't call UPDATE-PLACEMENTS.")

             (IF (NULL ROOMS)

                 (IL:* IL:|;;| "new window -- just close it")

                 (CLOSE-WINDOW WINDOW-TO-CLOSE)
                 (CASE (IF (AND (ENDP (REST ROOMS))
                                (FIND-PLACEMENT MAIN-WINDOW FROM-ROOM))

                           (IL:* IL:|;;| "we're looking at the only placement")

                           (IF (EQ FROM-ROOM (FIRST ROOMS))

                               (IL:* IL:|;;| "it's an immediate placement  -  just delete it")

                               :ALL

                               (IL:* IL:|;;| "it's inherited - get confirmation")

                               (IF (CONFIRM 
                    "This placement is in the included room ~S.~%Are you sure you want to delete it?"
                                          (ROOM-NAME (FIRST ROOMS)))
                                   :ALL))
                           (MENU '(("All placements" :ALL)
                                   ("Just this placement" :THIS))
                                 "Delete?" "This window has placements in more than one room"))
                     (:ALL (LET ((HIDDEN? (WINDOW-HIDDEN? MAIN-WINDOW)))

                                (IL:* IL:|;;| "note whether window was hidden & make it not")

                                (WHEN HIDDEN? (UN-HIDE-WINDOW MAIN-WINDOW))

                                (IL:* IL:|;;| "try to close visible part ")

                                (CLOSE-WINDOW (IF (SHRUNKEN? MAIN-WINDOW)
                                                  (WINDOW-ICON MAIN-WINDOW)
                                                  MAIN-WINDOW))
                                (IF (AND HIDDEN? (OR (IL:OPENWP MAIN-WINDOW)
                                                     (IL:OPENWP (WINDOW-ICON MAIN-WINDOW))))

                                    (IL:* IL:|;;| 
                                  "if close failed & window was hidden before, then re-hide it")

                                    (HIDE-WINDOW MAIN-WINDOW)

                                    (IL:* IL:|;;| "otherwise go ahead & delete all its placements")

                                    (DOLIST (ROOM ROOMS)
                                        (LET ((PLACEMENT (FIND-PLACEMENT-IN-ROOM MAIN-WINDOW ROOM)))
                                             (WHEN PLACEMENT (DELETE-PLACEMENT PLACEMENT ROOM)))))))
                     (:THIS (MULTIPLE-VALUE-BIND (PLACEMENT IN-ROOM)
                                   (FIND-PLACEMENT MAIN-WINDOW FROM-ROOM)
                                   (WHEN PLACEMENT (DELETE-PLACEMENT PLACEMENT IN-ROOM))

                                   (IL:* IL:|;;| "don't actually close -- just hide it")

                                   (HIDE-WINDOW MAIN-WINDOW)
                                   (SETQ PLACEMENT (FIND-PLACEMENT MAIN-WINDOW *CURRENT-ROOM*))
                                   (WHEN PLACEMENT

                                       (IL:* IL:|;;| "we now inherit it from somewhere else")

                                       (PLACE-PLACEMENT PLACEMENT)))))))))

(DEFUN INTERACTIVE-GO-TO-ROOM (&KEY ROOM ALLOW-NEW?)
   (LET ((NAME (IF ROOM
                   (ROOM-NAME ROOM)
                   (SELECT-ROOM :ALLOW-NEW? ALLOW-NEW? :REASON "Go to room" :NAME-ONLY? T))))
        (WHEN NAME
            (WITH-BUTTON `(INTERACTIVE-GO-TO-ROOM-NAMED ',NAME)
                   NAME
                   (FORMAT NIL "Go to room named ~S." NAME)))))

(DEFUN INTERACTIVE-GO-TO-OVERVIEW ()
   (UPDATE-PLACEMENTS)
   (GO-TO-ROOM *OVERVIEW-ROOM* :BAGGAGE (SELECT-BAGGAGE)
          :NO-UPDATE T))

(DEFUN INTERACTIVE-GO-TO-ROOM-NAMED (NAME)
   (LET ((ROOM (ROOM-NAMED NAME)))
        (IF ROOM
            (PROGN (UPDATE-PLACEMENTS *CURRENT-ROOM*)
                   (GO-TO-ROOM ROOM :BAGGAGE (SELECT-BAGGAGE)
                          :NO-UPDATE T))
            (NOTIFY-USER "No room named ~S exists!" NAME))))

(DEFUN INTERACTIVE-EDIT-ROOM ()
   (LET ((NAME (SELECT-ROOM :REASON "Edit" :NAME-ONLY? T)))
        (WHEN NAME
            (WITH-BUTTON `(EDIT-ROOM (ROOM-NAMED ',NAME))
                   (FORMAT NIL "Edit ~A" NAME)
                   (FORMAT NIL "Edit room named ~S." NAME)))))

(DEFUN EDIT-ROOM (ROOM)
   (LET* ((ROOM (COND
                   ((AND (ROOM-P ROOM)
                         (ROOM-NAMED (ROOM-NAME ROOM)))
                    ROOM)
                   ((ROOM-NAMED ROOM))
                   (T (NOTIFY-USER "Can't edit room ~S" ROOM)
                      (RETURN-FROM EDIT-ROOM))))
          (EXTERNAL-FORM `(:INCLUSIONS ,(COPY-TREE (ROOM-INCLUSIONS ROOM))
                                 :BACKGROUND
                                 ,(COPY-TREE (BACKGROUND-EXTERNAL-FORM (ROOM-BACKGROUND ROOM)))
                                 ,@(COPY-TREE (ROOM-PROPS ROOM)))))
         (WITH-PROFILE (FIND-PROFILE "XCL")
                (IL:EDITE EXTERNAL-FORM NIL (ROOM-NAME ROOM)
                       'IL:|Expression|
                       #'(LAMBDA (&REST IGNORE)

                                (IL:* IL:|;;| "in case ROOM has been redefined")

                                (SETQ ROOM (ROOM-NAMED (ROOM-NAME ROOM)))
                                (SETF (ROOM-BACKGROUND ROOM)
                                      (MAKE-BACKGROUND (COPY-TREE (GETF EXTERNAL-FORM :BACKGROUND))))
                                (WHEN (IN-ROOM? ROOM)
                                      (UPDATE-PLACEMENTS))
                                (SETF (ROOM-INCLUSIONS ROOM)
                                      (COPY-TREE (GETF EXTERNAL-FORM :INCLUSIONS)))
                                (LET ((PROPS (COPY-LIST EXTERNAL-FORM)))
                                     (DOLIST (PROP '(:INCLUSIONS :BACKGROUND))
                                         (REMF PROPS PROP))
                                     (SETF (ROOM-PROPS ROOM)
                                           (COPY-TREE PROPS)))
                                (ROOM-CHANGED ROOM :EDITED))
                       '(:DONTWAIT)))))

(DEFUN INTERACTIVE-EDIT-PLACEMENTS ()
   (LET ((NAME (SELECT-ROOM :REASON "Edit Placements" :NAME-ONLY? T)))
        (WHEN NAME
            (WITH-BUTTON `(GET-PE ',NAME)
                   (FORMAT NIL "Edit ~A's Placements" NAME)
                   (FORMAT NIL "Edit the placements of ~S." NAME)))))

(DEFUN INTERACTIVE-INCLUDE-ROOM (&OPTIONAL IN-ROOM)
   (LET* ((ALL-ROOMS (ALL-ROOMS T))
          (ROOM (OR IN-ROOM (SELECT-ROOM :ALLOW-NEW? T :REASON "Include in ..." :FROM-ROOMS 
                                   ALL-ROOMS))))
         (WHEN ROOM
             (UNLESS (LISTP (ROOM-INCLUSIONS ROOM))
                 (RETURN-FROM INTERACTIVE-INCLUDE-ROOM (NOTIFY-USER "Can't add inclusions to ~S." 
                                                              ROOM)))
             (LET ((INCLUSION (SELECT-ROOM :ALLOW-NEW? T :REASON (FORMAT NIL "Include in ~A"
                                                                            (ROOM-NAME ROOM))
                                     :FROM-ROOMS
                                     (REMOVE ROOM ALL-ROOMS))))
                  (WHEN INCLUSION
                      (WHEN (MEMBER (ROOM-NAME INCLUSION)
                                   (ROOM-INCLUSIONS ROOM)
                                   :TEST
                                   'EQUAL)
                          (RETURN-FROM INTERACTIVE-INCLUDE-ROOM (NOTIFY-USER 
                                                                       "~S is already included in ~S"
                                                                       (ROOM-NAME INCLUSION)
                                                                       (ROOM-NAME ROOM))))
                      (UPDATE-PLACEMENTS)
                      (WHEN (AND (EQUAL (BACKGROUND-EXTERNAL-FORM (ROOM-BACKGROUND INCLUSION))
                                        `((:TEXT ,(ROOM-NAME INCLUSION))))
                                 (EQUAL (BACKGROUND-EXTERNAL-FORM (ROOM-BACKGROUND ROOM))
                                        `((:TEXT ,(ROOM-NAME ROOM)))))

                          (IL:* IL:|;;| "feature: when both names are in default position we delete name of included room s.t. they don't overwrite.")

                          (SETF (ROOM-BACKGROUND INCLUSION)
                                (MAKE-BACKGROUND `((:TEXT ,""))))
                          (ROOM-CHANGED INCLUSION :EDITED))
                      (PUSH (ROOM-NAME INCLUSION)
                            (ROOM-INCLUSIONS ROOM))
                      (ROOM-CHANGED ROOM :EDITED)
                      (NOTIFY-USER "Included ~S in ~S." (ROOM-NAME INCLUSION)
                             (ROOM-NAME ROOM))
                      T)))))

(DEFUN INTERACTIVE-EXCLUDE-ROOM (&OPTIONAL FROM-ROOM)
   (LET ((ROOM (OR FROM-ROOM (SELECT-ROOM :REASON "Exclude from ..."))))
        (WHEN ROOM
            (UNLESS (CONSP (ROOM-INCLUSIONS ROOM))
                (RETURN-FROM INTERACTIVE-EXCLUDE-ROOM (NOTIFY-USER "~S has no inclusions." ROOM)))
            (LET ((INCLUSION (MENU (ROOM-INCLUSIONS ROOM)
                                   (FORMAT NIL "Exclude from ~A" (ROOM-NAME ROOM)))))
                 (WHEN INCLUSION
                     (UPDATE-PLACEMENTS)
                     (SETF (ROOM-INCLUSIONS ROOM)
                           (REMOVE INCLUSION (ROOM-INCLUSIONS ROOM :TEST 'EQUAL)))
                     (ROOM-CHANGED ROOM :EDITED)
                     (NOTIFY-USER "~S is no longer included in ~S." INCLUSION (ROOM-NAME ROOM))
                     T)))))

(DEFUN INTERACTIVE-DELETE-ROOM (&OPTIONAL ROOM)
   (FLET ((DELETE? (ROOM)
                 (WHEN (AND ROOM (CONFIRM " Delete room ~S?  (will close windows)" (ROOM-NAME ROOM)))
                       (DELETE-ROOM ROOM))))
         (LET ((ROOMS (ROOMS-NOT-IN-ANY-SUITE T)))
              (IF ROOM
                  (IF (MEMBER ROOM ROOMS :TEST 'EQ)
                      (DELETE? ROOM)
                      (NOTIFY-USER "Delete ~S from suite ~S before deleting" (ROOM-NAME ROOM)
                             (FIND-SUITE-CONTAINING (ROOM-NAME ROOM))))
                  (IF ROOMS
                      (DELETE? (SELECT-ROOM :REASON "Delete" :FROM-ROOMS ROOMS))
                      (NOTIFY-USER "All rooms belong to some suite."))))))

(DEFUN INTERACTIVE-FIND-PLACEMENT (WINDOW)
   (LET ((WINDOW (MAIN-WINDOW WINDOW)))
        (UPDATE-PLACEMENTS)
        (NOTIFY-USER "This placement is in ~S." (ROOM-NAME (MULTIPLE-VALUE-BIND (PLACEMENT ROOM)
                                                                  (FIND-PLACEMENT WINDOW)
                                                                  ROOM)))))

(DEFUN INTERACTIVE-COPY-PLACEMENT (WINDOW &OPTIONAL ROOM-NAME)
   (UN-HIDE-WINDOW WINDOW)
   (LET ((NAME (OR ROOM-NAME (SELECT-ROOM :REASON "Copy this placement to" :ALLOW-NEW? T 
                                    :NAME-ONLY? T))))
        (WHEN NAME (INTERACTIVE-MOVE-OR-COPY-PLACEMENT WINDOW NAME T))))

(DEFUN INTERACTIVE-MOVE-PLACEMENT (WINDOW &OPTIONAL ROOM-NAME)
   (UN-HIDE-WINDOW WINDOW)
   (LET ((NAME (OR ROOM-NAME (SELECT-ROOM :REASON "Move this placement to" :ALLOW-NEW? T 
                                    :NAME-ONLY? T))))
        (WHEN NAME (INTERACTIVE-MOVE-OR-COPY-PLACEMENT WINDOW NAME NIL))))

(DEFUN INTERACTIVE-COPY-PLACEMENT-TO-THIS-ROOM (WINDOW)
   (INTERACTIVE-MOVE-OR-COPY-PLACEMENT WINDOW (ROOM-NAME *CURRENT-ROOM*)
          T))

(DEFUN INTERACTIVE-MOVE-PLACEMENT-TO-POCKETS (WINDOW)
   (IF *POCKET-ROOM-NAME*
       (INTERACTIVE-MOVE-OR-COPY-PLACEMENT WINDOW *POCKET-ROOM-NAME* NIL)
       (NOTIFY-USER "There is no pocket room.")))

(DEFUN INTERACTIVE-MOVE-OR-COPY-PLACEMENT (WINDOW TO-ROOM-NAMED COPY?)
   (LET ((WINDOW (MAIN-WINDOW WINDOW))
         (TO-ROOM (OR (ROOM-NAMED TO-ROOM-NAMED)
                      (PROGN (NOTIFY-USER "There is no room named ~S." TO-ROOM-NAMED)
                             NIL))))
        (WHEN TO-ROOM
            (UPDATE-PLACEMENTS)
            (MULTIPLE-VALUE-BIND (PLACEMENT FROM-ROOM)
                   (FIND-PLACEMENT WINDOW)
                   (COND
                      ((EQ FROM-ROOM TO-ROOM)
                       (NOTIFY-USER "This placement is already in ~S." (ROOM-NAME FROM-ROOM))
                       :NOOP)
                      (T (MOVE-PLACEMENT PLACEMENT FROM-ROOM TO-ROOM COPY?)
                         (NOTIFY-USER "~A this placement from ~S to ~S." (IF COPY?
                                                                             "Copied"
                                                                             "Moved")
                                (ROOM-NAME FROM-ROOM)
                                TO-ROOM-NAMED)
                         T))))))

(DEFUN INTERACTIVE-RESET ()
   (WHEN (CONFIRM "Reset Rooms?  (Will lose windows.)")
         (RESET)))

(DEFUN SELECT-ROOM (&KEY ALLOW-NEW? NAME-ONLY? (FROM-ROOMS (ALL-ROOMS T))
                             (REASON "Select Room"))
   (LET ((ITEMS (WITH-COLLECTION (DOLIST (ROOM FROM-ROOMS)
                                     (COLLECT `(,(ROOM-NAME ROOM)
                                                ',ROOM)
                                            ITEMS))
                       (WHEN ALLOW-NEW?
                           (COLLECT '("<new room>" :NEW))))))
        (IF ITEMS
            (LET* ((CHOICE (MENU ITEMS REASON))
                   (ROOM (IF (AND ALLOW-NEW? (EQ CHOICE :NEW))
                             (INTERACTIVE-MAKE-ROOM)
                             CHOICE)))
                  (WHEN ROOM
                      (IF NAME-ONLY?
                          (ROOM-NAME ROOM)
                          ROOM)))
            (PROGN (NOTIFY-USER "No rooms!")
                   NIL))))

(DEFUN INTERACTIVE-MAKE-ROOM ()
   (LET ((NAME (PROMPT-USER "Name:" "Type name of new room (CR to abort).")))
        (WHEN NAME
            (IF (ROOM-NAMED NAME)
                (NOTIFY-USER "A room named ~S already exists.  Aborted." NAME)
                (MAKE-ROOM NAME)))))

(DEFUN INTERACTIVE-COPY-ROOM (&OPTIONAL ROOM)
   (LET ((ROOM (OR ROOM (SELECT-ROOM :REASON "Copy"))))
        (WHEN ROOM
            (LET ((NAME (PROMPT-USER "New Name:" "Copying room ~S." (ROOM-NAME ROOM))))
                 (WHEN NAME
                     (IF (ROOM-NAMED NAME)
                         (NOTIFY-USER "A room named ~S already exists." NAME)
                         (PROGN (COPY-ROOM ROOM NAME)
                                (NOTIFY-USER "Copied room ~S to ~S." (ROOM-NAME ROOM)
                                       NAME))))))))

(DEFUN INTERACTIVE-RENAME-ROOM (&OPTIONAL ROOM)
   (LET ((ROOM (OR ROOM (SELECT-ROOM :REASON "Rename"))))
        (WHEN ROOM
            (LET ((NAME (PROMPT-USER "New Name:" "Renaming room ~S." (ROOM-NAME ROOM))))
                 (WHEN NAME
                     (IF (ROOM-NAMED NAME)
                         (NOTIFY-USER "A room named ~S already exists." NAME)
                         (PROGN (RENAME-ROOM ROOM NAME)
                                (NOTIFY-USER "Renamed room ~S to be ~S." (ROOM-NAME ROOM)
                                       NAME))))))))

(DEFUN INTERACTIVE-MAKE-DOOR (&KEY ALLOW-NEW?)
   (LET ((NAME (SELECT-ROOM :NAME-ONLY? T :ALLOW-NEW? ALLOW-NEW?)))
        (WHEN NAME
            (LET ((BUTTON-TYPE (SELECT-BUTTON-TYPE)))
                 (WHEN BUTTON-TYPE (MAKE-DOOR :ROOM-NAME NAME :BUTTON-TYPE BUTTON-TYPE))))))

(DEFUN MAKE-DOOR (&KEY ROOM-NAME (BUTTON-TYPE *DEFAULT-BUTTON-TYPE*)
                           POSITION)
   (MAKE-BUTTON-WINDOW (MAKE-BUTTON :TEXT ROOM-NAME :ACTION
                              `(INTERACTIVE-GO-TO-ROOM-NAMED ,(IF (CONSTANTP ROOM-NAME)
                                                                      ROOM-NAME
                                                                      (LIST 'QUOTE ROOM-NAME)))
                              :HELP
                              (FORMAT NIL "Go to room named ~S" ROOM-NAME)
                              :TYPE BUTTON-TYPE)
          POSITION))

(DEFUN RETRIEVE-WINDOWS ()

(IL:* IL:|;;;| "un-hide all lost windows, telling the user what you've done.")

   (LET ((LOST-WINDOWS (LOST-WINDOWS)))
        (IF LOST-WINDOWS
            (PROGN (DOLIST (WINDOW LOST-WINDOWS)
                       (UN-HIDE-WINDOW WINDOW))
                   (NOTIFY-USER "~S window(s) retrieved." (LENGTH LOST-WINDOWS)))
            (NOTIFY-USER "All windows are in some room."))))

(DEFUN CHECK-LOST-WINDOWS ()
   (LET ((LOST-WINDOWS (LOST-WINDOWS)))
        (WHEN LOST-WINDOWS
            (NOTIFY-USER "~D lost window(s).  Try \"Retrieve Windows\"." (LENGTH LOST-WINDOWS)))))

(DEFUN EVAL-WALK (EXPRESSION)

   (IL:* IL:|;;| "an inverted evaluator:  expressions are implicitly quoted unless wrapped in :EVAL.  Only conses when it must, i.e. structure w/o EVALs in it will be shared.")

   (IF (CONSP EXPRESSION)
       (IF (AND (CONSP (FIRST EXPRESSION))
                (EQ (FIRST (FIRST EXPRESSION))
                    :EVAL))
           (CONS (EVAL (SECOND (FIRST EXPRESSION)))
                 (EVAL-WALK (REST EXPRESSION)))
           (LET* ((OLD-FIRST (FIRST EXPRESSION))
                  (OLD-REST (REST EXPRESSION))
                  (NEW-FIRST (EVAL-WALK OLD-FIRST))
                  (NEW-REST (EVAL-WALK OLD-REST)))
                 (IF (AND (EQ OLD-FIRST NEW-FIRST)
                          (EQ OLD-REST NEW-REST))
                     EXPRESSION
                     (CONS NEW-FIRST NEW-REST))))
       EXPRESSION))



(IL:* IL:|;;| "back doors")


(DEFGLOBALVAR *BACK-DOOR-ROOM-NAME* NIL)

(DEFUN MAKE-BACK-DOOR (&KEY POSITION BUTTON-TYPE)
   (MAKE-BUTTON-WINDOW (MAKE-BUTTON :TEXT-FORM '(SYMBOL-VALUE '*BACK-DOOR-ROOM-NAME*)
                              :ACTION
                              '(INTERACTIVE-GO-TO-ROOM-NAMED *BACK-DOOR-ROOM-NAME*)
                              :TYPE
                              (OR BUTTON-TYPE :DOOR)
                              :HELP "Go to the previous room." :INVERTED? T)
          POSITION))

(DEFUN BACK-DOOR-ENTRY-FUNCTION (ENTERING-ROOM)

(IL:* IL:|;;;| "called whenever we enter a room")

(IL:* IL:|;;;| "maintains the value of *BACK-DOOR-ROOM-NAME* to be the name of the last named room we were in before the current room.")

   (LET* ((LEAVING-ROOM *CURRENT-ROOM*)
          (LEAVING-NAME (ROOM-NAME LEAVING-ROOM))
          (ENTERING-NAME (ROOM-NAME ENTERING-ROOM)))
         (UNLESS *BACK-DOOR-ROOM-NAME*

             (IL:* IL:|;;| "bootstrapping  ")

             (SETQ *BACK-DOOR-ROOM-NAME* LEAVING-NAME))
         (WHEN (NOT (EQUAL ENTERING-NAME LEAVING-NAME))

             (IL:* IL:|;;| "ignore screen refreshes")

             (IF (ROOM-NAMED LEAVING-NAME)
                 (IF (ROOM-NAMED ENTERING-NAME)

                     (IL:* IL:|;;| "simple case - going between named rooms")

                     (SETQ *BACK-DOOR-ROOM-NAME* LEAVING-NAME)
                     (PROGN 
                            (IL:* IL:|;;| "when entering an un-named room from a named room we save the current back door on the room we're entering & update the global back door ")

                            (ROOM-PROP ENTERING-ROOM :BACK-DOOR *BACK-DOOR-ROOM-NAME*)
                            (SETQ *BACK-DOOR-ROOM-NAME* LEAVING-NAME)))
                 (IF (ROOM-NAMED ENTERING-NAME)

                     (IL:* IL:|;;| "entering a named room from an unnamed one")

                     (WHEN (EQUAL *BACK-DOOR-ROOM-NAME* ENTERING-NAME)

                         (IL:* IL:|;;| "if popping back to room we came from then restore back door we saved upon entering. global will be correct, making passage through un-named rooms transparent.")

                         (SETQ *BACK-DOOR-ROOM-NAME* (ROOM-PROP LEAVING-ROOM :BACK-DOOR)))

                     (IL:* IL:|;;| 
   "going between un-named rooms we just pass along the saved back door, & don't update the global")

                     (ROOM-PROP ENTERING-ROOM :BACK-DOOR (ROOM-PROP LEAVING-ROOM :BACK-DOOR)))))))

(PUSHNEW 'BACK-DOOR-ENTRY-FUNCTION *ROOM-ENTRY-FUNCTIONS*)
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY

(IL:GLOBALVARS IL:PROMPTWINDOW IL:CROSSHAIRS)
)
(IL:PUTPROPS IL:ROOMS-INTERACTIVE IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (9121 9591 (INSTALL-MENU-ITEMS 9121 . 9591)) (9593 10047 (INSTALL-MENU-ITEM 9593 . 
10047)) (10120 14598 (INTERACTIVE-CLOSE-WINDOW 10120 . 14598)) (14600 14989 (INTERACTIVE-GO-TO-ROOM 
14600 . 14989)) (14991 15136 (INTERACTIVE-GO-TO-OVERVIEW 14991 . 15136)) (15138 15454 (
INTERACTIVE-GO-TO-ROOM-NAMED 15138 . 15454)) (15456 15746 (INTERACTIVE-EDIT-ROOM 15456 . 15746)) (
15748 17564 (EDIT-ROOM 15748 . 17564)) (17566 17873 (INTERACTIVE-EDIT-PLACEMENTS 17566 . 17873)) (
17875 20277 (INTERACTIVE-INCLUDE-ROOM 17875 . 20277)) (20279 21106 (INTERACTIVE-EXCLUDE-ROOM 20279 . 
21106)) (21108 21849 (INTERACTIVE-DELETE-ROOM 21108 . 21849)) (21851 22228 (INTERACTIVE-FIND-PLACEMENT
 21851 . 22228)) (22230 22548 (INTERACTIVE-COPY-PLACEMENT 22230 . 22548)) (22550 22870 (
INTERACTIVE-MOVE-PLACEMENT 22550 . 22870)) (22872 23022 (INTERACTIVE-COPY-PLACEMENT-TO-THIS-ROOM 22872
 . 23022)) (23024 23235 (INTERACTIVE-MOVE-PLACEMENT-TO-POCKETS 23024 . 23235)) (23237 24334 (
INTERACTIVE-MOVE-OR-COPY-PLACEMENT 23237 . 24334)) (24336 24442 (INTERACTIVE-RESET 24336 . 24442)) (
24444 25349 (SELECT-ROOM 24444 . 25349)) (25351 25633 (INTERACTIVE-MAKE-ROOM 25351 . 25633)) (25635 
26192 (INTERACTIVE-COPY-ROOM 25635 . 26192)) (26194 26762 (INTERACTIVE-RENAME-ROOM 26194 . 26762)) (
26764 27056 (INTERACTIVE-MAKE-DOOR 26764 . 27056)) (27058 27676 (MAKE-DOOR 27058 . 27676)) (27678 
28098 (RETRIEVE-WINDOWS 27678 . 28098)) (28100 28298 (CHECK-LOST-WINDOWS 28100 . 28298)) (28300 29174 
(EVAL-WALK 28300 . 29174)) (29258 29710 (MAKE-BACK-DOOR 29258 . 29710)) (29712 31729 (
BACK-DOOR-ENTRY-FUNCTION 29712 . 31729)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-INTERACTIVE.DFASL b/rooms/ROOMS-INTERACTIVE.DFASL
new file mode 100644
index 00000000..fe3dfa30
Binary files /dev/null and b/rooms/ROOMS-INTERACTIVE.DFASL differ
diff --git a/rooms/ROOMS-INTRO b/rooms/ROOMS-INTRO
new file mode 100644
index 00000000..3a7fd750
--- /dev/null
+++ b/rooms/ROOMS-INTRO
@@ -0,0 +1,426 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "ROOMS" (USE "LISP" "XCL") (SHADOW CLROOM))
+)
+(IL:FILECREATED "17-Aug-90 12:50:32" IL:|{DSK}<usr>local>lde>SOURCES>rooms>Medley>ROOMS-INTRO.;3| 32618  
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:ROOMS-INTROCOMS)
+
+      IL:|previous| IL:|date:| "27-Jul-90 05:37:18" 
+IL:|{DSK}<usr>local>lde>SOURCES>rooms>Medley>ROOMS-INTRO.;2|)
+
+
+; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:ROOMS-INTROCOMS)
+
+(IL:RPAQQ IL:ROOMS-INTROCOMS
+          ((IL:FILES (IL:SYSLOAD)
+                  IL:ROOMS IL:ROOMS-NOTES)
+           (FILE-ENVIRONMENTS IL:ROOMS-INTRO)
+           (IL:VARIABLES *INTRO-NOTE-FONT*)
+           (IL:FUNCTIONS SET-INTRO-NOTE-FONT)
+           (EVAL-WHEN (LOAD)
+                  (IL:P 
+                        (IL:* IL:|;;| "create both fonts when we're loaded")
+
+                        (IL:FONTCREATE 'IL:MODERN 24)
+                        (IL:FONTCREATE 'IL:HELVETICA 14)
+                        
+                        (IL:* IL:|;;| "initialize variable")
+
+                        (SET-INTRO-NOTE-FONT)
+                        
+                        (IL:* IL:|;;| "make sure variable will get reset when screen size changes")
+
+                        (PUSHNEW 'SET-INTRO-NOTE-FONT *SCREEN-CHANGED-FUNCTIONS*)))
+           (IL:SUITES "ROOMS-INTRO")
+           (IL:P (EVAL-WHEN (LOAD)
+                        (LET ((BUTTON (MAKE-BUTTON :TEXT "Enter Introduction" :FONT
+                                             '(IL:HELVETICAD 24)
+                                             :SHADOWS T :TYPE :STRETCHY-ARK :ACTION
+                                             '(INTERACTIVE-GO-TO-ROOM-NAMED "Intro")
+                                             :HELP "Enter the Rooms Introduction suite")))
+                             (MAKE-BUTTON-WINDOW BUTTON (MAKE-POSITION (FLOOR (- IL:SCREENWIDTH
+                                                                                 (BUTTON-WIDTH BUTTON
+                                                                                        ))
+                                                                              2)
+                                                               (FLOOR (- IL:SCREENHEIGHT (
+                                                                                        BUTTON-HEIGHT
+                                                                                          BUTTON))
+                                                                      2))))))))
+
+(IL:FILESLOAD (IL:SYSLOAD)
+       IL:ROOMS IL:ROOMS-NOTES)
+
+(DEFINE-FILE-ENVIRONMENT IL:ROOMS-INTRO :PACKAGE (DEFPACKAGE "ROOMS" (:USE "LISP" "XCL")
+                                                            (:SHADOW CL:ROOM))
+   :READTABLE "XCL"
+   :COMPILER :COMPILE-FILE)
+
+(DEFGLOBALVAR *INTRO-NOTE-FONT*
+
+(IL:* IL:|;;;| "font for note windows in the Intro suite")
+
+   )
+
+(DEFUN SET-INTRO-NOTE-FONT ()
+   (DECLARE (GLOBAL IL:SCREENWIDTH))
+
+   (IL:* IL:|;;| "use a larger font when on a larger screen")
+
+   (SETQ *INTRO-NOTE-FONT* (IF (> IL:SCREENWIDTH SMALL-SCREEN-WIDTH)
+                               (IL:FONTCREATE 'IL:MODERN 24)
+                               (IL:FONTCREATE 'IL:HELVETICA 14))))
+(EVAL-WHEN (LOAD)
+
+
+(IL:* IL:|;;| "create both fonts when we're loaded")
+
+
+(IL:FONTCREATE 'IL:MODERN 24)
+
+(IL:FONTCREATE 'IL:HELVETICA 14)
+
+
+(IL:* IL:|;;| "initialize variable")
+
+
+(SET-INTRO-NOTE-FONT)
+
+
+(IL:* IL:|;;| "make sure variable will get reset when screen size changes")
+
+
+(PUSHNEW 'SET-INTRO-NOTE-FONT *SCREEN-CHANGED-FUNCTIONS*)
+)
+
+(DEFSUITE "ROOMS-INTRO"
+   (:VERSION 1)
+   (:FILES)
+   (:WINDOW 0 :TYPE :BUTTON :TEXT "Next >" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED "Intro Model")
+          :HELP "Go to the next room in the Introduction" :SHADOWS T :TYPE :STRETCHY-ARK)
+   (:WINDOW 1 :TYPE :BUTTON :TEXT-FORM (SYMBOL-VALUE '*BACK-DOOR-ROOM-NAME*)
+          :ACTION
+          (INTERACTIVE-GO-TO-ROOM-NAMED *BACK-DOOR-ROOM-NAME*)
+          :HELP "Go to the previous room." :TYPE :STRETCHY-ARK :INVERTED? T)
+   (:WINDOW 2 :TYPE :NOTE-WINDOW :REGION (33/1024 355/808 231/512 181/404)
+          :TITLE "Welcome" :STRING "
+
+Welcome to the Rooms Introduction.
+
+This is a suite of rooms which describe the Rooms system itself. Each room introduces certain topics, and where appropriate provides exercises to let you experience the things described (\"put some meat on the bones\").
+
+The collection of buttons at the right can be used to move through the exhibits. Following the screen buttons labelled \"Next\" in each room will provide a step-by-step introduction to the basics of Rooms. This is recommended as the best way to get started. Start by selecting the Next screen button with the left mouse button.
+
+" :FONT *INTRO-NOTE-FONT* :READ-ONLY? NIL)
+   (:WINDOW 3 :TYPE :BUTTON :TEXT "Next >" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED "Intro Doors")
+          :HELP "Go to the next room in the Introduction" :SHADOWS T :TYPE :STRETCHY-ARK)
+   (:WINDOW 4 :TYPE :NOTE-WINDOW :REGION (33/1024 137/808 31/64 145/202)
+          :TITLE "The Rooms Model" :STRING "
+
+Rooms provides many screens worth of working space for the Xerox LISP user.
+
+Each space is called a \"room\", has a name, and contains a collection of windows.
+
+Windows can be in one or more rooms. A window in more than one room is referred to as \"shared\".
+
+A window may have a different position and shape in each room. The collection of this information is called the \"placement\" of the window in that room. 
+
+In certain situations, it is desirable to use the same configuration of windows in more than one room. For example, in these introductory rooms, the navigation buttons, the promptwindow, and the EXEC window act as a common framework for each room's  specific information windows. In these situations, a room containing only the common windows is created (here it is called \"Intro Panel\") and this room is \"included\" in the other rooms.
+
+Exercise: The \"Intro Panel\" button is an easy way to go to the \"Intro Panel\". Use it to go to that room, and notice the set of windows which is common. Then return to this room, using the inverted button at the center of the screeen below (a \"back door\").
+
+So a room has (at least):
+      a name
+      a set of placements for various windows
+      a set of inclusions of other rooms.
+" :FONT *INTRO-NOTE-FONT* :READ-ONLY? NIL)
+   (:WINDOW 5 :TYPE :BUTTON :TEXT "Intro Panel" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED "Intro Panel")
+          :HELP "Go to the room named \"Intro Panel\"" :SHADOWS T :TYPE :STRETCHY-ARK)
+   (:WINDOW 6 :TYPE :BUTTON :TEXT "Next >" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED "Intro Overview")
+          :HELP "Go to the next room in the Introduction" :SHADOWS T :TYPE :STRETCHY-ARK)
+   (:WINDOW 7 :TYPE :NOTE-WINDOW :REGION (1/32 249/808 505/1024 461/808)
+          :TITLE "Doors" :STRING "
+
+
+The various buttons which you have been using to move about in this exploratorium are called \"doors\".
+
+Doors can be of various different shapes. To the right you will find a number of those shapes, all of which will take you to this very room.
+
+Doors can be created using the background menu: select the \"Rooms>Make Door\" command. (This X>Y notation is used to denote the Y subcommand of the X command of a menu.)  You will be prompted with a menu of room names to select a destination for the door; then you will be prompted with a menu of door shapes for the shape of the door. A door will be created, and you will be permitted to move it into the position you would like.
+
+Exercise: Create a door to this room, looking like a porthole. Then go through it to this room.
+
+Doors are windows. You can therefore get rid of them by closing the window.
+
+Exercise: Close the doors you just created.
+" :FONT *INTRO-NOTE-FONT* :READ-ONLY? NIL)
+   (:WINDOW 8 :TYPE :BUTTON :TEXT "Doors" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED "Intro Doors")
+          :HELP "Go to room named \"Intro Doors\"" :TYPE :DOOR)
+   (:WINDOW 9 :TYPE :BUTTON :TEXT "Intro Doors" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED "Intro Doors")
+          :HELP "Go to room named \"Intro Doors\"" :FONT (IL:HELVETICA 18 (IL:BOLD IL:REGULAR 
+                                                                                 IL:REGULAR))
+          :SHADOWS T)
+   (:WINDOW 10 :TYPE :BUTTON :TEXT "Doors" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED "Intro Doors")
+          :HELP "Go to room named \"Intro Doors\"" :TYPE :PORTHOLE)
+   (:WINDOW 11 :TYPE :BUTTON :TEXT "Next >" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED "Intro Menus")
+          :HELP "Go to the next room in the Introduction" :SHADOWS T :TYPE :STRETCHY-ARK)
+   (:WINDOW 12 :TYPE :NOTE-WINDOW :REGION (59/1024 39/202 263/512 555/808)
+          :TITLE "The Overview" :STRING "
+
+The Overview provides a number of different operations. Roughly these can be grouped into: room selection, room manipulation, room structure viewing. 
+
+All operations in the Overview are invoked in same way:
+. the operation is selected by depressing and holding down a mode key on the keyboard,
+. the object to be operated on selected by pointing and clicking:
+              a room: middle mouse button; or
+              a placement: left mouse button.
+
+The various operations are represented by screen buttons at the bottom of the screen. These are inverted to indicate the operation which is currently selected.
+
+Exercise: Use the GO TO operation to return to this room:
+        goto the overview;
+        select the GO TO operation (space bar);
+        return to this room by selecting its pictogram with the middle mouse button.
+
+Exercise: Use the Move operation on a placement:
+        goto the overview;
+        find the placement for this window;
+        select the MOVE operation (MOVE key);
+        move this placement around in this room;
+        return to this room when you are done.
+
+Exercise: Explore the other Overview commands. Return to this room when you are done.
+
+" :FONT *INTRO-NOTE-FONT* :READ-ONLY? NIL)
+   (:WINDOW 13 :TYPE :BUTTON :TEXT "Next >" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED "Intro Backgrounds"
+                                                           )
+          :HELP "Go to the next room in the Introduction" :SHADOWS T :TYPE :STRETCHY-ARK)
+   (:WINDOW 14 :TYPE :NOTE-WINDOW :REGION (1/32 227/808 261/512 503/808)
+          :TITLE "Background Menu" :STRING "
+
+So that commands to manipulate the Rooms system are always ready-at-hand, they are made available on the background menu, under the \"Rooms\" item. 
+
+Menus are used for prompting in the interactions invoked by some of these commands. Selecting outside any of these menus indicates that you do not want to issue the command after all (you are \"cancelling\" or \"aborting\" the command).
+
+Exercise:  Go to the \"Intro Doors\" room using the \"Rooms>Go to Room\" background command.  Return here.
+
+Exercise:  Go to the Overview using the \"Rooms\" background command.  Return here.
+
+To make it quicker to issue these commands , Rooms provides a way of getting a screen button (an accelerator) for any command appearing on the background menu. Hold down the COPY (or SHIFT) key when selecting the command from the menu. Instead of the command being invoked, a button which will invoke the command will be created.
+
+Exercise:  Create an accelerator for the \"Rooms>Go to Room\" background command. (It will be labelled \"Go to Room\", like the one you see at right.)
+" :FONT *INTRO-NOTE-FONT* :READ-ONLY? NIL)
+   (:WINDOW 15 :TYPE :BUTTON :TEXT "Next >" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED "Intro End")
+          :HELP "Go to the next room in the Introduction" :SHADOWS T :TYPE :STRETCHY-ARK)
+   (:WINDOW 16 :TYPE :NOTE-WINDOW :REGION (1/64 49/808 379/1024 691/808)
+          :TITLE "Backgrounds" :STRING "
+
+Each room has a background specification telling how to paint its background.  The specification is an ordered list of commands.
+
+The three commands available are:
+
+(:TEXT <string> &KEY :FONT :SHADOWS :POSITION :ALIGNMENT)
+
+(:REGION <region> &KEY :SHADE :BORDER :BORDER-SHADE)
+
+(:WHOLE-SCREEN <shade> &KEY :BORDER :BORDER-SHADE)
+
+The use of these commands is best illustrated by example.
+
+Exercise:  Select the \"Edit This Room\" button in the top middle of the screen using the left or middle button.  This opens an SEdit window with this room's description.
+
+As you can see, the background specification for a room can be very complex allowing great flexibility in customizing the way the background is painted.
+
+The functions il:getregion, il:getposition, and il:editshade can be used to get regions, positions and shades interactively.  For example, to insert a region in SEdit, type (il:getregion) followed by M-Z EVAL (mutate selection by EVAL).
+
+Exercise:  change some of the regions, positions and shades in this rooms background specification.  
+" :FONT *INTRO-NOTE-FONT* :READ-ONLY? NIL)
+   (:WINDOW 17 :TYPE :BUTTON :TEXT "Edit This Room" :ACTION (EDIT-ROOM *CURRENT-ROOM*)
+          :HELP "Edit the current room.")
+   (:WINDOW 18 :TYPE :NOTE-WINDOW :REGION (129/1024 37/101 471/1024 381/808)
+          :TITLE "Good Bye" :STRING "
+
+This is the end of the Rooms Introduction.
+
+For more information please refer to the Rooms documentation.
+
+
+
+Enjoy!
+" :FONT *INTRO-NOTE-FONT* :READ-ONLY? NIL)
+   (:WINDOW 19 :TYPE :BUTTON :TEXT "Intro Backgrounds" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED 
+                                                                      "Intro Backgrounds")
+          :HELP "Go to the room which introduces Rooms' menus" :SHADOWS T :TYPE :STRETCHY-ARK)
+   (:WINDOW 20 :TYPE :BUTTON :TEXT "< Start" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED "Intro")
+          :HELP "Go back to the begining of the Introduction" :SHADOWS T :TYPE :STRETCHY-ARK)
+   (:WINDOW 21 :TYPE :BUTTON :TEXT "Overview" :ACTION (GO-TO-OVERVIEW)
+          :HELP "Enter the overview" :SHADOWS T :TYPE :STRETCHY-ARK)
+   (:WINDOW 22 :TYPE :PROMPT-WINDOW)
+   (:WINDOW 23 :TYPE :BUTTON :TEXT "Intro Overview" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED 
+                                                                   "Intro Overview")
+          :HELP "Go to the room which introduces the Overview" :SHADOWS T :TYPE :STRETCHY-ARK)
+   (:WINDOW 24 :TYPE :BUTTON :TEXT "Intro Menus" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED "Intro Menus")
+          :HELP "Go to the room which introduces Rooms' menus" :SHADOWS T :TYPE :STRETCHY-ARK)
+   (:WINDOW 25 :TYPE :BUTTON :TEXT "Intro Doors" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED "Intro Doors")
+          :HELP "Go to the room which introduces doors" :SHADOWS T :TYPE :STRETCHY-ARK)
+   (:WINDOW 26 :TYPE :BUTTON :TEXT "Intro Model" :ACTION (INTERACTIVE-GO-TO-ROOM-NAMED "Intro Model")
+          :HELP "Go to the room which introduces the Rooms model" :SHADOWS T :TYPE :STRETCHY-ARK)
+   (:WINDOW 27 :TYPE :BUTTON :TEXT "Go to Room" :ACTION (INTERACTIVE-GO-TO-ROOM)
+          :HELP "Go to an existing room" :SHADOWS T :TYPE :STRETCHY-ARK)
+   (:WINDOW 28 :TYPE :EXEC :REGION (653/1024 15/808 11/32 85/404)
+          :PACKAGE "XCL-USER" :READTABLE "XCL")
+   (:ROOM "Intro" :PLACEMENTS ((0 :REGION (13/16 109/404 31/512 15/404))
+                               (1 :REGION (221/512 5/202 33/512 15/404))
+                               (2 :REGION (33/1024 355/808 231/512 181/404)))
+          :INCLUSIONS
+          ("Intro Panel")
+          :BACKGROUND
+          ((:TEXT "Intro" :POSITION (10 . 10)
+                  :FONT
+                  (IL:HELVETICAD 24)))
+          :FILE-WATCH-ON? NIL)
+   (:ROOM "Intro Model" :PLACEMENTS ((3 :REGION (13/16 219/808 31/512 15/404))
+                                     (4 :REGION (33/1024 137/808 31/64 145/202))
+                                     (1 :REGION (221/512 5/202 23/512 15/404))
+                                     (5 :REGION (605/1024 267/404 45/512 15/404)))
+          :INCLUSIONS
+          ("Intro Panel")
+          :BACKGROUND
+          ((:TEXT "Intro Model" :POSITION (10 . 10)
+                  :FONT
+                  (IL:HELVETICAD 24 IL:BOLD)))
+          :FILE-WATCH-ON? NIL)
+   (:ROOM "Intro Doors" :PLACEMENTS ((6 :REGION (13/16 219/808 31/512 15/404))
+                                     (7 :REGION (1/32 249/808 505/1024 461/808))
+                                     (1 :REGION (221/512 5/202 47/512 15/404))
+                                     (8 :REGION (145/256 473/808 59/1024 99/808))
+                                     (9 :REGION (655/1024 237/404 7/64 4/101))
+                                     (10 :REGION (165/256 529/808 87/1024 9/101)))
+          :INCLUSIONS
+          ("Intro Panel")
+          :BACKGROUND
+          ((:TEXT "Intro Doors" :POSITION (10 . 10)
+                  :FONT
+                  (IL:HELVETICAD 24)))
+          :FILE-WATCH-ON? NIL)
+   (:ROOM "Intro Overview" :PLACEMENTS ((11 :REGION (13/16 55/202 31/512 15/404))
+                                        (12 :REGION (59/1024 39/202 263/512 555/808))
+                                        (1 :REGION (221/512 5/202 45/512 15/404)))
+          :INCLUSIONS
+          ("Intro Panel")
+          :BACKGROUND
+          ((:TEXT "Intro Overview" :POSITION (10 . 10)
+                  :FONT
+                  (IL:HELVETICAD 24)))
+          :FILE-WATCH-ON? NIL)
+   (:ROOM "Intro Menus" :PLACEMENTS ((13 :REGION (415/512 55/202 31/512 15/404))
+                                     (14 :REGION (1/32 227/808 261/512 503/808))
+                                     (1 :REGION (221/512 5/202 59/512 15/404)))
+          :INCLUSIONS
+          ("Intro Panel")
+          :BACKGROUND
+          ((:TEXT "Intro Menus" :POSITION (10 . 10)
+                  :FONT
+                  (IL:HELVETICAD 24)))
+          :FILE-WATCH-ON? NIL)
+   (:ROOM "Intro Backgrounds" :PLACEMENTS ((15 :REGION (831/1024 55/202 31/512 15/404))
+                                           (16 :REGION (1/64 49/808 379/1024 691/808))
+                                           (1 :REGION (221/512 5/202 49/512 15/404))
+                                           (17 :REGION (437/1024 677/808 57/512 3/101)))
+          :INCLUSIONS
+          ("Intro Panel")
+          :BACKGROUND
+          ((:TEXT "Intro Backgrounds" :POSITION (10 . 10)
+                  :FONT
+                  (IL:HELVETICAD 24))
+           (:REGION (0.4 0.28 0.35 0.5)
+                  :SHADE 42405 :BORDER 8 :BORDER-SHADE 63903)
+           (:REGION (0.42 0.55 0.15 0.18)
+                  :SHADE #*(193 182)GB@@FD@@BD@IBBMIDABNJJHEEDDHAKFCD@@@@HABACFNJE@@@@@@MHADIHDALH@D@IEEEJEIAMBJJJIABEDBH@@@@@@@@JMKDH@@@@@@KB@HFBHBID@IBDKJIAEFGBHEMIBFAFHC@@@@@@@@AEKFM@@@@@@@NDKGIE@JJH@EEBNJFFKEHMEKGFEIDM@@D@@@@@@@@GGMJJ@@@@@@IEEJNDA@BJ@B@JJJIINJGCKEMMIFAD@@I@@@@@@@@HNKMA@H@@@@FBNDIEBDDA@@OEMDJGEM@NNOGKBM@M@@FH@@@D@@@CKODDH@@@@@LEJIGHA@@J@C@KBEELOEGAEJMFMHAH@@@B@@@H@@@@FJMA@@@@@@@BE@EEF@@@@LOEEJJKJNJFOOHICBAB@MAD@@@@@@@BIOJ@J@@@@@L@J@JJ@@@@@BBJJEEFOMJAMDABOL@@@B@B@@@@@@@@JJHID@@@@@@@DIEEFH@@HLJMEKJMKGDOFIB@BI@@@JJD@@@@@@@ABOJ@D@@@@@D@ABJKLA@@A@BJJDEJNNMAI@EHMJ@@@@@J@@@@@@@EEJHAI@@@@@@@JEEBJH@@BHEDIAJECMKOD@KECD@@@HOD@@@@@@@JHG@EF@@@@@@@@JJEE@@DEBJIFEBJJGNJJIGJNI@@@D@@@@@@@@@CADHBI@@@@@@BKEDHJD@@@DJJHHEEDOKOMFNNI@D@@@E@@@@@@@@DDE@EN@@@@@DADJIBJHBDKEEFKBHIEMGJKAOMJA@@@@I@@@@@@@@A@E@BH@@@@@HBBDJDEDHID@JIDHJJJKOGNKFOD@D@@@B@@@@@@@@@@J@EJ@@@@@@@DIADIIGBAGEEGBAEEGONJEOMH@@@@A@@@@@@@@@@EL@AD@@@@@B@AFFEBF@MFIEADJNNIOFOMKFKH@B@@@AH@@@@@@@@JH@FH@@@@@@@BHHHEIGBIFJFKDIMBJMJJBOOF@@@@JB@@@@@@@@@EJ@K@@@@@@@@@BBJJFHOFMMHDIGKOGKN@JMFM@@@ADHH@@@@@@@@K@JJD@@@@@@@@DJAEJOJKKGEI@JODMGJIDCMNH@@BEE@@@@@@@@@GEEFH@@@@@@@@HAJDEHMFNLIBAENOKNMBHEOM@@D@JI@@@@@@@@AFBMI@@@@@@@@A@BEEJGBIKOBDBKMNNK@E@AEKL@HAADH@@@D@@@BMEJFD@@@@@@@@DEJJAJEGNMDJ@NKOMNHJ@@OOE@JHFID@@@@@@@AFKE@@@@@@@HAAIJEDNEEEEKJIBKGMKJ@@@AEEJ@BBH@B@@@@@@@BMENJDH@@@@@@DFEJIAJDJJNIFANIGNH@B@DGOFHEJA@LH@@@@@@AKKGJKD@@@@@AJJMABE@IEEEFHNEBMED@@@@KEM@BE@@B@@@@@@@CFBNONM@@@@HDAEJFDHEBEEEAGANAEOD@@@@BOGHDN@@JH@@@@@@BMAEMENH@@@@IDBJIEBJEJJJF@OHBKED@@@@AMNHADEAB@@@@@@@AJ@CKKK@@@@DBBMEFIDJJMEFHOOFMFN@@@@@BOEHFH@BED@@@@@@BN@DD@GH@@@IDHBJIBAEGCOEGJJLJMIF@@@@@JOHH@BJHH@@@@@@@JH@IAFH@@@@A@EENLNKMEBODEGJKJBD@@@@@EOEC@@AA@@@@@@@AG@@@@CH@@@D@@BBICEFFJOJKJJOFMHH@@@@@CNMD@@B@D@@@@@@DM@@@ABH@@@HBHDMFLJIEGDOEBKMMJAJH@@@@GMNJ@@B@J@@@BH@BFDD@@CH@@@M@JAAEKDDIDKDJJOGGM@D@JH@@BKKE@@DAD@@@AB@JKI@@@A@@@@JK@DFKFJHBOLOFKJNL@AH@@@@@EODJ@@ADAB@@@DIEFBD@@BH@@@EDEIIBMEAEDKBMFOMJJ@@@A@@@CMEJH@DHJD@@@ABJMH@@@A@@@@JIBBFEEJDJOJMEMJKDH@H@@@@@BJKF@@ID@@@@@@@MKFJ@@@H@@@IEEEIDJEBMJDCJGEBI@@@@@@@@AEFM@@@H@@@@@@AGGMD@@B@@@@BJMEBEMJMKEIFOMJEB@@@@@@@@@JMO@@@@@@@@@@@IOOLH@@@@@@EGKEEBFKKFN@IHKDJD@@@@@@@@@AKJ@E@@@@@@@@@FKFKBH@@@@@JMFJBDIEFOKJFOOJJI@@@@@@@@ECGNH@@D@@@@@@@IFMOM@@H@@@EKOMMIFKOMFHIKGFJ@@@@@@@@@@BOE@@@B@@@@@@@B@KNKNI@@@@CGMGCBENJJMDGFNMH@@@@@B@@@BENN@@@H@@@@@@@@@BKOEB@@@@FOGMFDMEMFJHIOOOFH@@@@@@@@@EMHH@@B@@@@@@@@@EGOML@@@@EMMGOKJNJMEEFJKNM@@@@A@@@@@KKB@@@D@@@@@@@@@@JEGEH@@@BKKMEEEAEBNJIGNKJKD@@@@@@@AGFH@@@@@@@@@@@@@B@KMN@@@@JOGKOOJDJMIEBNKNOBDH@@@@@@BKO@@@@@@@@@@@@@@@@BKEH@@@AFOGEEDBIKFKEMMELHH@B@@@@AEFMD@@@@@@@@@@@@@@@EEO@@@@BMNOONIEGEMNOKJOKKJJ@D@@@BBOK@@@@@@@@@@@@@@@@@KJH@@@BKONNMFJMJCEJOEJBFEA@@@@@IOJN@@@@@@@@@@@@@@@@EEGH@@@COJMMNMEFMDOGJOFHLJ@@@@@AFJOH@@@@@@@@@@@@@@@@BJE@@@@EFOKKMJJMBCIMGMIEA@@@@@@JIOMD@@@@@@@BBB@@@@@@EDKH@@@KMBEOKEEJMDGGIBDBH@@@@@ACGEK@@@@@@@@DD@@@@@@@AAFH@@@FHDIEONJKEAMJBEHJ@@@@@@BNNOFD@@@@@@@A@A@@@J@@@NM@@@@G@@@OGEEFJJFNJIDBH@@@@@EEMNL@@@@@@@@D@@@@@@@@AEJ@@@@LD@ACNOGMEEMJD@M@@@@@@@KOOKH@@@@@@@@@@@@@@J@@JODH@@@K@@@EEMDKNIEFIEJ@@@@@JEEGED@@@@@@@@@@@HB@@A@BEHI@@@@LB@@JOOKFJJKM@AE@@@@A@HKMNH@@@@@@@@@@B@@@@J@IKFB@@@@JJJA@KJJMEEOJ@ED@@@EBJKNK@@@@@@@@@@@@DHB@@BJJFH@H@@@EDA@@NOMHKGFL@AD@@@@EEEEL@@@@@@@@@@@@AE@@@IAEN@@@@@@NAJD@KMEFBMMJ@@H@@@KJNKKB@@@@@@@@@@@@FH@@ABNKE@@H@@@DJ@I@AGOHMGGL@A@@@BJMKFJD@@@@@@@@@@@@A@@@BE@NH@A@@@@K@@DJBMJJKMMB@@@@@DOKFM@@@@@@@@@@@@@@FH@D@HOCD@@H@@@D@@IDEKGIFGFL@@@@@IJNH@@@@@@@@@@@@@@HC@@@FCDNHHA@@@@JH@@JHGOEEMME@@@@ACGH@@@@@@@@@@@@@@@BM@D@HLOMAB@@@@@I@@@JHMNLMCKJ@@@@@FNJ@@@@@@@@@@@@@@@DKFIEAEIEEH@@@@@BJ@@A@KEIBOFOH@@@BMM@@@@@@@@@@@@@@@@@EDBBBJBJBJH@@@@EDJ@DBFONMCOID@@@EGJ@@@@@@@@@@@@@@@@@I@@DAD@@IEE@@@@JKD@@AEOEJNMGJ@@@IML@@@@@@@@@@@@@@@@@@@@@BHB@@@JH@@@EDKD@BEJOGKGNLDJBFK@@@@@@JJ@@@@@@@@@@@H@@AB@@@AA@@@@H@BH@@CGMNHEKJH@@KOH@@@@ADD@@@@@@@@@@@@@@B@@@@@@@@@@@@BH@@EOOEJKGDAEEFJD@@AD@KE@@@@@@@@@@@@@@@H@@@@@@@@@H@AJ@BBMJKDGNOF@BMOH@JBIF@B@@@@@@@@@@@@@@B@@@@@@@@@@B@BM@@EKO@JIGMDIEOJ@@@EFHJHD@@H@@@@@@@@@@@@@@@@@H@@@D@AFH@IGJOECMFM@KENI@FJLB@@H@A@@@@@@@@@@@@@@@@EBH@@@@@@ID@BOGHNNOMJKFOE@BIA@@@@@@@@@@@@@@@@@@@@@@@BH@@@@@BAELAENOGECJOONMML@EDD@@@@@@@@@@@@@@@@@@@@@@@E@@@@@E@BHEBJKNNMFGJMEKKJ@JI@@@@@@BJ@@@@@@@@@@@@@@@BAD@@@@B@B@KDEBMOKFNOKOOGD@BHB@@@@@@@@@@@@@@@@@@@@@@@D@@@@@@@DAEEJEONNMMOGMKOH@E@D@@@@@@@@@@@@@@@@@@@@@@BI@@@@@H@HDBJEKEMOOKMOGNMD@A@I@@@@@@@@@@@@@@@@@@@@@@@B@@@@@BEBJMEJDOKMEGKNOGO@@B@B@@@@@@@@@@@@@@@@@@@@@@@D@@@@@JJIBJKAKMOOOOGENNJID@HD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DIFJJFJGGKJOFOOOMN@@BDH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ABM@@KEMJOOMONOMOID@AHB@@@@@@@@@@@@@@@@@@@@@@@@@@@@@NKJ@BBMGEOFOFMMGFJH@E@D@@@@@@@@@@@@@@@@@@@@@@@@@@@@@EDDH@EEJKMMMOKKNMJB@JHID@@@@@@@@@@@@@@@@@@@@@@@@@@@@EKA@@@JGOGKKJOGMOELJEJB@@@@@@@@@@@@@@@@@@@@@@@@@@@@@JDE@@AEIEMGGGNMGNHC@KEDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@JK@@@@ECJFMNMKEMMEDOELIAD@@@@@@@@@@@@@@@@@@@@@@@@@@@DJ@@@@JEDHJCJLKGKJ@@KE@J@@@@@@@@@@@@@@@@@@@@@@@@@@@@KD@@@AAJ@E@MECGOGL@EEJEBH@@@@@@@@@@@@@@@@@@@@@@@@@@@DJH@A@D@HHBJNLNJOKJBJHHD@H@@@@@@@@@@@@@@@@@@@@@@@@@@KM@@HA@H@B@JJKKOOFH@CKG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@EBDH@@D@A@@EGNOGOOJEMDD@@J@@@@@@@@@@@@@@@@@@@@@@@@@@JLH@@@@@J@ABJKNOFMFHCJH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@JAB@@@@@@H@JOKGNOOMAOEB@@@@@@@@@D@@@@@@@@@@@@@@BH@@@DJ@@@@H@I@A@JNNONMFHEN@@@@@@@@@@H@@@@@@@@@@@@@@A@@@@H@@@@A@@@@@AEIMMOODGKDH@@@@@@@@@B@@@@@@@@@@@@@@B@@@@D@@@@@@@@@@@CFKOMJH@BM@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@DIGOKOFJINB@@@@@@@@BB@I@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ABOMGJH@AED@@@@@@@@@@I@@BH@@@@@@@@@@@@@@@@A@@@@@@@@@HEOGOOID@M@@@@@@@@@BJD@@D@@@@@@@@@@@@@@@HED@@@@@@@@BACMONK@HAGD@@@@E@@@@DJHBI@@@@@@@@@@@@@@@EBKM@JH@@@@@NMGMENHB@EJ@@B@H@@@@IEBJBA@@@@@@@@@@@@@@JMDBECD@@D@@IGMGOODD@BH@@@DB@@@@BHDDHB@@@@@@@@@@@@@@OKKMHFM@@@@@GJKMOJH@@EJ@@FHL@@@@@CAJJHH@@@@@@@@@@@@@KGDBBJNJ@@@@HGFKJOL@@CD@@I@@@@H@@@FEBC@@@@@@@@@@@@@@NNOMLJML@@@@AMEOGNJ@@AN@@ED@@@D@@@HMDH@@@@@@@@@@@@@@KJHJIEKKH@@@BJKEOKD@@BJJEE@AE@HBJ@EEE@@@@@@@@@@@@@@@DDBKFKGFJ@@@OJFONNNH@@OLJJ@HHH@AD@BJJH@@@@@@@@@@@@@@@@@@MEOOL@@ADDMKEME@@AEEEB@EC@@BB@DLE@@@@@@@@@@@@@@@@@@@BOFMD@@AKIKGOKJ@@@ONJLHHD@@@MDIKDD@@@@@@@@@@@@@@@@@@ABMKM@@CDFNOGFNH@@BMDK@BHH@AAAFLHH@@@@@@@@@@@@@@@@@@@EOOJ@@EEIENNMJHH@ENIF@@B@@BJDIGDB@@@@@@@@@@@@@@@@@@@CGFL@@CJBOMMCEC@@CMJDJIDH@AEBEEI@@@@@@@@@@@@@@@@@@@@BJOK@@NDAJKNJNLJ@EKDAABA@@BJEBOF@@@@@@@@@@@@@@@@@@@@@GNNAECHCEOJCIC@@CFHEEDAD@@EJDJHH@@@@@@@@@@@@@@@@@@@@AMLBJF@@KKDMFJH@EN@BB@B@D@KDAGN@@@@@@@@@@@@@@@@@@@@@GGNKMN@CGGOCMD@@CL@@IODLJ@FJAMA@@@@@@@@@@@@@@@@@@@@@BOJEGD@@MNHNJI@@EJJOGEEA@EMMFGNB@@@@@@@@@@@@@@@@@@@@ENNKMJ@CKKOEHB@@CNMJNOMEEBEFJM@D@@@@@@@@@@@@@@@@@@@@CKJBKD@@GGJKD@@@NMKOMNKJLIJMMKFJ@@@@@@@@@@@@@@@@@@@@EGNADA@CMOFED@AECOGEKMOGKFKKCFMD@@E@H@@@@@@@@@@@A@@@COD@AF@DGFMJHH@ENMNOOKOMFMFENLED@B@@@@@@@@@@@@@@@@@@GFN@B@@AMMOBK@@KGKONJOMGMJMNKJJI@JJHH@@@@@@@@@@@A@@@BOMD@JDBKGMEE@BNNOJIEAGMGFKENNKEBJE@@@@@@@@@@@@@@@A@GNNHBDH@NOGJKDJKMJDD@BJKJMEGGIEEEEJ@@@@@@@@@@@@@@@D@BMMB@I@ACMNIFMENKG@@@@BDENNLOFFJME@H@@@@AD@@@@@@AEAJEKJ@@B@@NKKJMJJKON@@@ADICEKKNLIJJJNAD@@@HI@@@@@@BJJDCON@@@J@CGGEFKEOED@@@JJ@DAEGMICEEEIJ@@@@ABH@@@@@@@EHAFJ@@@D@ENOMKFKFOL@@ABDAABKNKNAJMGF@@@@@DE@@@@@@HJJHFMN@@@A@FKNJEMEMNH@@BDHBJAEEOJJOKJI@@@@@BJH@@@@BB@A@HKL@@@@@ANMNKBCGM@@@AKJIDJKKONIEFE@@@@@@DK@@@@@@H@@DFOJ@@@@HFKKMFLMOK@@@BEEFIBFJEKKKJH@@@@@@IBH@@@@@B@A@IEE@@@J@AMGOEBKFN@@AEONMFBILONNFE@@@@@@@BEH@@@@@@@B@BKL@@@DHAGOJLMEMHH@JOIEJDDFABKKLH@@@@@@ADI@@@@@@@@@@DKD@@@H@BMMGJ@KGJH@EJJKGEIHKEOFH@@@@@@@@JJH@@@@@@@AAAFL@@@@@DKKOEGFOD@@KOKENJBEDNJMD@@@@@@@AEA@@@@@@@@@@JMH@@@@@AGGMNHMNHH@EGDJEBMJKEGHH@@@@@@@DHFH@@@@@@@@ABKH@D@@@@JOGIGGM@@@KNODOEJE@JN@@@@@@@@@BJI@@@@@@@@@BMGD@BH@@CGNNNJMK@@@CMJIMOFJDDMH@@@@@@@@EAF@@@@@@@@@CBMH@A@@@DDKMMOOF@@@FCGGGJM@@AGFH@@@@@@@BEDH@@@@@@@@DMFHAB@@@AKNOKJMD@@@BLLMMGJ@@@EM@@@@@@@@DJK@@@@@@@@@CBIJD@@ADBEEMOGJH@@BFICKGND@@@AGL@@@@@@@AAD@@@@@@@@@DICFKD@@@AKOOKOF@@BLJBLFMKJ@@@@JK@@@@@@@BJKH@@@@@@@@CFFMLH@@@BFMMOFH@@ABFLBMGFDH@@@AFJ@@@@@@ADJ@@@@@@@@ADHKOKBI@@AMKKKM@@@BNMKLBMLH@@@@@EL@@H@@@BKEH@@@@@@@@KEEEOMF@@FGOONH@@@AIKD@DKA@@@@@@BK@A@@@@ALK@@@@@@@@@EJKOJID@@IMGGEBJJJJFFMHAJJ@@@@@@@JH@@@@@@KOH@@@@@@@@BOFMONJ@BFKNNMEEOEAJIKBKEEA@@@@@@EL@L@BJAOFH@@@@@@@@ADMOKENHAIOKOJOOEJFJ@FH@BJJ@@@@@@AE@@@ADBJOH@@@@@@@@@KKKGOKBFGFOMEJIKEID@I@@IADH@@@@@@NJJ@KJAONH@@@@@@BH@BGGNMNNKJMJKOMBDBE@@@@@@B@@@@@@@@CEEAGEEGMH@@@@@ADJ@@JOGOKMNOKFOFH@@@@@@@@@@@@@@@@@@@@OJEEFKMGH@@@@@J@JH@AFNMOKMJLI@M@@@@@@@@@@@@@@@@@@@@CEEJJEFKMH@@@@@@HE@@@AOOKGKOHBE@@@@@@@@@@@@@@@@@@@@@@COD@@IOG@@@@@@A@KD@@EKKGOGMDDHD@@@@@@@@@@@@@@@@@@@@@AEH@JBJLH@@@@@@HFJJHAFONMOKHJKEB@@@@@@@@@@@@@@@@@@@@@O@I@EGK@@@@@@@@HAE@@ENOKNO@EDHDH@@@@@@@@@@@@@@@@@@@AMB@EEJJH@@@@@@@JBJJ@KEJOKMAKMEI@@@@@@@@@@@@@@@@@@@@@JDJHIFKH@@@@@@A@@CMI@JKNOFBGGFBNH@@@@@@@@@@@@@@@@@@AEADKCMDH@@@H@@@@@AGBEABENNBNHMMED@@@@@@@@@@@@@@@@@@@@JI@EBEH@@@D@@AD@BMDJJDKMMEOECEED@@@@@@@@@@@@@@@@@@@@EFEELJH@@@H@@@@@@KEAD@JKLAEBEJKH@@@@@@@@@@@@@@@@@@@@KM@KAA@@@@@@@@H@@NIFA@EGJCOLBEFJ@@@@@@@@@@@@@@@@@@@@FJE@NE@@@@@@@@D@AEFHJ@HODDK@AEEL@@@@@@@@@@@@@@@@@@@@KOHCD@H@@@@@@@H@@JIFH@AJMEFNJJO@@@@@@@@@@@@@@@@@@@@AFKBDIA@@@@@@@@@@@JJIB@CGJJOIEJML@@@@@@@@@@@@@@@@@@@@KOLAF@@@@@@@@@H@AEBNL@JM@EMDBKO@@@@@@@@@@@@@@@@@@@@AFK@FID@@@@H@@@@@FJMI@AADFOGJENJH@@@@@@@@@@@@@@@@@@@@MONIGD@@@@@@@@H@JJKFMBDIJJNHCEM@@@@@@@@@@@@@@@@@@@@@KFHFMMH@@@@@@@D@EEJMB@IBGOMJNOJH@@@@@@@@@@@@@@@@@D@@FONIGG@@@@@@@AH@JOFKMB@EMEGDCMF@@@@@@@@@@@@@@@@@@A@@KMDJMMH@@@@@@@@@EEMFFHHKGOJMNOL@@@@@@@@@@@@@@@@@BN@@BKMEGGH@@@@@@C@@KNJMM@@JJJEBEM@@@@@@@@@@@@@@@@@@HA@@EGDJMOH@@@@@@D@@FEMKJH@GGLJIGO@@@@@@@@@@@@@@@@@@DN@ABJJJKM@@@@@@@CA@JNKGG@@MDAABMJ@@@@@@@@@@@@@@@@@@@A@HHEDKOKH@@@@@@DHBEKNNLHBJJJJEGM@@@@@@@@@@@@@@A@@@@NEBEBANNOH@@@@@BAADMNKKKBLJEEEKE@@@@@@@@@@@@@@@A@@@@@HEB@FKKM@@@@@@DBJAKENFDDA@JJKFNH@@@@@@@@@@@@@@@H@@JI@@H@EFOGH@@@
+                  :BORDER 2)
+           (:TEXT "A bitmap" :POSITION (0.42 . 0.525)
+                  :FONT
+                  (IL:HELVETICA 10 IL:BOLD)
+                  :SHADOWS :ARK)
+           (:REGION (0.62 0.62 0.1 0.1)
+                  :SHADE 52428)
+           (:REGION (0.58 0.58 0.1 0.1)
+                  :SHADE 52224)
+           (:TEXT "Some shades" :POSITION (0.58 . 0.525)
+                  :FONT
+                  (IL:HELVETICA 10 IL:BOLD)
+                  :SHADOWS :ARK)
+           (:TEXT "Text with shadows..." :POSITION (0.43 . 0.47)
+                  :FONT
+                  (IL:HELVETICA 18 IL:BOLD)
+                  :SHADOWS T)
+           (:TEXT "Erasing text..." :POSITION (0.43 . 0.44)
+                  :FONT
+                  (IL:HELVETICA 18 IL:BOLD)
+                  :SHADOWS
+                  ((:OPERATION IL:ERASE)))
+           (:TEXT "Outlined letters..." :POSITION (0.43 . 0.41)
+                  :FONT
+                  (IL:HELVETICA 18 IL:BOLD)
+                  :SHADOWS
+                  ((:DX 1)
+                   (:DY 1)
+                   (:DX -1)
+                   (:DY -1)
+                   (:TEXTURE 65535 :OPERATION IL:INVERT :SOURCE-TYPE IL:MERGE)))
+           (:TEXT "Some text" :POSITION (0.42 . 0.37)
+                  :FONT
+                  (IL:HELVETICA 10 IL:BOLD)
+                  :SHADOWS :ARK))
+          :FILE-WATCH-ON? NIL)
+   (:ROOM "Intro End" :PLACEMENTS ((1 :REGION (221/512 5/202 69/512 15/404))
+                                   (18 :REGION (129/1024 37/101 471/1024 381/808)))
+          :INCLUSIONS
+          ("Intro Panel")
+          :BACKGROUND
+          ((:TEXT "Intro End" :POSITION (10 . 10)
+                  :FONT
+                  (IL:HELVETICAD 24)))
+          :FILE-WATCH-ON? NIL)
+   (:ROOM "Intro Panel" :PLACEMENTS ((19 :REGION (793/1024 379/808 71/512 15/404))
+                                     (1 :REGION (221/512 5/202 33/512 15/404))
+                                     (20 :REGION (207/256 65/202 33/512 15/404))
+                                     (21 :REGION (409/512 661/808 41/512 15/404))
+                                     (22 :REGION (7/1024 94/101 63/64 6/101)
+                                         :FONT
+                                         (IL:HELVETICA 12 (IL:BOLD IL:REGULAR IL:REGULAR))
+                                         :BORDER 2 :SHADE 65535 :TITLE NIL :OPERATION IL:ERASE)
+                                     (23 :REGION (401/512 231/404 61/512 15/404))
+                                     (24 :REGION (407/512 105/202 49/512 15/404))
+                                     (25 :REGION (815/1024 251/404 47/512 15/404))
+                                     (26 :REGION (815/1024 271/404 47/512 15/404))
+                                     (27 :REGION (811/1024 619/808 49/512 15/404))
+                                     (28 :REGION (653/1024 15/808 11/32 85/404)))
+          :INCLUSIONS NIL :BACKGROUND ((:WHOLE-SCREEN 33825 :BORDER 2)
+                                       (:REGION (49/64 1/4 5/32 21/32)
+                                              :SHADE 50745)
+                                       (:REGION (5/8 7/8 340 40)
+                                              :SHADE 50745)
+                                       (:TEXT "Rooms Introduction" :POSITION
+                                              (:EVAL (CONS (+ (INTERNALIZE-COORDINATE 5/8 
+                                                                     IL:SCREENWIDTH)
+                                                              10)
+                                                           (+ (INTERNALIZE-COORDINATE 7/8 
+                                                                     IL:SCREENHEIGHT)
+                                                              3)))
+                                              :FONT
+                                              (IL:HELVETICAD 24)))))
+
+(EVAL-WHEN (LOAD)
+       (LET ((BUTTON (MAKE-BUTTON :TEXT "Enter Introduction" :FONT '(IL:HELVETICAD 24)
+                            :SHADOWS T :TYPE :STRETCHY-ARK :ACTION '(INTERACTIVE-GO-TO-ROOM-NAMED
+                                                                     "Intro")
+                            :HELP "Enter the Rooms Introduction suite")))
+            (MAKE-BUTTON-WINDOW BUTTON (MAKE-POSITION (FLOOR (- IL:SCREENWIDTH (BUTTON-WIDTH BUTTON))
+                                                             2)
+                                              (FLOOR (- IL:SCREENHEIGHT (BUTTON-HEIGHT BUTTON))
+                                                     2)))))
+(IL:PUTPROPS IL:ROOMS-INTRO IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP
diff --git a/rooms/ROOMS-MEDLEY-WINDOW-TYPES b/rooms/ROOMS-MEDLEY-WINDOW-TYPES
new file mode 100644
index 00000000..f5003c61
--- /dev/null
+++ b/rooms/ROOMS-MEDLEY-WINDOW-TYPES
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:36:07" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-MEDLEY-WINDOW-TYPES.;2| 20710  

      IL:|previous| IL:|date:| "17-Aug-90 12:52:53" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-MEDLEY-WINDOW-TYPES.;1|
)


; Copyright (c) 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMS-MEDLEY-WINDOW-TYPESCOMS)

(IL:RPAQQ IL:ROOMS-MEDLEY-WINDOW-TYPESCOMS
          (
           (IL:* IL:|;;| "window types for various modules")

           (FILE-ENVIRONMENTS IL:ROOMS-MEDLEY-WINDOW-TYPES)
           (IL:P (REQUIRE "ROOMS"))
           (IL:WINDOW-TYPES :EXEC :INSPECTOR :SPY-BUTTON :CHAT :TEXTSTREAM :TEDIT :BUTTON)
           (IL:COMS 

                  (IL:* IL:|;;| "the prompt window")

                  (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:P (OR (IL:RECLOOK 'IL:WINDOW)
                                                                      (IL:EVAL (IL:SYSRECLOOK1
                                                                                'IL:WINDOW)))))
                  (IL:WINDOW-TYPES :PROMPT-WINDOW)
                  (IL:GLOBALVARS IL:PROMPTWINDOW))
           (IL:COMS 

                  (IL:* IL:|;;| "SEdit")

                  (IL:ADVISE (IL:OPENWP :IN SEDIT::GET-CONTEXT))
                  (IL:WINDOW-TYPES :SEDIT))
           (IL:COMS 

                  (IL:* IL:|;;| "File Browser")

                  (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:P (OR (IL:RECLOOK 'IL:FILEBROWSER)
                                                                      (IL:EVAL (IL:SYSRECLOOK1
                                                                                'IL:FILEBROWSER)))
                                                                  (OR (IL:RECLOOK 'IL:TABLEBROWSER)
                                                                      (IL:EVAL (IL:SYSRECLOOK1
                                                                                'IL:TABLEBROWSER)))))
                  (IL:WINDOW-TYPES :FILE-BROWSER :TABLE-BROWSER))
           (IL:COMS 

                  (IL:* IL:|;;| "Sketch")

                  (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:P (OR (IL:RECLOOK 'IL:SKETCH)
                                                                      (IL:LOADDEF 'IL:SKETCH
                                                                             'IL:RECORDS
                                                                             'IL:SKETCH))))
                  (IL:WINDOW-TYPES :SKETCH))
           (IL:COMS 

                  (IL:* IL:|;;| "Logo Window")

                  (IL:WINDOW-TYPES :LOGO-WINDOW)
                  (IL:ADVISE IL:LOGOW))
           (IL:COMS 

                  (IL:* IL:|;;| "PSW")

                  (IL:WINDOW-TYPES :PSW))))



(IL:* IL:|;;| "window types for various modules")


(DEFINE-FILE-ENVIRONMENT IL:ROOMS-MEDLEY-WINDOW-TYPES :COMPILER :COMPILE-FILE
   :READTABLE "XCL"
   :PACKAGE "ROOMS")

(REQUIRE "ROOMS")

(DEF-WINDOW-TYPE :EXEC :RECOGNIZER (LAMBDA (WINDOW)
                                              (IL:EQMEMB 'XCL::EXEC-CLOSEFN (IL:WINDOWPROP
                                                                             WINDOW
                                                                             'IL:CLOSEFN)))
   :ABSTRACTER (LAMBDA (WINDOW)
                      (LET* ((PROCESS (IL:WINDOWPROP WINDOW 'IL:PROCESS)))
                            (WHEN PROCESS
                                (LET ((PROFILE (IL:PROCESSPROP PROCESS 'IL:PROFILE)))
                                     `(:REGION ,(EXTERNALIZE-REGION (WINDOW-REGION WINDOW))
                                             :PACKAGE
                                             ,(IF PROFILE
                                                  (PACKAGE-NAME (GETF PROFILE '*PACKAGE*))
                                                  "IL")
                                             :READTABLE
                                             ,(IF PROFILE
                                                  (IL:READTABLEPROP (GETF PROFILE '*READTABLE*)
                                                         'IL:NAME)
                                                  "OLD-INTERLISP-T"))))))
   :RECONSTITUTER (LAMBDA
                   (ARGS)
                   (LET ((PROCESS (ADD-EXEC :REGION (INTERNALIZE-REGION (GETF ARGS :REGION
                                                                              (LIST 0 0 400 100)))
                                         :PROFILE
                                         (OR (GETF ARGS :PROFILE)
                                             `(*PACKAGE* ,(OR (FIND-PACKAGE (GETF ARGS :PACKAGE))
                                                              (FIND-PACKAGE "XCL-USER"))
                                                     *READTABLE*
                                                     ,(OR (IL:FIND-READTABLE (GETF ARGS :READTABLE))
                                                          (IL:FIND-READTABLE "XCL")))))))

                        (IL:* IL:|;;| 
                      "this is really grody.  why doesn't ADD-EXEC just take a window?")

                        (IL:BLOCK)
                        (IL:WFROMDS (IL:PROCESS.EVALV PROCESS '*STANDARD-OUTPUT*))))
   :TITLE (LAMBDA (PLACEMENT REGION DSP)
                 (PRINT-PEP-TITLE-STRING (IL:WINDOWPROP (PLACEMENT-WINDOW PLACEMENT)
                                                'IL:TITLE)
                        REGION DSP)))

(DEF-WINDOW-TYPE :INSPECTOR :RECOGNIZER (IL:LAMBDA (WINDOW)
                                              (IL:WINDOWPROP WINDOW 'IL:DATUM))
   :TITLE "Inspector")

(DEF-WINDOW-TYPE :SPY-BUTTON :RECOGNIZER (LAMBDA (WINDOW)
                                                    (EQ (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN)
                                                        'IL:SPY.BUTTONA0001))
   :ABSTRACTER (LAMBDA (WINDOW)
                      (DECLARE (IGNORE WINDOW))
                      NIL)
   :RECONSTITUTER (LAMBDA (DATA)
                         (DECLARE (IGNORE DATA)
                                (GLOBAL IL:SPY.BUTTON))
                         (UNLESS (BOUNDP 'IL:SPY.BUTTON)
                                (IL:FILESLOAD "spy"))
                         (IF IL:SPY.BUTTON
                             IL:SPY.BUTTON
                             (PROGN (IL:SPY.BUTTON (MAKE-POSITION 0 0))
                                    IL:SPY.BUTTON)))
   :NO-SHAPE T
   :TITLE (LAMBDA (PLACEMENT REGION DSP)
                 (PRINT-PEP-TITLE-STRING "Spy" REGION DSP :NO-TITLE-BAR? T)))

(DEF-WINDOW-TYPE :CHAT :RECOGNIZER (LAMBDA (WINDOW)
                                              (EQ (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN)
                                                  'IL:CHAT.BUTTONFN))
   :ABSTRACTER (LAMBDA (WINDOW)
                      (LIST :HOST (IL:CANONICAL.HOSTNAME (FIRST (IL:WINDOWPROP WINDOW 'IL:CHATHOST)))
                            :REGION
                            (IL:WINDOWREGION WINDOW)))
   :RECONSTITUTER (LAMBDA (DATA)
                         (LET ((WINDOW (IL:CREATEW (GETF DATA :REGION)
                                              "Chat")))

                              (IL:* IL:|;;| "start the chat process")

                              (IL:CHAT (GETF DATA :HOST)
                                     NIL NIL WINDOW)

                              (IL:* IL:|;;| "return the window")

                              WINDOW))
   :TITLE (LAMBDA (PLACEMENT REGION DSP)
                 (PRINT-PEP-TITLE-STRING (FORMAT NIL "Chat ~A" (FIRST (IL:WINDOWPROP (
                                                                                     PLACEMENT-WINDOW
                                                                                      PLACEMENT)
                                                                             'IL:CHATHOST)))
                        REGION DSP)))

(DEF-WINDOW-TYPE :TEXTSTREAM :RECOGNIZER (LAMBDA (WINDOW)
                                                    (IL:TYPE? IL:TEXTOBJ (IL:WINDOWPROP
                                                                              WINDOW
                                                                              'IL:TEXTOBJ)))
   :TITLE "Text")

(DEF-WINDOW-TYPE :TEDIT :DEPENDENCIES (:TEXTSTREAM)
   :RECOGNIZER (LAMBDA (WINDOW)
                      (OR (IL:WINDOWPROP WINDOW 'IL:TEDITCREATED)
                          (LET ((TEXTOBJ (IL:WINDOWPROP WINDOW 'IL:TEXTOBJ)))
                               (AND (IL:TYPE? IL:TEXTOBJ TEXTOBJ)
                                    (GETF (IL:FFETCH (IL:TEXTOBJ IL:EDITPROPS) IL:OF TEXTOBJ)
                                          'IL:TEDITCREATEDWINDOW)))))
   :ABSTRACTER (LAMBDA (WINDOW)
                      (LET* ((STREAM (IL:FETCH (IL:TEXTOBJ IL:TXTFILE) IL:OF (IL:TEXTOBJ
                                                                                      WINDOW))))
                            (WHEN STREAM
                                `(:REGION ,(EXTERNALIZE-REGION (WINDOW-REGION WINDOW))
                                        :PATHNAME
                                        ,(MAKE-PATHNAME :VERSION :NEWEST :DEFAULTS (PATHNAME STREAM))
                                        ))))
   :RECONSTITUTER (LAMBDA (PROPS)
                         (IL:FILESLOAD (IL:SYSLOAD)
                                IL:TEDIT)
                         (LET* ((PATHNAME (GETF PROPS :PATHNAME))
                                (FOUND (WHEN PATHNAME (PROBE-FILE PATHNAME)))
                                (NAMESTRING (WHEN FOUND (NAMESTRING FOUND)))
                                (WINDOW (IL:\\TEDIT.CREATEW.FROM.REGION (INTERNALIZE-REGION
                                                                         (GETF PROPS :REGION
                                                                               (LIST 0 0 200 200)))
                                               (IF FOUND NAMESTRING))))
                               (IL:TEDIT (IF FOUND
                                             (INTERN NAMESTRING "INTERLISP")
                                             (IF PATHNAME
                                                 (FORMAT NIL "Couldn't edit file ~A" (NAMESTRING
                                                                                      PATHNAME))))
                                      WINDOW NIL (LIST 'IL:TEDITCREATEDWINDOW T 'IL:LEAVETTY T))
                               WINDOW))
   :TITLE "TEdit")

(DEF-WINDOW-TYPE :BUTTON :RECOGNIZER (LAMBDA (WINDOW)
                                                (TYPEP (IL:WINDOWPROP WINDOW 'BUTTON)
                                                       'BUTTON))
   :ABSTRACTER (LAMBDA (WINDOW)
                      (EXTERNALIZE-BUTTON (IL:WINDOWPROP WINDOW 'BUTTON)))
   :RECONSTITUTER (LAMBDA (ARGS)
                         (MAKE-BUTTON-WINDOW (APPLY #'MAKE-BUTTON ARGS)
                                (INTERNALIZE-POSITION (GETF ARGS :POSITION (MAKE-POSITION 0 0)))))
   :TITLE (LAMBDA (PLACEMENT REGION DSP)
                 (LET ((BUTTON (IL:WINDOWPROP (PLACEMENT-WINDOW PLACEMENT)
                                      'BUTTON)))
                      (WHEN BUTTON
                          (PRINT-PEP-TITLE-STRING (TEXT-STRING (BUTTON-TEXT BUTTON))
                                 REGION DSP :NO-TITLE-BAR? T)))))



(IL:* IL:|;;| "the prompt window")

(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY 

(OR (IL:RECLOOK 'IL:WINDOW)
    (IL:EVAL (IL:SYSRECLOOK1 'IL:WINDOW)))
)

(DEF-WINDOW-TYPE :PROMPT-WINDOW :RECOGNIZER (LAMBDA (WINDOW)
                                                       (EQ WINDOW IL:PROMPTWINDOW))
   :ABSTRACTER (LAMBDA (WINDOW)
                      NIL)
   :RECONSTITUTER (LAMBDA (DATA)
                         IL:PROMPTWINDOW)
   :UPDATER (LAMBDA (PLACEMENT)
                   (LET ((FONT (IL:DSPFONT NIL IL:PROMPTWINDOW)))
                        (PLACEMENT-PROP PLACEMENT :FONT (EXTERNALIZE-FONT FONT)))
                   (PLACEMENT-PROP PLACEMENT :BORDER (IL:WINDOWPROP IL:PROMPTWINDOW 'IL:BORDER))
                   (PLACEMENT-PROP PLACEMENT :SHADE (IL:DSPTEXTURE NIL IL:PROMPTWINDOW))
                   (PLACEMENT-PROP PLACEMENT :TITLE (IL:WINDOWPROP IL:PROMPTWINDOW 'IL:TITLE))
                   (PLACEMENT-PROP PLACEMENT :OPERATION (IL:DSPOPERATION NIL IL:PROMPTWINDOW)))
   :PLACER (LAMBDA (PLACEMENT)
                  (DO* ((CHANGED? NIL)
                        (PROP-LIST (PLACEMENT-PROPS PLACEMENT)
                               (CDDR PROP-LIST))
                        (PROP (CAR PROP-LIST)
                              (CAR PROP-LIST))
                        (VALUE (CADR PROP-LIST)
                               (CADR PROP-LIST)))
                       ((NULL PROP-LIST)
                        (WHEN CHANGED?

                            (IL:* IL:|;;| 
                          "this is how we change the border & title without changing the region")

                            (IL:CLOSEW IL:PROMPTWINDOW)
                            (IL:ADVISEWDS IL:PROMPTWINDOW)
                            (IL:SHOWWFRAME IL:PROMPTWINDOW)
                            (IL:CLEARW IL:PROMPTWINDOW)))
                     (CASE PROP
                         (:BORDER (UNLESS (EQL VALUE (IL:FETCH (IL:WINDOW IL:WBORDER)
                                                        IL:OF IL:PROMPTWINDOW))
                                      (IL:REPLACE (IL:WINDOW IL:WBORDER) IL:OF 
                                                                                   IL:PROMPTWINDOW
                                         IL:WITH VALUE)
                                      (SETQ CHANGED? T)))
                         (:FONT (LET ((NEW-FONT (IL:FONTCREATE VALUE NIL NIL NIL 'IL:DISPLAY)))
                                     (UNLESS (EQ (IL:DSPFONT NEW-FONT IL:PROMPTWINDOW)
                                                 NEW-FONT)
                                            (SETQ CHANGED? T))))
                         (:OPERATION (UNLESS (EQ VALUE (IL:DSPOPERATION VALUE IL:PROMPTWINDOW))
                                            (SETQ CHANGED? T)))
                         (:SHADE (UNLESS (EQ VALUE (IL:DSPTEXTURE VALUE IL:PROMPTWINDOW))
                                        (SETQ CHANGED? T)))
                         (:TITLE (UNLESS (EQL VALUE (IL:FETCH (IL:WINDOW IL:WTITLE) IL:OF
                                                                                        
                                                                                      IL:PROMPTWINDOW
                                                           ))
                                     (IL:REPLACE (IL:WINDOW IL:WTITLE) IL:OF IL:PROMPTWINDOW
                                        IL:WITH VALUE)
                                     (SETQ CHANGED? T))))))
   :TITLE (LAMBDA (PLACEMENT REGION DSP)
                 (IL:DSPFILL REGION IL:BLACKSHADE 'IL:PAINT DSP)))
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY

(IL:GLOBALVARS IL:PROMPTWINDOW)
)



(IL:* IL:|;;| "SEdit")


(REINSTALL-ADVICE '(IL:OPENWP :IN SEDIT::GET-CONTEXT)
       :BEFORE
       '((:FIRST (LOCALLY (DECLARE (SPECIAL IL:WINDOW))
                        (UN-HIDE-WINDOW IL:WINDOW)))))

(IL:READVISE (IL:OPENWP :IN SEDIT::GET-CONTEXT))

(DEF-WINDOW-TYPE :SEDIT :RECOGNIZER (LAMBDA (WINDOW)
                                               (IL:EQMEMB 'SEDIT::CLOSEFN (IL:WINDOWPROP WINDOW
                                                                                 'IL:CLOSEFN)))
   :TITLE "SEdit")



(IL:* IL:|;;| "File Browser")

(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY 

(OR (IL:RECLOOK 'IL:FILEBROWSER)
    (IL:EVAL (IL:SYSRECLOOK1 'IL:FILEBROWSER)))

(OR (IL:RECLOOK 'IL:TABLEBROWSER)
    (IL:EVAL (IL:SYSRECLOOK1 'IL:TABLEBROWSER)))
)

(DEF-WINDOW-TYPE :FILE-BROWSER :DEPENDENCIES (:TABLE-BROWSER)
   :RECOGNIZER (LAMBDA (WINDOW)
                      (IL:TYPE? IL:FILEBROWSER (IL:WINDOWPROP WINDOW 'IL:FILEBROWSER)))
   :ABSTRACTER (LAMBDA (WINDOW)
                      (LET ((FB (IL:WINDOWPROP WINDOW 'IL:FILEBROWSER)))
                           (LIST :REGION (EXTERNALIZE-REGION (WINDOW-REGION WINDOW))
                                 :PATTERN
                                 (IL:FETCH (IL:FILEBROWSER IL:PATTERN) IL:OF FB)
                                 :INFO
                                 (IL:FETCH (IL:FILEBROWSER IL:INFOMENUCHOICES) IL:OF FB))))
   :RECONSTITUTER (LAMBDA (PROPS)
                         (LET ((WINDOW (IL:FILEBROWSER (GETF PROPS :PATTERN "*")
                                              (GETF PROPS :INFO)
                                              (LIST 'IL:REGION (INTERNALIZE-REGION (GETF PROPS 
                                                                                         :REGION)))))
                               )

                              (IL:* IL:|;;| "wait for FB to recompute")

                              (IL:BLOCK)
                              (IL:WITH.MONITOR (IL:FETCH (IL:FILEBROWSER IL:FBLOCK)
                                                  IL:OF (IL:WINDOWPROP WINDOW 'IL:FILEBROWSER))
                                     WINDOW)))
   :TITLE "FB"
   :FILES (IL:FILEBROWSER))

(DEF-WINDOW-TYPE :TABLE-BROWSER :RECOGNIZER (LAMBDA (WINDOW)
                                                       (IL:TYPE? IL:TABLEBROWSER
                                                              (IL:WINDOWPROP WINDOW 'IL:TABLEBROWSER)
                                                              )))



(IL:* IL:|;;| "Sketch")

(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY 

(OR (IL:RECLOOK 'IL:SKETCH)
    (IL:LOADDEF 'IL:SKETCH 'IL:RECORDS 'IL:SKETCH))
)

(DEF-WINDOW-TYPE :SKETCH :RECOGNIZER (LAMBDA (W)
                                                (IL:WINDOWPROP W 'IL:SKETCH))
   :ABSTRACTER (LAMBDA (W)
                      (LIST :FILE (IL:FETCH (IL:SKETCH IL:SKETCHNAME) IL:OF
                                                                          (IL:WINDOWPROP W
                                                                                 'IL:SKETCH))
                            :REGION
                            (EXTERNALIZE-REGION (WINDOW-REGION W))))
   :RECONSTITUTER (LAMBDA (DATA)
                         (WHEN (FBOUNDP 'IL:SKETCH)
                             (IL:SKETCH (GETF DATA :FILE)
                                    (IL:CREATEW (INTERNALIZE-REGION (GETF DATA :REGION
                                                                          (LIST 0 0 500 500)))
                                           "Sketch"))))
   :TITLE "Sketch")



(IL:* IL:|;;| "Logo Window")


(DEF-WINDOW-TYPE :LOGO-WINDOW :RECOGNIZER (LAMBDA (WINDOW)
                                                     (EQ (IL:WINDOWPROP WINDOW 'TYPE)
                                                         'IL:LOGOW))
   :ABSTRACTER (LAMBDA (WINDOW)
                      (IL:WINDOWPROP WINDOW 'ABSTRACTION))
   :RECONSTITUTER (LAMBDA (ABSTRACTION)
                         (IL:LOGOW (GETF ABSTRACTION :STRING)
                                NIL
                                (GETF ABSTRACTION :TITLE)
                                (GETF ABSTRACTION :TITLE-LOCATION)))
   :TITLE (LAMBDA (PLACEMENT REGION DSP)
                 (PRINT-PEP-TITLE-STRING "Envos" REGION DSP :NO-TITLE-BAR? T)))

(REINSTALL-ADVICE 'IL:LOGOW :AFTER
       '((:LAST (IL:WINDOWPROP IL:!VALUE 'ABSTRACTION
                       `(,@(WHEN STRING
                               `(:STRING ,STRING))
                         ,@(WHEN IL:TITLE
                               `(:TITLE ,IL:TITLE))
                         ,@(WHEN IL:TITLE-LOCATION
                               `(:TITLE-LOCATION ,IL:TITLE-LOCATION)))))))

(IL:READVISE IL:LOGOW)



(IL:* IL:|;;| "PSW")


(DEF-WINDOW-TYPE :PSW :RECOGNIZER (LAMBDA (WINDOW)
                                             (DECLARE (GLOBAL IL:PROCESS.STATUS.WINDOW))
                                             (EQ WINDOW IL:PROCESS.STATUS.WINDOW))
   :TITLE (LAMBDA (PLACEMENT REGION DSP)
                 (PRINT-PEP-TITLE-STRING "PSW" REGION DSP :NO-TITLE-BAR? T)))
(IL:PUTPROPS IL:ROOMS-MEDLEY-WINDOW-TYPES IL:COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL)))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-MEDLEY-WINDOW-TYPES.DFASL b/rooms/ROOMS-MEDLEY-WINDOW-TYPES.DFASL
new file mode 100644
index 00000000..112674d8
Binary files /dev/null and b/rooms/ROOMS-MEDLEY-WINDOW-TYPES.DFASL differ
diff --git a/rooms/ROOMS-NOTES b/rooms/ROOMS-NOTES
new file mode 100644
index 00000000..5b7e133e
--- /dev/null
+++ b/rooms/ROOMS-NOTES
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:39:51" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-NOTES.;2| 12691  

      IL:|previous| IL:|date:| "17-Aug-90 12:55:10" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-NOTES.;1|)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMS-NOTESCOMS)

(IL:RPAQQ IL:ROOMS-NOTESCOMS
          ((FILE-ENVIRONMENTS IL:ROOMS-NOTES)
           (IL:P (EXPORT '(*DEFAULT-NOTE-WINDOW-FONT* MAKE-NOTE-WINDOW))
                 (REQUIRE "ROOMS"))
           
           (IL:* IL:|;;| "provides note windows")

           (IL:STRUCTURES NOTE)
           (IL:VARIABLES *DEFAULT-NOTE-WINDOW-FONT*)
           (IL:FUNCTIONS MAKE-NOTE-WINDOW NOTE-WINDOW-REPAINTFN PRINT-NOTE-STRING 
                  NOTE-WINDOW-BUTTONEVENTFN EDIT-NOTE-WINDOW-TEXT SET-NOTE-WINDOW-FONT 
                  SET-NOTE-WINDOW-TITLE)
           (IL:WINDOW-TYPES :NOTE-WINDOW)
           (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:P (OR (IL:HASDEF 'STREAM 'IL:RECORDS)
                                                               (IL:EVAL (IL:SYSRECLOOK1 'STREAM)))))
           (IL:GLOBALVARS IL:BOLDFONT)))

(DEFINE-FILE-ENVIRONMENT IL:ROOMS-NOTES :COMPILER :COMPILE-FILE
   :PACKAGE "ROOMS"
   :READTABLE "XCL")

(EXPORT '(*DEFAULT-NOTE-WINDOW-FONT* MAKE-NOTE-WINDOW))

(REQUIRE "ROOMS")



(IL:* IL:|;;| "provides note windows")


(DEFSTRUCT NOTE

(IL:* IL:|;;;| "a note for display in a note-window")

   (STRING "" :TYPE STRING)
   (FONT NIL :TYPE FONT)
   (TITLE "Note:" :TYPE STRING)
   (READ-ONLY? NIL :TYPE (MEMBER T NIL)))

(DEFVAR *DEFAULT-NOTE-WINDOW-FONT* IL:BOLDFONT)

(DEFUN MAKE-NOTE-WINDOW (&KEY REGION (TITLE "Note:")
                                  (STRING "")
                                  (FONT *DEFAULT-NOTE-WINDOW-FONT*)
                                  (READ-ONLY? NIL))
   (LET ((WINDOW (IL:CREATEW REGION TITLE)))
        (IL:WINDOWPROP WINDOW 'NOTE (MAKE-NOTE :STRING STRING :FONT (IF (SYMBOLP FONT)
                                                                        FONT
                                                                        (IL:FONTCREATE FONT))
                                           :TITLE TITLE :READ-ONLY? READ-ONLY?))
        (IL:WINDOWPROP WINDOW 'IL:REPAINTFN 'NOTE-WINDOW-REPAINTFN)
        (IL:WINDOWPROP WINDOW 'IL:RESHAPEFN 'NOTE-WINDOW-REPAINTFN)
        (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN 'NOTE-WINDOW-BUTTONEVENTFN)
        (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN 'NOTE-WINDOW-BUTTONEVENTFN)
        (NOTE-WINDOW-REPAINTFN WINDOW)
        WINDOW))

(DEFUN NOTE-WINDOW-REPAINTFN (WINDOW &REST IGNORE)
   (LET* ((NOTE (IL:WINDOWPROP WINDOW 'NOTE))
          (DSP (IL:GETSTREAM WINDOW))
          (FONT (NOTE-FONT NOTE)))
         (IL:WINDOWPROP WINDOW 'IL:TITLE (NOTE-TITLE NOTE))
         (IL:DSPFONT (IF (SYMBOLP FONT)
                         (SYMBOL-VALUE FONT)
                         FONT)
                DSP)
         (IL:CLEARW WINDOW)

         (IL:* IL:|;;| "why 8?  that's what TEdit uses.")

         (PRINT-NOTE-STRING (NOTE-STRING NOTE)
                DSP 8 (- (IL:WINDOWPROP WINDOW 'IL:WIDTH)
                         8))))

(DEFUN PRINT-NOTE-STRING (STRING DSP LEFT-MARGIN RIGHT-MARGIN &OPTIONAL (LINE-LEADING 0))

(IL:* IL:|;;;| "print STRING to DSP within LEFT-MARGIN & RIGHT-MARGIN, breaking lines at spaces.  I shouldn't have to write this, so it's ok if the code is ugly, right?")

   (CHECK-TYPE DSP (SATISFIES IL:DISPLAYSTREAMP))
   (PROG* ((CHAR)
           (FONT (IL:DSPFONT NIL DSP))
           (LINE-HEIGHT (+ (IL:FONTHEIGHT FONT)
                           LINE-LEADING))
           (LENGTH (VECTOR-LENGTH STRING))
           (DD (IL:FETCH (STREAM IL:IMAGEDATA) IL:OF DSP))
           (LAST-SPACE 0)                                    (IL:* IL:\; 
                                                           "offset in string where we'll break")
           (LINE-START 0)                                    (IL:* IL:\; 
                                                        "offset into string where this line starts")
           (I -1)                                            (IL:* IL:\; 
                                                           "current offset into string")
           (X LEFT-MARGIN)                                   (IL:* IL:\; 
                                                           "x position of char at I in pixels")
           (X-AT-LAST-SPACE LEFT-MARGIN)                     (IL:* IL:\; 
                                                       "x position of char at LAST-SPACE in pixels")
           )
          (IL:MOVETO LEFT-MARGIN (- (IL:DSPYPOSITION NIL DSP)
                                    LINE-LEADING)
                 DSP)
      LOOP
          (INCF I)
          (WHEN (>= I LENGTH)
              (SETQ LAST-SPACE LENGTH)
              (GO DUMP-LINE))
          (SETQ CHAR (AREF STRING I))
          (CASE CHAR
              (#\Space 
                 (DO ((N (1+ I)
                         (1+ N)))

                     (IL:* IL:|;;| "skip through multiple spaces without checking for line breaks so that line breaks are always forced after a group of spaces")

                     ((OR (= N LENGTH)
                          (NOT (EQL (AREF STRING N)
                                    #\Space))))
                   (INCF I)
                   (INCF X (IL:CHARWIDTH (CHAR-CODE #\Space)
                                  FONT)))
                 (SETQ LAST-SPACE I)
                 (SETQ X-AT-LAST-SPACE X))
              (#\Newline                                     (IL:* IL:\; "force line break")
                 (SETQ LAST-SPACE I)
                 (SETQ X-AT-LAST-SPACE X)
                 (GO DUMP-LINE)))
          (INCF X (IL:CHARWIDTH (CHAR-CODE CHAR)
                         FONT))
          (WHEN (> X RIGHT-MARGIN)

              (IL:* IL:|;;| "check if line needs breaking")

              (WHEN (AND (<= LAST-SPACE LINE-START))

                  (IL:* IL:|;;| "if we've had no spaces on this line, just break it where we are.  we actually lose a character here, as DUMP-LINE always skips the character we're on, presuming it's a space or CR.")

                  (SETQ LAST-SPACE I)
                  (SETQ X-AT-LAST-SPACE X))
              (GO DUMP-LINE))
          (GO LOOP)
      DUMP-LINE
          

    (IL:* IL:|;;| "dump chars from LINE-START up to (but not including) LAST-SPACE.")

          (DO ((N LINE-START (1+ N)))
              ((OR (= N LAST-SPACE)
                   (= N LENGTH))

               (IL:* IL:|;;| "move to the next line")

               (IL:MOVETO LEFT-MARGIN (- (IL:DSPYPOSITION NIL DSP)
                                         LINE-HEIGHT)
                      DSP)

               (IL:* IL:|;;| "adjust X & LINE-START")

               (SETQ X (+ LEFT-MARGIN (- X X-AT-LAST-SPACE)))
               (SETQ LINE-START (1+ LAST-SPACE)))

            (IL:* IL:|;;| "this is soooo much faster than calling WRITE-CHAR.  the down side is that this code will now only work on display streams.")

            (IL:\\BLTCHAR (CHAR-CODE (AREF STRING N))
                   DSP DD))
          (IF (>= I LENGTH)
              (RETURN)
              (GO LOOP))))

(DEFUN NOTE-WINDOW-BUTTONEVENTFN (WINDOW)
   (IL:TOTOPW WINDOW)
   (WHEN (AND (IL:MOUSESTATE (IL:ONLY IL:MIDDLE))
              (NOT (NOTE-READ-ONLY? (IL:WINDOWPROP WINDOW 'NOTE))))
       (CASE (MENU '(("Edit Text" :EDIT "Edit the text of this note window with TEdit.")
                     ("Set Font" :FONT "Set the font of this note window.")
                     ("Set Title" :TITLE "Set the title of this note window.")))
           (:EDIT (IL:ADD.PROCESS `(EDIT-NOTE-WINDOW-TEXT ',WINDOW)))
           (:FONT (IL:ADD.PROCESS `(SET-NOTE-WINDOW-FONT ',WINDOW)))
           (:TITLE (IL:ADD.PROCESS `(SET-NOTE-WINDOW-TITLE ',WINDOW))))))

(DEFUN EDIT-NOTE-WINDOW-TEXT (WINDOW)
   (LET ((NOTE (IL:WINDOWPROP WINDOW 'NOTE)))
        (IF (FBOUNDP 'IL:TEDIT)
            (LET ((TEXT-STREAM (IL:OPENTEXTSTREAM (NOTE-STRING NOTE)
                                      NIL NIL NIL
                                      `(IL:FONT ,(NOTE-FONT NOTE)
                                              IL:NOTITLE T IL:PROMPTWINDOW ,IL:PROMPTWINDOW IL:MENU
                                              (IL:|Find| IL:|Substitute| IL:|Quit|)
                                              IL:QUITFN
                                              ,#'(LAMBDA (WINDOW STREAM TEXTOBJ IL:PROPS)
                                                        (IL:|replace| IL:EDITFINISHEDFLG
                                                           IL:|of| TEXTOBJ IL:|with| T)
                                                        'IL:DON\'T)
                                              IL:AFTERQUITFN
                                              ,#'(LAMBDA (WINDOW STREAM)
                                                        (IL:OPENW WINDOW))))))
                 (IL:TTY.PROCESS (IL:THIS.PROCESS))
                 (SETF (NOTE-STRING NOTE)
                       (IL:TEDIT TEXT-STREAM WINDOW T))
                 (IL:BLOCK 200)
                 (IL:WINDOWPROP WINDOW 'IL:REPAINTFN 'NOTE-WINDOW-REPAINTFN)
                 (IL:WINDOWPROP WINDOW 'IL:RESHAPEFN 'NOTE-WINDOW-REPAINTFN)
                 (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN 'NOTE-WINDOW-BUTTONEVENTFN)
                 (NOTE-WINDOW-REPAINTFN WINDOW)))))

(DEFUN SET-NOTE-WINDOW-FONT (WINDOW)
   (LET* ((NOTE (IL:WINDOWPROP WINDOW 'NOTE))
          (OLD-FONT (NOTE-FONT NOTE))
          (NEW-FONT (SEDIT::SEDITE (IF (SYMBOLP OLD-FONT)
                                       OLD-FONT
                                       (EXTERNALIZE-FONT OLD-FONT))
                           NIL NIL NIL NIL '(:CLOSE-ON-COMPLETION))))
         (SETF (NOTE-FONT NOTE)
               (IF (SYMBOLP NEW-FONT)
                   NEW-FONT
                   (IL:FONTCREATE NEW-FONT)))
         (NOTE-WINDOW-REPAINTFN WINDOW)))

(DEFUN SET-NOTE-WINDOW-TITLE (WINDOW)
   (LET* ((NOTE (IL:WINDOWPROP WINDOW 'NOTE))
          (TITLE (PROMPT-USER "Title:" "Type title (CR to abort)")))
         (WHEN TITLE
             (SETF (NOTE-TITLE NOTE)
                   TITLE)
             (NOTE-WINDOW-REPAINTFN WINDOW))))

(DEF-WINDOW-TYPE :NOTE-WINDOW :RECOGNIZER (LAMBDA (WINDOW)
                                                     (NOTE-P (IL:WINDOWPROP WINDOW 'NOTE)))
   :ABSTRACTER (LAMBDA (WINDOW)
                      (LET* ((NOTE (IL:WINDOWPROP WINDOW 'NOTE))
                             (FONT (NOTE-FONT NOTE)))
                            `(:REGION ,(EXTERNALIZE-REGION (WINDOW-REGION WINDOW))
                                    :TITLE
                                    ,(NOTE-TITLE NOTE)
                                    :STRING
                                    ,(NOTE-STRING NOTE)
                                    :FONT
                                    ,(IF (SYMBOLP FONT)
                                         FONT
                                         (EXTERNALIZE-FONT FONT))
                                    :READ-ONLY?
                                    ,(NOTE-READ-ONLY? NOTE))))
   :RECONSTITUTER (LAMBDA (ARGS)
                         (LET ((REST (COPY-LIST ARGS)))
                              (REMF REST :REGION)
                              (APPLY #'MAKE-NOTE-WINDOW :REGION
                                     (INTERNALIZE-REGION (GETF ARGS :REGION
                                                               '(0 0 100 100)))
                                     REST)))
   :TITLE (LAMBDA (PLACEMENT REGION DSP)
                 (LET ((NOTE (IL:WINDOWPROP (PLACEMENT-WINDOW PLACEMENT)
                                    'NOTE)))
                      (PRINT-PEP-TITLE-STRING (IF (AND NOTE (NOTE-TITLE NOTE))
                                                  (STRING (NOTE-TITLE NOTE))
                                                  "Note:")
                             REGION DSP :NO-TITLE-BAR? (PLACEMENT-SHRUNKEN? PLACEMENT)))))
(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY 

(OR (IL:HASDEF 'STREAM 'IL:RECORDS)
    (IL:EVAL (IL:SYSRECLOOK1 'STREAM)))
)
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY

(IL:GLOBALVARS IL:BOLDFONT)
)
(IL:PUTPROPS IL:ROOMS-NOTES IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (1804 2758 (MAKE-NOTE-WINDOW 1804 . 2758)) (2760 3362 (NOTE-WINDOW-REPAINTFN 2760 . 
3362)) (3364 7501 (PRINT-NOTE-STRING 3364 . 7501)) (7503 8159 (NOTE-WINDOW-BUTTONEVENTFN 7503 . 8159))
 (8161 9742 (EDIT-NOTE-WINDOW-TEXT 8161 . 9742)) (9744 10302 (SET-NOTE-WINDOW-FONT 9744 . 10302)) (
10304 10595 (SET-NOTE-WINDOW-TITLE 10304 . 10595)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-NOTES.DFASL b/rooms/ROOMS-NOTES.DFASL
new file mode 100644
index 00000000..1e270bf2
Binary files /dev/null and b/rooms/ROOMS-NOTES.DFASL differ
diff --git a/rooms/ROOMS-OVERVIEW b/rooms/ROOMS-OVERVIEW
new file mode 100644
index 00000000..c4d49fa1
--- /dev/null
+++ b/rooms/ROOMS-OVERVIEW
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:35:56" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-OVERVIEW.;2| 20426  

      IL:|previous| IL:|date:| "17-Aug-90 13:23:15" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-OVERVIEW.;1|)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMS-OVERVIEWCOMS)

(IL:RPAQQ IL:ROOMS-OVERVIEWCOMS
          ((FILE-ENVIRONMENTS IL:ROOMS-OVERVIEW)
           (IL:P (EXPORT '(RESET-OVERVIEW ROOM-UNWIND-SAVE)
                        "ROOMS")
                 (REQUIRE "ROOMS"))
           (IL:COMS                                          (IL:* IL:\; "the room")
                  (IL:VARIABLES *OVERVIEW-ROOM*)
                  (IL:FUNCTIONS GO-TO-OVERVIEW OV-ENTRY-FN OV-EXIT-FN OV-ROOM-CHANGED-FN 
                         OV-SUITE-BODY))
           (IL:COMS                                          (IL:* IL:\; "tiling code")
                  (IL:VARIABLES *OV-BORDER-SIZE*)
                  (IL:FUNCTIONS OV-LAYOUT-PLACEMENT-EDITORS OV-ROWS&COLUMNS))
           (IL:COMS                                          (IL:* IL:\; "buttons")
                  (IL:VARIABLES *OV-BUTTONS* *OV-SELECTED-BUTTON-WINDOW* *OV-CHANGED?*)
                  (IL:FUNCTIONS MAKE-OV-KEYACTION-TABLE OV-WATCH-KEYBOARD OV-SELECT-BUTTON 
                         OV-DESELECT-BUTTON OV-OPERATION)
                  (IL:VARIABLES *OV-KEYACTION-TABLE*))
           (IL:FUNCTIONS RESET-OVERVIEW)
           (IL:COMS (IL:VARIABLES *ROOM-UNWINDERS*)
                  (IL:FUNCTIONS ROOM-UNWIND-SAVE ROOM-UNWIND)
                  (EVAL-WHEN (LOAD)
                         (IL:P (PUSHNEW '(RESET-OVERVIEW)
                                      *RESET-FORMS* :TEST 'EQUAL)
                               (PUSHNEW 'RESET-OVERVIEW *SCREEN-CHANGED-FUNCTIONS*)
                               (PUSHNEW 'ROOM-UNWIND *ROOM-EXIT-FUNCTIONS*)
                               (PUSHNEW 'OV-ROOM-CHANGED-FN *ROOM-CHANGED-FUNCTIONS*))))))

(DEFINE-FILE-ENVIRONMENT IL:ROOMS-OVERVIEW :COMPILER :COMPILE-FILE
   :PACKAGE "ROOMS"
   :READTABLE "XCL")

(EXPORT '(RESET-OVERVIEW ROOM-UNWIND-SAVE)
       "ROOMS")

(REQUIRE "ROOMS")



(IL:* IL:\; "the room")


(DEFGLOBALVAR *OVERVIEW-ROOM* NIL)

(DEFUN GO-TO-OVERVIEW ()
   (GO-TO-ROOM *OVERVIEW-ROOM*))

(DEFUN OV-ENTRY-FN (OVERVIEW-ROOM)

   (IL:* IL:|;;| 
 "the entry function of the overview room.  called whenever we enter the overview room.")

   (LET ((KEYBOARD-WATCHER (IL:ADD.PROCESS '(OV-WATCH-KEYBOARD)
                                  'IL:KEYACTION *OV-KEYACTION-TABLE* 'IL:RESTARTABLE T)))

        (IL:* IL:|;;| "add the keyboard watcher")

        (ROOM-UNWIND-SAVE 

               (IL:* IL:|;;| "make sure it will get deleted when we exit")

               (IL:DEL.PROCESS KEYBOARD-WATCHER T))

        (IL:* IL:|;;| "make sure it will have the TTY when we enter the overview")

        (SETF (ROOM-TTY-PROCESS OVERVIEW-ROOM)
              KEYBOARD-WATCHER))

   (IL:* IL:|;;| "place a PE for each room")

   (OV-LAYOUT-PLACEMENT-EDITORS (ALL-ROOMS T)
          (INTERNALIZE-REGION (MAKE-REGION :LEFT 0 :BOTTOM 1/4 :WIDTH 1.0 :HEIGHT 3/4)))

   (IL:* IL:|;;| "make sure PE's don't get placed again")

   (SETF (ROOM-PLACEMENTS OVERVIEW-ROOM)
         (WITH-COLLECTION (DOLIST (PLACEMENT (ROOM-PLACEMENTS OVERVIEW-ROOM))
                              (UNLESS (PLACEMENT-EDITOR-P (IL:WINDOWPROP (PLACEMENT-WINDOW PLACEMENT)
                                                                 :PLACEMENT-EDITOR))
                                     (COLLECT PLACEMENT)))))

   (IL:* IL:|;;| "select GO-TO button initially")

   (OV-SELECT-BUTTON (GETHASH :ENTER *OV-BUTTONS*)))

(DEFUN OV-EXIT-FN (OVERVIEW-ROOM)
   (WHEN *OV-SELECTED-BUTTON-WINDOW* (OV-DESELECT-BUTTON *OV-SELECTED-BUTTON-WINDOW*)))

(DEFUN OV-ROOM-CHANGED-FN (ROOM REASON)

   (IL:* IL:|;;| "called whenever a room is changed")

   (WHEN (AND (EQ *CURRENT-ROOM* *OVERVIEW-ROOM*)
              (NOT (EQ ROOM *OVERVIEW-ROOM*)))

       (IL:* IL:|;;| "when we're in the overview")

       (CASE REASON
           ((:CREATED :DELETED) 

              (IL:* IL:|;;| "have to re-layout placement editors")

              (MAPHASH #'(LAMBDA (NAME PE)
                                (WHEN (IL:OPENWP (PE-WINDOW PE))
                                    (IL:CLOSEW (PE-WINDOW PE))))
                     *PLACEMENT-EDITORS*)

              (IL:* IL:|;;| "hack: signal OV-WATCH-KEYBOARD process that re-layout is required.  this makes multiple deletes & adds appear as one event.")

              (SETQ *OV-CHANGED?* T)))))

(DEFUN OV-SUITE-BODY ()
   `((:VERSION 0)
     (:WINDOW :SPACE-BAR :TYPE :BUTTON :TEXT
            ,(LET ((FILLER (MAKE-STRING (- (FLOOR (/ IL:SCREENWIDTH (* (IL:CHARWIDTH (CHAR-CODE
                                                                                      #\Space)
                                                                              *DEFAULT-TEXT-FONT*)
                                                                       6)))
                                           4)
                                  :INITIAL-ELEMENT #\Space)))
                  (CONCATENATE 'STRING FILLER "GO TO" FILLER))
            :SHADOWS :ARK :TYPE :STRETCHY-ARK :HELP "GO TO mode - selected rooms will be entered" 
            :ACTION OV-SELECT-BUTTON :OV-BUTTON :ENTER :PROTECTED? T)
     (:WINDOW :EDIT :TYPE :BUTTON :TEXT "EDIT" :SHADOWS :ARK :TYPE :ARK :HELP 
            "EDIT mode - selected rooms will be edited" :ACTION OV-SELECT-BUTTON :OV-BUTTON :EDIT 
            :PROTECTED? T)
     (:WINDOW :EXPAND :TYPE :BUTTON :TEXT "EXPAND" :SHADOWS :ARK :TYPE :ARK :HELP 
            "EDIT mode - selected rooms will be edited" :ACTION OV-SELECT-BUTTON :OV-BUTTON :EXPAND 
            :PROTECTED? T)
     (:WINDOW :MOVE :TYPE :BUTTON :TEXT "MOVE" :SHADOWS :ARK :TYPE :ARK :HELP 
            "MOVE mode - selected placements will be moved, rooms renamed" :ACTION OV-SELECT-BUTTON 
            :OV-BUTTON :MOVE :PROTECTED? T)
     (:WINDOW :COPY :TYPE :BUTTON :TEXT "COPY" :SHADOWS :ARK :TYPE :ARK :HELP 
            "COPY mode - selected rooms & placements will be copied" :ACTION OV-SELECT-BUTTON 
            :OV-BUTTON :COPY :PROTECTED? T)
     (:WINDOW :DELETE :TYPE :BUTTON :TEXT "DELETE" :SHADOWS :ARK :TYPE :ARK :HELP 
            "DELETE mode - selected rooms & placements will be deleted" :ACTION OV-SELECT-BUTTON 
            :OV-BUTTON :DELETE :PROTECTED? T)
     (:WINDOW :PROMPT-WINDOW :TYPE :PROMPT-WINDOW)
     (:ROOM "Overview" :PLACEMENTS ((:PROMPT-WINDOW :REGION (0 3/16 1.0 1/16)
                                           :BORDER 0 :SHADE 65535 :OPERATION IL:INVERT :TITLE NIL 
                                           :FONT (IL:HELVETICA 12 (IL:BOLD IL:REGULAR IL:REGULAR)))
                                    (:SPACE-BAR :REGION (1/3 1/60 100 100))
                                    (:EXPAND :REGION (7/8 1/60 100 100))
                                    ,@(CASE (IL:MACHINETYPE)
                                          (IL:MAIKO '((:DELETE :REGION (26 1/60 100 100))
                                                      (:COPY :REGION (26 1/20 100 100))
                                                      (:MOVE :REGION (26 1/12 100 100))
                                                      (:EDIT :REGION (125 1/20 100 100))))
                                          (T '((:EDIT :REGION (1/40 1/60 100 100))
                                               (:MOVE :REGION (1/40 1/20 100 100))
                                               (:COPY :REGION (1/40 1/12 100 100))
                                               (:DELETE :REGION (1/40 7/60 100 100))))))
            :INCLUSIONS T :BACKGROUND ((:WHOLE-SCREEN 25500 :BORDER 2)
                                       (:REGION (0 0 1.0 3/16)
                                              :SHADE 31710 :BORDER 2)
                                       (:TEXT "Rooms  Overview" :POSITION (0.5 . 1/8)
                                              :ALIGNMENT :CENTER)
                                       (:TEXT "TM" :POSITION (0.47 . 1/7)
                                              :ALIGNMENT :CENTER :FONT (:EVAL IL:BIGFONT))
                                       (:TEXT 
                                             "Copyright (c) Envos Corporations, 1988; Patent Pending"
                                              :POSITION (0.5 . 5/64)
                                              :ALIGNMENT :CENTER :FONT (:EVAL IL:BIGFONT)))
            :BEFORE-ENTRY-FUNCTIONS
            (OV-ENTRY-FN)
            :BEFORE-EXIT-FUNCTIONS
            (OV-EXIT-FN))))



(IL:* IL:\; "tiling code")


(DEFGLOBALPARAMETER *OV-BORDER-SIZE* 10)

(DEFUN OV-LAYOUT-PLACEMENT-EDITORS (ROOMS CONTAINING-REGION)

   (IL:* IL:|;;| "layout placement editors for ROOMS in rows & columns within SCREEN-REGION, attempting to use screen space as best as possible")

   (WHEN ROOMS
       (LET* ((N-ROOMS (LENGTH ROOMS))
              (TITLE-FONT-HEIGHT (IL:FONTHEIGHT *PE-TITLE-FONT*))
              (TITLE-HEIGHT 

                     (IL:* IL:|;;| "height of title including shadows")

                     (+ TITLE-FONT-HEIGHT 1 (CEILING TITLE-FONT-HEIGHT *TEXT-SHADOW-FACTOR*))))
             (MULTIPLE-VALUE-BIND (ROWS COLUMNS TILE-WIDTH TILE-HEIGHT SCALE)
                    (OV-ROWS&COLUMNS N-ROOMS (REGION-WIDTH CONTAINING-REGION)
                           (REGION-HEIGHT CONTAINING-REGION)
                           *OV-BORDER-SIZE* TITLE-HEIGHT)
                    (LET* ((WIDTH (FLOOR (* IL:SCREENWIDTH SCALE)))
                           (HEIGHT (FLOOR (* IL:SCREENHEIGHT SCALE)))
                           (X-OFFSET (+ (REGION-LEFT CONTAINING-REGION)
                                        *OV-BORDER-SIZE*

                                        (IL:* IL:|;;| "center within borders")

                                        (FLOOR (- TILE-WIDTH WIDTH)
                                               2)))
                           (Y-OFFSET (+ (REGION-BOTTOM CONTAINING-REGION)
                                        *OV-BORDER-SIZE*

                                        (IL:* IL:|;;| "center within borders")

                                        (FLOOR (- TILE-HEIGHT HEIGHT)
                                               2))))
                          (DO* ((ROOMS ROOMS (REST ROOMS))
                                (ROOM (FIRST ROOMS)
                                      (FIRST ROOMS))
                                (COLUMN 0 (MOD (1+ COLUMN)
                                               COLUMNS))
                                (ROW (1- ROWS)
                                     (IF (= COLUMN 0)
                                         (1- ROW)
                                         ROW)))
                               ((ENDP ROOMS))
                             (GET-PE (ROOM-NAME ROOM)
                                    (MAKE-REGION :LEFT (+ (* COLUMN TILE-WIDTH)
                                                          (* COLUMN *OV-BORDER-SIZE*)
                                                          X-OFFSET)
                                           :BOTTOM
                                           (+ (* ROW TILE-HEIGHT)
                                              (* ROW TITLE-HEIGHT)
                                              Y-OFFSET)
                                           :WIDTH WIDTH :HEIGHT (+ HEIGHT TITLE-HEIGHT)))))))))

(DEFUN OV-ROWS&COLUMNS (N WIDTH HEIGHT BORDER TITLE-HEIGHT)

(IL:* IL:|;;;| "compute the optimal (in terms of use of screen space) tiling for n tiles within WIDTH & HEIGHT with the constraint that each tile must preserve the screen aspect ratio. ")

(IL:* IL:|;;;| "returns 5 values:  1. the number of rows; 2; the number of columns; 3. the tile width; 4. the tile height and 5. the scale factor to use. ")

   (LET ((ROWS 0)
         (MAX-SCALE 0)
         TILE-WIDTH-AT-MAX-SCALE TILE-HEIGHT-AT-MAX-SCALE)
        (LOOP 
              (IL:* IL:|;;| "go through each possible tiling & maximize the scale we'd have to use at that tiling.  with a little algebra we could probably find a formula which directly gave us this maximum, but this code is plenty fast & easy to understand, so why bother?")

              (INCF ROWS)
              (LET* ((COLUMNS (CEILING N ROWS))

                     (IL:* IL:|;;| 
              "there's one more border than rows & columns, but the same number of titles as rows.")

                     (X-BORDERS (* (1+ COLUMNS)
                                   BORDER))
                     (Y-BORDERS (+ BORDER (* ROWS TITLE-HEIGHT)
                                   BORDER))

                     (IL:* IL:|;;| "subtract off the borders from the available space")

                     (USEFUL-WIDTH (- WIDTH X-BORDERS))
                     (USEFUL-HEIGHT (- HEIGHT Y-BORDERS))

                     (IL:* IL:|;;| "divide up the useful space")

                     (TILE-WIDTH (/ USEFUL-WIDTH COLUMNS))
                     (TILE-HEIGHT (/ USEFUL-HEIGHT ROWS))

                     (IL:* IL:|;;| "calculate the scale w.r.t the screen dimensions")

                     (X-SCALE (/ TILE-WIDTH IL:SCREENWIDTH))
                     (Y-SCALE (/ TILE-HEIGHT IL:SCREENHEIGHT))

                     (IL:* IL:|;;| "in order to preserve aspect ratio the X & Y scales must be the same.  we must chose the lesser so we stay within the tile.  we'll center within the tile when we actually lay things out.  ")

                     (SCALE (MIN X-SCALE Y-SCALE)))

                    (IL:* IL:|;;| "scale will smoothly increase until it reaches it maximum value, then decrease. we return the previous value as soon as it begins to decrease.  ")

                    (WHEN (< SCALE MAX-SCALE)
                        (RETURN (VALUES (1- ROWS)
                                       (CEILING N (1- ROWS))
                                       (FLOOR TILE-WIDTH-AT-MAX-SCALE)
                                       (FLOOR TILE-HEIGHT-AT-MAX-SCALE)
                                       MAX-SCALE)))
                    (SETF MAX-SCALE SCALE)
                    (SETF TILE-WIDTH-AT-MAX-SCALE TILE-WIDTH)
                    (SETF TILE-HEIGHT-AT-MAX-SCALE TILE-HEIGHT)))))



(IL:* IL:\; "buttons")


(DEFGLOBALVAR *OV-BUTTONS* (MAKE-HASH-TABLE :TEST 'EQ))

(DEFGLOBALVAR *OV-SELECTED-BUTTON-WINDOW* NIL)

(DEFGLOBALVAR *OV-CHANGED?* NIL)

(DEFUN MAKE-OV-KEYACTION-TABLE ()

(IL:* IL:|;;;| "make keyaction table for overview")

   (IL:* IL:|;;| "want to get users' mods to shift, ctrl & meta, but don't want users' interrupts")

   (LET ((TABLE (IL:KEYACTIONTABLE IL:\\DEFAULTKEYACTION)))
        (DECLARE (GLOBAL IL:\\DEFAULTKEYACTION))

        (IL:* IL:|;;| "install default interrupts")

        (IL:INTERRUPTCHAR T NIL NIL TABLE)

        (IL:* IL:|;;| "we need delete key & don't care about type ahead, so remove delete interrupt so screen doesn't flash")

        (IL:INTERRUPTCHAR (CHAR-CODE #\Rubout)
               NIL NIL TABLE)
        TABLE))

(DEFUN OV-WATCH-KEYBOARD ()

(IL:* IL:|;;;| "added as process when in overview.")

   (LOOP 
         (IL:* IL:|;;| "watch the keyboard")

         (LET* ((KEY (COND
                        ((EDIT-KEY-DOWN-P)
                         :EDIT)
                        ((MOVE-KEY-DOWN-P)
                         :MOVE)
                        ((COPY-KEY-DOWN-P)
                         :COPY)
                        ((DELETE-KEY-DOWN-P)
                         :DELETE)
                        ((EXPAND-KEY-DOWN-P)
                         :EXPAND)
                        ((IL:KEYDOWNP 'IL:SPACE)
                         :ENTER))))
               (WHEN KEY
                   (LET ((BUTTON-WINDOW (GETHASH KEY *OV-BUTTONS*)))
                        (UNLESS (EQ BUTTON-WINDOW *OV-SELECTED-BUTTON-WINDOW*)

                            (IL:* IL:|;;| "select the button")

                            (OV-SELECT-BUTTON BUTTON-WINDOW :REDISPLAY T)))))

         (IL:* IL:|;;| "watch for room creation/deletion signal.  this flag is set by OV-ROOM-CHANGED-FN.  doing this in a separate process makes DELETE-SUITE only re-layout once.  this hack depends upon non-preemptive scheduling.    ")

         (WHEN *OV-CHANGED?*

             (IL:* IL:|;;| "have to re-layout placement editors")

             (SETQ *OV-CHANGED?* NIL)
             (OV-LAYOUT-PLACEMENT-EDITORS (ALL-ROOMS T)
                    (INTERNALIZE-REGION (MAKE-REGION :LEFT 0 :BOTTOM 1/4 :WIDTH 1.0 :HEIGHT 3/4))))

         (IL:* IL:|;;| "clear any type ahead")

         (IL:\\CLEARSYSBUF)

         (IL:* IL:|;;| "don't want to cycle too fast, else chords won't be sticky")

         (IL:BLOCK 50)))

(DEFUN OV-SELECT-BUTTON (WINDOW)
   (DECLARE (IGNORE REST))

(IL:* IL:|;;;| "called when one of the overview buttons is selected")

   (UNLESS (EQ WINDOW *OV-SELECTED-BUTTON-WINDOW*)
       (WHEN *OV-SELECTED-BUTTON-WINDOW*

           (IL:* IL:|;;| "first unselect the previously selected button ")

           (OV-DESELECT-BUTTON *OV-SELECTED-BUTTON-WINDOW*))

       (IL:* IL:|;;| "mark us as the selected button")

       (LET ((BUTTON (IL:WINDOWPROP WINDOW 'BUTTON)))
            (SETQ *OV-SELECTED-BUTTON-WINDOW* WINDOW)
            (SETF (BUTTON-INVERTED? BUTTON)
                  T)
            (IL:REDISPLAYW WINDOW))))

(DEFUN OV-DESELECT-BUTTON (WINDOW)
   (LET ((BUTTON (IL:WINDOWPROP WINDOW 'BUTTON)))
        (SETF (BUTTON-INVERTED? BUTTON)
              NIL)
        (SETQ *OV-SELECTED-BUTTON-WINDOW* NIL)
        (IL:REDISPLAYW WINDOW)))

(DEFUN OV-OPERATION ()

(IL:* IL:|;;;| "call this to find out what key is down in the overview")

   (AND *OV-SELECTED-BUTTON-WINDOW* (EQ *CURRENT-ROOM* *OVERVIEW-ROOM*)
        (BUTTON-PROP (IL:WINDOWPROP *OV-SELECTED-BUTTON-WINDOW* 'BUTTON)
               :OV-BUTTON)))

(DEFGLOBALPARAMETER *OV-KEYACTION-TABLE*)

(DEFUN RESET-OVERVIEW ()
   (SETQ *OV-KEYACTION-TABLE* (MAKE-OV-KEYACTION-TABLE))
   (WHEN *OVERVIEW-ROOM*

       (IL:* IL:|;;| "clean up existing overview")

       (DELETE-ROOM *OVERVIEW-ROOM*))
   (LET ((ROOM-NAMED-OVERVIEW (ROOM-NAMED "Overview")))

        (IL:* IL:|;;| "make an un-named room from the description in *OVERVIEW-SUITE-BODY*")

        (UNWIND-PROTECT
            (PROGN (INSTALL-SUITE-BODY (COPY-TREE (OV-SUITE-BODY)))
                   (SETQ *OVERVIEW-ROOM* (ROOM-NAMED "Overview")))
            (IF ROOM-NAMED-OVERVIEW
                (SETF (ROOM-NAMED "Overview")
                      ROOM-NAMED-OVERVIEW)
                (REMHASH "Overview" *ROOMS*)))
        (WHEN (EQ *CURRENT-ROOM* *OVERVIEW-ROOM*)

            (IL:* IL:|;;| "re-tile Overview to get rid of pe for Overview")

            (OV-ROOM-CHANGED-FN NIL :DELETED))
        (DOLIST (PLACEMENT (ROOM-PLACEMENTS *OVERVIEW-ROOM*))
            (LET ((BUTTON (IL:WINDOWPROP (PLACEMENT-WINDOW PLACEMENT)
                                 'BUTTON)))
                 (WHEN BUTTON

                     (IL:* IL:|;;| "save pointers to buttons in *OV-BUTTONS*")

                     (SETF (GETHASH (BUTTON-PROP BUTTON :OV-BUTTON)
                                  *OV-BUTTONS*)
                           (PLACEMENT-WINDOW PLACEMENT)))))
        *OVERVIEW-ROOM*))

(DEFGLOBALVAR *ROOM-UNWINDERS* NIL)

(DEFMACRO ROOM-UNWIND-SAVE (&BODY BODY)
   `(PUSH #'(LAMBDA NIL ,@BODY)
          *ROOM-UNWINDERS*))

(DEFUN ROOM-UNWIND (ROOM)
   (DECLARE (IGNORE ROOM))
   (DOLIST (UNWINDER (PROG1 *ROOM-UNWINDERS* (SETQ *ROOM-UNWINDERS* NIL)))
       (FUNCALL UNWINDER)))
(EVAL-WHEN (LOAD)

(PUSHNEW '(RESET-OVERVIEW)
       *RESET-FORMS* :TEST 'EQUAL)

(PUSHNEW 'RESET-OVERVIEW *SCREEN-CHANGED-FUNCTIONS*)

(PUSHNEW 'ROOM-UNWIND *ROOM-EXIT-FUNCTIONS*)

(PUSHNEW 'OV-ROOM-CHANGED-FN *ROOM-CHANGED-FUNCTIONS*)
)
(IL:PUTPROPS IL:ROOMS-OVERVIEW IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (2406 2467 (GO-TO-OVERVIEW 2406 . 2467)) (2469 3906 (OV-ENTRY-FN 2469 . 3906)) (3908 
4037 (OV-EXIT-FN 3908 . 4037)) (4039 4839 (OV-ROOM-CHANGED-FN 4039 . 4839)) (4841 8919 (OV-SUITE-BODY 
4841 . 8919)) (9002 11780 (OV-LAYOUT-PLACEMENT-EDITORS 9002 . 11780)) (11782 14626 (OV-ROWS&COLUMNS 
11782 . 14626)) (14810 15449 (MAKE-OV-KEYACTION-TABLE 14810 . 15449)) (15451 17158 (OV-WATCH-KEYBOARD 
15451 . 17158)) (17160 17813 (OV-SELECT-BUTTON 17160 . 17813)) (17815 18042 (OV-DESELECT-BUTTON 17815
 . 18042)) (18044 18323 (OV-OPERATION 18044 . 18323)) (18372 19747 (RESET-OVERVIEW 18372 . 19747)) (
19896 20059 (ROOM-UNWIND 19896 . 20059)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-OVERVIEW.DFASL b/rooms/ROOMS-OVERVIEW.DFASL
new file mode 100644
index 00000000..8e969284
Binary files /dev/null and b/rooms/ROOMS-OVERVIEW.DFASL differ
diff --git a/rooms/ROOMS-PLACEMENT-EDITOR b/rooms/ROOMS-PLACEMENT-EDITOR
new file mode 100644
index 00000000..6767eb05
--- /dev/null
+++ b/rooms/ROOMS-PLACEMENT-EDITOR
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:35:48" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-PLACEMENT-EDITOR.;2| 43072  

      IL:|previous| IL:|date:| "17-Aug-90 13:25:31" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-PLACEMENT-EDITOR.;1|
)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMS-PLACEMENT-EDITORCOMS)

(IL:RPAQQ IL:ROOMS-PLACEMENT-EDITORCOMS
          ((FILE-ENVIRONMENTS IL:ROOMS-PLACEMENT-EDITOR)
           (IL:P (REQUIRE "ROOMS")
                 (EXPORT '(GET-PE PRINT-PEP-TITLE-STRING)
                        "ROOMS"))
           (IL:STRUCTURES PLACEMENT-EDITOR PE-PLACEMENT)
           (IL:VARIABLES *PLACEMENT-EDITORS* *PE-INHIBIT-REDISPLAY*)
           (IL:FUNCTIONS GET-PE MAKE-PE FIND-PE PE-WINDOW-P PE-CLOSEFN PE-REPAINTFN PE-RESHAPEFN 
                  PE-TOTOPFN UPDATE-PE? UPDATE-PE UPDATE-PEPS UPDATE-PEP-SAVE-BITMAP UPDATE-PE-WINDOW
                  PLACED-REGION)
           (IL:COMS                                          (IL:* IL:\; "display")
                  (IL:VARIABLES *DEFAULT-ICON-SIZE* *PE-TITLE-FONT* *PEP-TITLE-FONT* 
                         *PEP-INCLUDED-SHADE* *PE-BORDER*)
                  (IL:FUNCTIONS DISPLAY-PEPS SAVE-PEP-IMAGE DISPLAY-PE-TITLE DISPLAY-PE-BORDER 
                         DISPLAY-PEP PRINT-PEP-TITLE PRINT-PEP-TITLE-STRING)
                  (IL:VARIABLES *DISPLAY-PE-DEPTH*)
                  (IL:WINDOW-TYPES :PLACEMENT-EDITOR))
           (IL:FUNCTIONS PE-RIGHTBUTTONFN                    (IL:* IL:\; "mouse trackers")
                  PE-BUTTONEVENTFN PE-BUTTONEVENTFN-INTERNAL PE-TRACK-MOUSE PE-GETMOUSESTATE 
                  PE-TRACK-LEFT-BUTTON PE-TRACK-MIDDLE-BUTTON PEP-GETBOXPOSITION 
                  PEP-GETBOXPOSITION-INTERNAL)
           (IL:COMS                                          (IL:* IL:\; "editing")
                  (IL:FUNCTIONS PE-ROOM-CHANGED-FN PEP-SELECTED EXPAND-PLACEMENT 
                         PEP-SELECTED-COPY-OR-MOVE PE-ROOM-SELECTED)
                  (EVAL-WHEN (LOAD)
                         (IL:P (PUSHNEW 'PE-ROOM-CHANGED-FN *ROOM-CHANGED-FUNCTIONS*))))
           (IL:GLOBALVARS IL:TINYFONT IL:CROSSHAIRS)))

(DEFINE-FILE-ENVIRONMENT IL:ROOMS-PLACEMENT-EDITOR :COMPILER :COMPILE-FILE
   :PACKAGE "ROOMS"
   :READTABLE "XCL")

(REQUIRE "ROOMS")

(EXPORT '(GET-PE PRINT-PEP-TITLE-STRING)
       "ROOMS")

(DEFSTRUCT (PLACEMENT-EDITOR (:CONC-NAME "PE-")
                                 (:CONSTRUCTOR MAKE-PE-INTERNAL)
                                 (:PRINT-FUNCTION (LAMBDA (PE STREAM DEPTH)
                                                         (FORMAT STREAM "#<Placement Editor for ~S>"
                                                                (PE-ROOM-NAME PE)))))
   (CHANGED? T :TYPE (MEMBER T NIL :PLACEMENTS))
   (ROOM-NAME NIL)
   (SCALE *ONE-TO-ONE* :TYPE SCALE)
   (PEPS NIL :TYPE LIST)
   (WINDOW NIL)
   (TITLE-TEXT NIL :TYPE TEXT)
   (CLIPPING-REGION NIL))

(DEFSTRUCT (PE-PLACEMENT (:CONC-NAME "PEP-")
                             (:PRINT-FUNCTION (LAMBDA (PEP STREAM DEPTH)
                                                     (FORMAT STREAM "#<PEP ~O,~O>" (IL:\\HILOC PEP)
                                                            (IL:\\LOLOC PEP)))))
   (PLACEMENT NIL :TYPE PLACEMENT)
   (SCALED-REGION NIL :TYPE REGION)
   (IMMEDIATE? NIL :TYPE (MEMBER T NIL))
   (OPEN? NIL :TYPE (MEMBER T NIL))
   (SAVE-BITMAP NIL)
   (UNSCALED-REGION NIL :TYPE REGION))

(DEFGLOBALVAR *PLACEMENT-EDITORS* (MAKE-HASH-TABLE :TEST 'EQUAL))

(DEFVAR *PE-INHIBIT-REDISPLAY* NIL)

(DEFUN GET-PE (ROOM-NAME &OPTIONAL REGION)

(IL:* IL:|;;;| "returns the PE for ROOM, creating one if required.  if REGION is provided then the PE will occupy it.")

   (LET ((PE (FIND-PE ROOM-NAME)))
        (IF PE

            (IL:* IL:|;;| 
          "this code optimized so there is never more than one redisplay when entering overview")

            (LET* ((WINDOW (PE-WINDOW PE))
                   (ICON (WINDOW-ICON WINDOW))
                   SHAPED?)

                  (IL:* IL:|;;| "this gets smashed when window closed")

                  (IL:WINDOWPROP WINDOW :PLACEMENT-EDITOR PE)
                  (LET ((*PE-INHIBIT-REDISPLAY* T))
                       (UN-HIDE-WINDOW WINDOW)
                       (IL:OPENW WINDOW)
                       (IL:TOTOPW WINDOW)
                       (WHEN REGION (SHAPE-WINDOW WINDOW REGION)))
                  (UPDATE-PE? PE)
                  PE)
            (MAKE-PE ROOM-NAME REGION))))

(DEFUN MAKE-PE (ROOM-NAME &OPTIONAL REGION)

(IL:* IL:|;;;| 
"don't call this.  call GET-PE instead.  we depend on there only being on PE per room.")

   (LET* ((WINDOW (IL:CREATEW REGION NIL 0))
          (PE (MAKE-PE-INTERNAL :ROOM-NAME ROOM-NAME :WINDOW WINDOW :TITLE-TEXT
                     (MAKE-TEXT :STRING (IF (STRINGP ROOM-NAME)
                                            ROOM-NAME
                                            (PRINC-TO-STRING ROOM-NAME))
                            :SHADOWS T :FONT *PE-TITLE-FONT*))))
         (IL:WINDOWPROP WINDOW 'IL:CLOSEFN 'PE-CLOSEFN)
         (IL:WINDOWPROP WINDOW :PLACEMENT-EDITOR PE)
         (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN 'PE-BUTTONEVENTFN)
         (IL:WINDOWPROP WINDOW 'IL:RIGHTBUTTONFN 'PE-RIGHTBUTTONFN)
         (IL:WINDOWPROP WINDOW 'IL:REPAINTFN 'PE-REPAINTFN)
         (IL:WINDOWPROP WINDOW 'IL:RESHAPEFN 'PE-RESHAPEFN)
         (IL:WINDOWPROP WINDOW 'IL:TOTOPFN 'PE-TOTOPFN)
         (IL:WINDOWPROP WINDOW 'IL:AFTERMOVEFN 'PE-TOTOPFN)
         (IL:WINDOWPROP WINDOW 'IL:OPENFN 'PE-TOTOPFN)
         (IL:DSPFONT *PEP-TITLE-FONT* WINDOW)
         (SETF (FIND-PE ROOM-NAME)
               PE)

         (IL:* IL:|;;| "update things")

         (UPDATE-PE-WINDOW PE)
         (UPDATE-PE PE)
         PE))

(DEFMACRO FIND-PE (ROOM-NAME)
   `(GETHASH ,ROOM-NAME *PLACEMENT-EDITORS*))

(DEFUN PE-WINDOW-P (WINDOW)
   (PLACEMENT-EDITOR-P (IL:WINDOWPROP WINDOW :PLACEMENT-EDITOR)))

(DEFUN PE-CLOSEFN (WINDOW)

   (IL:* IL:|;;| "remove circularity")

   (IL:WINDOWPROP WINDOW :PLACEMENT-EDITOR NIL))

(DEFUN PE-REPAINTFN (WINDOW &REST IGNORE)
   (LET ((PE (IL:WINDOWPROP WINDOW :PLACEMENT-EDITOR)))
        (DISPLAY-PE-TITLE PE)
        (DISPLAY-PE-BORDER PE)
        (SETF (PE-CHANGED? PE)
              T)
        (UPDATE-PE PE)))

(DEFUN PE-RESHAPEFN (WINDOW &REST IGNORE)
   (LET ((PE (IL:WINDOWPROP WINDOW :PLACEMENT-EDITOR)))
        (UPDATE-PE-WINDOW PE)
        (SETF (PE-CHANGED? PE)
              T)
        (UNLESS *PE-INHIBIT-REDISPLAY* (UPDATE-PE PE))))

(DEFUN PE-TOTOPFN (WINDOW)
   (IL:TOTOPW WINDOW T)
   (LET ((PE (IL:WINDOWPROP WINDOW :PLACEMENT-EDITOR)))
        (WHEN PE
            (DISPLAY-PE-TITLE PE)
            (UNLESS *PE-INHIBIT-REDISPLAY* (UPDATE-PE? PE)))))

(DEFUN UPDATE-PE? (PE)
   (WHEN (PE-CHANGED? PE)
         (UPDATE-PE PE)))

(DEFUN UPDATE-PE (PE)

(IL:* IL:|;;;| "update PE per the current state of rooms")

   (LET ((*PE-INHIBIT-REDISPLAY* T)

         (IL:* IL:|;;| "don't want TOTOP to update too")

         (ROOM (ROOM-NAMED (PE-ROOM-NAME PE))))
        (WHEN ROOM
            (LET ((DSP (IL:GETSTREAM (PE-WINDOW PE))))
                 (CASE (PE-CHANGED? PE)
                     (:PLACEMENTS                            (IL:* IL:\; "incremental redisplay")
                        (LET ((OLD-PEPS (PE-PEPS PE)))
                             (UPDATE-PEPS PE OLD-PEPS)
                             (DISPLAY-PEPS PE DSP OLD-PEPS)))
                     (T                                      (IL:* IL:\; "total redisplay")
                        (UPDATE-PEPS PE)
                        (PAINT-BACKGROUND ROOM DSP :SCALE (PE-SCALE PE)
                               :NO-TEXT T :CLIPPING-REGION (PE-CLIPPING-REGION PE))
                        (DISPLAY-PEPS PE DSP)))
                 (SETF (PE-CHANGED? PE)
                       NIL)))))

(DEFUN UPDATE-PEPS (PE &OPTIONAL OLD-PEPS)

   (IL:* IL:|;;| "build a new list of PEPs for PE.")

   (IL:* IL:|;;| 
 "the redisplay code depends upon us leaving EQ peps only when the placement hasn't changed.")

   (LET
    ((ROOM (ROOM-NAMED (PE-ROOM-NAME PE))))
    (WHEN ROOM
        (LET ((IMMEDIATE-PLACEMENTS (ROOM-PLACEMENTS ROOM))
              (SCALE (PE-SCALE PE)))
             (DO* ((ALL (FIND-PLACEMENTS ROOM))
                   (TAIL ALL (CDR TAIL)))
                  ((NULL TAIL)
                   (SETF (PE-PEPS PE)
                         ALL))
                (SETF (FIRST TAIL)
                      (LET* ((PLACEMENT (FIRST TAIL))
                             (IMMEDIATE? (MEMBER PLACEMENT IMMEDIATE-PLACEMENTS :TEST 'EQ))
                             (SCALED-REGION (PLACED-REGION PLACEMENT)))
                            (OR (DOLIST (PEP OLD-PEPS)

                                    (IL:* IL:|;;| "try to find an old PEP for placement")

                                    (WHEN (EQ (PEP-PLACEMENT PEP)
                                              PLACEMENT)

                                        (IL:* IL:|;;| "found it")

                                        (WHEN (EQ PEP (FIRST OLD-PEPS))

                                            (IL:* IL:|;;| "speed future searches")

                                            (POP OLD-PEPS))
                                        (RETURN (WHEN (AND (IF (PEP-IMMEDIATE? PEP)
                                                               IMMEDIATE?
                                                               (NOT IMMEDIATE?))
                                                           (EQUAL (PEP-UNSCALED-REGION PEP)
                                                                  SCALED-REGION))
                                                             (IL:* IL:\; "ok to use it")
                                                    PEP))))
                                (UPDATE-PEP-SAVE-BITMAP (MAKE-PE-PLACEMENT :PLACEMENT PLACEMENT 
                                                                   :IMMEDIATE? IMMEDIATE? 
                                                                   :SCALED-REGION (SCALE-REGION
                                                                                   SCALED-REGION 
                                                                                   SCALE)
                                                                   :UNSCALED-REGION SCALED-REGION))))
                      ))))))

(DEFUN UPDATE-PEP-SAVE-BITMAP (PEP)
   (LET* ((SCALED-REGION (PEP-SCALED-REGION PEP))
          (SAVE (IL:BITMAPCREATE (REGION-WIDTH SCALED-REGION)
                       (REGION-HEIGHT SCALED-REGION)))
          (DSP (IL:LOADTIMECONSTANT (IL:DSPCREATE))))
         (IL:DSPDESTINATION SAVE DSP)
         (IL:DSPXOFFSET (- (REGION-LEFT SCALED-REGION))
                DSP)
         (IL:DSPYOFFSET (- (REGION-BOTTOM SCALED-REGION))
                DSP)
         (DISPLAY-PEP PEP DSP)
         (SETF (PEP-SAVE-BITMAP PEP)
               SAVE)
         (SETF (PEP-OPEN? PEP)
               NIL)
         PEP))

(DEFUN UPDATE-PE-WINDOW (PE)
   (LET* ((WINDOW (PE-WINDOW PE))
          (DSP (IL:GETSTREAM WINDOW))
          (WINDOW-REGION (WINDOW-REGION WINDOW))
          (WINDOW-HEIGHT (REGION-HEIGHT WINDOW-REGION))
          (TEXT (PE-TITLE-TEXT PE))
          (HEIGHT (- WINDOW-HEIGHT (TEXT-%HEIGHT TEXT)))
          (TWICE-BORDER (* *PE-BORDER* 2))
          (CLIPPING-REGION (MAKE-REGION :LEFT *PE-BORDER* :BOTTOM *PE-BORDER* :WIDTH
                                  (- (REGION-WIDTH WINDOW-REGION)
                                     TWICE-BORDER)
                                  :HEIGHT
                                  (- HEIGHT TWICE-BORDER))))

         (IL:* IL:|;;| "update scale & clipping region")

         (SETF (PE-CLIPPING-REGION PE)
               CLIPPING-REGION)
         (SETF (PE-SCALE PE)
               (MAKE-SCALE CLIPPING-REGION))
         (SETF (TEXT-POSITION TEXT)
               (MAKE-POSITION *PE-BORDER* HEIGHT))
         (DISPLAY-PE-TITLE PE)
         (DISPLAY-PE-BORDER PE)))

(DEFUN PLACED-REGION (PLACEMENT)

(IL:* IL:|;;;| "returns the region PLACEMENT would occupy on the screen.  for non-shrunken placements this is just the PLACEMENT-REGION, but for shrunken placements we need to figure what the region of the icon would be.")

   (IF (PLACEMENT-SHRUNKEN? PLACEMENT)
       (LET* ((ICON-POSITION (PLACEMENT-ICON-POSITION PLACEMENT))
              (ICON (WINDOW-ICON (PLACEMENT-WINDOW PLACEMENT)))
              (ICON-REGION (IF ICON (WINDOW-REGION ICON))))
             (MAKE-REGION :LEFT (POSITION-X ICON-POSITION)
                    :BOTTOM
                    (POSITION-Y ICON-POSITION)
                    :WIDTH
                    (IF ICON
                        (REGION-WIDTH ICON-REGION)
                        *DEFAULT-ICON-SIZE*)
                    :HEIGHT
                    (IF ICON
                        (REGION-HEIGHT ICON-REGION)
                        *DEFAULT-ICON-SIZE*)))
       (PLACEMENT-REGION PLACEMENT)))



(IL:* IL:\; "display")


(DEFVAR *DEFAULT-ICON-SIZE*

(IL:* IL:|;;;| "when we draw a placement for a non-existant icon, we draw it as a square with this many (scaled) pixels per side.")

   75)

(DEFGLOBALVAR *PE-TITLE-FONT* (IL:FONTCREATE 'IL:HELVETICA 36 '(IL:BOLD IL:REGULAR IL:REGULAR)
                                         NIL
                                         'IL:DISPLAY))

(DEFGLOBALPARAMETER *PEP-TITLE-FONT* (IL:FONTCREATE IL:TINYFONT NIL NIL NIL 'IL:DISPLAY))

(DEFGLOBALPARAMETER *PEP-INCLUDED-SHADE* 4680)

(DEFGLOBALPARAMETER *PE-BORDER* 4)

(DEFUN DISPLAY-PEPS (PE DSP &OPTIONAL OLD-PEPS)

(IL:* IL:|;;;| "displays PE on DSP.  Should be called DISPLAY-PE-INTERNAL.")

   (LET ((OLD OLD-PEPS)
         (NEW (PE-PEPS PE)))
        (LOOP 
              (IL:* IL:|;;| "pop off the EQ peps on the bottom of window stack")

              (WHEN (OR (NULL OLD)
                        (NULL NEW)
                        (NOT (EQ (FIRST OLD)
                                 (FIRST NEW))))
                    (RETURN))
              (POP OLD)
              (POP NEW))

        (IL:* IL:|;;| "remove image of remaining old peps")

        (DOLIST (PEP (REVERSE OLD))
            (SAVE-PEP-IMAGE DSP PEP PE))

        (IL:* IL:|;;| "display remaining new peps")

        (DOLIST (PEP NEW)
            (SAVE-PEP-IMAGE DSP PEP PE))))

(DEFUN SAVE-PEP-IMAGE (DSP PEP PE)

(IL:* IL:|;;;| "switch contents of PEP's save & its region of DSP.")

   (LET* ((REGION (PEP-SCALED-REGION PEP))
          (LEFT (POP REGION))
          (BOTTOM (POP REGION))
          (WIDTH (POP REGION))
          (HEIGHT (POP REGION))
          (CLIPPING (PE-CLIPPING-REGION PE))
          (CLIPPING-LEFT (POP CLIPPING))
          (CLIPPING-BOTTOM (POP CLIPPING))
          (CLIPPING-WIDTH (POP CLIPPING))
          (CLIPPING-HEIGHT (POP CLIPPING))
          (SAVE (PEP-SAVE-BITMAP PEP)))
         (IL:UNINTERRUPTABLY
             (IL:BITBLT SAVE 0 0 DSP LEFT BOTTOM WIDTH HEIGHT 'IL:INPUT 'IL:INVERT NIL CLIPPING)
             (IL:BITBLT DSP (MAX LEFT CLIPPING-LEFT)
                    (MAX BOTTOM CLIPPING-BOTTOM)
                    SAVE 0 0 (MIN WIDTH (- (+ CLIPPING-WIDTH CLIPPING-LEFT)
                                           LEFT))
                    (MIN HEIGHT (- (+ CLIPPING-HEIGHT CLIPPING-BOTTOM)
                                   BOTTOM))
                    'IL:INPUT
                    'IL:INVERT)
             (IL:BITBLT SAVE 0 0 DSP LEFT BOTTOM WIDTH HEIGHT 'IL:INPUT 'IL:INVERT NIL CLIPPING))
         (SETF (PEP-OPEN? PEP)
               (NOT (PEP-OPEN? PEP)))))

(DEFUN DISPLAY-PE-TITLE (PE)
   (LET* ((WINDOW (PE-WINDOW PE))
          (WINDOW-REGION (WINDOW-REGION WINDOW))
          (DSP (IL:GETSTREAM WINDOW))
          (TEXT (PE-TITLE-TEXT PE))
          (WINDOW-HEIGHT (REGION-HEIGHT WINDOW-REGION))
          (BOTTOM (- WINDOW-HEIGHT (TEXT-%HEIGHT TEXT))))

         (IL:* IL:|;;| "blt the background into the title bar")

         (IL:BITBLT (IL:WINDOWPROP WINDOW 'IL:IMAGECOVERED)
                0 BOTTOM DSP 0 BOTTOM (REGION-WIDTH WINDOW-REGION)
                (- WINDOW-HEIGHT BOTTOM))
         (IF (EQUAL (PE-ROOM-NAME PE)
                    *BACK-DOOR-ROOM-NAME*)

             (IL:* IL:|;;| "the title of the back door room gets special shadows ")

             (WHEN (EQ (TEXT-SHADOWS TEXT)
                       T)
                 (SETF (TEXT-SHADOWS TEXT)
                       (MAPLIST #'(LAMBDA (TAIL)
                                         (IF (REST TAIL)
                                             (FIRST TAIL)
                                             (IL:CONSTANT (MAKE-TEXT-SHADOW :SOURCE-TYPE 'IL:MERGE 
                                                                 :TEXTURE 42405 :OPERATION
                                                                 'IL:INVERT))))
                              (GET-TEXT-SHADOWS-INTERNAL *PE-TITLE-FONT*)))
                 (UPDATE-TEXT-CACHES TEXT))
             (UNLESS (EQ (TEXT-SHADOWS TEXT)
                         T)

                 (IL:* IL:|;;| "used to be back-door room")

                 (SETF (TEXT-SHADOWS TEXT)
                       T)
                 (UPDATE-TEXT-CACHES TEXT)))
         (DISPLAY-TEXT TEXT DSP)))

(DEFUN DISPLAY-PE-BORDER (PE)
   (LET* ((WINDOW (PE-WINDOW PE))
          (WINDOW-REGION (WINDOW-REGION WINDOW)))

         (IL:* IL:|;;| "draw the window border & clear inside it")

         (DRAW&FILL-BOX-WITHIN (MAKE-REGION :LEFT 0 :BOTTOM 0 :WIDTH (REGION-WIDTH WINDOW-REGION)
                                      :HEIGHT
                                      (- (REGION-HEIGHT WINDOW-REGION)
                                         (TEXT-%HEIGHT (PE-TITLE-TEXT PE))))
                (IL:GETSTREAM WINDOW)
                :BORDER-WIDTH
                (FLOOR *PE-BORDER* 2))))

(DEFUN DISPLAY-PEP (PEP DSP)

(IL:* IL:|;;;| "displays a PE-PLACEMENT")

   (IL:* IL:|;;| "draw a box around the region & fill it if it represents an immediate placement in the room of this PEP.")

   (DRAW&FILL-BOX-WITHIN (PEP-SCALED-REGION PEP)
          DSP :BORDER-WIDTH 1 :SHADE (IF (PEP-IMMEDIATE? PEP)
                                         IL:WHITESHADE
                                         *PEP-INCLUDED-SHADE*))
   (PRINT-PEP-TITLE PEP DSP))

(DEFUN PRINT-PEP-TITLE (PEP DSP)

   (IL:* IL:|;;| "print something within the box drawn for PEP on DSP ")

   (LET* ((WINDOW-TYPE (WINDOW-TYPE (PLACEMENT-WINDOW (PEP-PLACEMENT PEP))
                              T)))
         (WHEN WINDOW-TYPE
             (LET ((TITLE (WINDOW-TYPE-PROP WINDOW-TYPE :TITLE)))

                  (IL:* IL:|;;| 
             "interpret the TITLE property of the window type of the placement this PEP represents")

                  (COND
                     ((NULL TITLE)

                      (IL:* IL:|;;| "if none specified, just print the name of the type")

                      (PRINT-PEP-TITLE-STRING (STRING (WINDOW-TYPE-NAME WINDOW-TYPE))
                             (PEP-SCALED-REGION PEP)
                             DSP :NO-TITLE-BAR? (PLACEMENT-SHRUNKEN? (PEP-PLACEMENT PEP))))
                     ((STRINGP TITLE)

                      (IL:* IL:|;;| "if it's a string, print it")

                      (PRINT-PEP-TITLE-STRING TITLE (PEP-SCALED-REGION PEP)
                             DSP :NO-TITLE-BAR? (PLACEMENT-SHRUNKEN? (PEP-PLACEMENT PEP))))
                     (T 
                        (IL:* IL:|;;| "otherwise assume it's a function & call it")

                        (FUNCALL TITLE (PEP-PLACEMENT PEP)
                               (PEP-SCALED-REGION PEP)
                               DSP)))))))

(DEFUN PRINT-PEP-TITLE-STRING (STRING REGION DSP &KEY (FONT *PEP-TITLE-FONT*)
                                         NO-TITLE-BAR?)

(IL:* IL:|;;;| "prints STRING in the top left corner of REGION if it will fit.")

   (LET* ((STRING (IF (STRINGP STRING)
                      STRING
                      (PRINC-TO-STRING STRING)))
          (FONT-HEIGHT (IL:FONTHEIGHT FONT))
          (TITLE-Y (- (+ (REGION-BOTTOM REGION)
                         (REGION-HEIGHT REGION))
                      FONT-HEIGHT
                      (IF NO-TITLE-BAR?
                          1
                          0)))
          (STRING-WIDTH (IL:STRINGWIDTH STRING FONT)))
         (WHEN (AND (< STRING-WIDTH (- (REGION-WIDTH REGION)
                                       2))
                    (< FONT-HEIGHT (- (REGION-HEIGHT REGION)
                                      2)))
             (UNLESS NO-TITLE-BAR?
                 (IL:BLTSHADE IL:BLACKSHADE DSP (REGION-LEFT REGION)
                        (1- TITLE-Y)
                        (REGION-WIDTH REGION)
                        FONT-HEIGHT
                        'IL:PAINT))
             (IL:DSPOPERATION (IF NO-TITLE-BAR?
                                  'IL:PAINT
                                  'IL:INVERT)
                    DSP)
             (IL:DSPFONT FONT DSP)
             (IL:MOVETO (+ (REGION-LEFT REGION)
                           (IF NO-TITLE-BAR?
                               (- (FLOOR (REGION-WIDTH REGION)
                                         2)
                                  (FLOOR STRING-WIDTH 2))
                               2))
                    (IF NO-TITLE-BAR?
                        (+ (REGION-BOTTOM REGION)
                           (- (FLOOR (REGION-HEIGHT REGION)
                                     2)
                              (FLOOR FONT-HEIGHT 2))
                           (IL:FONTDESCENT FONT))
                        (+ TITLE-Y (IL:FONTDESCENT FONT)))
                    DSP)
             (CHECK-TYPE DSP STREAM)
             (IL:\\SOUT STRING DSP)
             (IL:DSPOPERATION 'IL:REPLACE DSP))))

(DEFPARAMETER *DISPLAY-PE-DEPTH* 1
   "Depth to recursivly display placement editors within placement editors")

(DEF-WINDOW-TYPE :PLACEMENT-EDITOR :RECOGNIZER (LAMBDA (WINDOW)
                                                          (PLACEMENT-EDITOR-P (IL:WINDOWPROP WINDOW 
                                                                                    :PLACEMENT-EDITOR
                                                                                     )))
   :ABSTRACTER (LAMBDA (WINDOW)
                      (LET ((PE (IL:WINDOWPROP WINDOW :PLACEMENT-EDITOR)))
                           (WHEN PE
                               `(:REGION ,(EXTERNALIZE-REGION (WINDOW-REGION (PE-WINDOW PE)))
                                       :ROOM-NAME
                                       ,(PE-ROOM-NAME (IL:WINDOWPROP WINDOW :PLACEMENT-EDITOR))))))
   :RECONSTITUTER (LAMBDA (PLIST)
                         (PE-WINDOW (GET-PE (GETF PLIST :ROOM-NAME)
                                           (INTERNALIZE-REGION (GETF PLIST :REGION)))))
   :TITLE (LAMBDA (PLACEMENT REGION DSP)
                 (LET ((PE (IL:WINDOWPROP (PLACEMENT-WINDOW PLACEMENT)
                                  :PLACEMENT-EDITOR)))
                      (WHEN PE
                          (PRINT-PEP-TITLE-STRING (LET ((NAME (PE-ROOM-NAME PE)))
                                                           (IF (STRINGP NAME)
                                                               NAME
                                                               (PRINC-TO-STRING NAME)))
                                 REGION DSP)

(IL:* IL:\| "(when (> *display-pe-depth* 0) (let ((*display-pe-depth* (1- *display-pe-depth*)) (old-scale (pe-scale pe)) (old-peps (pe-peps pe)) (old-clipping-region (pe-clipping-region pe)) (new-clipping-region (make-region :left (+ (region-left region) 1) :bottom (+ (region-bottom region) 1) :width (- (region-width region) 2) :height (- (region-height region) 2 (il:fontheight *pep-title-font*))))) (unwind-protect (progn (setf (pe-scale pe) (make-scale new-clipping-region)) (setf (pe-changed? pe) t) (setf (pe-clipping-region pe) new-clipping-region) (update-peps pe) (il:* il:|;;| \"recursively display pictogram\") (display-peps pe dsp)) (setf (pe-scale pe) old-scale) (setf (pe-peps pe) old-peps) (setf (pe-clipping-region pe) old-clipping-region))))")

                          ))))

(DEFUN PE-RIGHTBUTTONFN (WINDOW)
   (UNLESS (EQ *CURRENT-ROOM* *OVERVIEW-ROOM*)
          (IL:DOWINDOWCOM WINDOW)))

(DEFUN PE-BUTTONEVENTFN (WINDOW)
   (IL:TOTOPW WINDOW)
   (LET ((PE (IL:WINDOWPROP WINDOW :PLACEMENT-EDITOR)))
        (IF (IL:INSIDEP (PE-CLIPPING-REGION PE)
                   (IL:LASTMOUSEX WINDOW)
                   (IL:LASTMOUSEY WINDOW))
            (PE-BUTTONEVENTFN-INTERNAL PE WINDOW)
            (UNLESS (EQ *CURRENT-ROOM* *OVERVIEW-ROOM*)
                (CASE (MENU '(("ReFetch" :RE-FETCH)))
                    (:RE-FETCH (UPDATE-PLACEMENTS)))))))

(DEFUN PE-BUTTONEVENTFN-INTERNAL (PE WINDOW)
   (LET ((WINDOW WINDOW)
         (PE PE))
        (LOOP (WHEN (AND (PLACEMENT-EDITOR-P PE)
                         (PE-TRACK-MOUSE PE WINDOW))
                    (RETURN))
              (PE-GETMOUSESTATE)
              (UNLESS (IL:LASTMOUSESTATE (OR IL:LEFT IL:MIDDLE))
                     (RETURN))
              (SETQ WINDOW (IL:WHICHW))
              (SETQ PE (WHEN WINDOW (IL:WINDOWPROP WINDOW :PLACEMENT-EDITOR))))))

(DEFUN PE-TRACK-MOUSE (PE WINDOW)
   (LET ((*TIMER* (IL:SETUPTIMER *BUTTON-HELP-DELAY*)))
        (DECLARE (SPECIAL *TIMER*))
        (COND
           ((IL:LASTMOUSESTATE (IL:ONLY IL:LEFT))
            (LET ((SELECTED-PEP (PE-TRACK-LEFT-BUTTON PE)))
                 (WHEN SELECTED-PEP
                     (PEP-SELECTED SELECTED-PEP PE)

                     (IL:* IL:|;;| "return true when something's been selected")

                     T)))
           ((IL:LASTMOUSESTATE IL:MIDDLE)
            (LET ((ROOM-SELECTED? (PE-TRACK-MIDDLE-BUTTON PE)))
                 (WHEN ROOM-SELECTED?
                     (PE-ROOM-SELECTED PE)

                     (IL:* IL:|;;| "return true when something's been selected")

                     T))))))

(DEFUN PE-GETMOUSESTATE ()

   (IL:* IL:|;;| "call GETMOUSESTATE, and if the mouse hasn't moved, block.  This is in case we're in the Overview, so the keyboard watcher will run.")

   (LET ((X IL:LASTMOUSEX)
         (Y IL:LASTMOUSEY))
        (IL:GETMOUSESTATE)
        (WHEN (AND (= X IL:LASTMOUSEX)
                   (= Y IL:LASTMOUSEY))
              (IL:BLOCK))))

(DEFUN PE-TRACK-LEFT-BUTTON (PE)
   (DECLARE (SPECIAL *TIMER*))
   (LET ((SELECTED-PEP NIL)
         (CLIPPING-REGION (PE-CLIPPING-REGION PE))
         (WINDOW (PE-WINDOW PE))

         (IL:* IL:|;;| "need PEPS in top down order to handle occlusion correctly")

         (PEPS (REVERSE (PE-PEPS PE))))
        (MACROLET ((INVERT-SELECTED-PEP NIL `(LET ((REGION (PEP-SCALED-REGION SELECTED-PEP)))
                                                  (IL:BLTSHADE IL:BLACKSHADE WINDOW (REGION-LEFT
                                                                                     REGION)
                                                         (REGION-BOTTOM REGION)
                                                         (REGION-WIDTH REGION)
                                                         (REGION-HEIGHT REGION)
                                                         'IL:INVERT CLIPPING-REGION))))
               (LOOP (UNLESS (AND (IL:LASTMOUSESTATE (IL:ONLY IL:LEFT))
                                  (IL:INSIDEP CLIPPING-REGION (IL:LASTMOUSEX WINDOW)
                                         (IL:LASTMOUSEY WINDOW)))
                         (RETURN (WHEN SELECTED-PEP

                                     (IL:* IL:|;;| "restore the display")

                                     (INVERT-SELECTED-PEP)
                                     (WHEN (AND (NOT (IL:LASTMOUSESTATE IL:MIDDLE))
                                                (IL:INSIDEP CLIPPING-REGION (IL:LASTMOUSEX WINDOW)
                                                       (IL:LASTMOUSEY WINDOW)))

                                         (IL:* IL:|;;| 
                   "return the PEP if there's one selected & the button event fn should be exited.")

                                         SELECTED-PEP))))
                     (DOLIST 
                             (IL:* IL:|;;| "look down the occlusion stack")
(PEP PEPS (WHEN SELECTED-PEP

              (IL:* IL:|;;| "bottomed out -- must be in the background")

              (IL:* IL:|;;| "have to de-select selection")

              (INVERT-SELECTED-PEP)
              (SETQ SELECTED-PEP NIL)))
                         (WHEN (IL:INSIDEP (PEP-SCALED-REGION PEP)
                                      (IL:LASTMOUSEX WINDOW)
                                      (IL:LASTMOUSEY WINDOW))

                             (IL:* IL:|;;| "we're in a PEP")

                             (UNLESS (EQ PEP SELECTED-PEP)

                                 (IL:* IL:|;;| "it's a new selection")

                                 (WHEN SELECTED-PEP

                                     (IL:* IL:|;;| "unselect the current selection")

                                     (INVERT-SELECTED-PEP))

                                 (IL:* IL:|;;| "select the new one")

                                 (SETQ SELECTED-PEP PEP)
                                 (INVERT-SELECTED-PEP))

                             (IL:* IL:|;;| "pop to the outer loop")

                             (RETURN)))
                     (WHEN (AND *TIMER* (IL:TIMEREXPIRED? *TIMER*))
                         (NOTIFY-USER "Use LEFT to select placements, MIDDLE Rooms.")
                         (IL:TOTOPW WINDOW T)
                         (SETQ *TIMER* NIL))
                     (PE-GETMOUSESTATE)))))

(DEFUN PE-TRACK-MIDDLE-BUTTON (PE)
   (DECLARE (SPECIAL *TIMER*))
   (LET* ((WINDOW (PE-WINDOW PE))
          (REGION (WINDOW-REGION WINDOW)))
         (UNWIND-PROTECT
             (PROGN (IL:INVERTW WINDOW)
                    (LOOP (UNLESS (IL:INSIDEP REGION IL:LASTMOUSEX IL:LASTMOUSEY)

                              (IL:* IL:|;;| "return NIL if mouse leaves clipping region")

                              (RETURN NIL))
                          (UNLESS (IL:LASTMOUSESTATE IL:MIDDLE)

                              (IL:* IL:|;;| "return true iff room was selected")

                              (RETURN (NOT (IL:LASTMOUSESTATE (OR IL:LEFT IL:RIGHT)))))
                          (WHEN (AND *TIMER* (IL:TIMEREXPIRED? *TIMER*))
                              (NOTIFY-USER "Use LEFT to select placements, MIDDLE Rooms.")
                              (IL:TOTOPW WINDOW T)
                              (SETQ *TIMER* NIL))
                          (PE-GETMOUSESTATE)))
             (IL:INVERTW WINDOW))))

(DEFUN PEP-GETBOXPOSITION (PE PEP)

(IL:* IL:|;;;| 
"called when a placement is MOVE or COPY selected to get the new position for the placement.")

(IL:* IL:|;;;| "returns two values - a position and a PE - or NIL")

   (LET* ((OLD-CURSOR (IL:CURSOR))
          (OLD-TTY (IL:TTY.PROCESS)))
         (UNWIND-PROTECT
             (PROGN (IL:CURSOR IL:CROSSHAIRS)
                    (IL:TTY.PROCESS (IL:THIS.PROCESS))
                    (IL:CURSORPOSITION (MAKE-POSITION (REGION-LEFT (PEP-SCALED-REGION PEP))
                                              (REGION-BOTTOM (PEP-SCALED-REGION PEP)))
                           (PE-WINDOW PE))
                    (DO* ((PLACED-REGION (PLACED-REGION (PEP-PLACEMENT PEP)))
                          (HEIGHT (REGION-HEIGHT PLACED-REGION))
                          (WIDTH (REGION-WIDTH PLACED-REGION))
                          (WINDOW NIL 

                                 (IL:* IL:|;;| "the window the cursor is over (if any)")

                                 (IL:WHICHW))
                          (PE NIL 

                              (IL:* IL:|;;| "the PE the cursor is over (if any)")

                              (IF (AND WINDOW (PE-WINDOW-P WINDOW))
                                  (IL:WINDOWPROP WINDOW :PLACEMENT-EDITOR)))
                          (POSITION NIL 

                                 (IL:* IL:|;;| "the selected position within PE (if any)")

                                 (IF PE
                                     (LET ((CLIPPING-REGION (PE-CLIPPING-REGION PE))
                                           (SCALE (PE-SCALE PE)))
                                          (IF (IL:INSIDEP CLIPPING-REGION (IL:LASTMOUSEX WINDOW)
                                                     (IL:LASTMOUSEY WINDOW))

                                              (IL:* IL:|;;| "have to rescale box for each PE")

                                              (PEP-GETBOXPOSITION-INTERNAL (SCALE-WIDTH WIDTH 
                                                                                      SCALE)
                                                     (SCALE-HEIGHT HEIGHT SCALE)
                                                     (PE-CLIPPING-REGION PE)
                                                     WINDOW)
                                              (IL:GETMOUSESTATE)))
                                     (IL:GETMOUSESTATE))))
                         ((OR POSITION (IL:LASTMOUSESTATE (OR IL:LEFT IL:MIDDLE IL:RIGHT)))
                          (WHEN POSITION
                              (VALUES (UN-SCALE-POSITION POSITION (PE-SCALE PE))
                                     PE)))))
             (IL:CURSOR OLD-CURSOR)
             (IL:TTY.PROCESS OLD-TTY))))

(DEFUN PEP-GETBOXPOSITION-INTERNAL (WIDTH HEIGHT CLIPPING-REGION WINDOW)

(IL:* IL:|;;;| "track a box WIDTH by HEIGHT within CLIPPING-REGION in WINDOW.  if a button goes down return the X,Y position.  if cursor goes outside CLIPPING-REGION then return NIL.")

   (LET* ((DSP (IL:GETSTREAM WINDOW))
          (OLD-OPERATION (IL:DSPOPERATION NIL DSP))
          (LAST-X (IL:LASTMOUSEX DSP))
          (LAST-Y (IL:LASTMOUSEY DSP)))
         (MACROLET ((INVERT-BOX NIL `(IL:DRAWGRAYBOX LAST-X LAST-Y (+ LAST-X WIDTH)
                                            (+ LAST-Y HEIGHT)
                                            DSP IL:GRAYSHADE)))
                (UNWIND-PROTECT
                    (PROGN (IL:TOTOPW WINDOW)
                           (IL:DSPOPERATION 'IL:INVERT DSP)
                           (INVERT-BOX)
                           (TAGBODY LOOP (UNLESS (IL:INSIDEP CLIPPING-REGION LAST-X LAST-Y)
                                                (RETURN-FROM PEP-GETBOXPOSITION-INTERNAL))
                                  (WHEN (IL:MOUSESTATE (OR IL:LEFT IL:MIDDLE IL:RIGHT))
                                      (RETURN-FROM PEP-GETBOXPOSITION-INTERNAL (MAKE-POSITION LAST-X
                                                                                      LAST-Y)))
                                  (UNLESS (AND (= (IL:LASTMOUSEX DSP)
                                                  LAST-X)
                                               (= (IL:LASTMOUSEY DSP)
                                                  LAST-Y))
                                      (IL:UNINTERRUPTABLY

                                          (IL:* IL:|;;| "un-draw old")

                                          (INVERT-BOX)
                                          (SETQ LAST-X (IL:LASTMOUSEX DSP))
                                          (SETQ LAST-Y (IL:LASTMOUSEY DSP))

                                          (IL:* IL:|;;| "re-draw new")

                                          (INVERT-BOX)))
                                  (GO LOOP)))
                    (INVERT-BOX)
                    (IL:DSPOPERATION OLD-OPERATION DSP)))))



(IL:* IL:\; "editing")


(DEFUN PE-ROOM-CHANGED-FN (ROOM REASON)
   (WHEN (EQ REASON :DELETED)

       (IL:* IL:|;;| "if ROOM has been deleted then delete the placement editor")

       (LET ((PE (FIND-PE (ROOM-NAME ROOM))))
            (WHEN PE
                (LET ((WINDOW (PE-WINDOW PE)))

                     (IL:* IL:|;;| "delete the placement editor")

                     (UN-HIDE-WINDOW WINDOW)
                     (CLOSE-WINDOW WINDOW)
                     (REMHASH (ROOM-NAME ROOM)
                            *PLACEMENT-EDITORS*)))))
   (LET ((INCLUDERS (ROOM-INCLUDERS ROOM T)))

        (IL:* IL:|;;| "ensure PE's for all rooms which include ROOM will be redisplayed")

        (DOLIST (INCLUDER INCLUDERS)
            (LET ((PE (FIND-PE (ROOM-NAME INCLUDER))))
                 (WHEN PE

                     (IL:* IL:|;;| "otherwise mark it as needing update")

                     (UNLESS (EQ (PE-CHANGED? PE)
                                 T)

                         (IL:* IL:|;;| "OK to upgrade :PLACEMENTS to T, but not vice versa")

                         (SETF (PE-CHANGED? PE)
                               (IF (EQ REASON :PLACEMENTS)
                                   REASON
                                   T)))
                     (LET ((WINDOW (PE-WINDOW PE)))
                          (WHEN (AND (IL:OPENWP WINDOW)
                                     (NOT (WINDOW-HIDDEN? WINDOW)))

                              (IL:* IL:|;;| "update the PE if it's visible")

                              (UPDATE-PE PE))))))))

(DEFUN PEP-SELECTED (PEP PE)

(IL:* IL:|;;;| "called when a placement is selected in PE")

   (LET ((OP (COND
                ((COPY-KEY-DOWN-P)
                 :COPY)
                ((MOVE-KEY-DOWN-P)
                 :MOVE)
                ((DELETE-KEY-DOWN-P)
                 :DELETE)
                ((EXPAND-KEY-DOWN-P)
                 :EXPAND)
                (T (OV-OPERATION)))))
        (CASE OP
            ((:COPY :MOVE) (PEP-SELECTED-COPY-OR-MOVE OP PEP PE))
            (:DELETE (INTERACTIVE-CLOSE-WINDOW (PLACEMENT-WINDOW (PEP-PLACEMENT PEP))
                            (ROOM-NAMED (PE-ROOM-NAME PE))))
            (:EXPAND (EXPAND-PLACEMENT (PEP-PLACEMENT PEP)))
            (T (NOTIFY-USER "Use a modifier (eg. COPY, MOVE or DELETE)")))))

(DEFUN EXPAND-PLACEMENT (PLACEMENT)
   (LET ((WINDOW (PLACEMENT-WINDOW PLACEMENT)))
        (IF (WINDOW-HIDDEN? WINDOW)
            (PROGN (NOTIFY-USER "Click LEFT when finished")
                   (PLACE-PLACEMENT PLACEMENT)
                   (LOOP (WHEN (IL:MOUSESTATE IL:LEFT)
                               (RETURN)))
                   (HIDE-WINDOW WINDOW))
            (IL:FLASHWINDOW (IF (SHRUNKEN? WINDOW)
                                (WINDOW-ICON WINDOW)
                                WINDOW)))))

(DEFUN PEP-SELECTED-COPY-OR-MOVE (OP PEP PE)
   (MULTIPLE-VALUE-BIND (DESTINATION-POS DESTINATION-PE)
          (PEP-GETBOXPOSITION PE PEP)
          (IF DESTINATION-POS
              (LET* ((OLD-PLACEMENT (PEP-PLACEMENT PEP))
                     (NEW-PLACEMENT (COPY-PLACEMENT OLD-PLACEMENT)))

                    (IL:* IL:|;;| "adjust the position of the new placement")

                    (IF (PLACEMENT-SHRUNKEN? NEW-PLACEMENT)
                        (SETF (PLACEMENT-ICON-POSITION NEW-PLACEMENT)
                              DESTINATION-POS)
                        (SETF (PLACEMENT-REGION NEW-PLACEMENT)
                              (MAKE-REGION :LEFT (POSITION-X DESTINATION-POS)
                                     :BOTTOM
                                     (POSITION-Y DESTINATION-POS)
                                     :WIDTH
                                     (REGION-WIDTH (PLACEMENT-REGION NEW-PLACEMENT))
                                     :HEIGHT
                                     (REGION-HEIGHT (PLACEMENT-REGION NEW-PLACEMENT)))))

                    (IL:* IL:|;;| "do the move/copy")

                    (LET ((PE-ROOM (ROOM-NAMED (PE-ROOM-NAME PE)))
                          (DESTINATION-ROOM (ROOM-NAMED (PE-ROOM-NAME DESTINATION-PE))))
                         (MULTIPLE-VALUE-BIND (PLACEMENT SOURCE-ROOM)

                                (IL:* IL:|;;| "find the room this placement is due to")

                                (FIND-PLACEMENT (PLACEMENT-WINDOW OLD-PLACEMENT)
                                       PE-ROOM)
                                (ECASE OP
                                    (:MOVE 
                                       (IF (EQ PE DESTINATION-PE)

                                           (IL:* IL:|;;| 
"Allow inherited placements to be moved in place -- w/o moving them to the room they're visible in.")

                                           (SETQ DESTINATION-ROOM SOURCE-ROOM)
                                           (UNLESS (EQ DESTINATION-ROOM SOURCE-ROOM)

                                 (IL:* IL:|;;| "We don't bother deleting first when source & destination are same, as we know ADD-PLACEMENT will delete the old & we only want to redisplay once")

                                               (DELETE-PLACEMENT PLACEMENT SOURCE-ROOM)))
                                       (ADD-PLACEMENT NEW-PLACEMENT DESTINATION-ROOM))
                                    (:COPY (ADD-PLACEMENT NEW-PLACEMENT DESTINATION-ROOM))))))
              (NOTIFY-USER "Invalid destination."))))

(DEFUN PE-ROOM-SELECTED (PE)

(IL:* IL:|;;;| "called when a room is selected in PE")

   (LET ((ROOM (ROOM-NAMED (PE-ROOM-NAME PE)))
         (OP (COND
                ((IL:KEYDOWNP 'IL:SPACE)
                 :ENTER)
                ((EDIT-KEY-DOWN-P)
                 :EDIT)
                ((COPY-KEY-DOWN-P)
                 :COPY)
                ((MOVE-KEY-DOWN-P)
                 :MOVE)
                ((DELETE-KEY-DOWN-P)
                 :DELETE)
                (T (IF (EQ *CURRENT-ROOM* *OVERVIEW-ROOM*)
                       (OV-OPERATION)
                       :ENTER)))))
        (CASE OP
            (:EDIT (EDIT-ROOM ROOM))
            (:COPY (INTERACTIVE-COPY-ROOM ROOM))
            (:MOVE (INTERACTIVE-RENAME-ROOM ROOM))
            (:DELETE (INTERACTIVE-DELETE-ROOM ROOM))
            (:ENTER (GO-TO-ROOM ROOM))
            (T (NOTIFY-USER "Use a modifier (eg. COPY, DELETE or GO TO).")))))
(EVAL-WHEN (LOAD)

(PUSHNEW 'PE-ROOM-CHANGED-FN *ROOM-CHANGED-FUNCTIONS*)
)
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY

(IL:GLOBALVARS IL:TINYFONT IL:CROSSHAIRS)
)
(IL:PUTPROPS IL:ROOMS-PLACEMENT-EDITOR IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (3759 4733 (GET-PE 3759 . 4733)) (4735 6041 (MAKE-PE 4735 . 6041)) (6124 6221 (
PE-WINDOW-P 6124 . 6221)) (6223 6347 (PE-CLOSEFN 6223 . 6347)) (6349 6596 (PE-REPAINTFN 6349 . 6596)) 
(6598 6842 (PE-RESHAPEFN 6598 . 6842)) (6844 7076 (PE-TOTOPFN 6844 . 7076)) (7078 7160 (UPDATE-PE? 
7078 . 7160)) (7162 8216 (UPDATE-PE 7162 . 8216)) (8218 10796 (UPDATE-PEPS 8218 . 10796)) (10798 11411
 (UPDATE-PEP-SAVE-BITMAP 10798 . 11411)) (11413 12431 (UPDATE-PE-WINDOW 11413 . 12431)) (12433 13407 (
PLACED-REGION 12433 . 13407)) (14005 14813 (DISPLAY-PEPS 14005 . 14813)) (14815 16050 (SAVE-PEP-IMAGE 
14815 . 16050)) (16052 17720 (DISPLAY-PE-TITLE 16052 . 17720)) (17722 18313 (DISPLAY-PE-BORDER 17722
 . 18313)) (18315 18788 (DISPLAY-PEP 18315 . 18788)) (18790 20194 (PRINT-PEP-TITLE 18790 . 20194)) (
20196 22323 (PRINT-PEP-TITLE-STRING 20196 . 22323)) (24746 24865 (PE-RIGHTBUTTONFN 24746 . 24865)) (
24867 25335 (PE-BUTTONEVENTFN 24867 . 25335)) (25337 25819 (PE-BUTTONEVENTFN-INTERNAL 25337 . 25819)) 
(25821 26598 (PE-TRACK-MOUSE 25821 . 26598)) (26600 26977 (PE-GETMOUSESTATE 26600 . 26977)) (26979 
30354 (PE-TRACK-LEFT-BUTTON 26979 . 30354)) (30356 31384 (PE-TRACK-MIDDLE-BUTTON 30356 . 31384)) (
31386 34182 (PEP-GETBOXPOSITION 31386 . 34182)) (34184 36348 (PEP-GETBOXPOSITION-INTERNAL 34184 . 
36348)) (36381 37953 (PE-ROOM-CHANGED-FN 36381 . 37953)) (37955 38730 (PEP-SELECTED 37955 . 38730)) (
38732 39248 (EXPAND-PLACEMENT 38732 . 39248)) (39250 41851 (PEP-SELECTED-COPY-OR-MOVE 39250 . 41851)) 
(41853 42775 (PE-ROOM-SELECTED 41853 . 42775)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-PLACEMENT-EDITOR.DFASL b/rooms/ROOMS-PLACEMENT-EDITOR.DFASL
new file mode 100644
index 00000000..b6957b64
Binary files /dev/null and b/rooms/ROOMS-PLACEMENT-EDITOR.DFASL differ
diff --git a/rooms/ROOMS-SUITES b/rooms/ROOMS-SUITES
new file mode 100644
index 00000000..b73b145f
--- /dev/null
+++ b/rooms/ROOMS-SUITES
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:35:25" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-SUITES.;2| 25421  

      IL:|previous| IL:|date:| "17-Aug-90 13:29:14" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-SUITES.;1|)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMS-SUITESCOMS)

(IL:RPAQQ IL:ROOMS-SUITESCOMS
          ((FILE-ENVIRONMENTS IL:ROOMS-SUITES)
           (IL:P (EXPORT '(*SUITE-FILE-TYPE* *SUITE-DIRECTORIES* DEFSUITE))
                 (REQUIRE "ROOMS"))
           (IL:DEFINE-TYPES IL:SUITES)
           (IL:VARIABLES *DEFSUITE-VERSION* *SUITES* *SUITE-DIRECTORIES* *SUITE-FILE-TYPE*)
           (IL:P (PUSHNEW '(CLRHASH *SUITES*)
                        *RESET-FORMS* :TEST 'EQUAL))
           
           (IL:* IL:|;;| "loading suites")

           (IL:FUNCTIONS DEFSUITE MAKE-SUITE SUITE-ROOMS INSTALL-SUITE INSTALL-SUITE-BODY 
                  INSTALL-ROOM INSTALL-PLACEMENT)
           (IL:SEDIT-FORMATS DEFSUITE)
           
           (IL:* IL:|;;| "deleting suites")

           (IL:FUNCTIONS DELETE-SUITE)
           
           (IL:* IL:|;;| "constructing suites")

           (IL:FUNCTIONS DUMP-SUITE UPDATE-SUITE CONSTRUCT-DEFSUITE ALL-WINDOWS-IN-ROOMS 
                  CONSTRUCT-WINDOWS CONSTRUCT-FILES CONSTRUCT-PLACEMENTS)
           (IL:FUNCTIONS ROOMS-NOT-IN-ANY-SUITE FIND-SUITE-CONTAINING AUGMENT-SUITE 
                  DELETE-ROOM-FROM-SUITE)
           
           (IL:* IL:|;;| "interactive code")

           (IL:VARIABLES *SUITE-MENU-ITEMS* *SUITE-MENU*)
           (IL:FUNCTIONS SUITE-MENU INTERACTIVE-LOAD-SUITE INTERACTIVE-DUMP-SUITE 
                  INTERACTIVE-MAKE-SUITE INTERACTIVE-UPDATE-SUITE INTERACTIVE-DELETE-SUITE 
                  INTERACTIVE-SHOW-SUITE INTERACTIVE-AUGMENT-SUITE INTERACTIVE-DELETE-ROOM-FROM-SUITE
                  SELECT-SUITE PROMPT-FOR-SUITE-NAME)))

(DEFINE-FILE-ENVIRONMENT IL:ROOMS-SUITES :COMPILER :COMPILE-FILE
   :PACKAGE "ROOMS"
   :READTABLE "XCL")

(EXPORT '(*SUITE-FILE-TYPE* *SUITE-DIRECTORIES* DEFSUITE))

(REQUIRE "ROOMS")

(DEF-DEFINE-TYPE IL:SUITES "Room Suites")

(DEFCONSTANT *DEFSUITE-VERSION* 1)

(DEFGLOBALVAR *SUITES* (MAKE-HASH-TABLE :TEST 'EQUAL))

(DEFPARAMETER *SUITE-DIRECTORIES*

   (IL:* IL:|;;| "initially just the connected directory")

   (LIST T))

(DEFVAR *SUITE-FILE-TYPE* "SUITE")

(PUSHNEW '(CLRHASH *SUITES*)
       *RESET-FORMS* :TEST 'EQUAL)



(IL:* IL:|;;| "loading suites")


(DEFDEFINER (DEFSUITE (:UNDEFINER (LAMBDA (NAME)
                                             (REMHASH NAME *SUITES*)))) IL:SUITES (NAME &BODY BODY)
   `(INSTALL-SUITE ',NAME ',BODY))

(DEFUN MAKE-SUITE (SUITE-NAME ROOM-NAMES)
   (WHEN (SUITE-ROOMS SUITE-NAME)
       (CERROR "Delete all rooms in existing suite named ~S" "Attempt to redefine suite ~S" 
              SUITE-NAME)
       (DELETE-SUITE SUITE-NAME T))
   (SETF (SUITE-ROOMS SUITE-NAME)
         ROOM-NAMES)
   SUITE-NAME)

(DEFMACRO SUITE-ROOMS (SUITE-NAME)
   `(GETHASH ,SUITE-NAME *SUITES*))

(DEFUN INSTALL-SUITE (SUITE-NAME SUITE-BODY)

(IL:* IL:|;;;| "do the work of DEFSUITE.")

   (IL:* IL:|;;| "first check for suite redefinition.  MAKE-SUITE will do this for us, but by checking first we assure things will be left consistent should the user abort.")

   (WHEN (SUITE-ROOMS SUITE-NAME)
       (CERROR "Delete all rooms in existing suite named ~S" "Attempt to redefine suite ~S" 
              SUITE-NAME)
       (DELETE-SUITE SUITE-NAME T))
   (LET ((ROOM-NAMES (WITH-COLLECTION (DOLIST (SPEC SUITE-BODY)
                                          (CASE (FIRST SPEC)
                                              (:ROOM (COLLECT (SECOND SPEC))))))))
        (DOLIST (ROOM-NAME ROOM-NAMES)

            (IL:* IL:|;;| "check for room redefinitions.  MAKE-ROOM will do this again, but checking here leaves us in a much more consitstent state should the user choose to abort rather than continue.  ")

            (WHEN (ROOM-NAMED ROOM-NAME)
                (CERROR "Delete existing room named ~S (will close windows)" 
                       "A room named ~S already exists" ROOM-NAME)
                (DELETE-ROOM (ROOM-NAMED ROOM-NAME))))

        (IL:* IL:|;;| "make the rooms")

        (INSTALL-SUITE-BODY SUITE-BODY)

        (IL:* IL:|;;| "remember what rooms were in this suite")

        (MAKE-SUITE SUITE-NAME ROOM-NAMES)
        (CHECK-LOST-WINDOWS)))

(DEFUN INSTALL-SUITE-BODY (SUITE-BODY)
   (IL:WITH.MONITOR *MONITOR-LOCK*
       (LET ((WINDOWS (MAKE-HASH-TABLE))
             (VERSION NIL))

            (IL:* IL:|;;| "first load files & parse version")

            (DOLIST (SPEC SUITE-BODY)
                (ECASE (FIRST SPEC)
                    (:FILES (IL:DOFILESLOAD (REST SPEC)))
                    ((:WINDOW :ROOM) )
                    (:VERSION 
                       (SETQ VERSION (SECOND SPEC))
                       (WHEN (> VERSION *DEFSUITE-VERSION*)
                             (ERROR "DEFSUITE version ~S too high." VERSION)))))
            (UNLESS VERSION
                (WARN "No version found in DEFSUITE.  Presuming current.")
                (SETQ VERSION *DEFSUITE-VERSION*))

            (IL:* IL:|;;| "now make all the windows")

            (UPDATE-PLACEMENTS)
            (DOLIST (SPEC SUITE-BODY)
                (CASE (FIRST SPEC)
                    (:WINDOW (LET ((WINDOW (RECONSTITUTE-WINDOW (FOURTH SPEC)
                                                  (NTHCDR 4 SPEC))))
                                  (WHEN (IL:WINDOWP WINDOW)
                                      (SETF (GETHASH (SECOND SPEC)
                                                   WINDOWS)
                                            WINDOW)
                                      (UNLESS (FIND-PLACEMENT WINDOW)
                                             (HIDE-WINDOW WINDOW)))))))

            (IL:* IL:|;;| "finally make the rooms")

            (DOLIST (SPEC SUITE-BODY)
                (CASE (FIRST SPEC)
                    (:ROOM (APPLY #'INSTALL-ROOM WINDOWS (REST SPEC))))))))

(DEFUN INSTALL-ROOM (WINDOWS NAME &REST REST-KEYS &KEY PLACEMENTS &ALLOW-OTHER-KEYS)
   (APPLY 'MAKE-ROOM NAME :PLACEMENTS (WITH-COLLECTION (DOLIST (PLACEMENT-SPEC PLACEMENTS)
                                                           (LET ((PLACEMENT (APPLY 
                                                                                   #'
                                                                                    INSTALL-PLACEMENT
                                                                                   WINDOWS 
                                                                                   PLACEMENT-SPEC)))
                                                                (WHEN PLACEMENT (COLLECT PLACEMENT))))
                                             )
          (LET ((REST (COPY-LIST REST-KEYS)))
               (REMF REST :PLACEMENTS)
               REST)))

(DEFUN INSTALL-PLACEMENT (WINDOWS NAME &REST REST-KEYS &KEY REGION SHRUNKEN? ICON-POSITION 
                                    &ALLOW-OTHER-KEYS)
   (LET ((WINDOW (GETHASH NAME WINDOWS)))
        (WHEN WINDOW
            (MAKE-PLACEMENT-INTERNAL :WINDOW WINDOW :REGION (INTERNALIZE-REGION REGION)
                   :SHRUNKEN? SHRUNKEN? :ICON-POSITION (WHEN ICON-POSITION (INTERNALIZE-POSITION
                                                                            ICON-POSITION))
                   :PROPS
                   (LET ((PROPS (COPY-LIST REST-KEYS)))
                        (DOLIST (KEYWORD '(:REGION :SHRUNKEN? :ICON-POSITION))
                            (REMF PROPS KEYWORD))
                        PROPS)))))

(SEDIT:DEF-LIST-FORMAT DEFSUITE :ARGS (NIL :KEYWORD NIL)
   :INDENT (1))



(IL:* IL:|;;| "deleting suites")


(DEFUN DELETE-SUITE (SUITE-NAME &OPTIONAL ROOMS-TOO?)

   (IL:* IL:|;;| "delete all the rooms in the suite")

   (WHEN ROOMS-TOO?
       (DOLIST (ROOM-NAME (SUITE-ROOMS SUITE-NAME))
           (LET ((ROOM (ROOM-NAMED ROOM-NAME)))
                (WHEN ROOM (DELETE-ROOM ROOM)))))

   (IL:* IL:|;;| "delete the suite")

   (REMHASH SUITE-NAME *SUITES*))



(IL:* IL:|;;| "constructing suites")


(DEFUN DUMP-SUITE (SUITE-NAME &OPTIONAL QUIET?)
   (UPDATE-SUITE SUITE-NAME)

   (IL:* IL:|;;| "dump it to a file")

   (LET ((FILE (OR (FIRST (IL:WHEREIS SUITE-NAME 'IL:SUITES))
                   (INTERN (NAMESTRING (MAKE-PATHNAME :NAME (STRING-UPCASE SUITE-NAME)
                                              :TYPE *SUITE-FILE-TYPE* :HOST NIL :DEVICE NIL 
                                              :DIRECTORY NIL))
                          "IL")))
         FULL-NAME)
        (UNLESS (AND (IL:HASDEF FILE 'IL:FILES)
                     (IL:INFILECOMS? SUITE-NAME 'IL:SUITES (IL:FILECOMS FILE)))
            (IL:PUTDEF FILE 'FILE-ENVIRONMENTS `(DEFINE-FILE-ENVIRONMENT ,FILE :PACKAGE (DEFPACKAGE
                                                                                         "ROOMS"
                                                                                         (:USE "LISP"
                                                                                               "XCL")
                                                                                         (:SHADOW
                                                                                          CL:ROOM))
                                                   :READTABLE "XCL"
                                                   :COMPILER :COMPILE-FILE))
            (IL:PUTDEF FILE 'IL:FILES `(((IL:FILES IL:ROOMS)
                                         (FILE-ENVIRONMENTS ,FILE)
                                         (IL:SUITES ,SUITE-NAME)))))
        (UNLESS QUIET? (NOTIFY-USER "Making file ~A ..." FILE))
        (IL:ALLOW.BUTTON.EVENTS)
        (SETQ FULL-NAME (PATHNAME (IL:MAKEFILE FILE '(IL:FAST IL:NEW))))
        (UNLESS QUIET?
            (NOTIFY-USER "Made file ~A" (NAMESTRING FULL-NAME)))
        (SETQ IL:NOTCOMPILEDFILES (REMOVE FILE IL:NOTCOMPILEDFILES))
        (SETQ IL:NOTLISTEDFILES (REMOVE FILE IL:NOTLISTEDFILES))
        FULL-NAME))

(DEFUN UPDATE-SUITE (SUITE-NAME)
   (LET ((IL:DFNFLG 'IL:PROP))
        (IL:PUTDEF SUITE-NAME 'IL:SUITES (CONSTRUCT-DEFSUITE SUITE-NAME (SUITE-ROOMS 
                                                                                   SUITE-NAME)))))

(DEFUN CONSTRUCT-DEFSUITE (SUITE-NAME ROOM-NAMES)
   (LET* ((ROOMS (WITH-COLLECTION (DOLIST (NAME ROOM-NAMES)
                                      (LET ((ROOM (ROOM-NAMED NAME)))
                                           (IF ROOM
                                               (COLLECT ROOM)
                                               (WARN "No room named ~S exists." NAME))))))
          (WINDOW-NAMES (MAKE-HASH-TABLE))
          (WINDOW-ABSTRACTIONS (CONSTRUCT-WINDOWS (ALL-WINDOWS-IN-ROOMS ROOMS)
                                      WINDOW-NAMES)))
         `(DEFSUITE ,SUITE-NAME
             (:VERSION ,*DEFSUITE-VERSION*)
             (:FILES ,@(CONSTRUCT-FILES WINDOW-NAMES))
             ,@WINDOW-ABSTRACTIONS
             ,@(MAPCAR #'(LAMBDA (ROOM)
                                `(:ROOM ,(ROOM-NAME ROOM)
                                        :PLACEMENTS
                                        ,(CONSTRUCT-PLACEMENTS ROOM WINDOW-NAMES)
                                        :INCLUSIONS
                                        ,(ROOM-INCLUSIONS ROOM)
                                        :BACKGROUND
                                        ,(BACKGROUND-EXTERNAL-FORM (ROOM-BACKGROUND ROOM))
                                        ,@(ROOM-PROPS ROOM)))
                      ROOMS))))

(DEFUN ALL-WINDOWS-IN-ROOMS (ROOMS)

(IL:* IL:|;;;| "return a list containing all the windows in ROOMS")

   (UPDATE-PLACEMENTS)
   (LET (WINDOWS)
        (DOLIST (ROOM ROOMS)
            (DOLIST (PLACEMENT (ROOM-PLACEMENTS ROOM))
                (PUSHNEW (PLACEMENT-WINDOW PLACEMENT)
                       WINDOWS :TEST 'EQ)))
        (NREVERSE WINDOWS)))

(DEFUN CONSTRUCT-WINDOWS (WINDOWS WINDOW-NAMES)

(IL:* IL:|;;;| "construct the list of window abstractions for WINDOWS.  store a name for each window in WINDOW-NAMES. ")

   (WITH-COLLECTION (LET ((WINDOW-NUMBER 0))
                         (DOLIST (WINDOW WINDOWS)
                             (LET ((ABSTRACTION (ABSTRACT-WINDOW WINDOW)))
                                  (WHEN ABSTRACTION
                                      (COLLECT `(:WINDOW ,WINDOW-NUMBER ,@ABSTRACTION))
                                      (SETF (GETHASH WINDOW WINDOW-NAMES)
                                            WINDOW-NUMBER)
                                      (INCF WINDOW-NUMBER)))))))

(DEFUN CONSTRUCT-FILES (WINDOW-NAMES)

(IL:* IL:|;;;| "returns the appended list of all the :FILES properties of all the window types of all the windows in WINDOW-NAMES. ")

   (LET ((ALL-FILES NIL))
        (MAPHASH #'(LAMBDA (WINDOW NAME)
                          (DOLIST (FILE (WINDOW-TYPE-PROP (WINDOW-TYPE WINDOW)
                                               :FILES))
                              (PUSHNEW FILE ALL-FILES)))
               WINDOW-NAMES)
        (REVERSE ALL-FILES)))

(DEFUN CONSTRUCT-PLACEMENTS (ROOM WINDOW-NAMES)

   (IL:* IL:|;;| "construct a list of external representations for the placements in ROOM, using the hash table WINDOW-NAMES to name windows.  these external representations are installed by INSTALL-PLACEMENT")

   (WITH-COLLECTION (DOLIST (PLACEMENT (ROOM-PLACEMENTS ROOM))
                        (LET ((WINDOW-NAME (GETHASH (PLACEMENT-WINDOW PLACEMENT)
                                                  WINDOW-NAMES)))
                             (WHEN WINDOW-NAME

                                 (IL:* IL:|;;| 
                   "unnamed windows are ones that could not be abstracted -- we ignore them here. ")

                                 (COLLECT `(,WINDOW-NAME :REGION ,(EXTERNALIZE-REGION (
                                                                                     PLACEMENT-REGION
                                                                                       PLACEMENT))
                                                  ,@(WHEN (PLACEMENT-ICON-POSITION PLACEMENT)
                                                        (LIST :SHRUNKEN? (PLACEMENT-SHRUNKEN? 
                                                                                PLACEMENT)
                                                              :ICON-POSITION
                                                              (EXTERNALIZE-POSITION (
                                                                              PLACEMENT-ICON-POSITION
                                                                                     PLACEMENT))))
                                                  ,@(PLACEMENT-PROPS PLACEMENT))))))))

(DEFUN ROOMS-NOT-IN-ANY-SUITE (&OPTIONAL FOR-DELETION?)

(IL:* IL:|;;;| "returns a list of all the rooms which are not in any suite")

   (WITH-COLLECTION (DOLIST (ROOM (ALL-ROOMS T))
                        (LET ((NAME (ROOM-NAME ROOM)))
                             (UNLESS (OR (UNLESS FOR-DELETION?

                                             (IL:* IL:|;;| 
"Original & Pockets implicitly belong to the bootstrap suite & we don't want them added to others.")

                                             (OR (EQUAL NAME "Pockets")
                                                 (EQUAL NAME "Original")))
                                         (FIND-SUITE-CONTAINING NAME))
                                    (COLLECT ROOM))))))

(DEFUN FIND-SUITE-CONTAINING (ROOM-NAME)
   (MAPHASH #'(LAMBDA (SUITE-NAME ROOM-NAMES)
                     (WHEN (MEMBER ROOM-NAME ROOM-NAMES :TEST 'EQUAL)
                           (RETURN-FROM FIND-SUITE-CONTAINING SUITE-NAME)))
          *SUITES*))

(DEFUN AUGMENT-SUITE (SUITE-NAME ROOM-NAME)
   (PUSHNEW ROOM-NAME (SUITE-ROOMS SUITE-NAME)
          :TEST
          'EQUAL))

(DEFUN DELETE-ROOM-FROM-SUITE (ROOM-NAME SUITE-NAME)
   (SETF (SUITE-ROOMS SUITE-NAME)
         (DELETE ROOM-NAME (SUITE-ROOMS SUITE-NAME)
                :TEST
                'EQUAL)))



(IL:* IL:|;;| "interactive code")


(DEFGLOBALPARAMETER *SUITE-MENU-ITEMS*
   '(("Save Suite" '(WITH-BUTTON '(INTERACTIVE-DUMP-SUITE)
                           "Save Suite" "Save a set of rooms to a file")
            "Save a set of rooms to a file"
            (IL:SUBITEMS ("Update Suite" '(WITH-BUTTON '(INTERACTIVE-UPDATE-SUITE)
                                                 "Update Suite" "Update the DEFSUITE form of a suite"
                                                 )
                                "Update the DEFSUITE form of a suite")))
     ("Restore Suite" '(WITH-BUTTON '(INTERACTIVE-LOAD-SUITE)
                              "Restore Suite" "Load a set of rooms from a file")
            "Load a set of rooms from a file")
     ("Show Suite" '(WITH-BUTTON '(INTERACTIVE-SHOW-SUITE)
                           "Show Suite" "List the rooms in a suite")
            "List the rooms in a suite")
     ("Augment Suite" '(WITH-BUTTON '(INTERACTIVE-AUGMENT-SUITE)
                              "Augment Suite" "Add a room to a suite")
            "Add a room to a suite")
     ("Delete Suite" '(WITH-BUTTON '(INTERACTIVE-DELETE-SUITE)
                             "Delete Suite" "Delete a suite, and optionally all the rooms in it.")
            "Delete a suite, and optionally all the rooms in it."
            (IL:SUBITEMS ("Delete Room From Suite" '(WITH-BUTTON '(
                                                                 INTERACTIVE-DELETE-ROOM-FROM-SUITE
                                                                   )
                                                           "Delete Room From Suite"))))))

(DEFGLOBALVAR *SUITE-MENU* NIL)

(DEFUN SUITE-MENU ()
   (OR *SUITE-MENU* (SETQ *SUITE-MENU* (IL:CREATE IL:MENU
                                              IL:ITEMS IL:_ *SUITE-MENU-ITEMS*
                                              IL:TITLE IL:_ "Suites"
                                              IL:CENTERFLG IL:_ T)))
   (LET* ((ITEM (IL:MENU *SUITE-MENU*)))
         (WHEN ITEM                                          (IL:* IL:\; 
                                                         "to be 100% compatible w/ background menu")
             (IL:EVAL ITEM))))

(DEFUN INTERACTIVE-LOAD-SUITE ()
   (LET
    ((SUITE-NAME (PROMPT-FOR-SUITE-NAME)))
    (WHEN SUITE-NAME
        (IF (SUITE-ROOMS SUITE-NAME)
            (NOTIFY-USER "A suite named ~S already exists." SUITE-NAME)
            (LET
             ((FOUND (IL:FINDFILE (NAMESTRING (MERGE-PATHNAMES SUITE-NAME
                                                     (MAKE-PATHNAME :TYPE *SUITE-FILE-TYPE* 

                                                            (IL:* IL:|;;| 
                                                          "override default defaults")

                                                            :HOST NIL :DEVICE NIL :DIRECTORY NIL 
                                                            :VERSION NIL)
                                                     NIL))
                            T *SUITE-DIRECTORIES*)))
             (IF FOUND
                 (IL:ADD.PROCESS
                  `(FUNCALL ',#'(LAMBDA NIL (LET ((LOAD-COMPLETED? 'NIL))
                                                 (UNWIND-PROTECT
                                                     (PROGN (LOAD FOUND)
                                                            (SETQ LOAD-COMPLETED? T))
                                                     (LET ((WINDOW (IL:WFROMDS NIL T)))
                                                          (WHEN WINDOW (IL:CLOSEW WINDOW)))
                                                     (WHEN LOAD-COMPLETED? (NOTIFY-USER 
                                                                                 "Restored suite ~S."
                                                                                  SUITE-NAME))))))
                  'IL:NAME "Restore Suite")
                 (NOTIFY-USER "Can't find suite ~S on *SUITE-DIRECTORIES*" SUITE-NAME)))))))

(DEFUN INTERACTIVE-DUMP-SUITE ()
   (LET ((SUITE-NAME (SELECT-SUITE :REASON "Save" :ALLOW-NEW? T)))
        (WHEN SUITE-NAME
            (WITH-BUTTON `(IL:RESETFORM (IL:TTYDISPLAYSTREAM (GET-MESSAGE-STREAM))
                                 (DUMP-SUITE ',SUITE-NAME))
                   (FORMAT NIL "Save ~A" SUITE-NAME)
                   (FORMAT NIL "Save suite named ~S." SUITE-NAME)))))

(DEFUN INTERACTIVE-MAKE-SUITE ()
   (LET
    ((ROOMS (ROOMS-NOT-IN-ANY-SUITE)))
    (IF (NULL ROOMS)
        (NOTIFY-USER "All rooms are already in some suite.")
        (LET ((SUITE-NAME (PROMPT-FOR-SUITE-NAME)))
             (WHEN SUITE-NAME
                 (IF (SUITE-ROOMS SUITE-NAME)
                     (NOTIFY-USER "A suite named ~S already exists" SUITE-NAME)
                     (LET ((ROOM-NAMES (WITH-COLLECTION
                                        (NOTIFY-USER 
                                       "Select rooms to go in ~S.~%Click outside menu when finished."
                                               SUITE-NAME)
                                        (LOOP (WHEN (NULL ROOMS)
                                                    (RETURN))
                                              (LET ((ROOM (SELECT-ROOM :FROM-ROOMS ROOMS)))
                                                   (COND
                                                      (ROOM (SETQ ROOMS (DELETE ROOM ROOMS :TEST
                                                                               'EQ))
                                                            (COLLECT (ROOM-NAME ROOM)))
                                                      (T (RETURN))))))))
                          (WHEN ROOM-NAMES (MAKE-SUITE SUITE-NAME ROOM-NAMES)))))))))

(DEFUN INTERACTIVE-UPDATE-SUITE ()
   (LET ((SUITE-NAME (SELECT-SUITE :REASON "Update" :ALLOW-NEW? T)))
        (WHEN SUITE-NAME
            (WITH-BUTTON `(IL:RESETFORM (IL:TTYDISPLAYSTREAM (GET-MESSAGE-STREAM))
                                 (UPDATE-SUITE ',SUITE-NAME))
                   (FORMAT NIL "Update ~A" SUITE-NAME)
                   (FORMAT NIL "Update suite named ~S." SUITE-NAME)))))

(DEFUN INTERACTIVE-DELETE-SUITE ()
   (LET ((SUITE-NAME (SELECT-SUITE :REASON "Delete")))
        (WHEN (AND SUITE-NAME (CONFIRM "Delete suite ~S?" SUITE-NAME))
            (DELETE-SUITE SUITE-NAME (CONFIRM "Delete all rooms in ~S too? (will close windows)"
                                                SUITE-NAME))
            (NOTIFY-USER "Suite ~S deleted." SUITE-NAME))))

(DEFUN INTERACTIVE-SHOW-SUITE ()
   (LET ((SUITE-NAME (SELECT-SUITE :REASON "Show")))
        (WHEN SUITE-NAME
            (NOTIFY-USER "Suite ~S contains rooms:~{ ~S~}." SUITE-NAME (SUITE-ROOMS SUITE-NAME)))
        ))

(DEFUN INTERACTIVE-AUGMENT-SUITE ()
   (LET ((ROOMS (ROOMS-NOT-IN-ANY-SUITE)))
        (IF (NULL ROOMS)
            (NOTIFY-USER "All rooms are already in some suite.")
            (LET ((SUITE-NAME (SELECT-SUITE :REASON "Augment Suite")))
                 (WHEN SUITE-NAME
                     (NOTIFY-USER "Select room to add to suite ~S" SUITE-NAME)
                     (LET ((ROOM-NAME (SELECT-ROOM :FROM-ROOMS ROOMS :NAME-ONLY? T)))
                          (WHEN ROOM-NAME (AUGMENT-SUITE SUITE-NAME ROOM-NAME))))))))

(DEFUN INTERACTIVE-DELETE-ROOM-FROM-SUITE ()
   (LET ((SUITE-NAME (SELECT-SUITE :REASON "Delete room from")))
        (WHEN SUITE-NAME
            (LET ((ROOM-NAME (MENU (SUITE-ROOMS SUITE-NAME)
                                   "Select Room")))
                 (WHEN ROOM-NAME
                     (DELETE-ROOM-FROM-SUITE ROOM-NAME SUITE-NAME)
                     (NOTIFY-USER "Deleted room ~S from suite ~S." ROOM-NAME SUITE-NAME))))))

(DEFUN SELECT-SUITE (&KEY REASON ALLOW-NEW?)
   (LET ((ITEMS (WHEN ALLOW-NEW?
                    '(("<new suite>" :NEW)))))
        (MAPHASH #'(LAMBDA (SUITE-NAME SUITE-BODY)
                          (PUSH SUITE-NAME ITEMS))
               *SUITES*)
        (IF ITEMS
            (LET ((SUITE-NAME (MENU ITEMS REASON)))
                 (IF (AND ALLOW-NEW? (EQ SUITE-NAME :NEW))
                     (INTERACTIVE-MAKE-SUITE)
                     SUITE-NAME))
            (PROGN (NOTIFY-USER "No suites!")
                   NIL))))

(DEFUN PROMPT-FOR-SUITE-NAME (&OPTIONAL (PROMPT "Suite Name:"))
   (LET ((STRING (PROMPT-USER PROMPT)))
        (WHEN STRING (STRING-UPCASE STRING))))
(IL:PUTPROPS IL:ROOMS-SUITES IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (2846 3162 (MAKE-SUITE 2846 . 3162)) (3240 4653 (INSTALL-SUITE 3240 . 4653)) (4655 
6318 (INSTALL-SUITE-BODY 4655 . 6318)) (6320 7222 (INSTALL-ROOM 6320 . 7222)) (7224 7960 (
INSTALL-PLACEMENT 7224 . 7960)) (8081 8449 (DELETE-SUITE 8081 . 8449)) (8496 10464 (DUMP-SUITE 8496 . 
10464)) (10466 10726 (UPDATE-SUITE 10466 . 10726)) (10728 12059 (CONSTRUCT-DEFSUITE 10728 . 12059)) (
12061 12426 (ALL-WINDOWS-IN-ROOMS 12061 . 12426)) (12428 13114 (CONSTRUCT-WINDOWS 12428 . 13114)) (
13116 13615 (CONSTRUCT-FILES 13116 . 13615)) (13617 15321 (CONSTRUCT-PLACEMENTS 13617 . 15321)) (15323
 16081 (ROOMS-NOT-IN-ANY-SUITE 15323 . 16081)) (16083 16340 (FIND-SUITE-CONTAINING 16083 . 16340)) (
16342 16475 (AUGMENT-SUITE 16342 . 16475)) (16477 16675 (DELETE-ROOM-FROM-SUITE 16477 . 16675)) (18404
 18962 (SUITE-MENU 18404 . 18962)) (18964 20790 (INTERACTIVE-LOAD-SUITE 18964 . 20790)) (20792 21194 (
INTERACTIVE-DUMP-SUITE 20792 . 21194)) (21196 22561 (INTERACTIVE-MAKE-SUITE 21196 . 22561)) (22563 
22975 (INTERACTIVE-UPDATE-SUITE 22563 . 22975)) (22977 23367 (INTERACTIVE-DELETE-SUITE 22977 . 23367))
 (23369 23600 (INTERACTIVE-SHOW-SUITE 23369 . 23600)) (23602 24142 (INTERACTIVE-AUGMENT-SUITE 23602 . 
24142)) (24144 24600 (INTERACTIVE-DELETE-ROOM-FROM-SUITE 24144 . 24600)) (24602 25143 (SELECT-SUITE 
24602 . 25143)) (25145 25299 (PROMPT-FOR-SUITE-NAME 25145 . 25299)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-SUITES.DFASL b/rooms/ROOMS-SUITES.DFASL
new file mode 100644
index 00000000..bfe1474e
Binary files /dev/null and b/rooms/ROOMS-SUITES.DFASL differ
diff --git a/rooms/ROOMS-TEXT b/rooms/ROOMS-TEXT
new file mode 100644
index 00000000..96160854
--- /dev/null
+++ b/rooms/ROOMS-TEXT
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:27:41" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-TEXT.;2| 16532  

      IL:|previous| IL:|date:| "17-Aug-90 13:31:54" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-TEXT.;1|)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMS-TEXTCOMS)

(IL:RPAQQ IL:ROOMS-TEXTCOMS
          ((FILE-ENVIRONMENTS IL:ROOMS-TEXT)
           (IL:P (EXPORT '(*DEFAULT-TEXT-FONT* MAKE-TEXT DISPLAY-TEXT DEF-TEXT-SHADOWS 
                                 SET-TEXT-STRING)))
           (IL:STRUCTURES TEXT TEXT-SHADOW)
           (IL:VARIABLES *DEFAULT-TEXT-FONT* DEFAULT-TEXT-FONT--SMALL-SCREEN 
                  DEFAULT-TEXT-FONT--LARGE-SCREEN SMALL-SCREEN-WIDTH)
           (IL:FUNCTIONS MAKE-TEXT UPDATE-TEXT-CACHES COMPUTE-TEXT-DIMEMSIONS MAXIMIZE MINIMIZE 
                  DISPLAY-TEXT SET-TEXT-STRING SET-DEFAULT-TEXT-FONT)
           (IL:P (SET-DEFAULT-TEXT-FONT))
           (IL:FUNCTIONS 

                  (IL:* IL:|;;| "for back compatibility: buttons & pe's still call these two")

                  TEXT-%WIDTH TEXT-%HEIGHT)
           (IL:VARIABLES *TEXT-SHADOWS* *TEXT-SHADOW-FACTOR*)
           (IL:FUNCTIONS GET-TEXT-SHADOWS GET-TEXT-SHADOWS-INTERNAL MAKE-TEXT-SHADOWS 
                  EXTERNALIZE-TEXT-SHADOWS INTERNALIZE-TEXT-SHADOWS INTERNALIZE-TEXT-SHADOWS-INTERNAL
                  )
           
           (IL:* IL:|;;| "a definer for shadows")

           (IL:DEFINE-TYPES IL:TEXT-SHADOWS)
           (IL:FUNCTIONS DEF-TEXT-SHADOWS)
           (IL:TEXT-SHADOWS NIL :ARK)))

(DEFINE-FILE-ENVIRONMENT IL:ROOMS-TEXT :COMPILER :COMPILE-FILE
   :PACKAGE "ROOMS"
   :READTABLE "XCL")

(EXPORT '(*DEFAULT-TEXT-FONT* MAKE-TEXT DISPLAY-TEXT DEF-TEXT-SHADOWS SET-TEXT-STRING))

(DEFSTRUCT

(IL:* IL:|;;;| "specifies a bit of text for display")

    (TEXT (:CONSTRUCTOR MAKE-TEXT-INTERNAL)
              (:PRINT-FUNCTION (LAMBDA (TEXT STREAM DEPTH)
                                      (FORMAT STREAM "#<Text ~S>" (TEXT-STRING TEXT)))))
   (STRING "" :TYPE STRING)

   (IL:* IL:|;;| "the text to print.  use SET-TEXT-STRING to change this field.")

   (POSITION (MAKE-POSITION 0 0)
          :TYPE CONS)

   (IL:* IL:|;;| "where to print it")

   (ALIGNMENT :LEFT-BOTTOM :TYPE 

          (IL:* IL:|;;| "how to align it")

          (MEMBER :LEFT-BOTTOM :LEFT-TOP :CENTER :RIGHT-BOTTOM :RIGHT-TOP))

   (IL:* IL:|;;| "how to align it relative to POSITION")

   (FONT *DEFAULT-TEXT-FONT*)

   (IL:* IL:|;;| "font to use")

   (SHADOWS (MAKE-TEXT-SHADOWS *DEFAULT-TEXT-FONT*)
          :TYPE LIST)

   (IL:* IL:|;;| "a list of TEXT-SHADOW structures")

(IL:* IL:|;;;| "caches to speed redisplay")

   (%IMAGE NIL :TYPE BITMAP)
   (%MASK NIL :TYPE BITMAP))

(DEFSTRUCT TEXT-SHADOW

(IL:* IL:|;;;| "a specification of a call to IL:BITBLT.  a list of these is used to achieve special effects when displaying text.  the most common effect is that of shadowed text, hence the name TEXT-SHADOW.")

   (IL:* IL:|;;| "offset for this BLT")

   (DX 0 :TYPE INTEGER)
   (DY 0 :TYPE INTEGER)

   (IL:* IL:|;;| "args to IL:BITBLT")

   (SOURCE-TYPE 'IL:INPUT :TYPE (MEMBER IL:INPUT IL:INVERT IL:TEXTURE IL:MERGE))
   (OPERATION 'IL:PAINT :TYPE (MEMBER IL:PAINT IL:REPLACE IL:ERASE IL:INVERT))
   (TEXTURE 0 :TYPE TEXTURE))

(DEFVAR *DEFAULT-TEXT-FONT* NIL)

(DEFGLOBALPARAMETER DEFAULT-TEXT-FONT--SMALL-SCREEN (IL:FONTCREATE 'IL:HELVETICA 10 'IL:BOLD))

(DEFGLOBALPARAMETER DEFAULT-TEXT-FONT--LARGE-SCREEN (IL:FONTCREATE 'IL:HELVETICA 18 'IL:BOLD))

(DEFGLOBALPARAMETER SMALL-SCREEN-WIDTH 1400)

(DEFUN MAKE-TEXT (&KEY STRING (POSITION (MAKE-POSITION 0 0))
                           (ALIGNMENT :LEFT-BOTTOM)
                           (FONT *DEFAULT-TEXT-FONT*)
                           SHADOWS)

   (IL:* IL:|;;| "check args")

   (UNLESS (IL:POSITIONP POSITION)
          (ERROR "~S not a position" POSITION))
   (ECASE ALIGNMENT
       ((:LEFT-BOTTOM :LEFT-TOP :CENTER :RIGHT-BOTTOM :RIGHT-TOP) ))
   (CHECK-TYPE FONT FONT)
   (LET ((TEXT (MAKE-TEXT-INTERNAL :STRING STRING :POSITION POSITION :ALIGNMENT ALIGNMENT :FONT FONT
                      :SHADOWS (INTERNALIZE-TEXT-SHADOWS SHADOWS))))

        (IL:* IL:|;;| "fill in the caches")

        (UPDATE-TEXT-CACHES TEXT)
        TEXT))

(DEFUN UPDATE-TEXT-CACHES (TEXT)
   (LET* ((FONT (TEXT-FONT TEXT))
          (STRING-WIDTH (IL:STRINGWIDTH (TEXT-STRING TEXT)
                               FONT))
          (FONT-HEIGHT (IL:FONTHEIGHT FONT))
          (TEMP-BITMAP (IL:BITMAPCREATE STRING-WIDTH FONT-HEIGHT)))
         (LET ((DSP (IL:LOADTIMECONSTANT (IL:DSPCREATE))))

              (IL:* IL:|;;| "first put string into a temporary bitmap")

              (IL:DSPDESTINATION TEMP-BITMAP DSP)
              (IL:DSPFONT FONT DSP)
              (IL:MOVETO 0 (IL:FONTDESCENT FONT)
                     DSP)
              (PRINC (TEXT-STRING TEXT)
                     DSP))
         (MULTIPLE-VALUE-BIND (WIDTH HEIGHT X-OFFSET Y-OFFSET)
                (COMPUTE-TEXT-DIMEMSIONS TEXT STRING-WIDTH)
                (LET* ((OLD-IMAGE (TEXT-%IMAGE TEXT))
                       (IMAGE (IF (AND OLD-IMAGE (= HEIGHT (IL:BITMAPHEIGHT OLD-IMAGE))
                                       (= WIDTH (IL:BITMAPWIDTH OLD-IMAGE)))

                                  (IL:* IL:|;;| "OK to re-use bitmap")

                                  (PROGN (IL:BLTSHADE IL:WHITESHADE OLD-IMAGE 0 0 WIDTH HEIGHT)
                                         OLD-IMAGE)
                                  (IL:BITMAPCREATE WIDTH HEIGHT)))
                       (SHADOWS (GET-TEXT-SHADOWS TEXT))
                       (OLD-MASK (TEXT-%MASK TEXT))
                       (MASK (WHEN (CDR SHADOWS)             (IL:* IL:\; 
                                                           "don't need mask for simple shadows")
                                 (IF (AND OLD-MASK (= HEIGHT (IL:BITMAPHEIGHT OLD-MASK))
                                          (= WIDTH (IL:BITMAPWIDTH OLD-MASK)))

                                     (IL:* IL:|;;| "OK to re-use bitmap")

                                     (PROGN (IL:BLTSHADE IL:WHITESHADE OLD-MASK 0 0 WIDTH HEIGHT)
                                            OLD-MASK)
                                     (IL:BITMAPCREATE WIDTH HEIGHT)))))
                      (DOLIST (SHADOW (GET-TEXT-SHADOWS TEXT))
                          (IL:BITBLT TEMP-BITMAP 0 0 IMAGE (+ (TEXT-SHADOW-DX SHADOW)
                                                              X-OFFSET)
                                 (+ (TEXT-SHADOW-DY SHADOW)
                                    Y-OFFSET)
                                 STRING-WIDTH FONT-HEIGHT (TEXT-SHADOW-SOURCE-TYPE SHADOW)
                                 (TEXT-SHADOW-OPERATION SHADOW)
                                 (TEXT-SHADOW-TEXTURE SHADOW))
                          (WHEN MASK
                              (IL:BITBLT TEMP-BITMAP 0 0 MASK (+ X-OFFSET (TEXT-SHADOW-DX SHADOW))
                                     (+ Y-OFFSET (TEXT-SHADOW-DY SHADOW))
                                     STRING-WIDTH FONT-HEIGHT 'IL:SOURCE 'IL:PAINT)))
                      (SETF (TEXT-%IMAGE TEXT)
                            IMAGE)
                      (SETF (TEXT-%MASK TEXT)
                            MASK)
                      IMAGE))))

(DEFUN COMPUTE-TEXT-DIMEMSIONS (TEXT STRING-WIDTH)

(IL:* IL:|;;;| 
"compute & return width, height & offsets of TEXT, taking shadows into consideration.")

   (LET* ((SHADOWS (GET-TEXT-SHADOWS TEXT))
          (MAX-DX (MAXIMIZE (SHADOW SHADOWS)
                         (TEXT-SHADOW-DX SHADOW)))
          (MIN-DX (MINIMIZE (SHADOW SHADOWS)
                         (TEXT-SHADOW-DX SHADOW)))
          (MAX-DY (MAXIMIZE (SHADOW SHADOWS)
                         (TEXT-SHADOW-DY SHADOW)))
          (MIN-DY (MINIMIZE (SHADOW SHADOWS)
                         (TEXT-SHADOW-DY SHADOW))))
         (VALUES 

                (IL:* IL:|;;| "width")

                (+ STRING-WIDTH MAX-DX (- MIN-DX))

                (IL:* IL:|;;| "height")

                (+ (IL:FONTHEIGHT (TEXT-FONT TEXT))
                   MAX-DY
                   (- MIN-DY))

                (IL:* IL:|;;| "x-offset")

                (- MIN-DX)

                (IL:* IL:|;;| "y-offset")

                (- MIN-DY))))

(DEFMACRO MAXIMIZE ((VAR LIST)
                        FORM)
   `(LET ((SI::$MAX-VALUE$ NIL)
          (SI::$VALUE$ NIL))
         (DOLIST (,VAR ,LIST SI::$MAX-VALUE$)
             (SETQ SI::$VALUE$ ,FORM)
             (UNLESS (AND SI::$MAX-VALUE$ (> SI::$MAX-VALUE$ SI::$VALUE$))
                    (SETQ SI::$MAX-VALUE$ SI::$VALUE$)))))

(DEFMACRO MINIMIZE ((VAR LIST)
                        FORM)
   `(LET* ((SI::$MIN-VALUE$ NIL)
           (SI::$VALUE$ NIL))
          (DOLIST (,VAR ,LIST SI::$MIN-VALUE$)
              (SETQ SI::$VALUE$ ,FORM)
              (UNLESS (AND SI::$MIN-VALUE$ (< SI::$MIN-VALUE$ SI::$VALUE$))
                     (SETQ SI::$MIN-VALUE$ SI::$VALUE$)))))

(DEFUN DISPLAY-TEXT (TEXT DESTINATION &KEY SCALE MASK-ONLY)

(IL:* IL:|;;;| "print TEXT, a TEXT structure, to DESTINATION, a valid destination for IL:BITBLT.")

   (LET* ((POSITION (TEXT-POSITION TEXT))
          (ALIGNMENT (TEXT-ALIGNMENT TEXT))
          (IMAGE (TEXT-%IMAGE TEXT))
          (WIDTH (IL:BITMAPWIDTH IMAGE))
          (HEIGHT (IL:BITMAPHEIGHT IMAGE))
          (SCALED-X (IF SCALE
                        (SCALE-X (POSITION-X POSITION)
                               SCALE)
                        (POSITION-X POSITION)))
          (SCALED-Y (IF SCALE
                        (SCALE-Y (POSITION-Y POSITION)
                               SCALE)
                        (POSITION-Y POSITION)))
          (X-COORD (ECASE ALIGNMENT
                       ((:LEFT-BOTTOM :LEFT-TOP) SCALED-X)
                       ((:RIGHT-BOTTOM :RIGHT-TOP) (- SCALED-X WIDTH))
                       (:CENTER (- SCALED-X (FLOOR WIDTH 2)))))
          (Y-COORD (CASE ALIGNMENT
                       ((:LEFT-BOTTOM :RIGHT-BOTTOM) SCALED-Y)
                       ((:LEFT-TOP :RIGHT-TOP) (- SCALED-Y HEIGHT))
                       (:CENTER (- SCALED-Y (FLOOR HEIGHT 2)))))
          (MASK (TEXT-%MASK TEXT)))
         (WHEN MASK                                          (IL:* IL:\; "erase the mask")
             (IL:BITBLT MASK 0 0 DESTINATION X-COORD Y-COORD WIDTH HEIGHT 'IL:INPUT
                    (IF MASK-ONLY
                        'IL:PAINT
                        'IL:ERASE)))
         (UNLESS MASK-ONLY                                   (IL:* IL:\; "paint in the image")
             (IL:BITBLT IMAGE 0 0 DESTINATION X-COORD Y-COORD WIDTH HEIGHT 'IL:INPUT 'IL:PAINT))))

(DEFUN SET-TEXT-STRING (TEXT STRING)

(IL:* IL:|;;;| "call this to change the string of a TEXT object")

   (SETF (TEXT-STRING TEXT)
         STRING)

   (IL:* IL:|;;| "update all caches")

   (UPDATE-TEXT-CACHES TEXT)

   (IL:* IL:|;;| "return the string")

   STRING)

(DEFUN SET-DEFAULT-TEXT-FONT ()

(IL:* IL:|;;;| "called when screen size changes")

   (FLET ((DEFAULT-FONT (SCREEN-WIDTH)
                 (IF (> SCREEN-WIDTH SMALL-SCREEN-WIDTH)
                     DEFAULT-TEXT-FONT--LARGE-SCREEN
                     DEFAULT-TEXT-FONT--SMALL-SCREEN)))

         (IL:* IL:|;;| 
       "if user hasn't changed *DEFAULT-TEXT-FONT* then set it proportional to the screen size.")

         (IF (OR (NULL *DEFAULT-TEXT-FONT*)
                 (EQ (DEFAULT-FONT (REGION-WIDTH OLD-WHOLESCREEN))
                     *DEFAULT-TEXT-FONT*))
             (SETQ *DEFAULT-TEXT-FONT* (DEFAULT-FONT IL:SCREENWIDTH))
             *DEFAULT-TEXT-FONT*)))

(SET-DEFAULT-TEXT-FONT)

(DEFMACRO TEXT-%WIDTH (TEXT)
   `(IL:BITMAPWIDTH (TEXT-%IMAGE ,TEXT)))

(DEFMACRO TEXT-%HEIGHT (TEXT)
   `(IL:BITMAPHEIGHT (TEXT-%IMAGE ,TEXT)))

(DEFGLOBALVAR *TEXT-SHADOWS* (MAKE-HASH-TABLE :TEST 'EQ)
                                 "Cache of default shadows indexed by font.")

(DEFPARAMETER *TEXT-SHADOW-FACTOR* 10
   "Text shadows will use the inverse of this number to determine what fraction of the font size should be shadow."
)

(DEFUN GET-TEXT-SHADOWS (TEXT)
   (LET ((SHADOWS (TEXT-SHADOWS TEXT)))
        (ETYPECASE SHADOWS
            ((MEMBER T) (GET-TEXT-SHADOWS-INTERNAL (TEXT-FONT TEXT)))
            (SYMBOL 

               (IL:* IL:|;;| "user defined shadows")

               (LET ((INTERNAL (GETHASH SHADOWS *TEXT-SHADOWS*)))
                    (OR INTERNAL (ERROR "No text shadows named ~S" SHADOWS))))
            (CONS SHADOWS))))

(DEFUN GET-TEXT-SHADOWS-INTERNAL (FONT)

   (IL:* IL:|;;| "cache default shadows per font")

   (OR (GETHASH FONT *TEXT-SHADOWS*)
       (SETF (GETHASH FONT *TEXT-SHADOWS*)
             (MAKE-TEXT-SHADOWS FONT))))

(DEFUN MAKE-TEXT-SHADOWS (FONT &OPTIONAL (FACTOR *TEXT-SHADOW-FACTOR*))
   (LIST (LET ((DEPTH (CEILING (IL:FONTHEIGHT FONT)
                             FACTOR)))
              (MAKE-TEXT-SHADOW :DX DEPTH :DY (- DEPTH)
                     :OPERATION
                     'IL:PAINT))
         (MAKE-TEXT-SHADOW :DY 1)
         (MAKE-TEXT-SHADOW :DX 1)
         (MAKE-TEXT-SHADOW :DY -1)
         (MAKE-TEXT-SHADOW :DX -1)
         (MAKE-TEXT-SHADOW :OPERATION 'IL:ERASE)))

(DEFUN EXTERNALIZE-TEXT-SHADOWS (SHADOWS)
   (ETYPECASE SHADOWS
       (SYMBOL SHADOWS)
       (CONS (MAPCAR #'(LAMBDA (SHADOW)
                              (LIST :DX (TEXT-SHADOW-DX SHADOW)
                                    :DY
                                    (TEXT-SHADOW-DY SHADOW)
                                    :OPERATION
                                    (TEXT-SHADOW-OPERATION SHADOW)
                                    :SOURCE-TYPE
                                    (TEXT-SHADOW-SOURCE-TYPE SHADOW)
                                    :TEXTURE
                                    (TEXT-SHADOW-TEXTURE SHADOW)))
                    SHADOWS))))

(DEFUN INTERNALIZE-TEXT-SHADOWS (SHADOWS)
   (ETYPECASE SHADOWS
       (SYMBOL 

          (IL:* IL:|;;| "named shadows -- handled by GET-TEXT-SHADOWS")

          SHADOWS)
       (CONS 

          (IL:* IL:|;;| "explitly specified shadows")

          (INTERNALIZE-TEXT-SHADOWS-INTERNAL SHADOWS))))

(DEFUN INTERNALIZE-TEXT-SHADOWS-INTERNAL (SHADOWS)
   (MAPCAR #'(LAMBDA (SHADOW)
                    (IF (TEXT-SHADOW-P SHADOW)
                        SHADOW

                        (IL:* IL:|;;| "parse shadow from property list")

                        (LET ((DX (GETF SHADOW :DX 0))
                              (DY (GETF SHADOW :DY 0))
                              (OPERATION (GETF SHADOW :OPERATION 'IL:PAINT))
                              (SOURCE-TYPE (GETF SHADOW :SOURCE-TYPE 'IL:INPUT))
                              (TEXTURE (GETF SHADOW :TEXTURE 0)))

                             (IL:* IL:|;;| "check the types (defstruct won't)")

                             (CHECK-TYPE DX INTEGER)
                             (CHECK-TYPE DY INTEGER)
                             (CHECK-TYPE OPERATION (MEMBER IL:PAINT IL:REPLACE IL:ERASE IL:INVERT))
                             (CHECK-TYPE SOURCE-TYPE (MEMBER IL:INPUT IL:INVERT IL:TEXTURE IL:MERGE))
                             (CHECK-TYPE TEXTURE TEXTURE)

                             (IL:* IL:|;;| "make a shadow")

                             (MAKE-TEXT-SHADOW :DX DX :DY DY :OPERATION OPERATION :SOURCE-TYPE 
                                    SOURCE-TYPE :TEXTURE TEXTURE))))
          SHADOWS))



(IL:* IL:|;;| "a definer for shadows")


(DEF-DEFINE-TYPE IL:TEXT-SHADOWS "Text Shadows"
   :UNDEFINER (LAMBDA (NAME)
                     (REMHASH NAME *TEXT-SHADOWS*)))

(DEFDEFINER DEF-TEXT-SHADOWS IL:TEXT-SHADOWS (NAME &REST EXTERNAL-FORM)
   `(SETF (GETHASH ',NAME *TEXT-SHADOWS*)
          (INTERNALIZE-TEXT-SHADOWS-INTERNAL ',EXTERNAL-FORM)))

(DEF-TEXT-SHADOWS NIL NIL)

(DEF-TEXT-SHADOWS :ARK (:OPERATION IL:ERASE)
                           (:DX -1 :DY 1))
(IL:PUTPROPS IL:ROOMS-TEXT IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (3805 4523 (MAKE-TEXT 3805 . 4523)) (4525 7611 (UPDATE-TEXT-CACHES 4525 . 7611)) (
7613 8652 (COMPUTE-TEXT-DIMEMSIONS 7613 . 8652)) (9350 11046 (DISPLAY-TEXT 9350 . 11046)) (11048 11337
 (SET-TEXT-STRING 11048 . 11337)) (11339 12027 (SET-DEFAULT-TEXT-FONT 11339 . 12027)) (12513 12943 (
GET-TEXT-SHADOWS 12513 . 12943)) (12945 13170 (GET-TEXT-SHADOWS-INTERNAL 12945 . 13170)) (13172 13648 
(MAKE-TEXT-SHADOWS 13172 . 13648)) (13650 14321 (EXTERNALIZE-TEXT-SHADOWS 13650 . 14321)) (14323 14638
 (INTERNALIZE-TEXT-SHADOWS 14323 . 14638)) (14640 15918 (INTERNALIZE-TEXT-SHADOWS-INTERNAL 14640 . 
15918)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-TEXT.DFASL b/rooms/ROOMS-TEXT.DFASL
new file mode 100644
index 00000000..0a6719a9
Binary files /dev/null and b/rooms/ROOMS-TEXT.DFASL differ
diff --git a/rooms/ROOMS-WINDOW-HIDER b/rooms/ROOMS-WINDOW-HIDER
new file mode 100644
index 00000000..a69a0045
--- /dev/null
+++ b/rooms/ROOMS-WINDOW-HIDER
@@ -0,0 +1,17 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:26:33" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-WINDOW-HIDER.;2| 30816  

      IL:|previous| IL:|date:| "17-Aug-90 13:34:55" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-WINDOW-HIDER.;1|)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMS-WINDOW-HIDERCOMS)

(IL:RPAQQ IL:ROOMS-WINDOW-HIDERCOMS
          ((FILE-ENVIRONMENTS IL:ROOMS-WINDOW-HIDER)
           (IL:P (EXPORT '(HIDE-WINDOW UN-HIDE-WINDOW WINDOW-HIDDEN? ALL-WINDOWS LOST-WINDOWS))
                 (REQUIRE "ROOMS"))
           (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:FILES (IL:LOADCOMP T)
                                                            IL:WINDOW IL:FILEIO IL:LLDISPLAY IL:TTYIN
                                                            ))
           (IL:VARIABLES *HIDDEN-WINDOWS*)
           (IL:FUNCTIONS ALL-WINDOWS LOST-WINDOWS)
           (IL:FUNCTIONS HIDE-ALL-WINDOWS HIDE-WINDOW HIDE-WINDOW-INTERNAL UN-HIDE-WINDOW 
                  UN-HIDE-WINDOW-INTERNAL DO-TOTOP-FUNCTIONS WINDOW-HIDDEN? %WINDOW-HIDDEN?)
           (IL:FNS SHAPEW1 \\CLOSEW1 MOVEW \\INTERNALTOTOPW WFROMMENU RESHOWTITLE \\RESHOWBORDER1 
                  TTYIN.SETUP)
           (IL:GLOBALVARS IL:LAMBDASPLST IL:\\EM.DISPINTERRUPT IL:\\SCREENBITMAPS 
                  IL:\\TTYIN.LAST.FONT IL:\\TTYIN.LAST.COMMENTFONT)
           (EVAL-WHEN (LOAD)
                  (IL:P (IL:MOVD 'SHAPEW1 'IL:SHAPEW1)
                        (IL:MOVD '\\CLOSEW1 'IL:\\CLOSEW1)
                        (IL:MOVD 'MOVEW 'IL:MOVEW)
                        (IL:MOVD '\\INTERNALTOTOPW 'IL:\\INTERNALTOTOPW)
                        (IL:MOVD 'WFROMMENU 'IL:WFROMMENU)
                        (IL:MOVD 'RESHOWTITLE 'IL:RESHOWTITLE)
                        (IL:MOVD '\\RESHOWBORDER1 'IL:\\RESHOWBORDER1)
                        (IL:MOVD 'TTYIN.SETUP 'IL:TTYIN.SETUP)))
           (IL:ADVISE IL:ATTACHWINDOW)))

(DEFINE-FILE-ENVIRONMENT IL:ROOMS-WINDOW-HIDER :COMPILER :COMPILE-FILE
   :PACKAGE "ROOMS"
   :READTABLE "XCL")

(EXPORT '(HIDE-WINDOW UN-HIDE-WINDOW WINDOW-HIDDEN? ALL-WINDOWS LOST-WINDOWS))

(REQUIRE "ROOMS")
(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY 

(IL:FILESLOAD (IL:LOADCOMP T)
       IL:WINDOW IL:FILEIO IL:LLDISPLAY IL:TTYIN)
)

(DEFGLOBALVAR *HIDDEN-WINDOWS* (MAKE-HASH-TABLE :TEST 'EQ))

(DEFUN ALL-WINDOWS (&OPTIONAL INCLUDE-HIDDEN?)

(IL:* IL:|;;;| "returns a list of all the window groups in bottom first order.")

   (LET (RESULT MAIN-WINDOW)
        (DOLIST (WINDOW (IL:OPENWINDOWS T)
                       RESULT)
            (PUSHNEW (MAIN-WINDOW WINDOW)
                   RESULT :TEST 'EQ))
        (WHEN INCLUDE-HIDDEN?
            (MAPHASH #'(LAMBDA (WINDOW TRUE)
                              (PUSHNEW (MAIN-WINDOW WINDOW)
                                     RESULT :TEST 'EQ))
                   *HIDDEN-WINDOWS*))
        RESULT))

(DEFUN LOST-WINDOWS ()

(IL:* IL:|;;;| "returns the subset of all existing windows which are not in any room.")

(IL:* IL:|;;;| "as UPDATE-PLACEMENTS guarentees us that all un-hidden windows belong to a room, we know that all lost windows must be hidden. ")

   (UPDATE-PLACEMENTS)
   (WITH-COLLECTION (DOLIST (WINDOW (ALL-WINDOWS T))
                        (UNLESS (FIND-ROOMS-CONTAINING WINDOW)
                               (COLLECT WINDOW)))))

(DEFUN HIDE-ALL-WINDOWS ()
   (DOLIST (WINDOW (NREVERSE (ALL-WINDOWS)))
       (HIDE-WINDOW WINDOW)))

(DEFUN HIDE-WINDOW (WINDOW)
   (LET ((WINDOW (MAIN-WINDOW WINDOW)))
        (UNLESS (WINDOW-HIDDEN? WINDOW)
            (LET ((ICON (WINDOW-ICON WINDOW)))
                 (WHEN ICON (HIDE-WINDOW-INTERNAL ICON)))
            (HIDE-WINDOW-INTERNAL WINDOW)

            (IL:* IL:|;;| "return T if we succeded")

            T)))

(DEFUN HIDE-WINDOW-INTERNAL (WINDOW)
   (UNLESS (WINDOW-HIDDEN? WINDOW)
       (DOLIST (ATTACHED-WINDOW (IL:WINDOWPROP WINDOW 'IL:ATTACHEDWINDOWS))

           (IL:* IL:|;;| "recursively hide attached windows")

           (HIDE-WINDOW-INTERNAL ATTACHED-WINDOW))
       (WHEN (IL:OPENWP WINDOW)

           (IL:* IL:|;;| "save the image")

           (IL:\\CLOSEW1 WINDOW))
       (LET* ((DSP (IL:FETCH (IL:WINDOW IL:DSP) IL:OF WINDOW))
              (BORDER (IL:FFETCH (IL:WINDOW IL:WBORDER) IL:OF WINDOW))
              (CLIPPING-REGION (IL:DSPCLIPPINGREGION NIL DSP)))
             (IL:UNINTERRUPTABLY

                 (IL:* IL:|;;| "switch the destination to the save bitmap")

                 (IL:DSPDESTINATION (IL:FFETCH (IL:WINDOW IL:SAVE) IL:OF WINDOW)
                        DSP)

                 (IL:* IL:|;;| "adjust the offset")

                 (IL:DSPXOFFSET (- BORDER (REGION-LEFT CLIPPING-REGION))
                        DSP)
                 (IL:DSPYOFFSET (- BORDER (REGION-BOTTOM CLIPPING-REGION))
                        DSP)

                 (IL:* IL:|;;| "so it's still IL:OPENWP")

                 (IL:FREPLACE (IL:WINDOW IL:NEXTW) IL:OF WINDOW IL:WITH NIL))
             (SETF (GETHASH WINDOW *HIDDEN-WINDOWS*)
                   T))
       T))

(DEFUN UN-HIDE-WINDOW (WINDOW)
   (LET* ((WINDOW (MAIN-WINDOW WINDOW))
          (ICON (WINDOW-ICON WINDOW))
          (SHRUNKEN? (SHRUNKEN? WINDOW)))
         (WHEN ICON
             (UN-HIDE-WINDOW-INTERNAL ICON (NOT SHRUNKEN?)))
         (UN-HIDE-WINDOW-INTERNAL WINDOW SHRUNKEN?)
         T))

(DEFUN UN-HIDE-WINDOW-INTERNAL (WINDOW &OPTIONAL NO-OPEN)
   (WHEN (WINDOW-HIDDEN? WINDOW)
       (IL:UNINTERRUPTABLY
           (LET* ((DSP (IL:FETCH (IL:WINDOW IL:DSP) IL:OF WINDOW))
                  (REGION (IL:FFETCH (IL:WINDOW IL:REG) IL:OF WINDOW))
                  (BORDER (IL:FFETCH (IL:WINDOW IL:WBORDER) IL:OF WINDOW))
                  (CLIPPING-REGION (IL:DSPCLIPPINGREGION NIL DSP)))

                 (IL:* IL:|;;| "switch the destination to the screen")

                 (IL:DSPDESTINATION (IL:FETCH (IL:SCREEN IL:SCDESTINATION)
                                       IL:OF (IL:FFETCH (IL:WINDOW IL:SCREEN) IL:OF
                                                                                      WINDOW))
                        DSP)

                 (IL:* IL:|;;| "adjust the offsets")

                 (IL:DSPXOFFSET (- (+ (REGION-LEFT REGION)
                                      BORDER)
                                   (REGION-LEFT CLIPPING-REGION))
                        DSP)
                 (IL:DSPYOFFSET (- (+ (REGION-BOTTOM REGION)
                                      BORDER)
                                   (REGION-BOTTOM CLIPPING-REGION))
                        DSP)

                 (IL:* IL:|;;| "so it's not IL:OPENWP")

                 (IL:FREPLACE (IL:WINDOW IL:NEXTW) IL:OF WINDOW IL:WITH 'IL:CLOSED))))
   (UNLESS NO-OPEN (IL:\\OPENW1 WINDOW))
   (REMHASH WINDOW *HIDDEN-WINDOWS*)
   (DOLIST (ATTACHED-WINDOW (IL:WINDOWPROP WINDOW 'IL:ATTACHEDWINDOWS))

       (IL:* IL:|;;| "recursively un-hide attached windows")

       (UN-HIDE-WINDOW-INTERNAL ATTACHED-WINDOW NO-OPEN))
   (UNLESS NO-OPEN (DO-TOTOP-FUNCTIONS WINDOW)))

(DEFUN DO-TOTOP-FUNCTIONS (WINDOW)
   (LET ((TOTOPFN (IL:WINDOWPROP WINDOW 'IL:TOTOPFN)))

        (IL:* IL:|;;| "TOTOPFN's often look at what's behind a window & since this window now has a new screen behind it we do these.  This makes buttons & icons work right.  ")

        (WHEN (AND TOTOPFN (NOT 
                                (IL:* IL:|;;| "we take care of attached windows already")

                                (OR (IL:EQMEMB 'IL:TOPATTACHEDWINDOWS TOTOPFN)
                                    (IL:EQMEMB 'IL:ATTACHEDWINDOWTOTOPFN TOTOPFN))))
              (IL:DOUSERFNS TOTOPFN WINDOW))))

(DEFUN WINDOW-HIDDEN? (WINDOW)
   (%WINDOW-HIDDEN? WINDOW))

(DEFINLINE %WINDOW-HIDDEN? (WINDOW)
   (EQ (IL:FETCH (IL:\\DISPLAYDATA IL:|DDDestination|) IL:OF (IL:FETCH (STREAM 
                                                                                         IL:IMAGEDATA
                                                                                          )
                                                                        IL:OF (IL:FETCH
                                                                                   (IL:WINDOW IL:DSP)
                                                                                     IL:OF WINDOW
                                                                                   )))
       (IL:FFETCH (IL:WINDOW IL:SAVE) IL:OF WINDOW)))
(IL:DEFINEQ

(shapew1
+(il:lambda (il:window il:region) (il:* il:\; "Edited 15-Jun-88 17:08 by drc:") (il:* il:|;;| "entry for shaping a window that does the reshape without checking for a user function.") (declare (il:localvars . t)) (il:setq il:window (il:\\insurewindow il:window)) (or (il:regionp il:region) (il:\\illegal.arg il:region)) (prog ((il:oldregion (il:|fetch| (il:window il:reg) il:|of| il:window)) (il:oldclipreg (il:dspclippingregion nil (il:|fetch| (il:window il:dsp) il:|of| il:window))) (il:wborder (il:|fetch| (il:window il:wborder) il:|of| il:window)) (il:save (il:|fetch| (il:window il:save) il:|of| il:window)) (il:screen (il:|fetch| (il:window il:screen) il:|of| il:window)) il:nusav il:nowopen? il:hidden?) (il:setq il:nusav (il:bitmapcreate (il:|fetch| (il:region il:width) il:|of| il:region) (il:|fetch| (il:region il:height) il:|of| il:region) (il:|fetch| (il:bitmap il:bitmapbitsperpixel) il:|of| (il:|fetch| (il:screen il:scdestination) il:|of| il:screen)))) (il:uninterruptably (cond ((il:openwp il:window) (il:if (window-hidden? il:window) il:then (il:setq il:hidden? t) il:else (il:* il:\; "notice whether window is open or not to call OPENFNs only if not now open.") (il:setq il:nowopen? t) (il:\\closew1 il:window)))) (il:* il:\; "Save window image") (il:|replace| (il:window il:reg) il:|of| il:window il:|with| il:region) (il:|replace| (il:window il:save) il:|of| il:window il:|with| il:nusav) (il:if il:hidden? il:then (let ((il:twiceborder (il:itimes (il:|fetch| (il:window il:wborder) il:|of| il:window) 2)) (il:dsp (il:|fetch| (il:window il:dsp) il:of il:window))) (il:dspdestination il:nusav il:dsp) (il:dspclippingregion (il:|create| il:region il:|using| (il:dspclippingregion nil il:dsp) il:width il:_ (- (il:|fetch| (il:region il:width) il:|of| il:region) il:twiceborder) il:height il:_ (+ (- (il:|fetch| (il:region il:height) il:|of| il:region) il:twiceborder) (il:|if| (il:|fetch| (il:window il:wtitle) il:|of| il:window) il:|then| (il:dsplinefeed nil (il:|fetch| (il:screen il:sctitleds) il:|of| il:screen)) il:|else| 0))) il:dsp) (il:showwframe il:window)) il:else (il:advisewds il:window il:oldregion) (il:showwframe il:window) (cond (il:nowopen? (il:\\openw1 il:window)) (t (il:openw il:window))))) (il:douserfns2 (or (il:|fetch| (il:window il:reshapefn) il:|of| il:window) (il:function il:reshapebyrepaintfn)) il:window il:save (il:|create| il:region il:left il:_ il:wborder il:bottom il:_ il:wborder il:width il:_ (il:|fetch| (il:region il:width) il:|of| il:oldclipreg) il:height il:_ (il:|fetch| (il:region il:height) il:|of| il:oldclipreg)) il:oldregion) (return il:window)))
+)

(\\closew1
+(il:lambda (il:window) (il:* il:\; "Edited 15-Jun-88 15:36 by drc:") (il:* il:|;;| "actually does the closing operation.  Is used by SHRINKW to avoid the CLOSEFN mechanism.") (let (il:screen il:nextw) (il:if (window-hidden? il:window) il:then (un-hide-window-internal il:window t) (quote il:closed) il:else (il:setq il:screen (il:|fetch| (il:window il:screen) il:|of| il:window)) (il:.while.top.ds. il:window (il:\\sw2bm (il:|fetch| (il:screen il:scdestination) il:|of| il:screen) (il:|fetch| (il:window il:reg) il:|of| il:window) (il:|fetch| (il:window il:save) il:|of| il:window) nil) (il:setq il:nextw (il:|fetch| (il:window il:nextw) il:|of| il:window)) (il:|replace| (il:screen il:sctopw) il:|of| il:screen il:|with| il:nextw) (il:setq il:\\topwds (cond (il:nextw (il:|fetch| (il:window il:dsp) il:|of| il:nextw)))) (il:* il:\; "smash the window's link to other's in the chain.") (il:|replace| (il:window il:nextw) il:|of| il:window il:|with| (quote il:closed))))))
+)

(movew
+(il:lambda (il:window il:|POSorX| il:y) (il:* il:\; "Edited 15-Jun-88 15:42 by drc:") (il:* il:|;;| "moves a window.  If window is closed and position is given, it won't open the window.  It also calls the window's MOVEFN property.") (il:setq il:window (il:\\insurewindow il:window)) (prog ((il:oldregion (il:|fetch| (il:window il:reg) il:|of| il:window)) (il:usermovefn (il:|fetch| (il:window il:movefn) il:|of| il:window)) (il:open? (il:openwp il:window)) il:oldscreen il:pos il:newregion il:oldleft il:oldbottom il:oldwidth il:oldheight il:oldclipregion il:lft il:btm il:reg il:fn) (il:setq il:oldscreen (il:|fetch| (il:window il:screen) il:|of| il:window)) (cond ((cond ((il:listp il:usermovefn) (il:fmemb (quote il:don\'t) il:usermovefn)) (t (eq il:usermovefn (quote il:don\'t)))) (il:promptprint "This window cannot be moved.") (return))) (cond ((not (il:subregionp il:oldregion (il:|fetch| (il:screen il:scregion) il:|of| il:oldscreen))) (il:* il:\; "use T as an indication that the window was completely off screen.") (il:setq il:oldclipregion (or (il:\\onscreenclippingregion il:window) t)))) (il:setq il:oldleft (il:|fetch| (il:region il:left) il:|of| il:oldregion)) (il:setq il:oldbottom (il:|ffetch| (il:region il:bottom) il:|of| il:oldregion)) (il:setq il:oldwidth (il:|ffetch| (il:region il:width) il:|of| il:oldregion)) (il:setq il:oldheight (il:|ffetch| (il:region il:height) il:|of| il:oldregion)) (cond ((and il:|POSorX| (il:setq il:pos (cond ((il:positionp il:|POSorX|) il:|POSorX|) ((il:numberp il:|POSorX|) (cond ((il:numberp il:y) (il:|create| il:position il:xcoord il:_ il:|POSorX| il:ycoord il:_ il:y)) (t (il:\\illegal.arg il:y)))) ((il:regionp il:|POSorX|) (il:|create| il:position il:xcoord il:_ (il:|fetch| (il:region il:left) il:|of| il:|POSorX|) il:ycoord il:_ (il:|fetch| (il:region il:bottom) il:|of| il:|POSorX|))) (t (il:\\illegal.arg il:|POSorX|))))) (il:* il:\; "if not aready open, don't") (and il:open? (il:totopw il:window))) (t (il:* il:\; "no position to move to has been given, ask user for one.") (il:totopw il:window) (il:* il:\; "TOTOPW opens the window if it is not already.") (cond ((and (il:setq il:fn (il:windowprop il:window (quote il:calculateregionfn))) (il:setq il:reg (il:apply* il:fn il:window (quote movew)))) (il:* il:\; "prompt with a region that is calculated by the window") (il:setq il:pos (il:getboxposition (il:|fetch| (il:region il:width) il:|of| il:reg) (il:|ffetch| (il:region il:height) il:|of| il:reg) (il:setq il:lft (il:|ffetch| (il:region il:left) il:|of| il:reg)) (il:setq il:btm (il:|ffetch| (il:region il:bottom) il:|of| il:reg)))) (il:* il:|;;| "use a position that is offset by the same amount as the calculated region was from the window's region.") (il:setq il:pos (il:|create| il:position il:xcoord il:_ (il:iplus (il:|fetch| (il:position il:xcoord) il:|of| il:pos) (il:idifference il:oldleft il:lft)) il:ycoord il:_ (il:iplus (il:|ffetch| (il:position il:ycoord) il:|of| il:pos) (il:idifference il:oldbottom il:btm))))) (t (il:setq il:pos (il:getboxposition il:oldwidth il:oldheight il:oldleft il:oldbottom)))) (il:setq il:open? t))) (cond ((and (il:listp il:usermovefn) (not (il:fmemb (car il:usermovefn) il:lambdasplst))) (and (eq (il:|for| il:mfn il:|in| il:usermovefn il:|do| (il:setq il:newregion (il:apply* il:mfn il:window il:pos)) (cond ((eq il:newregion (quote il:don\'t)) (return (quote il:don\'t))) ((il:positionp il:newregion) (il:setq il:pos il:newregion)))) (quote il:don\'t)) (return))) (il:usermovefn (il:setq il:newregion (il:apply* il:usermovefn il:window il:pos)) (cond ((eq il:newregion (quote il:don\'t)) (return)) ((il:positionp il:newregion) (il:setq il:pos il:newregion))))) (cond ((or (not (eq (il:|fetch| (il:position il:xcoord) il:|of| il:pos) il:oldleft)) (not (eq (il:|ffetch| (il:position il:ycoord) il:|of| il:pos) il:oldbottom))) (il:setq il:newregion (il:|create| il:region il:left il:_ (il:|ffetch| (il:position il:xcoord) il:|of| il:pos) il:bottom il:_ (il:|ffetch| (il:position il:ycoord) il:|of| il:pos) il:width il:_ il:oldwidth il:height il:_ il:oldheight)) (il:if (window-hidden? il:window) il:then (il:* il:|;;| "just update region") (il:|replace| (il:window il:reg) il:|of| il:window il:|with| il:newregion) il:else (il:uninterruptably (cond (il:open? (il:* il:|;;| "if window is open, move it to top as its MOVEFN may have changed things and swap its bits to its new location") (il:.while.top.ds. il:window (il:\\sw2bm (il:|fetch| (il:screen il:scdestination) il:|of| il:oldscreen) il:oldregion (il:|fetch| (il:window il:save) il:|of| il:window) nil) (il:\\sw2bm (il:|ffetch| (il:window il:save) il:|of| il:window) nil (il:|ffetch| (il:screen il:scdestination) il:|of| il:oldscreen) il:newregion)))) (il:|replace| (il:window il:reg) il:|of| il:window il:|with| il:newregion) (il:advisewds il:window il:oldregion t))) (cond ((and il:open? (il:windowprop il:window (quote il:repaintfn)) il:oldclipregion) (il:* il:\; "redisplay those parts that were off the screen.") (cond ((eq il:oldclipregion t) (il:* il:\; "whole window was off.") (il:redisplayw il:window nil t)) (t (prog (il:newclippingregion il:ncl il:ocl il:ncb il:ocb il:ocr il:ncr il:ocw il:ncw il:och il:nch il:oct il:nct) (il:setq il:newclippingregion (il:\\onscreenclippingregion il:window)) (il:* il:\; "the title may be the only thing now on the screen.") (or il:newclippingregion (return)) (il:setq il:ncb (il:|fetch| (il:region il:bottom) il:|of| il:newclippingregion)) (il:setq il:ocb (il:|fetch| (il:region il:bottom) il:|of| il:oldclipregion)) (il:setq il:ocw (il:|ffetch| (il:region il:width) il:|of| il:oldclipregion)) (il:setq il:ncw (il:|ffetch| (il:region il:width) il:|of| il:newclippingregion)) (il:setq il:och (il:|ffetch| (il:region il:height) il:|of| il:oldclipregion)) (il:setq il:nch (il:|ffetch| (il:region il:height) il:|of| il:newclippingregion)) (cond ((il:ilessp (il:setq il:ncl (il:|ffetch| (il:region il:left) il:|of| il:newclippingregion)) (il:setq il:ocl (il:|ffetch| (il:region il:left) il:|of| il:oldclipregion))) (il:redisplayw il:window (il:createregion il:ncl il:ocb (il:idifference il:ocl il:ncl) il:och)))) (cond ((il:ilessp (il:setq il:ocr (il:iplus il:ocl il:ocw)) (il:setq il:ncr (il:iplus il:ncl il:ncw))) (il:* il:\; "some stuff appeared from the right.") (il:redisplayw il:window (il:createregion il:ocr il:ocb (il:idifference il:ncr il:ocr) il:och)))) (cond ((il:ilessp il:ncb il:ocb) (il:redisplayw il:window (il:createregion il:ncl il:ncb il:ncw (il:idifference il:ocb il:ncb))))) (cond ((il:ilessp (il:setq il:oct (il:iplus il:ocb il:och)) (il:setq il:nct (il:iplus il:ncb il:nch))) (il:* il:\; "some stuff appeared from the top") (il:redisplayw il:window (il:createregion il:ncl il:oct il:ncw (il:idifference il:nct il:oct))))) (cond ((il:igreaterp (il:iplus il:oldbottom il:oldheight) (il:|fetch| (il:screen il:scheight) il:|of| il:oldscreen)) (il:* il:\; "should reshow the title but don't have any entry for that.") nil))))))) (il:douserfns (il:windowprop il:window (quote il:aftermovefn)) il:window))) (return il:pos)))
+)

(\\internaltotopw
+(il:lambda (il:w1 il:rpt) (il:* il:\; "Edited 15-Jun-88 14:50 by drc:") (prog (il:screen il:screentopw) (il:setq il:w1 (il:\\insurewindow il:w1)) (il:setq il:screen (il:|fetch| (il:window il:screen) il:|of| il:w1)) (il:setq il:screentopw (il:|fetch| (il:screen il:sctopw) il:|of| il:screen)) (or (eq il:w1 il:screentopw) (window-hidden? il:w1) (cond ((null il:screentopw) (il:* il:\; "all windows are closed open this one.") (il:openw il:w1)) (t (il:uninterruptably (il:\\ttw1 il:w1 il:screentopw) (il:* il:|;;| "N.B.  \\TTW1 can side effect the screen") (cond ((eq il:w1 (il:|fetch| (il:screen il:sctopw) il:|of| il:screen))) ((not il:rpt) (il:* il:\; "GC msgs or other glitches can cause W1 not to make it.  Check and try ONCE more") (\\internaltotopw il:w1 t)))))))))
+)

(wfrommenu
+(il:lambda (il:menu) (il:* il:\; "Edited 15-Jun-88 19:19 by drc:") (il:* il:|;;;| "finds the window that menu is in if any.") (block wfrommenu (dolist (il:window (all-windows t)) (labels ((il:search-attached-windows (il:window) (when (il:fmemb il:menu (il:windowprop il:window (quote il:menu))) (return-from wfrommenu il:window)) (dolist (il:window (il:windowprop il:window (quote il:attachedwindows))) (il:search-attached-windows il:window)))) (il:search-attached-windows il:window)))))
+)

(reshowtitle
+(il:lambda (il:title il:window il:justdisplayflg) (il:* il:\; "Edited 15-Jun-88 18:57 by drc:") (il:* il:|;;| "updates a windows display with a new title") (prog* ((il:wreg (il:|fetch| (il:window il:reg) il:|of| il:window)) (il:titleds (il:|fetch| (il:screen il:sctitleds) il:|of| (il:|fetch| (il:window il:screen) il:|of| il:window))) (il:titleheight (il:iminus (il:dsplinefeed nil il:titleds))) (il:oldtitle (il:|fetch| (il:window il:wtitle) il:|of| il:window)) (il:border (il:|fetch| (il:window il:wborder) il:|of| il:window)) il:bm il:bmbtm il:hght) (cond (il:justdisplayflg) ((eq il:title (il:|fetch| (il:window il:wtitle) il:|of| il:window)) (return)) (t (il:|replace| (il:window il:wtitle) il:|of| il:window il:|with| il:title) (cond ((or (null il:oldtitle) (null il:title) (il:neq il:titleheight (il:idifference (il:|fetch| (il:region il:height) il:|of| il:wreg) (il:iplus (il:|fetch| (il:region il:height) il:|of| (il:dspclippingregion nil (il:|fetch| (il:window il:dsp) il:|of| il:window))) (il:itimes 2 il:border))))) (il:* il:\; "Previously no title, so make space for one") (il:* il:\; "Have to remove title") (il:* il:\; "or title height changed.") (il:* il:\; "so windows region on the screen has to be made larger.") (il:\\reshowborder1 (il:|fetch| (il:window il:wborder) il:|of| il:window) (il:|fetch| (il:window il:wborder) il:|of| il:window) il:window) (return))))) (il:* il:\; "code from here is to reprint the title in place to avoid creating any large bitmaps.") (il:setq il:bm (il:bitmapcreate (il:|fetch| (il:region il:width) il:|of| il:wreg) (il:setq il:titleheight (il:add1 il:titleheight)) (il:bitsperpixel (il:|fetch| (il:screen il:scdestination) il:|of| (il:|fetch| (il:window il:screen) il:|of| il:window))))) (il:bitblt nil nil nil il:bm 0 0 nil nil (quote il:texture) (quote il:replace) il:blackshade) (il:* il:\; "use SHOWWTITLE to put the image of the title into the auxilliary bitmap.") (il:showwtitle il:title il:bm il:border nil il:window) (cond ((il:igreaterp il:titleheight (il:setq il:hght (il:|fetch| (il:region il:height) il:|of| il:wreg))) (il:setq il:bmbtm (il:idifference (il:sub1 il:titleheight) il:hght)))) (let ((il:hidden? (window-hidden? il:window))) (il:uninterruptably (il:totopw il:window) (il:bitblt il:bm 0 (cond (il:bmbtm) ((il:igreaterp il:border 0) (il:* il:|;;| "if there is a border, the title was printed in the scratch bitmap so to leave one point of the border on top") 0) (t 1)) (il:dspdestination nil il:window) (il:if il:hidden? il:then 0 il:else (il:|fetch| (il:region il:left) il:|of| il:wreg)) (il:idifference (il:if il:hidden? il:then (il:|fetch| (il:region il:height) il:|of| il:wreg) il:else (il:|fetch| (il:region il:ptop) il:|of| il:wreg)) (cond (il:bmbtm il:hght) (t (il:iplus il:titleheight (cond ((il:igreaterp il:border 0) (il:* il:|;;| "if there is a border, the title was printed in the scratch bitmap so to leave one point of the border on top") 0) (t -1)))))) nil (cond (il:bmbtm il:hght)))))))
+)

(\\reshowborder1
+(il:lambda (il:newborder il:oldborder il:window) (il:* il:\; "Edited 15-Jun-88 19:05 by drc:") (il:* il:|;;| "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 ((il:region (il:|fetch| (il:window il:reg) il:|of| il:window)) (il:oldsave (il:|fetch| (il:window il:save) il:|of| il:window)) il:nusav il:delta il:nuwidth il:nuheight il:hidden?) (il:setq il:delta (il:idifference il:newborder il:oldborder)) (il:setq il:nuwidth (il:iplus (il:|fetch| (il:region il:width) il:|of| il:region) (il:itimes il:delta 2))) (il:setq il:nuheight (il:idifference (il:iplus (il:|fetch| (il:region il:height) il:|of| (il:dspclippingregion nil (il:|fetch| (il:window il:dsp) il:|of| il:window))) (il:itimes il:newborder 2)) (cond ((il:|fetch| (il:window il:wtitle) il:|of| il:window) (il:dsplinefeed nil (il:|fetch| (il:screen il:sctitleds) il:|of| (il:|fetch| (il:window il:screen) il:|of| il:window)))) (t 0)))) (il:setq il:nusav (il:bitmapcreate il:nuwidth il:nuheight (il:|fetch| (il:bitmap il:bitmapbitsperpixel) il:|of| il:oldsave))) (il:setq il:hidden? (window-hidden? il:window)) (il:.while.top.ds. il:window (il:* il:\; "Save window image") (or il:hidden? (il:\\sw2bm (il:|fetch| (il:screen il:scdestination) il:|of| (il:|fetch| (il:window il:screen) il:|of| il:window)) il:region (il:|fetch| (il:window il:save) il:|of| il:window) nil)) (il:* il:\; "put new save image into window") (il:|replace| (il:window il:save) il:|of| il:window il:|with| il:nusav) (il:if il:hidden? il:then (il:dspdestination il:nusav il:window)) (il:|replace| (il:window il:wborder) il:|of| il:window il:|with| il:newborder) (il:if il:hidden? il:then (il:* il:|;;| "re-adjust X & Y offset") (il:dspxoffset il:newborder il:window) (il:dspyoffset il:newborder il:window)) (il:* il:\; "create a region that coresponds to the old region with the new border.") (il:|replace| (il:window il:reg) il:|of| il:window il:|with| (il:|create| il:region il:left il:_ (il:idifference (il:|fetch| (il:region il:left) il:|of| il:region) il:delta) il:bottom il:_ (il:idifference (il:|fetch| (il:region il:bottom) il:|of| il:region) il:delta) il:width il:_ il:nuwidth il:height il:_ il:nuheight)) (il:update/scroll/reg il:window) (il:* il:\; "draw border in the new image.") (il:showwframe il:window) (il:* il:\; "copy the visible part from the old image into the new one.") (il:bitblt il:oldsave il:oldborder il:oldborder il:nusav il:newborder il:newborder (il:idifference (il:|fetch| (il:bitmap il:bitmapwidth) il:|of| il:oldsave) (il:itimes 2 il:oldborder)) (il:|fetch| (il:region il:height) il:|of| (il:dspclippingregion nil (il:|fetch| (il:window il:dsp) il:|of| il:window))) (quote il:input) (quote il:replace)) (il:* il:\; "put the new image up on the screen.") (or il:hidden? (il:\\sw2bm (il:|fetch| (il:screen il:scdestination) il:|of| (il:|fetch| (il:window il:screen) il:|of| il:window)) (il:|fetch| (il:window il:reg) il:|of| il:window) (il:|fetch| (il:window il:save) il:|of| il:window) nil)))))
+)

(ttyin.setup
+(il:lambda nil (il:* il:\; "Edited 16-Jun-88 11:37 by drc:") (il:* il:\; "Disable buttons so we can do selection") (let ((il:window (il:wfromds il:\\dsp t))) (cond (il:window (il:|replace| (il:ttyinbuffer il:ttoldrightfn) il:|of| il:\\ttyinstate il:|with| (il:windowprop il:window (quote il:rightbuttonfn) (quote il:totopw))) (il:|replace| (il:ttyinbuffer il:ttoldbuttonfn) il:|of| il:\\ttyinstate il:|with| (il:windowprop il:window (quote il:buttoneventfn) (quote il:totopw))) (il:|replace| (il:ttyinbuffer il:ttoldentryfn) il:|of| il:\\ttyinstate il:|with| (il:windowprop il:window (quote il:windowentryfn) (quote il:ttyinentryfn))) (il:|replace| (il:ttyinbuffer il:ttyinwindow) il:|of| il:\\ttyinstate il:|with| il:window) (il:windowprop il:window (quote il:ttyinstate) (il:|fetch| (il:ttyinbuffer il:ttyinwindowstate) il:|of| il:\\ttyinstate)) (il:resetsave nil (list (il:function il:ttyin.cleanup) il:\\ttyinstate)))) (cond ((or (il:imagestreamtypep il:\\dsp (quote il:text)) (il:fmemb (il:dspdestination nil il:\\dsp) il:\\screenbitmaps) (and il:window (window-hidden? il:window))) (il:setq il:\\charwidth (il:charwidth (il:charcode il:a) il:\\dsp)) (il:setq il:\\font (il:dspfont nil il:\\dsp)) (il:|if| (eq il:\\font il:\\ttyin.last.font) il:|then| (il:setq il:\\commentfont il:\\ttyin.last.commentfont) il:|elseif| il:\\reading il:|then| (il:* il:\; "Want a \"comment\" font for ?=") (il:setq il:\\commentfont (il:setq il:\\ttyin.last.commentfont (il:fontcopy il:\\font (quote il:weight) (il:selectq (il:fontprop il:\\font (quote il:weight)) (il:bold (quote il:medium)) (quote il:bold))))) (il:setq il:\\ttyin.last.font il:\\font) il:|else| (il:setq il:\\commentfont il:\\font)) (il:setq il:\\charheight (max (il:fontheight il:\\font) (il:fontheight il:\\commentfont))) (il:setq il:\\descent (il:fontprop il:\\font (quote il:descent))) (il:* il:\; "How many pixels below the baseline this font goes") (il:setq il:\\texture (il:dsptexture nil il:\\dsp)) (il:setq il:\\ttpagelength (il:pageheight nil il:\\dsp)) (il:setq il:\\lmarg (il:dspleftmargin nil il:\\dsp)) (il:* il:\; "bit pos of left margin") (il:setq il:\\rmarg (il:dsprightmargin nil il:\\dsp)) (il:* il:\; "bit pos of right margin, dsp relative") (il:setq il:\\initpos (il:dspxposition nil il:\\dsp))))))
+)
)
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY

(IL:GLOBALVARS IL:LAMBDASPLST IL:\\EM.DISPINTERRUPT IL:\\SCREENBITMAPS IL:\\TTYIN.LAST.FONT 
       IL:\\TTYIN.LAST.COMMENTFONT)
)
(EVAL-WHEN (LOAD)

(IL:MOVD 'SHAPEW1 'IL:SHAPEW1)

(IL:MOVD '\\CLOSEW1 'IL:\\CLOSEW1)

(IL:MOVD 'MOVEW 'IL:MOVEW)

(IL:MOVD '\\INTERNALTOTOPW 'IL:\\INTERNALTOTOPW)

(IL:MOVD 'WFROMMENU 'IL:WFROMMENU)

(IL:MOVD 'RESHOWTITLE 'IL:RESHOWTITLE)

(IL:MOVD '\\RESHOWBORDER1 'IL:\\RESHOWBORDER1)

(IL:MOVD 'TTYIN.SETUP 'IL:TTYIN.SETUP)
)

(REINSTALL-ADVICE 'IL:ATTACHWINDOW :AFTER '((:LAST (WHEN (AND (WINDOW-HIDDEN? (IL:INSURE.WINDOW
                                                                                   IL:MAINWINDOW))
                                                              (NOT (WINDOW-HIDDEN? (
                                                                                     IL:INSURE.WINDOW
                                                                                        
                                                                                    IL:WINDOWTOATTACH
                                                                                        ))))
                                                         (HIDE-WINDOW-INTERNAL IL:WINDOWTOATTACH)
                                                         ))))

(IL:READVISE IL:ATTACHWINDOW)
(IL:PUTPROPS IL:ROOMS-WINDOW-HIDER IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (2505 3071 (ALL-WINDOWS 2505 . 3071)) (3073 3538 (LOST-WINDOWS 3073 . 3538)) (3540 
3653 (HIDE-ALL-WINDOWS 3540 . 3653)) (3655 4001 (HIDE-WINDOW 3655 . 4001)) (4003 5348 (
HIDE-WINDOW-INTERNAL 4003 . 5348)) (5350 5658 (UN-HIDE-WINDOW 5350 . 5658)) (5660 7422 (
UN-HIDE-WINDOW-INTERNAL 5660 . 7422)) (7424 8040 (DO-TOTOP-FUNCTIONS 7424 . 8040)) (8042 8109 (
WINDOW-HIDDEN? 8042 . 8109)) (8886 29312 (SHAPEW1 8899 . 11521) (\\CLOSEW1 11523 . 12510) (MOVEW 12512
 . 19579) (\\INTERNALTOTOPW 19581 . 20375) (WFROMMENU 20377 . 20881) (RESHOWTITLE 20883 . 23878) (
\\RESHOWBORDER1 23880 . 27015) (TTYIN.SETUP 27017 . 29310)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-WINDOW-HIDER.DFASL b/rooms/ROOMS-WINDOW-HIDER.DFASL
new file mode 100644
index 00000000..567cd4e0
Binary files /dev/null and b/rooms/ROOMS-WINDOW-HIDER.DFASL differ
diff --git a/rooms/ROOMS-WINDOW-TYPES b/rooms/ROOMS-WINDOW-TYPES
new file mode 100644
index 00000000..dd0d249d
--- /dev/null
+++ b/rooms/ROOMS-WINDOW-TYPES
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:34:55" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-WINDOW-TYPES.;2| 8980   

      IL:|previous| IL:|date:| "17-Aug-90 13:37:32" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>ROOMS-WINDOW-TYPES.;1|)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:ROOMS-WINDOW-TYPESCOMS)

(IL:RPAQQ IL:ROOMS-WINDOW-TYPESCOMS
          ((FILE-ENVIRONMENTS IL:ROOMS-WINDOW-TYPES)
           (IL:P (EXPORT '(DEF-WINDOW-TYPE WINDOW-TYPE WINDOW-TYPE-PROP))
                 (REQUIRE "ROOMS"))
           (IL:STRUCTURES WINDOW-TYPE)
           (IL:FUNCTIONS WINDOW-TYPE-PROP)
           (IL:DEFINE-TYPES IL:WINDOW-TYPES)
           (IL:VARIABLES *WINDOW-TYPES*)
           (IL:FUNCTIONS DEF-WINDOW-TYPE WINDOW-TYPE-NAMED WINDOW-TYPE WINDOW-TYPE-INTERNAL 
                  ABSTRACT-WINDOW RECONSTITUTE-WINDOW)
           (IL:SEDIT-FORMATS DEF-WINDOW-TYPE)))

(DEFINE-FILE-ENVIRONMENT IL:ROOMS-WINDOW-TYPES :COMPILER :COMPILE-FILE
   :PACKAGE "ROOMS"
   :READTABLE "XCL")

(EXPORT '(DEF-WINDOW-TYPE WINDOW-TYPE WINDOW-TYPE-PROP))

(REQUIRE "ROOMS")

(DEFSTRUCT (WINDOW-TYPE (:PRINT-FUNCTION (LAMBDA (WINDOW-TYPE STREAM DEPTH)
                                                    (FORMAT STREAM "#<Window Type ~S>" (
                                                                                     WINDOW-TYPE-NAME
                                                                                        WINDOW-TYPE))
                                                    )))
   (NAME NIL :TYPE STRING)
   (DEPENDENCIES NIL :TYPE LIST)
   (RECOGNIZER NIL :TYPE FUNCTION)
   (ABSTRACTER NIL :TYPE FUNCTION)
   (RECONSTITUTER NIL :TYPE FUNCTION)
   (PLACER NIL :TYPE FUNCTION)
   (UPDATER NIL :TYPE FUNCTION)
   (PROPS NIL :TYPE LIST))

(DEFMACRO WINDOW-TYPE-PROP (WINDOW-TYPE PROP &OPTIONAL (NEW-VALUE NIL NEW-VALUE-SUPPLIED))
   (IF NEW-VALUE-SUPPLIED
       `(SETF (GETF (WINDOW-TYPE-PROPS ,WINDOW-TYPE)
                    ,PROP)
              ,NEW-VALUE)
       `(GETF (WINDOW-TYPE-PROPS ,WINDOW-TYPE)
              ,PROP)))

(DEF-DEFINE-TYPE IL:WINDOW-TYPES "Window types"
   :UNDEFINER (LAMBDA (NAME)
                     (REMHASH NAME *WINDOW-TYPES*)))

(DEFGLOBALVAR *WINDOW-TYPES* (MAKE-HASH-TABLE :TEST 'EQ)
                                 "Hash table mapping from window type names to window type objects.")

(DEFDEFINER DEF-WINDOW-TYPE IL:WINDOW-TYPES (NAME &REST REST-KEYS &KEY DEPENDENCIES RECOGNIZER 
                                                      ABSTRACTER RECONSTITUTER PLACER UPDATER 
                                                      &ALLOW-OTHER-KEYS)

(IL:* IL:|;;;| "defines a window type")

   (FLET ((KWOTE (X)

                 (IL:* IL:|;;| 
               "we want lambda expressions wrapped in FUNCTION and named functions just quoted")

                 (TYPECASE X
                     (CONS (LIST (CASE (FIRST X)
                                     ((LAMBDA IL:LAMBDA) 'FUNCTION)
                                     (T 'QUOTE))
                                 X))
                     ((SATISFIES CONSTANTP) X)
                     (T (LIST 'QUOTE X)))))
         `(SETF (GETHASH ',NAME *WINDOW-TYPES*)
                (MAKE-WINDOW-TYPE :NAME ',NAME :DEPENDENCIES ',DEPENDENCIES :RECOGNIZER
                       ,(KWOTE RECOGNIZER)
                       ,@(WHEN ABSTRACTER
                             `(:ABSTRACTER ,(KWOTE ABSTRACTER)))
                       ,@(WHEN RECONSTITUTER
                             `(:RECONSTITUTER ,(KWOTE RECONSTITUTER)))
                       ,@(WHEN UPDATER
                             `(:UPDATER ,(KWOTE UPDATER)))
                       ,@(WHEN PLACER
                             `(:PLACER ,(KWOTE PLACER)))
                       :PROPS
                       (LIST ,@(MAPCAR #'KWOTE
                                      (LET ((PROPS (COPY-LIST REST-KEYS)))
                                           (DOLIST (KEYWORD '(:DEPENDENCIES :RECOGNIZER :ABSTRACTER 
                                                                    :RECONSTITUTER :PLACER :UPDATER))
                                               (REMF PROPS KEYWORD))
                                           PROPS)))))))

(DEFUN WINDOW-TYPE-NAMED (NAME &OPTIONAL NO-ERROR?)
   (OR (GETHASH NAME *WINDOW-TYPES*)
       (UNLESS NO-ERROR? (ERROR "No window type named ~S." NAME))))

(DEFUN WINDOW-TYPE (WINDOW &OPTIONAL NO-ERROR?)

(IL:* IL:|;;;| "return the window type object for WINDOW.")

   (LET ((CACHED-TYPE-NAME (IL:WINDOWPROP WINDOW 'WINDOW-TYPE)))
        (IF CACHED-TYPE-NAME
            (LET ((TYPE (WINDOW-TYPE-NAMED CACHED-TYPE-NAME T)))
                 (IF (AND TYPE (FUNCALL (WINDOW-TYPE-RECOGNIZER TYPE)
                                      WINDOW))
                     TYPE
                     (PROGN 
                            (IL:* IL:|;;| "invalidate cache")

                            (IL:WINDOWPROP WINDOW 'WINDOW-TYPE NIL)

                            (IL:* IL:|;;| "try again")

                            (WINDOW-TYPE WINDOW NO-ERROR?))))
            (LET ((TYPE (WINDOW-TYPE-INTERNAL WINDOW NO-ERROR?)))

                 (IL:* IL:|;;| "should cache misses here too")

                 (WHEN TYPE                                  (IL:* IL:\; "cache it")
                     (IL:WINDOWPROP WINDOW 'WINDOW-TYPE (WINDOW-TYPE-NAME TYPE))
                                                             (IL:* IL:\; "return it")
                     TYPE)))))

(DEFUN WINDOW-TYPE-INTERNAL (WINDOW NO-ERROR?)

(IL:* IL:|;;;| "We only want the most specific type -- that which no others are dependent upon.  We find this by first enumerating all the types whose recognizer fires on WINDOW.  We then delete from this list any types upon which others in the list are dependent.  The remaining list should have only one element -- the right type.")

   (LET* ((ALL-TYPES (WITH-COLLECTION (MAPHASH #'(LAMBDA (NAME TYPE)
                                                        (WHEN (FUNCALL (WINDOW-TYPE-RECOGNIZER TYPE)
                                                                     WINDOW)
                                                              (COLLECT TYPE)))
                                             *WINDOW-TYPES*)))
          (REMAINING-TYPES (COPY-LIST ALL-TYPES)))
         (DOLIST (TYPE ALL-TYPES)
             (DOLIST (DEPENDENCY (WINDOW-TYPE-DEPENDENCIES TYPE))
                 (SETQ REMAINING-TYPES (DELETE (WINDOW-TYPE-NAMED DEPENDENCY)
                                              REMAINING-TYPES))))
         (COND
            ((NULL REMAINING-TYPES)
             (UNLESS NO-ERROR? (ERROR "Can't find window type for ~S." WINDOW)))
            ((ENDP (REST REMAINING-TYPES))
             (FIRST REMAINING-TYPES))
            (T (UNLESS NO-ERROR?
                   (ERROR "Type conflict: ~S is of types ~S." WINDOW (MAPCAR #'WINDOW-TYPE-NAME 
                                                                            REMAINING-TYPES)))))))

(DEFUN ABSTRACT-WINDOW (WINDOW &OPTIONAL SHH)

(IL:* IL:|;;;| 
"returns an abstraction suitable for passing to RECONSTITUTE-WINDOW, or NIL if it can't find one.")

   (LET* ((TYPE (WINDOW-TYPE WINDOW T))
          (ABSTRACTER (AND TYPE (WINDOW-TYPE-ABSTRACTER TYPE))))
         (IF ABSTRACTER
             (LIST* :TYPE (WINDOW-TYPE-NAME TYPE)
                    (FUNCALL ABSTRACTER WINDOW))
             (UNLESS SHH
                 (FRESH-LINE *ERROR-OUTPUT*)
                 (IF TYPE
                     (FORMAT *ERROR-OUTPUT* "Can't abstract windows of type ~S." (WINDOW-TYPE-NAME
                                                                                  TYPE))
                     (FORMAT *ERROR-OUTPUT* "~S has no type." WINDOW))
                 (LET ((HIDDEN? (WINDOW-HIDDEN? WINDOW)))
                      (WHEN HIDDEN? (UN-HIDE-WINDOW WINDOW))
                      (IL:FLASHWINDOW (IF (SHRUNKEN? WINDOW)
                                          (WINDOW-ICON WINDOW)
                                          WINDOW)
                             2)
                      (WHEN HIDDEN? (HIDE-WINDOW WINDOW)))
                 (FORMAT *ERROR-OUTPUT* "  Ignoring.~%")
                 NIL))))

(DEFUN RECONSTITUTE-WINDOW (TYPE-NAME ARG)
   (LET ((TYPE (WINDOW-TYPE-NAMED TYPE-NAME T)))
        (IF TYPE
            (FUNCALL (WINDOW-TYPE-RECONSTITUTER TYPE)
                   ARG)
            (PROG1 NIL (WARN "Can't reconstitute windows of type ~A." TYPE-NAME)))))

(SEDIT:DEF-LIST-FORMAT DEF-WINDOW-TYPE :ARGS (NIL :KEYWORD NIL)
   :INDENT (1))
(IL:PUTPROPS IL:ROOMS-WINDOW-TYPES IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (4427 4587 (WINDOW-TYPE-NAMED 4427 . 4587)) (4589 5733 (WINDOW-TYPE 4589 . 5733)) (
5735 7256 (WINDOW-TYPE-INTERNAL 5735 . 7256)) (7258 8486 (ABSTRACT-WINDOW 7258 . 8486)) (8488 8767 (
RECONSTITUTE-WINDOW 8488 . 8767)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/ROOMS-WINDOW-TYPES.DFASL b/rooms/ROOMS-WINDOW-TYPES.DFASL
new file mode 100644
index 00000000..c1049d1a
Binary files /dev/null and b/rooms/ROOMS-WINDOW-TYPES.DFASL differ
diff --git a/rooms/ROOMS.DFASL b/rooms/ROOMS.DFASL
new file mode 100644
index 00000000..74e0bc02
Binary files /dev/null and b/rooms/ROOMS.DFASL differ
diff --git a/rooms/ROOMSTECHDESC.TEDIT b/rooms/ROOMSTECHDESC.TEDIT
new file mode 100644
index 00000000..97e7d0ce
Binary files /dev/null and b/rooms/ROOMSTECHDESC.TEDIT differ
diff --git a/rooms/ROOMSUSERS-RULES.TEDIT b/rooms/ROOMSUSERS-RULES.TEDIT
new file mode 100644
index 00000000..0ddcc3c8
Binary files /dev/null and b/rooms/ROOMSUSERS-RULES.TEDIT differ
diff --git a/rooms/RoomsUsers-Rules.IP b/rooms/RoomsUsers-Rules.IP
new file mode 100644
index 00000000..2c35ca44
Binary files /dev/null and b/rooms/RoomsUsers-Rules.IP differ
diff --git a/rooms/SCREENPAPER b/rooms/SCREENPAPER
new file mode 100644
index 00000000..66bca6f5
--- /dev/null
+++ b/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)))
+    BM2])

(INVERT.BITMAP.VERTICALLY
+  [LAMBDA (BITMAP BM2 PBT)                                   (* edited%: "31-Dec-00 18:13")
+    (OR BM2 (SETQ BM2 (BITMAPCOPY BITMAP)))
+    (OR PBT (SETQ PBT (create PILOTBBT)))
+    [with PILOTBBT PBT                                       (*)
+          (SETQ PBTDESTHI (ffetch BitMapHiLoc BM2))
+          [SETQ PBTDESTLO (PLUS (ffetch BitMapLoLoc BM2)
+                                (TIMES (SUB1 (ffetch BITMAPHEIGHT BITMAP))
+                                       (ffetch BITMAPRASTERWIDTH BM2]
+          (SETQ PBTSOURCELO (ffetch BitMapLoLoc BITMAP))
+          (SETQ PBTSOURCEHI (ffetch BitMapHiLoc BITMAP))
+          (SETQ PBTDESTBPL (TIMES 16 (ffetch BITMAPRASTERWIDTH BM2)))
+          (SETQ PBTSOURCEBPL (TIMES 16 (ffetch BITMAPRASTERWIDTH BITMAP)))
+          (SETQ PBTSOURCEBIT 0)
+          (SETQ PBTDESTBIT 0)
+          (SETQ PBTFLAGS 16384)                              (* by experiment, disjoint replace)
+          (SETQ PBTHEIGHT 1)
+          (SETQ PBTWIDTH (ffetch BITMAPWIDTH BITMAP))
+          (for I from 0 while (LESSP I (ffetch BITMAPHEIGHT BITMAP))
+             do (\PILOTBITBLT PBT 0)
+                (add PBTSOURCELO (ffetch BITMAPRASTERWIDTH BITMAP))
+                (add PBTDESTLO (MINUS (ffetch BITMAPRASTERWIDTH BM2]
+    BM2])

(ROTATE.BITMAP
+  [LAMBDA (BITMAP BM2 PBT)                                   (* edited%: "31-Dec-00 16:24")
+    [OR BM2 (SETQ BM2 (BITMAPCREATE (ffetch BITMAPHEIGHT BITMAP)
+                             (ffetch BITMAPWIDTH BITMAP]
+    (OR PBT (SETQ PBT (create PILOTBBT)))
+    [with PILOTBBT PBT                                       (*)
+          (SETQ PBTDESTHI (ffetch BitMapHiLoc BM2))
+          (SETQ PBTDESTLO (ffetch BitMapLoLoc BM2))
+          (SETQ PBTSOURCELO (ffetch BitMapLoLoc BITMAP))
+          (SETQ PBTSOURCEHI (ffetch BitMapHiLoc BITMAP))
+          (SETQ PBTDESTBPL (TIMES 16 (ffetch BITMAPRASTERWIDTH BM2)))
+          (SETQ PBTSOURCEBPL 1)
+          (SETQ PBTSOURCEBIT 0)
+          (SETQ PBTDESTBIT (ffetch BITMAPWIDTH BM2))
+          (SETQ PBTFLAGS 0)                                  (* by experiment, disjoint replace)
+          (SETQ PBTHEIGHT (ffetch BITMAPHEIGHT BM2))
+          (SETQ PBTWIDTH 1)
+          (for I from 0 while (LESSP I (ffetch BITMAPHEIGHT BITMAP))
+             do (add PBTDESTBIT -1)
+                (\PILOTBITBLT PBT 0)
+                (add PBTSOURCELO (ffetch BITMAPRASTERWIDTH BITMAP]
+    BM2])
)

(RPAQQ SCREENPAPERSIZE 64)

(RPAQQ SCREENPERIOD 100)

(RPAQQ SCREENREPEAT 0)
(PUTPROPS SCREENPAPER COPYRIGHT ("Venue & Xerox Corporation" 1901 1986 1988 1990 2020))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (851 8746 (SCREENPAPER 861 . 5549) (SCREENPAPERNEWREGIONFN 5551 . 6058) (KALSHOW 6060 . 
7050) (DOPOINT 7052 . 7424) (MAPN 7426 . 8744)) (8870 12612 (INVERT.BITMAP.HORIZONTALLY 8880 . 9997) (
INVERT.BITMAP.VERTICALLY 9999 . 11375) (ROTATE.BITMAP 11377 . 12610)))))
STOP
\ No newline at end of file
diff --git a/rooms/SCREENPAPER.LCOM b/rooms/SCREENPAPER.LCOM
new file mode 100644
index 00000000..d1edceae
Binary files /dev/null and b/rooms/SCREENPAPER.LCOM differ
diff --git a/rooms/TABLE-OF-CONTENTS.TEDIT b/rooms/TABLE-OF-CONTENTS.TEDIT
new file mode 100644
index 00000000..c4a761d0
Binary files /dev/null and b/rooms/TABLE-OF-CONTENTS.TEDIT differ
diff --git a/rooms/TITLEPAGE.TEDIT b/rooms/TITLEPAGE.TEDIT
new file mode 100644
index 00000000..f3fd5b50
Binary files /dev/null and b/rooms/TITLEPAGE.TEDIT differ
diff --git a/rooms/TOUCHY-BUTTONS b/rooms/TOUCHY-BUTTONS
new file mode 100644
index 00000000..1c99c740
--- /dev/null
+++ b/rooms/TOUCHY-BUTTONS
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "ROOMS" READTABLE "XCL")
(IL:FILECREATED " 5-Dec-2020 16:37:08" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>TOUCHY-BUTTONS.;2| 7138   

      IL:|previous| IL:|date:| "17-Aug-90 14:46:54" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>TOUCHY-BUTTONS.;1|)


; Copyright (c) 1987, 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:TOUCHY-BUTTONSCOMS)

(IL:RPAQQ IL:TOUCHY-BUTTONSCOMS
          (
           (IL:* IL:|;;| "Includer buttons so you can have dynamic mixin rooms.  For example, you can have a \"Notecards-Mixin\" or \"Programming-Mixin\" Room and have buttons to include these in \"Pockets\"  then whenever you need these facilities you can mix them in.")

           (IL:FUNCTIONS MAKE-INCLUDER INCLUDER-TEXT INCLUDER-ACTION)
           
           (IL:* IL:|;;| "Toggle buttons for switching between variable settings.  This should obviously be generalized to something that allows you to select or circulate through value settings.")

           (IL:FUNCTIONS MAKE-TOGGLER MAKE-N-VALUER MAKE-EXSET-TOGGLER MAKE-RANGE-TOGGLER 
                  N-VALUER-ACTION N-VALUER-TEXT CHECK-EVAL)
           (IL:FUNCTIONS MAKE-SWITCH SWITCH-ACTION)
           
           (IL:* IL:|;;| "")

           
           (IL:* IL:|;;| 
         "(MAKE-ONCE-ONLY (IL:PROMPTPRINT \"Hello, World\") \"Fire...\" \"Exhausted\")")

           (IL:FUNCTIONS MAKE-ONCE-ONLY ONCE-ONLY-ACTION ONCE-ONLY-TEXT)
           (IL:DECLARE\: IL:DONTCOPY (IL:PROPS (IL:TOUCHY-BUTTONS IL:MAKEFILE-ENVIRONMENT)
                                            (IL:TOUCHY-BUTTONS IL:FILETYPE)))))



(IL:* IL:|;;| 
"Includer buttons so you can have dynamic mixin rooms.  For example, you can have a \"Notecards-Mixin\" or \"Programming-Mixin\" Room and have buttons to include these in \"Pockets\"  then whenever you need these facilities you can mix them in."
)


(DEFUN MAKE-INCLUDER (ROOM-NAME)
   (MAKE-BUTTON-WINDOW (MAKE-BUTTON :TEXT-FORM (LIST 'INCLUDER-TEXT ROOM-NAME)
                              :ACTION
                              'INCLUDER-ACTION :INCLUDER-ROOM-NAME ROOM-NAME)))

(DEFUN INCLUDER-TEXT (INCLUDER-ROOM-NAME)
   (LET ((INCLUSIONS (ROOM-INCLUSIONS *CURRENT-ROOM*)))
        (IF (LISTP INCLUSIONS)
            (IF (MEMBER INCLUDER-ROOM-NAME INCLUSIONS :TEST #'EQUAL)
                (FORMAT NIL "Exclude ~A" INCLUDER-ROOM-NAME)
                (FORMAT NIL "Include ~A" INCLUDER-ROOM-NAME))
            (FORMAT NIL "*-???-* ~A" INCLUDER-ROOM-NAME))))

(DEFUN INCLUDER-ACTION (DSP BUTTON)
   (LET* ((ROOM *CURRENT-ROOM*)
          (INCLUDER-ROOM-NAME (BUTTON-PROP BUTTON :INCLUDER-ROOM-NAME)))
         (UPDATE-PLACEMENTS)
         (IF (MEMBER INCLUDER-ROOM-NAME (ROOM-INCLUSIONS ROOM)
                    :TEST
                    #'EQUAL)
             (SETF (ROOM-INCLUSIONS ROOM)
                   (DELETE INCLUDER-ROOM-NAME (ROOM-INCLUSIONS ROOM)
                          :TEST
                          #'EQUAL))
             (PUSH INCLUDER-ROOM-NAME (ROOM-INCLUSIONS ROOM)))
         (ROOM-CHANGED ROOM :EDITED)))



(IL:* IL:|;;| 
"Toggle buttons for switching between variable settings.  This should obviously be generalized to something that allows you to select or circulate through value settings."
)


(DEFUN MAKE-TOGGLER (VARIABLE-NAME &REST KEYS)
   (APPLY #'MAKE-N-VALUER VARIABLE-NAME '(NIL T)
          KEYS))

(DEFUN MAKE-N-VALUER (VARIABLE-NAME N-VALUES &REST KEYS)
   (MAKE-BUTTON-WINDOW (APPLY #'MAKE-BUTTON :TEXT-FORM `(N-VALUER-TEXT ',VARIABLE-NAME)
                              :ACTION
                              'N-VALUER-ACTION :VARIABLE-NAME VARIABLE-NAME :N-VALUES N-VALUES KEYS)))

(DEFUN MAKE-EXSET-TOGGLER (VARIABLE-NAME EXPLICIT-SET &REST KEYS)
   (APPLY #'MAKE-N-VALUER VARIABLE-NAME EXPLICIT-SET :HELP (FORMAT NIL "Set variable ~S" 
                                                                  VARIABLE-NAME)
          KEYS))

(DEFUN MAKE-RANGE-TOGGLER (VARIABLE-NAME RANGE-START RANGE-END &REST KEYS)
   (APPLY #'MAKE-N-VALUER VARIABLE-NAME (DO ((I RANGE-START (1+ I))
                                             (ACCUMULATOR NIL ACCUMULATOR))
                                            ((> I RANGE-END)
                                             (NREVERSE ACCUMULATOR))
                                          (PUSH I ACCUMULATOR))
          :HELP
          (FORMAT NIL "Set variable ~S" VARIABLE-NAME)
          KEYS))

(DEFUN N-VALUER-ACTION (DSP BUTTON)
   (LET* ((N-VALUES (BUTTON-PROP BUTTON :N-VALUES))
          (VARIABLE-NAME (BUTTON-PROP BUTTON :VARIABLE-NAME)))
         (SETQ N-VALUES (REMOVE (CHECK-EVAL VARIABLE-NAME)
                               N-VALUES))
         (SET VARIABLE-NAME (IF (EQ (LENGTH N-VALUES)
                                    1)
                                (CAR N-VALUES)
                                (IL:MENU (IL:CREATE IL:MENU
                                                IL:ITEMS IL:_ N-VALUES))))))

(DEFUN N-VALUER-TEXT (VARIABLE-NAME)
   (FORMAT NIL "~A is ~a" VARIABLE-NAME (CHECK-EVAL VARIABLE-NAME)))

(DEFUN CHECK-EVAL (VARIABLE-NAME)
   (IF (BOUNDP VARIABLE-NAME)
       (EVAL VARIABLE-NAME)
       "Unbound"))

(DEFUN MAKE-SWITCH (DECISION-FN SET-FN TEXT-FORM &REST KEYS)
   (MAKE-BUTTON-WINDOW (APPLY #'MAKE-BUTTON :TEXT-FORM TEXT-FORM :ACTION 'SWITCH-ACTION :DECISION-FN
                              DECISION-FN :SET-FN SET-FN KEYS)))

(DEFUN SWITCH-ACTION (DSP BUTTON)
   (LET* ((VALUE (FUNCALL (BUTTON-PROP BUTTON :DECISION-FN)
                        BUTTON)))
         (FUNCALL (BUTTON-PROP BUTTON :SET-FN)
                BUTTON VALUE)))



(IL:* IL:|;;| "")




(IL:* IL:|;;| "(MAKE-ONCE-ONLY (IL:PROMPTPRINT \"Hello, World\") \"Fire...\" \"Exhausted\")")


(DEFUN MAKE-ONCE-ONLY (FORM INITIAL-TEXT FINAL-TEXT)
   (MAKE-BUTTON-WINDOW (MAKE-BUTTON :TEXT INITIAL-TEXT :TEXT-FORM 'ONCE-ONLY-TEXT :ACTION
                              'ONCE-ONLY-ACTION :ONCE-ONLY-FORM FORM :INITIAL-TEXT INITIAL-TEXT 
                              :FINAL-TEXT FINAL-TEXT)))

(DEFUN ONCE-ONLY-ACTION (STREAM BUTTON)
   (UNLESS (IL:STREAMPROP (IL:GETSTREAM STREAM)
                  BUTTON)

       (IL:* IL:|;;| "store the state of the button on its host, so that the state is reset each time the button is reconstituted.")

       (EVAL (BUTTON-PROP BUTTON :ONCE-ONLY-FORM))
       (IL:STREAMPROP (IL:GETSTREAM STREAM)
              BUTTON T)))

(DEFUN ONCE-ONLY-TEXT (STREAM BUTTON)
   (WHEN STREAM
       (IF (IL:STREAMPROP (IL:GETSTREAM STREAM)
                  BUTTON)
           (BUTTON-PROP BUTTON :FINAL-TEXT)
           (BUTTON-PROP BUTTON :INITIAL-TEXT))))
(IL:DECLARE\: IL:DONTCOPY 

(IL:PUTPROPS IL:TOUCHY-BUTTONS IL:MAKEFILE-ENVIRONMENT (:PACKAGE "ROOMS" :READTABLE "XCL"))

(IL:PUTPROPS IL:TOUCHY-BUTTONS IL:FILETYPE :COMPILE-FILE)
)
(IL:PUTPROPS IL:TOUCHY-BUTTONS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (1998 2231 (MAKE-INCLUDER 1998 . 2231)) (2233 2617 (INCLUDER-TEXT 2233 . 2617)) (2619
 3191 (INCLUDER-ACTION 2619 . 3191)) (3390 3506 (MAKE-TOGGLER 3390 . 3506)) (3508 3801 (MAKE-N-VALUER 
3508 . 3801)) (3803 4060 (MAKE-EXSET-TOGGLER 3803 . 4060)) (4062 4566 (MAKE-RANGE-TOGGLER 4062 . 4566)
) (4568 5108 (N-VALUER-ACTION 4568 . 5108)) (5110 5223 (N-VALUER-TEXT 5110 . 5223)) (5225 5339 (
CHECK-EVAL 5225 . 5339)) (5341 5571 (MAKE-SWITCH 5341 . 5571)) (5573 5783 (SWITCH-ACTION 5573 . 5783))
 (5913 6212 (MAKE-ONCE-ONLY 5913 . 6212)) (6214 6591 (ONCE-ONLY-ACTION 6214 . 6591)) (6593 6817 (
ONCE-ONLY-TEXT 6593 . 6817)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/TOUCHY-BUTTONS.DFASL b/rooms/TOUCHY-BUTTONS.DFASL
new file mode 100644
index 00000000..ba3962a6
Binary files /dev/null and b/rooms/TOUCHY-BUTTONS.DFASL differ
diff --git a/rooms/TOUCHY-BUTTONS.TEDIT b/rooms/TOUCHY-BUTTONS.TEDIT
new file mode 100644
index 00000000..6c12520d
Binary files /dev/null and b/rooms/TOUCHY-BUTTONS.TEDIT differ
diff --git a/rooms/UN-HIDE-TTY b/rooms/UN-HIDE-TTY
new file mode 100644
index 00000000..8cf6f5dd
--- /dev/null
+++ b/rooms/UN-HIDE-TTY
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:37:26" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>UN-HIDE-TTY.;2| 1806   

      IL:|previous| IL:|date:| "17-Aug-90 14:47:42" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>UN-HIDE-TTY.;1|)


; Copyright (c) 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:UN-HIDE-TTYCOMS)

(IL:RPAQQ IL:UN-HIDE-TTYCOMS ((FILE-ENVIRONMENTS IL:UN-HIDE-TTY)
                                  
                                  (IL:* IL:|;;| 
"make Control-Y be an interrupt which yanks the window with the TTY process into the current room.")

                                  (IL:P (EXPORT 'UN-HIDE-TTY "ROOMS"))
                                  (IL:FUNCTIONS UN-HIDE-TTY)
                                  (IL:P (IL:INTERRUPTCHAR (CHAR-CODE #\^Y)
                                               '(UN-HIDE-TTY)))))

(DEFINE-FILE-ENVIRONMENT IL:UN-HIDE-TTY :COMPILER :COMPILE-FILE
   :PACKAGE "ROOMS"
   :READTABLE "XCL")



(IL:* IL:|;;| 
"make Control-Y be an interrupt which yanks the window with the TTY process into the current room.")


(EXPORT 'UN-HIDE-TTY "ROOMS")

(DEFUN UN-HIDE-TTY ()
   (LET ((TTY-WINDOW (IL:WFROMDS (IL:PROCESS.TTY (IL:TTY.PROCESS))
                            T)))
        (IF TTY-WINDOW
            (IF (WINDOW-HIDDEN? TTY-WINDOW)
                (UN-HIDE-WINDOW TTY-WINDOW)
                (IL:FLASHWINDOW TTY-WINDOW))
            (FORMAT IL:PROMPTWINDOW "~%No TTY window to un-hide!~%"))))

(IL:INTERRUPTCHAR (CHAR-CODE #\^Y)
       '(UN-HIDE-TTY))
(IL:PUTPROPS IL:UN-HIDE-TTY IL:COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (1274 1627 (UN-HIDE-TTY 1274 . 1627)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/UN-HIDE-TTY.DFASL b/rooms/UN-HIDE-TTY.DFASL
new file mode 100644
index 00000000..48e2a260
Binary files /dev/null and b/rooms/UN-HIDE-TTY.DFASL differ
diff --git a/rooms/UN-HIDE-TTY.TEDIT b/rooms/UN-HIDE-TTY.TEDIT
new file mode 100644
index 00000000..a216143e
Binary files /dev/null and b/rooms/UN-HIDE-TTY.TEDIT differ
diff --git a/rooms/USERINTRO.TEDIT b/rooms/USERINTRO.TEDIT
new file mode 100644
index 00000000..5a40bb3c
Binary files /dev/null and b/rooms/USERINTRO.TEDIT differ
diff --git a/rooms/WALLPAPER b/rooms/WALLPAPER
new file mode 100644
index 00000000..90632647
--- /dev/null
+++ b/rooms/WALLPAPER
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "ROOMS")
(IL:FILECREATED " 5-Dec-2020 16:37:39" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>WALLPAPER.;2| 3287   

      IL:|previous| IL:|date:| "17-Aug-90 14:48:22" 
IL:|{DSK}<Users>arunwelch>SKYDRIVE>DOCUMENTS>UNIX>LISP>LDE>ROOMS>MEDLEY-35>WALLPAPER.;1|)


; Copyright (c) 1988, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:WALLPAPERCOMS)

(IL:RPAQQ IL:WALLPAPERCOMS ((FILE-ENVIRONMENTS IL:WALLPAPER)
                                (IL:P (EXPORT '(MAKE-WALLPAPER-WINDOW HACK-BACKGROUND)
                                             "ROOMS"))
                                (IL:FILES (IL:SYSLOAD)
                                       IL:SCREENPAPER)
                                (IL:FUNCTIONS MAKE-WALLPAPER-WINDOW WALLPAPER-WINDOW-BUTTONEVENTFN 
                                       HACK-BACKGROUND)
                                (IL:WINDOW-TYPES :WALLPAPER)))

(DEFINE-FILE-ENVIRONMENT IL:WALLPAPER :COMPILER :COMPILE-FILE
   :PACKAGE "ROOMS"
   :READTABLE "XCL")

(EXPORT '(MAKE-WALLPAPER-WINDOW HACK-BACKGROUND)
       "ROOMS")

(IL:FILESLOAD (IL:SYSLOAD)
       IL:SCREENPAPER)

(DEFUN MAKE-WALLPAPER-WINDOW (&OPTIONAL REGION)
   (LET ((WINDOW (IL:CREATEW REGION "Wallpaper" 10)))
        (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN 'WALLPAPER-WINDOW-BUTTONEVENTFN)
        WINDOW))

(DEFUN WALLPAPER-WINDOW-BUTTONEVENTFN (WINDOW)
   (NOTIFY-USER "Pick regions of the screen with LEFT~%Press MIDDLE when satisfied, RIGHT to abort.")
   (LET ((SHADE (IL:SCREENPAPER WINDOW NIL 'IL:PICK)))
        (WHEN SHADE (HACK-BACKGROUND SHADE))))

(DEFUN HACK-BACKGROUND (SHADE &OPTIONAL (ROOM *CURRENT-ROOM*))

(IL:* IL:|;;;| "set the first shade specification of ROOM to be SHADE, or add a :WHOLE-SCREEN specification ROOM has no shades specified.")

   (IL:* IL:|;;| "always call this before we hack a room")

   (UPDATE-PLACEMENTS)
   (LET ((SPECS (BACKGROUND-EXTERNAL-FORM (ROOM-BACKGROUND ROOM))))
        (DOLIST (SPEC SPECS (PUSH (LIST :WHOLE-SCREEN SHADE)
                                  SPECS))
            (CASE (FIRST SPEC)
                (:WHOLE-SCREEN 
                   (SETF (SECOND SPEC)
                         SHADE)
                   (RETURN))
                (:REGION 
                   (SETF (GETF SPEC :SHADE)
                         SHADE)
                   (RETURN))))
        (SETF (ROOM-BACKGROUND ROOM)
              (MAKE-BACKGROUND SPECS)))

   (IL:* IL:|;;| "always call this after we hack a room")

   (ROOM-CHANGED ROOM :EDITED))

(DEF-WINDOW-TYPE :WALLPAPER :RECOGNIZER (LAMBDA (WINDOW)
                                                   (EQ (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN)
                                                       'WALLPAPER-WINDOW-BUTTONEVENTFN))
   :ABSTRACTER (LAMBDA (WINDOW)
                      (LIST :REGION (EXTERNALIZE-REGION (WINDOW-REGION WINDOW))))
   :RECONSTITUTER (LAMBDA (ARGS)
                         (MAKE-WALLPAPER-WINDOW (INTERNALIZE-REGION (GETF ARGS :REGION))))
   :TITLE "Wallpaper"
   :FILES (IL:WALLPAPER))
(IL:PUTPROPS IL:WALLPAPER IL:COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 2020))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (1232 1435 (MAKE-WALLPAPER-WINDOW 1232 . 1435)) (1437 1695 (
WALLPAPER-WINDOW-BUTTONEVENTFN 1437 . 1695)) (1697 2636 (HACK-BACKGROUND 1697 . 2636)))))
IL:STOP
\ No newline at end of file
diff --git a/rooms/WALLPAPER.DFASL b/rooms/WALLPAPER.DFASL
new file mode 100644
index 00000000..e0c40361
Binary files /dev/null and b/rooms/WALLPAPER.DFASL differ
diff --git a/rooms/WALLPAPER.TEDIT b/rooms/WALLPAPER.TEDIT
new file mode 100644
index 00000000..41afe97f
Binary files /dev/null and b/rooms/WALLPAPER.TEDIT differ
