TEDITKEY TKDORADO TEDITDORADOKEYS EDITKEYS are obsoleted by new Tedit keybinding architecture (#2088)
This commit is contained in:
rmkaplan
GitHub
141
obsolete/lispusers/EDITKEYS
Normal file
141
obsolete/lispusers/EDITKEYS
Normal file
@@ -0,0 +1,141 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 4-Dec-2023 21:06:15" {WMEDLEY}<lispusers>EDITKEYS.;6 7146
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS EDITKEYSCOMS)
|
||||
|
||||
:PREVIOUS-DATE "25-Oct-2022 10:58:27" {WMEDLEY}<lispusers>EDITKEYS.;5)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT EDITKEYSCOMS)
|
||||
|
||||
(RPAQQ EDITKEYSCOMS
|
||||
((VARS KEY.TEMPLATE)
|
||||
(FNS BUILDFNKEYS KEY.BITMAP)
|
||||
(P (* ; "could have (STRIKEOUT)")
|
||||
(* ; "RMK: Removed (HELP HELP)")
|
||||
(BUILDFNKEYS '((BOLD BOLD)
|
||||
(ITALICS ITALICS)
|
||||
(CASE CASE)
|
||||
(STRIKEOUT (STRIKE- OUT))
|
||||
(UNDERLINE (UNDER- LINE))
|
||||
(SUPERSCRIPT (SUPER/ SUB))
|
||||
(LARGER (LARGER SMALLER))
|
||||
(DEFAULTS DEFAULTS)
|
||||
(CENTER JUSTIFY)
|
||||
(AGAIN REDO))
|
||||
'(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)")
|
||||
|
||||
(* ; "RMK: Removed (HELP HELP)")
|
||||
|
||||
(BUILDFNKEYS '((BOLD BOLD)
|
||||
(ITALICS ITALICS)
|
||||
(CASE CASE)
|
||||
(STRIKEOUT (STRIKE- OUT))
|
||||
(UNDERLINE (UNDER- LINE))
|
||||
(SUPERSCRIPT (SUPER/ SUB))
|
||||
(LARGER (LARGER SMALLER))
|
||||
(DEFAULTS DEFAULTS)
|
||||
(CENTER JUSTIFY)
|
||||
(AGAIN REDO))
|
||||
'(Tedit Keys)
|
||||
1)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2120 6542 (BUILDFNKEYS 2130 . 5158) (KEY.BITMAP 5160 . 6540)))))
|
||||
STOP
|
||||
Reference in New Issue
Block a user