(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