Change WHEELSCROLL constants from LEFT,RIGHT etc to \WSLEFT etc
This commit is contained in:
Larry Masinter
parent
b67cf5ae09
commit
1c9c1da257
@ -1,11 +1,11 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "11-Jun-2021 12:50:16"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;18 10803
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (FNS ENABLEWHEELSCROLL)
|
||||
(FILECREATED "23-Oct-2021 16:33:29" {DSK}<home>larry>medley>lispusers>WHEELSCROLL.;2 11221
|
||||
|
||||
previous date%: "11-Jun-2021 11:11:10"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;14)
|
||||
changes to%: (VARS WHEELSCROLLCOMS)
|
||||
(FNS ENABLEWHEELSCROLL WHEELSCROLL)
|
||||
|
||||
previous date%: "11-Jun-2021 12:50:16" {DSK}<home>larry>medley>lispusers>WHEELSCROLL.;1)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT WHEELSCROLLCOMS)
|
||||
@ -14,15 +14,15 @@
|
||||
[(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL
|
||||
LISPINTERRUPTS.WHEELSCROLL)
|
||||
|
||||
(* ;; "These are the highest meta-ctrl characters, they will be unaffected by teh state of ctrl and meta mode keys")
|
||||
(* ;; "These are the highest meta-ctrl characters, they will be unaffected by teh state of ctrl and meta mode keys")
|
||||
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (UP 156)
|
||||
(DOWN 157)
|
||||
(LEFT 158)
|
||||
(RIGHT 159)))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\WSUP 156)
|
||||
(\WSDOWN 157)
|
||||
(\WSLEFT 158)
|
||||
(\WSRIGHT 159)))
|
||||
(GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS)
|
||||
|
||||
(* ;; "To restore the keyactions for PAD..., if the keyaction table has been reinitialized")
|
||||
(* ;; "To restore the keyactions for PAD..., if the keyaction table has been reinitialized")
|
||||
|
||||
[ADDVARS (AFTERSYSOUTFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T)))
|
||||
(AFTERMAKESYSFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T]
|
||||
@ -35,65 +35,69 @@
|
||||
(DEFINEQ
|
||||
|
||||
(ENABLEWHEELSCROLL
|
||||
[LAMBDA (ON EXCLUDEHORIZONTAL) (* ; "Edited 11-Jun-2021 12:50 by rmk:")
|
||||
(* ; "Edited 28-May-2021 11:46 by rmk:")
|
||||
[LAMBDA (ON EXCLUDEHORIZONTAL) (* ;
|
||||
"Edited 23-Oct-2021 16:31 by larry")
|
||||
(* ;
|
||||
"Edited 11-Jun-2021 12:50 by rmk:")
|
||||
(* ;
|
||||
"Edited 28-May-2021 11:46 by rmk:")
|
||||
|
||||
(* ;; "So we can toggle this scrolling.")
|
||||
(* ;; "So we can toggle this scrolling.")
|
||||
|
||||
(IF ON
|
||||
THEN (CL:UNLESS (EQP (GETD 'LISPINTERRUPTS)
|
||||
(if ON
|
||||
then (CL:UNLESS (EQP (GETD 'LISPINTERRUPTS)
|
||||
(GETD 'LISPINTERRUPTS.WHEELSCROLL))
|
||||
(CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL)
|
||||
(* ; "In case of LOADFROM?")
|
||||
(* ; "In case of LOADFROM?")
|
||||
(MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG)
|
||||
(MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)))
|
||||
|
||||
(* ;; "In some situations these other keyactions seem to be installed, hit them all.")
|
||||
(* ;; "In some situations these other keyactions seem to be installed, hit them all.")
|
||||
|
||||
[FOR KAT IN (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
|
||||
DO ((FOR K IN [IF EXCLUDEHORIZONTAL
|
||||
THEN `((PAD1 ,UP)
|
||||
(PAD2 ,DOWN)
|
||||
(PAD4 IGNORE)
|
||||
(PAD5 IGNORE))
|
||||
ELSE `((PAD1 ,UP)
|
||||
(PAD2 ,DOWN)
|
||||
(PAD4 ,LEFT)
|
||||
(PAD5 ,RIGHT]
|
||||
DO (KEYACTION (CAR K)
|
||||
(CONS (CL:IF (EQ (CADR K)
|
||||
'IGNORE)
|
||||
'IGNORE
|
||||
`(,(CADR K)
|
||||
,(CADR K)))
|
||||
`IGNORE)
|
||||
KAT]
|
||||
(FOR I IN WHEELSCROLLINTERRUPTS
|
||||
DO (INTERRUPTCHAR (CAR I)
|
||||
(for KAT in (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
|
||||
do (for K in [if EXCLUDEHORIZONTAL
|
||||
then `((PAD1 ,\WSUP)
|
||||
(PAD2 ,\WSDOWN)
|
||||
(PAD4 IGNORE)
|
||||
(PAD5 IGNORE))
|
||||
else `((PAD1 ,\WSUP)
|
||||
(PAD2 ,\WSDOWN)
|
||||
(PAD4 ,\WSLEFT)
|
||||
(PAD5 ,\WSRIGHT]
|
||||
do (KEYACTION (CAR K)
|
||||
(CONS (CL:IF (EQ (CADR K)
|
||||
'IGNORE)
|
||||
'IGNORE
|
||||
`(,(CADR K)
|
||||
,(CADR K)))
|
||||
`IGNORE)
|
||||
KAT)))
|
||||
(for I in WHEELSCROLLINTERRUPTS
|
||||
do (INTERRUPTCHAR (CAR I)
|
||||
(CADR I)
|
||||
(CADDR I))
|
||||
(CL:WHEN (BOUNDP 'TEDIT.READTABLE)
|
||||
|
||||
(* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")
|
||||
(* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")
|
||||
|
||||
(TEDIT.SETFUNCTION (CAR I)
|
||||
`[LAMBDA NIL
|
||||
,(CADR I]
|
||||
TEDIT.READTABLE)))
|
||||
(SETQ WHEELSCROLLENABLED T)
|
||||
ELSE (CL:WHEN (EQP (GETD 'LISPINTERRUPTS.WHEELSCROLL)
|
||||
else (CL:WHEN (EQP (GETD 'LISPINTERRUPTS.WHEELSCROLL)
|
||||
(GETD 'LISPINTERRUPTS))
|
||||
(MOVD 'LISPINTERRUPTS.WSORIG 'LISPINTERRUPTS))
|
||||
(FOR I IN WHEELSCROLLINTERRUPTS DO (INTERRUPTCHAR (CAR I)
|
||||
(for I in WHEELSCROLLINTERRUPTS do (INTERRUPTCHAR (CAR I)
|
||||
NIL)
|
||||
(CL:WHEN (BOUNDP 'TEDIT.READTABLE)
|
||||
|
||||
(* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")
|
||||
(* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")
|
||||
|
||||
(TEDIT.SETFUNCTION (CAR I)
|
||||
NIL TEDIT.READTABLE)))
|
||||
(FOR KAT IN (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
|
||||
DO (KEYACTION 'PAD1 '(IGNORE . IGNORE)
|
||||
(for KAT in (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
|
||||
do (KEYACTION 'PAD1 '(IGNORE . IGNORE)
|
||||
KAT)
|
||||
(KEYACTION 'PAD2 '(IGNORE . IGNORE)
|
||||
KAT)
|
||||
@ -104,41 +108,42 @@
|
||||
(SETQ WHEELSCROLLENABLED NIL])
|
||||
|
||||
(WHEELSCROLL
|
||||
[LAMBDA (DIRECTION DELTA) (* ; "Edited 21-Feb-2021 09:38 by rmk:")
|
||||
[LAMBDA (DIRECTION DELTA) (* ;
|
||||
"Edited 21-Feb-2021 09:38 by rmk:")
|
||||
|
||||
(* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button. And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button. We don't yet have a good solution to this problem. (This is not an issue with a trackpad)")
|
||||
(* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button. And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button. We don't yet have a good solution to this problem. (This is not an issue with a trackpad)")
|
||||
|
||||
(* ;; "")
|
||||
(* ;; "")
|
||||
|
||||
(CL:WHEN (MOUSESTATE UP) (* ;
|
||||
"Ignore interrupt if a button is down")
|
||||
(CL:WHEN (MOUSESTATE UP) (* ;
|
||||
"Ignore interrupt if a button is down")
|
||||
[LET ((W (WHICHW)))
|
||||
|
||||
(* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within
|
||||
the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME)))
|
||||
(* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within
|
||||
the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME)))
|
||||
|
||||
(CL:WHEN W
|
||||
|
||||
(* ;; "We scroll only if the window has a scrollfn. Our behavior is thus different from a direct call to SCROLLW, which defaults to SCROLLBYREPAINTFN in that case, but conforms to what happens with IN/SCROLL/BAR? and SCROLL.HANDLER in WINDOWSCROLL. Menus and scrollbars typically do not have scrollfns, so this suppresses otherwise funky behavior. ")
|
||||
(* ;; "We scroll only if the window has a scrollfn. Our behavior is thus different from a direct call to SCROLLW, which defaults to SCROLLBYREPAINTFN in that case, but conforms to what happens with IN/SCROLL/BAR? and SCROLL.HANDLER in WINDOWSCROLL. Menus and scrollbars typically do not have scrollfns, so this suppresses otherwise funky behavior. ")
|
||||
|
||||
(IF (WINDOWPROP W 'SCROLLFN)
|
||||
THEN [PROCESS.EVAL (FIND.PROCESS 'MOUSE)
|
||||
(if (WINDOWPROP W 'SCROLLFN)
|
||||
then [PROCESS.EVAL (FIND.PROCESS 'MOUSE)
|
||||
(CL:IF (EQ DIRECTION 'VERTICAL)
|
||||
`(WHEELSCROLL.DOIT ,(KWOTE W)
|
||||
0
|
||||
,DELTA)
|
||||
`(WHEELSCROLL.DOIT ,(KWOTE W)
|
||||
,DELTA 0))]
|
||||
ELSEIF (EQ DIRECTION 'VERTICAL)
|
||||
THEN
|
||||
elseif (EQ DIRECTION 'VERTICAL)
|
||||
then
|
||||
|
||||
(* ;; "We are in a pop-up scrollbar. This moves the cursor there, the user has to click to scroll the main window.")
|
||||
(* ;; "We are in a pop-up scrollbar. This moves the cursor there, the user has to click to scroll the main window.")
|
||||
|
||||
(CL:WHEN (WINDOWPROP W 'VERTICALSCROLLBARFOR)
|
||||
(\CURSORPOSITION LASTMOUSEX (IPLUS LASTMOUSEY DELTA))
|
||||
(GETMOUSESTATE))
|
||||
ELSEIF (EQ DIRECTION 'HORIZONTAL)
|
||||
THEN (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR)
|
||||
elseif (EQ DIRECTION 'HORIZONTAL)
|
||||
then (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR)
|
||||
(\CURSORPOSITION (IPLUS DELTA LASTMOUSEX)
|
||||
LASTMOUSEY)
|
||||
(GETMOUSESTATE))))])])
|
||||
@ -186,19 +191,19 @@
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ UP 156)
|
||||
(RPAQQ \WSUP 156)
|
||||
|
||||
(RPAQQ DOWN 157)
|
||||
(RPAQQ \WSDOWN 157)
|
||||
|
||||
(RPAQQ LEFT 158)
|
||||
(RPAQQ \WSLEFT 158)
|
||||
|
||||
(RPAQQ RIGHT 159)
|
||||
(RPAQQ \WSRIGHT 159)
|
||||
|
||||
|
||||
(CONSTANTS (UP 156)
|
||||
(DOWN 157)
|
||||
(LEFT 158)
|
||||
(RIGHT 159))
|
||||
(CONSTANTS (\WSUP 156)
|
||||
(\WSDOWN 157)
|
||||
(\WSLEFT 158)
|
||||
(\WSRIGHT 159))
|
||||
)
|
||||
)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
@ -229,6 +234,6 @@
|
||||
(ENABLEWHEELSCROLL T)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1575 9814 (ENABLEWHEELSCROLL 1585 . 5542) (WHEELSCROLL 5544 . 8080) (WHEELSCROLL.DOIT
|
||||
8082 . 8718) (INSTALL-WHEELSCROLL 8720 . 9535) (LISPINTERRUPTS.WHEELSCROLL 9537 . 9812)))))
|
||||
(FILEMAP (NIL (1604 10208 (ENABLEWHEELSCROLL 1614 . 5871) (WHEELSCROLL 5873 . 8474) (WHEELSCROLL.DOIT
|
||||
8476 . 9112) (INSTALL-WHEELSCROLL 9114 . 9929) (LISPINTERRUPTS.WHEELSCROLL 9931 . 10206)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Loading…
x
Reference in New Issue
Block a user