(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)


(FILECREATED "20-Jul-2022 08:41:05" 
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>EDITKEYS.;3
 7073   

      :CHANGES-TO (FNS BUILDFNKEYS)
                  (VARS EDITKEYSCOMS)

      :PREVIOUS-DATE " 9-Feb-87 21:28:31" 
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>EDITKEYS.;1)


(* ; "
Copyright (c) 1985, 1987 by Xerox Corporation.
")

(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))
                  '(Tedit 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)

    (* ;; "Edited 20-Jul-2022 08:40 by rmk:  BKSYSBUF only if the TTY is TEDIT, change title to Tedit Keys, expand with left button.  Move with background menu")


    (* ;; "Edited 20-Jul-2022 07:56 by rmk")

                                                             (* lmm " 5-Nov-85 15:35")

    (LET
     (ICONWINDOW)
     [SETQ ICONWINDOW
      (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)
                                      (CL:WHEN (EQ '\TEDIT.PROCENTRYFN (FETCH
 (PROCESS PROCTTYENTRYFN
                                                                                     ) OF
 (
                                                                                          TTY.PROCESS
                                                                                           )))
                                          [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]
     [WINDOWPROP ICONWINDOW 'BUTTONEVENTFN (FUNCTION (LAMBDA (ICONW)
                                                       (CL:WHEN (LASTMOUSESTATE (OR LEFT MIDDLE))
                                                           (CURSOR (PROG1 (CURSOR WAITINGCURSOR)
                                                                          (EXPANDW ICONW))))]
     ICONWINDOW])

(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))
       '(Tedit Keys)
       1)
(PUTPROPS EDITKEYS COPYRIGHT ("Xerox Corporation" 1985 1987))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2103 6525 (BUILDFNKEYS 2113 . 5141) (KEY.BITMAP 5143 . 6523)))))
STOP