(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")

(FILECREATED " 9-Feb-87 21:28:31" {ERIS}<LISPUSERS>LYRIC>EDITKEYS.;2
 5949   

      previous date%: " 5-Nov-85 15:37:40" {ERIS}<LISPUSERS>LYRIC>EDITKEYS.;1)


(* "
Copyright (c) 1985, 1987 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT EDITKEYSCOMS)

(RPAQQ EDITKEYSCOMS
 ((VARS KEY.TEMPLATE)
                     (FNS BUILDFNKEYS KEY.BITMAP)
                     (P (* could have (STRIKEOUT))
                        (BUILDFNKEYS '((BOLD BOLD)
                                       (ITALICS ITALICS)
                                       (UNDERLINE (UNDER- LINE))
                                       (SUPERSCRIPT (SUPER/ SUB))
                                       (LARGER (LARGER SMALLER))
                                       (DEFAULTS DEFAULTS)
                                       (CASE CASE)
                                       (CENTER JUSTIFY)
                                       (AGAIN REDO)
                                       (HELP HELP)) '(Function Keys) 1))))

(RPAQQ KEY.TEMPLATE
 #*(78 48)OOOOOOOOOOOOOOOOOOOLON@@@@@@@@@@@@@@@AOLO@@@@@@@@@@@@@@@@@CLO@@@@@@@@@@@@@@@@@CLMH@@@@@@@@@@@@@@@@DLNLGOOOOOOOOOOOOOOHHLMFL@@@@@@@@@@@@@@M@LJK@@@@@@@@@@@@@@@B@DMF@@@@@@@@@@@@@@@A@DJN@@@@@@@@@@@@@@@AHDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMF@@@@@@@@@@@@@@@AHDJJ@@@@@@@@@@@@@@@A@DMG@@@@@@@@@@@@@@@B@DNEL@@@@@@@@@@@@@@O@LLIGOOOOOOOOOOOOOOMHLOBBJJJJJJJJJJJJJJJLLNDEEEEEEEEEEEEEEEEGLOHJJJJJJJJJJJJJJJJKLOLEEEEEEEEEEEEEEEEOLOOOOOOOOOOOOOOOOOOOL
)
(DEFINEQ

(BUILDFNKEYS

  [LAMBDA (KEYS TITLE NROWS)
                                 (* lmm " 5-Nov-85 15:35")

    (SHRINKW
     (ADDMENU
      [create

       MENU
       ITEMS _
       [for
 KEY in
 KEYS
          collect
 (LIST (KEY.BITMAP
 (CADR KEY))
                        (LET [(KEYN (OR (SMALLP (CAR KEY))
                                        (\KEYNAMETONUMBER (CAR KEY]
                             (for
 LST in
 (LIST \DOVEKEYACTIONS \DLIONKEYACTIONS \ORIGKEYACTIONS)
                                do
 (AND [SETQ $$VAL (for
 KEY in
 LST
                                                       when
 (EQ (OR (SMALLP (CAR KEY))
                                                                    (\KEYNAMETONUMBER (CAR KEY)))
                                                                KEYN)
                                                       do
 (RETURN (CADR KEY]
                                        (RETURN (LIST (OR (SMALLP (CAR $$VAL))
                                                          (CHARCODE.DECODE (CAR $$VAL)))
                                                      (OR (SMALLP (CADR $$VAL))
                                                          (CHARCODE.DECODE (CADR $$VAL]
       TITLE _ (SUBSTRING TITLE 2 -2)
       MENUROWS _ NROWS
       WHENSELECTEDFN _ (FUNCTION (LAMBDA (X)
                                    (BKSYSCHARCODE (if
 (SHIFTDOWNP 'SHIFT)
                                                       then
 (CADR (CADR X))
                                                     else
 (CAR (CADR X]
      NIL
      (create
 POSITION
             XCOORD _ (PLUS (DIFFERENCE (QUOTIENT SCREENWIDTH 2)
                                   (QUOTIENT (TIMES (BITMAPWIDTH KEY.TEMPLATE)
                                                    (LENGTH KEYS))
                                          2))
                            (TIMES 2 WBorder))
             YCOORD _ 0))
     (KEY.BITMAP
 TITLE)
     '(0 . 0])

(KEY.BITMAP

  [LAMBDA (X)
                                                (* lmm " 5-Nov-85 14:04")

    (PROG ((BITMAP (BITMAPCOPY KEY.TEMPLATE))
           DS QUARTER REGION)
          (SETQ DS (DSPCREATE BITMAP))
          (DSPFONT MENUFONT DS)
          (COND
             ((LISTP X)
          
          (* this is supposed to have two labels, one on top of the other)


              (SETQ QUARTER (IQUOTIENT (BITMAPHEIGHT BITMAP)
                                   4))
              (CENTERPRINTINREGION (CADR X)
                     (SETQ REGION (create
 REGION
                                         LEFT _ 0
                                         BOTTOM _ QUARTER
                                         WIDTH _ (BITMAPWIDTH BITMAP)
                                         HEIGHT _ QUARTER))
                     DS)
              (replace
 BOTTOM of
 REGION with
 (ITIMES 2 QUARTER))
              (CENTERPRINTINREGION (CAR X)
                     REGION DS))
             (T (CENTERPRINTINREGION X (create
 REGION
                                              LEFT _ 0
                                              BOTTOM _ 0
                                              WIDTH _ (BITMAPWIDTH BITMAP)
                                              HEIGHT _ (BITMAPHEIGHT BITMAP))
                       DS)))
          (RETURN BITMAP])
)
(* could have (STRIKEOUT))
(BUILDFNKEYS '((BOLD BOLD)
               (ITALICS ITALICS)
               (UNDERLINE (UNDER- LINE))
               (SUPERSCRIPT (SUPER/ SUB))
               (LARGER (LARGER SMALLER))
               (DEFAULTS DEFAULTS)
               (CASE CASE)
               (CENTER JUSTIFY)
               (AGAIN REDO)
               (HELP HELP)) '(Function Keys) 1)
(PUTPROPS EDITKEYS COPYRIGHT ("Xerox Corporation" 1985 1987))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2077 5483 (BUILDFNKEYS 2087 . 4099) (KEY.BITMAP 4101 . 5481)))))
STOP