From 217d5a17d221dc71a10caf1f94ad070235f900c7 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 22 Feb 2021 12:48:51 -0800 Subject: [PATCH] WHEELSCROLL: Added keyactions for LEFT/RIGHT --- lispusers/WHEELSCROLL | 2 +- lispusers/WHEELSCROLL.LCOM | Bin 3526 -> 4030 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/lispusers/WHEELSCROLL b/lispusers/WHEELSCROLL index baf31632..db277f2a 100644 --- a/lispusers/WHEELSCROLL +++ b/lispusers/WHEELSCROLL @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "21-Feb-2021 09:39:06"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;42 6734 changes to%: (VARS WHEELSCROLLCOMS) (FNS WHEELSCROLL) previous date%: "20-Feb-2021 17:34:35" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;39) (PRETTYCOMPRINT WHEELSCROLLCOMS) (RPAQQ WHEELSCROLLCOMS [(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL) [VARS (WHEELSCROLLINTERRUPTS '((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T] (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS) (INITVARS (WHEELSCROLLDELTA 20) (WHEELSCROLLSETTLETIME 50) (\WHEELSCROLLINPROGRESS NIL)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T]) (DEFINEQ (ENABLEWHEELSCROLL [LAMBDA (ON) (* ; "Edited 15-Feb-2021 18:17 by rmk:") (* ;; "So we can toggle this scrolling, for experimentation.") (IF ON THEN [KEYACTION 'PAD1 '((520 520) . IGNORE] [KEYACTION 'PAD2 '((521 521) . IGNORE] ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE)) (KEYACTION 'PAD2 '(IGNORE . IGNORE]) (WHEELSCROLL [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)") (* ;; "") (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))) (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. ") (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 (* ;; "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) (\CURSORPOSITION (IPLUS DELTA LASTMOUSEX) LASTMOUSEY) (GETMOUSESTATE))))])]) (WHEELSCROLL.DOIT [LAMBDA (WINDOW DX DY) (* ; "Edited 20-Feb-2021 17:34 by rmk:") (* ;; "This does the actual wheel scrolling, runing in the mouse process.") (* ;; "There have been instances where the window gets garbled as the wheel moves. The hypothesis is that this is because the wheel moves so fast that another scroll starts before a previous one completes.") (* ;; "The global variable \WHEELSCROLLINPROGRESS is set to prevent that interference.") (CL:UNLESS \WHEELSCROLLINPROGRESS (RESETVAR \WHEELSCROLLINPROGRESS T (SCROLLW WINDOW DX DY)))]) (INSTALL-WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:53 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG) (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)) (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") (TEDIT.SETFUNCTION (CAR I) `[LAMBDA NIL ,(CADR I] TEDIT.READTABLE))]) (LISPINTERRUPTS.WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:09 by rmk:") (* ;; "So wheelscroll interrupts will be installed in every process") (APPEND WHEELSCROLLINTERRUPTS (LISPINTERRUPTS.WSORIG]) ) (RPAQQ WHEELSCROLLINTERRUPTS ((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS) ) (RPAQ? WHEELSCROLLDELTA 20) (RPAQ? WHEELSCROLLSETTLETIME 50) (RPAQ? \WHEELSCROLLINPROGRESS NIL) (DECLARE%: DONTEVAL@LOAD DOCOPY (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1187 6142 (ENABLEWHEELSCROLL 1197 . 1622) (WHEELSCROLL 1624 . 4160) (WHEELSCROLL.DOIT 4162 . 4798) (INSTALL-WHEELSCROLL 4800 . 5863) (LISPINTERRUPTS.WHEELSCROLL 5865 . 6140))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Feb-2021 09:47:46"  {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;43 7259 changes to%: (VARS WHEELSCROLLCOMS) (FNS ENABLEWHEELSCROLL) previous date%: "21-Feb-2021 09:39:06" {DSK}kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;42) (PRETTYCOMPRINT WHEELSCROLLCOMS) (RPAQQ WHEELSCROLLCOMS [(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL) [VARS (WHEELSCROLLINTERRUPTS '((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T) (522 (WHEELSCROLL 'HORIZONTAL (IMINUS WHEELSCROLLDELTA) T)) (523 (WHEELSCROLL 'HORIZONTAL WHEELSCROLLDELTA T] (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS) (INITVARS (WHEELSCROLLDELTA 20) (WHEELSCROLLSETTLETIME 50) (\WHEELSCROLLINPROGRESS NIL)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T]) (DEFINEQ (ENABLEWHEELSCROLL [LAMBDA (ON) (* ; "Edited 22-Feb-2021 09:47 by rmk:") (* ;; "So we can toggle this scrolling, for experimentation.") (IF ON THEN [KEYACTION 'PAD1 '((520 520) . IGNORE] [KEYACTION 'PAD2 '((521 521) . IGNORE] [KEYACTION 'PAD4 '((522 522) . IGNORE] [KEYACTION 'PAD5 '((523 523) . IGNORE] ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE)) (KEYACTION 'PAD2 '(IGNORE . IGNORE)) (KEYACTION 'PAD4 '(IGNORE . IGNORE)) (KEYACTION 'PAD5 '(IGNORE . IGNORE]) (WHEELSCROLL [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)") (* ;; "") (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))) (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. ") (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 (* ;; "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) (\CURSORPOSITION (IPLUS DELTA LASTMOUSEX) LASTMOUSEY) (GETMOUSESTATE))))])]) (WHEELSCROLL.DOIT [LAMBDA (WINDOW DX DY) (* ; "Edited 20-Feb-2021 17:34 by rmk:") (* ;; "This does the actual wheel scrolling, runing in the mouse process.") (* ;; "There have been instances where the window gets garbled as the wheel moves. The hypothesis is that this is because the wheel moves so fast that another scroll starts before a previous one completes.") (* ;; "The global variable \WHEELSCROLLINPROGRESS is set to prevent that interference.") (CL:UNLESS \WHEELSCROLLINPROGRESS (RESETVAR \WHEELSCROLLINPROGRESS T (SCROLLW WINDOW DX DY)))]) (INSTALL-WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:53 by rmk:") (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL) (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG) (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)) (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") (TEDIT.SETFUNCTION (CAR I) `[LAMBDA NIL ,(CADR I] TEDIT.READTABLE))]) (LISPINTERRUPTS.WHEELSCROLL [LAMBDA NIL (* ; "Edited 17-Feb-2021 11:09 by rmk:") (* ;; "So wheelscroll interrupts will be installed in every process") (APPEND WHEELSCROLLINTERRUPTS (LISPINTERRUPTS.WSORIG]) ) (RPAQQ WHEELSCROLLINTERRUPTS ((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA) T) (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA)) T) (522 (WHEELSCROLL 'HORIZONTAL (IMINUS WHEELSCROLLDELTA) T)) (523 (WHEELSCROLL 'HORIZONTAL WHEELSCROLLDELTA T)))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS) ) (RPAQ? WHEELSCROLLDELTA 20) (RPAQ? WHEELSCROLLSETTLETIME 50) (RPAQ? \WHEELSCROLLINPROGRESS NIL) (DECLARE%: DONTEVAL@LOAD DOCOPY (INSTALL-WHEELSCROLL) (ENABLEWHEELSCROLL T) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (1432 6591 (ENABLEWHEELSCROLL 1442 . 2071) (WHEELSCROLL 2073 . 4609) (WHEELSCROLL.DOIT 4611 . 5247) (INSTALL-WHEELSCROLL 5249 . 6312) (LISPINTERRUPTS.WHEELSCROLL 6314 . 6589))))) STOP \ No newline at end of file diff --git a/lispusers/WHEELSCROLL.LCOM b/lispusers/WHEELSCROLL.LCOM index 97812037d1609f8a787cad5ce2aae88c1e6bf51a..0c1e49d74d98f643e656d93938e457d8ddf8bc09 100644 GIT binary patch delta 640 zcmZXP(Q4E{6oxlhER}S$)C!{19wXQUX~;~HO|m!LX)@bg9WvWAR$CBU*crp{(EDW(HocNc{a?ZACG20Y#q>E-)DVFZI?L1u@qS;cqMYM+5bIo zYP?toAZAgDr^fTER`|SOK-05_T!PypmH6P=NdAF`*?Ytr=3*et_l2$Y5wVFc2E_o1Na@J}Ft)%t5Kxu-s zd(Wgk`rTDCX_XN-;#m}f<3x4Zx?J#Jyi=%BxCBDh0#*a&eowoz#ivjk>s#`AB!t|{ zN+l&YyRTFwV5G|Np(-l;WUbwX%5@uWfK%%}yGC5Ppg+xptaxK>7C1XnZF9NL%RRtv z*1#b6#{yhl${v!u{#fjDIgpCykgH5h4#1g!gCCYIZndeJPIvT94#CgXgMXtu(GA)V NH%V|pR&hj*{{qwJopJyG delta 302 zcmdlde@uFUpOB%hTWXT7k%5t+f`O%#v89#4#DpkDqlvrqCcam*?t!DWoKp zq^2nFDj`c4npl|_TA5fXY4U2gdHT3I2e~?ixVlVcVM<_CFf%tcnY^7*d-4lLd0_*D zX@=%j#wJ$ArV|T2n2aqar!XmTI599VFgk2foZQDGH~AEkypRBchMBQ~w`-)MbBL$E zpMr_SWPfIL3sYl-07n-i1!D^kZKz;m1mT;5xj;uKm|7@kc)I)f2e~TfDL@#S3MP{; zGK*|>V2R`q(gXqp4R;@ZCr6(!$Dm*Z-pQK04wJKZ6&QIZ2l7i!Ud*dC`5dn#koTPT J*ko<~$pHQnOSk|4