(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