github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-05-05 15:44:25 +00:00
Code Issues Projects Releases Wiki Activity

WHEELSCROLL: Put more of the branching logic inside the WHEELSCROLL function, add character names (#2069)

Browse Source 
Put more of the branching logic inside WHEELSCROLL, add character names
This commit is contained in:
rmkaplan
2025-03-24 10:19:06 -07:00
committed by GitHub
parent 88327b8644
commit 1bdaa63d49
3 changed files with 80 additions and 82 deletions
Download Patch File Download Diff File Expand all files Collapse all files

162
lispusers/WHEELSCROLL
View File

@@ -1,29 +1,29 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "31-Mar-2024 06:57:25" {DSK}<home>larry>il>medley>lispusers>WHEELSCROLL.;2 9911 (FILECREATED "16-Mar-2025 18:23:44" {WMEDLEY}<lispusers>WHEELSCROLL.;36 10917
:EDIT-BY "lmm" :EDIT-BY rmk
:CHANGES-TO (VARS WHEELSCROLLCOMS) :CHANGES-TO (FNS WHEELSCROLL)
(FNS ENABLEWHEELSCROLL)
:PREVIOUS-DATE " 2-Oct-2023 10:15:55" {DSK}<home>larry>il>medley>lispusers>WHEELSCROLL.;1) :PREVIOUS-DATE "15-Mar-2025 11:36:27" {WMEDLEY}<lispusers>WHEELSCROLL.;35)
(PRETTYCOMPRINT WHEELSCROLLCOMS) (PRETTYCOMPRINT WHEELSCROLLCOMS)
(RPAQQ WHEELSCROLLCOMS (RPAQQ WHEELSCROLLCOMS
[(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL) [(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL)
(GLOBALVARS WHEELSCROLLENABLED WHEELSCROLLDELTA HWHEELSCROLLDELTA WHEELSCROLLSETTLETIME
(* ;; "These are the highest meta-ctrl characters, they will be unaffected by teh state of ctrl and meta mode keys") \WHEELSCROLLINPROGRESS)
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS * WHEELSCROLLCHARS))
(GLOBALVARS WHEELSCROLLENABLED 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))) [ADDVARS (AFTERSYSOUTFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T)))
(AFTERMAKESYSFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T] (AFTERMAKESYSFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T]
(* ;; "These are the highest meta-ctrl characters, they will be unaffected by the state of ctrl and meta mode keys. Should be moved to Function")
(ALISTS (CHARACTERNAMES WHEELSCROLL-UP WHEELSCROLL-DOWN WHEELSCROLL-LEFT WHEELSCROLL-RIGHT))
(INITVARS (WHEELSCROLLENABLED NIL) (INITVARS (WHEELSCROLLENABLED NIL)
(WHEELSCROLLDELTA 20) (WHEELSCROLLDELTA 20)
(HWHEELSCROLLDELTA NIL) (HWHEELSCROLLDELTA NIL)
@@ -34,7 +34,8 @@
(DEFINEQ (DEFINEQ
(ENABLEWHEELSCROLL (ENABLEWHEELSCROLL
[LAMBDA (ON EXCLUDEHORIZONTAL) (* ; "Edited 31-Mar-2024 06:30 by lmm") [LAMBDA (ON EXCLUDEHORIZONTAL) (* ; "Edited 14-Mar-2025 18:27 by rmk")
(* ; "Edited 31-Mar-2024 06:30 by lmm")
(* ; "Edited 2-Oct-2023 10:05 by rmk") (* ; "Edited 2-Oct-2023 10:05 by rmk")
(* ; "Edited 23-Oct-2021 16:31 by larry") (* ; "Edited 23-Oct-2021 16:31 by larry")
(* ; "Edited 11-Jun-2021 12:50 by rmk:") (* ; "Edited 11-Jun-2021 12:50 by rmk:")
@@ -49,14 +50,14 @@
(for KAT in (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION) (for KAT in (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
do (for K in [if EXCLUDEHORIZONTAL do (for K in [if EXCLUDEHORIZONTAL
then `((PAD1 ,\WSUP) then `((PAD1 ,(CHARCODE WHEELSCROLL-UP))
(PAD2 ,\WSDOWN) (PAD2 ,(CHARCODE WHEELSCROLL-DOWN))
(PAD4 IGNORE) (PAD4 IGNORE)
(PAD5 IGNORE)) (PAD5 IGNORE))
else `((PAD1 ,\WSUP) else `((PAD1 ,(CHARCODE WHEELSCROLL-UP))
(PAD2 ,\WSDOWN) (PAD2 ,(CHARCODE WHEELSCROLL-DOWN))
(PAD4 ,\WSLEFT) (PAD4 ,(CHARCODE WHEELSCROLL-LEFT))
(PAD5 ,\WSRIGHT] (PAD5 ,(CHARCODE WHEELSCROLL-RIGHT]
do (KEYACTION (CAR K) do (KEYACTION (CAR K)
(CONS (CL:IF (EQ (CADR K) (CONS (CL:IF (EQ (CADR K)
'IGNORE) 'IGNORE)
@@ -84,45 +85,56 @@
(SETQ WHEELSCROLLENABLED NIL]) (SETQ WHEELSCROLLENABLED NIL])
(WHEELSCROLL (WHEELSCROLL
[LAMBDA (DIRECTION DELTA) (* ; [LAMBDA (DIRECTION DELTA/POS) (* ; "Edited 16-Mar-2025 18:23 by rmk")
 "Edited 21-Feb-2021 09:38 by rmk:") (* ; "Edited 14-Mar-2025 17:11 by rmk")
(* ; "Edited 13-Mar-2025 16:31 by rmk")
(* ; "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) (* ; (CL:WHEN (AND WHEELSCROLLENABLED (MOUSESTATE UP)) (* ;
 "Ignore interrupt if a button is down")  "Ignore interrupt if a button is down")
[LET ((W (WHICHW))) [LET ((W (WHICHW))
DELTA)
(* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within (* ;; "Unsuccessful a ttempt to suppress scroll if middlebutton comes down within the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME))")
 the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME)))
(CL:WHEN W (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. ")
(SETQ DELTA (SELECTQ DELTA/POS
(T (* ; "UP/RIGHT")
(CL:IF (EQ DIRECTION 'VERTICAL)
WHEELSCROLLDELTA
(OR HWHEELSCROLLDELTA WHEELSCROLLDELTA)))
(NIL (* ; "DOWN/LEFT")
(IMINUS (CL:IF (EQ DIRECTION 'VERTICAL)
WHEELSCROLLDELTA
(OR HWHEELSCROLLDELTA WHEELSCROLLDELTA))))
DELTA/POS))
(if (WINDOWPROP W 'SCROLLFN) (if (WINDOWPROP W 'SCROLLFN)
then [PROCESS.EVAL (FIND.PROCESS 'MOUSE) then [PROCESS.EVAL (FIND.PROCESS 'MOUSE)
(CL:IF (EQ DIRECTION 'VERTICAL) (CL:IF (EQ DIRECTION 'VERTICAL)
`(WHEELSCROLL.DOIT ,(KWOTE W) `(WHEELSCROLL.DOIT ,(KWOTE W)
0 0
,DELTA) ,DELTA)
`(WHEELSCROLL.DOIT ,(KWOTE W) `(WHEELSCROLL.DOIT ,(KWOTE W)
,DELTA 0))] ,DELTA 0))]
elseif (EQ DIRECTION 'VERTICAL) elseif (EQ DIRECTION 'VERTICAL)
then 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))
(CL:WHEN (WINDOWPROP W 'VERTICALSCROLLBARFOR) (GETMOUSESTATE))
(\CURSORPOSITION LASTMOUSEX (IPLUS LASTMOUSEY DELTA))
(GETMOUSESTATE))
elseif (EQ DIRECTION 'HORIZONTAL) elseif (EQ DIRECTION 'HORIZONTAL)
then (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR) then (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR)
(\CURSORPOSITION (IPLUS DELTA LASTMOUSEX) (\CURSORPOSITION (IPLUS DELTA LASTMOUSEX)
LASTMOUSEY) LASTMOUSEY)
(GETMOUSESTATE))))])]) (GETMOUSESTATE))))])])
(WHEELSCROLL.DOIT (WHEELSCROLL.DOIT
[LAMBDA (WINDOW DX DY) (* ; "Edited 20-Feb-2021 17:34 by rmk:") [LAMBDA (WINDOW DX DY) (* ; "Edited 20-Feb-2021 17:34 by rmk:")
@@ -137,56 +149,30 @@
(RESETVAR \WHEELSCROLLINPROGRESS T (SCROLLW WINDOW DX DY)))]) (RESETVAR \WHEELSCROLLINPROGRESS T (SCROLLW WINDOW DX DY)))])
(INSTALL-WHEELSCROLL (INSTALL-WHEELSCROLL
[LAMBDA NIL (* ; "Edited 29-Nov-2021 21:56 by rmk:") [LAMBDA NIL (* ; "Edited 14-Mar-2025 18:27 by rmk")
(* ; "Edited 29-Nov-2021 21:56 by rmk:")
(* ; "Edited 28-May-2021 11:46 by rmk:") (* ; "Edited 28-May-2021 11:46 by rmk:")
(* ; "Edited 17-Feb-2021 11:53 by rmk:") (* ; "Edited 17-Feb-2021 11:53 by rmk:")
(* ;; "We want the UP, DOWN...constants to be compiled awsy") (* ;; "We want the UP, DOWN...constants to be compiled awsy")
(SETQ WHEELSCROLLINTERRUPTS `((,\WSUP (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) (SETQ WHEELSCROLLINTERRUPTS `((,(CHARCODE WHEELSCROLL-UP)
T) (WHEELSCROLL 'VERTICAL T)
(,\WSDOWN (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T)
T) (,(CHARCODE WHEELSCROLL-DOWN)
(,\WSLEFT (WHEELSCROLL 'HORIZONTAL (IMINUS (OR HWHEELSCROLLDELTA (WHEELSCROLL 'VERTICAL)
WHEELSCROLLDELTA)) T)
T)) (,(CHARCODE WHEELSCROLL-LEFT)
(,\WSRIGHT (WHEELSCROLL 'HORIZONTAL (OR HWHEELSCROLLDELTA (WHEELSCROLL 'HORIZONTAL)
WHEELSCROLLDELTA) T)
WHEELSCROLLDELTA T]) (,(CHARCODE WHEELSCROLL-RIGHT)
) (WHEELSCROLL 'HORIZONTAL T)
T])
(* ;;
"These are the highest meta-ctrl characters, they will be unaffected by teh state of ctrl and meta mode keys"
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(RPAQQ WHEELSCROLLCHARS ((\WSUP 156)
(\WSDOWN 157)
(\WSLEFT 158)
(\WSRIGHT 159)))
(DECLARE%: EVAL@COMPILE
(RPAQQ \WSUP 156)
(RPAQQ \WSDOWN 157)
(RPAQQ \WSLEFT 158)
(RPAQQ \WSRIGHT 159)
(CONSTANTS (\WSUP 156)
(\WSDOWN 157)
(\WSLEFT 158)
(\WSRIGHT 159))
)
) )
(DECLARE%: DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS WHEELSCROLLENABLED WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS) (GLOBALVARS WHEELSCROLLENABLED WHEELSCROLLDELTA HWHEELSCROLLDELTA WHEELSCROLLSETTLETIME
\WHEELSCROLLINPROGRESS)
) )
@@ -198,6 +184,18 @@
(ADDTOVAR AFTERMAKESYSFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T))) (ADDTOVAR AFTERMAKESYSFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T)))
(* ;;
"These are the highest meta-ctrl characters, they will be unaffected by the state of ctrl and meta mode keys. Should be moved to Function"
)
(ADDTOVAR CHARACTERNAMES (WHEELSCROLL-UP 156)
(WHEELSCROLL-DOWN 157)
(WHEELSCROLL-LEFT 158)
(WHEELSCROLL-RIGHT 159))
(RPAQ? WHEELSCROLLENABLED NIL) (RPAQ? WHEELSCROLLENABLED NIL)
(RPAQ? WHEELSCROLLDELTA 20) (RPAQ? WHEELSCROLLDELTA 20)
@@ -214,6 +212,6 @@
(ENABLEWHEELSCROLL T) (ENABLEWHEELSCROLL T)
) )
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (1452 8682 (ENABLEWHEELSCROLL 1462 . 4220) (WHEELSCROLL 4222 . 6823) (WHEELSCROLL.DOIT (FILEMAP (NIL (1462 9850 (ENABLEWHEELSCROLL 1472 . 4458) (WHEELSCROLL 4460 . 8008) (WHEELSCROLL.DOIT
6825 . 7461) (INSTALL-WHEELSCROLL 7463 . 8680))))) 8010 . 8646) (INSTALL-WHEELSCROLL 8648 . 9848)))))
STOP STOP

BIN
lispusers/WHEELSCROLL.LCOM
View File

Binary file not shown.

BIN
lispusers/WHEELSCROLL.TEDIT
View File

Binary file not shown.