From 6b53149afa47f51ba15bdc2b2dffeb5302438bbb Mon Sep 17 00:00:00 2001
From: rmkaplan <ron.kaplan@post.harvard.edu>
Date: Sun, 21 Feb 2021 17:34:42 -0800
Subject: [PATCH] WHEELSCROLL: a little tuning, plus a WHEELSCROLL.TXT file

---
 lispusers/WHEELSCROLL      |   2 +-
 lispusers/WHEELSCROLL.LCOM | Bin 2587 -> 3526 bytes
 lispusers/WHEELSCROLL.TXT  | Bin 0 -> 1415 bytes
 3 files changed, 1 insertion(+), 1 deletion(-)
 create mode 100644 lispusers/WHEELSCROLL.TXT

diff --git a/lispusers/WHEELSCROLL b/lispusers/WHEELSCROLL
index 5cb1b473..baf31632 100644
--- a/lispusers/WHEELSCROLL
+++ b/lispusers/WHEELSCROLL
@@ -1 +1 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")

(FILECREATED "17-Feb-2021 22:37:01" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;31
 5760   

      changes to%:  (FNS WHEELSCROLL)

      previous date%: "17-Feb-2021 22:22:29" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;28)


(PRETTYCOMPRINT WHEELSCROLLCOMS)

(RPAQQ WHEELSCROLLCOMS

       [(FNS ENABLEWHEELSCROLL WHEELSCROLL INSTALL-WHEELSCROLL LISPINTERRUPTS.WHEELSCROLL)
        [VARS (WHEELSCROLLINTERRUPTS '((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA)
                                            T)
                                       (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA))
                                            T]
        (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME)
        (INITVARS (WHEELSCROLLDELTA 10)
               (WHEELSCROLLSETTLETIME 50))
        (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 17-Feb-2021 22:35 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.  Here we try to detect and ignore wheel motions in the first case, we don't yet have the information to solve the second.  (This should not be an issue with a trackpad)")


    (* ;; "")


    (* ;; "Below we ignore a motion interrupt if it is received when a mouse button is down. We also ignore if the MIDDLE shows up within an interval of WHEELSCROLLSETTLETIME milliseconds.")


    (CL:WHEN (LET ((W (WHICHW)))

                  (* ;; "Returns the window that should be wheel scrolled, skipping windows that have no SCROLLFN or are pop-up scrollbar window for some other window. ")


                  (* ;; "The behavior of pop-up scrollbars (via IN/SCROLL/BAR? in WINDOWSCROLL) is inconsistent with a direct call to SCROLLW in that SCROLLW uses SCROLLBYREPAINTFN for a window without a SCROLLFN while the pop-up does nothing.  We implement th pop-up behavior, otherwise odd windows like those holding menus would scroll in a funky way.")


                  (CL:WHEN [AND W (WINDOWPROP W 'SCROLLFN)
                                (NOT (WINDOWPROP W (CL:IF (EQ DIRECTION 'VERTICAL)
                                                       'VERTICALSCROLLBARFOR
                                                       'HORIZONTALSCROLLBARFOR)]
                      (CL:WHEN [OR T (AND (MOUSESTATE UP)
                                          (NOT (UNTILMOUSESTATE (ONLY MIDDLE)
                                                      WHEELSCROLLSETTLETIME]

                          (* ;; "Always scroll from the MOUSE process.  Need the KWOTE because PROCESS.EVAL uses CL:EVAL which doesn't like raw windows")


                          [PROCESS.EVAL (FIND.PROCESS 'MOUSE)
                                 (CL:IF (EQ DIRECTION 'VERTICAL)
                                     `(SCROLLW ,(KWOTE W)
                                             0
                                             ,DELTA)
                                     `(SCROLLW ,(KWOTE W)
                                             ,DELTA 0))]))])

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

(RPAQ? WHEELSCROLLDELTA
 10)

(RPAQ? WHEELSCROLLSETTLETIME
 50)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(INSTALL-WHEELSCROLL
)

(ENABLEWHEELSCROLL
 T)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1046 5231 (ENABLEWHEELSCROLL 1056 . 1481) (WHEELSCROLL 1483 . 3887) (
INSTALL-WHEELSCROLL 3889 . 4952) (LISPINTERRUPTS.WHEELSCROLL 4954 . 5229)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")

(FILECREATED "21-Feb-2021 09:39:06" 
{DSK}<Users>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}<Users>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
diff --git a/lispusers/WHEELSCROLL.LCOM b/lispusers/WHEELSCROLL.LCOM
index f3c48249f5b7fd0308ab6d52cb58f4996952a6cd..97812037d1609f8a787cad5ce2aae88c1e6bf51a 100644
GIT binary patch
literal 3526
zcmb_eOK;mo5T<OjO&bVs8x#n12&O`VQb8qfN$T0cF(t07MJSRcDJu?)B2Fa4N|ng)
zqi9g{(x1|E4~grX4fIm<)?@xa@4ofg*<D3iJ?!QXLnb*hyR+XscXXFFnNRag=FvR!
zn*rR4sN*J1-J_6YenKOU#bFk1g-+w1vpK`erFFiqfjbiFLe?btX8%#%G)w|UwPsao
zMkxz=_VMW1!C=_$!RR?;A^npZ-~0L7&QbsHX#M-WgW=xub#L@|Z@B)f-y8N{ScT&H
zlfiLbQtQLP(ZPvW+ig+m#f>QNyuvrOnL}OGymN4f2O0*DO3ffO%ftg79rh<j_J2G$
zJi1*2Wit#AMq8W(co;NKhC_&79F0znfmEj^6bgkb^!APscsi>Jh+VTu&8}wO%>nPr
zU?`O>8y@fPJ%7?ag5wcdrEfb?3~9x<M$nFPpf~+kH8}?dhy5Q0qmv_H5bn&H#?(?$
zu32`?D!#AaSk+vb`aFjeWKeS}X`O)qfu94du4!6o<MfLs_|``J@d<y-k!y4G9J!|H
zB@6D+9jB47zz4gc5SFPBq&y`sY()z~$2GyK@HYX|lyq5;xB!Y3(AlORL=*}jKXPDO
zOPFREbiIf<kN-JkF);<-K)#{yb85JxQ$irn1%^+TdWnNy2DmJu!YK6Bzbl%ya*ey^
z{2_l1Kl<m>l-7EB@jBi5VD;=;>toLS>}>UySK8lV-KVJ(>;3vl`$I_nx^?=U@SLDF
z#OK9nR=ip7^hR%R@td{w`nqK7XEINn{mjcN<c<hfCX*2{TifW3Rep8O#Ft>7xeqxk
z@o?S<mcS-sdU1AJU3=3J>)wc`vR2bg+lEb=w1ZAe;{-bmm{t{b8=WW)qA-Y=h`ebU
zd{vkEZqUV*Q5XdwU}u=yORB|%y`)@PvX}52iGl`=;{x4wJSdxhz0xg=nLI;wnICr|
zDo+Ij+HJ8$s|%QVyUhobLzn}PsbyjndrmAZ+QHPTOv(FTk|MN%h&>4W#2L4{x)U{n
z2(2k8BJ6m|#vLRrRSzi>*rrj!8gp7mX(|9>6=ACrpi>E{s2!u=1}p($SYvUev?wiC
zCMRHT0udqHGDT7EBuU`Myqt(#1l`EZB)>Sr!RAe58Td|{Ld<HlI~||9G>@K6un6vm
zf)Ij+M;*Tt=FuJP_zpC&P{z)0^6I&d9249fteMZXRV^iwaUjwu+={MaHfq>1&{BDg
zbUE6XBFGQ}j4*B3RXP^)5x{1I34o$S<Zo*iRdCF>jwWMVOrVezeP5uLC=r*P(zMlw
z2t@n+YXPq(iZZjG!IBmXL5qhdm-8<_Os(xBY-~RKAaRa#5N}_*?QOiF6R@m>07=(k
z=flF7n26anuZ56H%*N!s!XKFXn4w-?@z~TQ3?qR}ZF*&kSt9C$Ni1T70|QG6lUV~D
z^DKp3Zt8$>dlC#0z;p4b&|5ESy%g_*sn!bqR#GCqa+z@7>CKkRfPGwmT`eOs;QYqQ
z>gzwbN2^tkIC$hbzPv-Q8PtQ0?}kt+!UT1r<wRhcnB?0om?iPP3)qL`0Of|5B9$Vh
ze!K2EfVDSgAXsJKlhj0E%$vk4r=YkC`@n(}`yJZ^QkoNBlrGmJGWT+^445dRWud~b
zq%};~P-LPA1Fs(gcAYS!K3<?`@{Co5u0WYf`^@7-qlXbD-wuu?VT87;86ifMv>t`d
z*48{9Z%#hKEDjN>i<EEKu9jtFdLG}@PMnj({G=<2l=$efG4i|J0Cf$FC2!knZe{`#
zS9lH*)Xs;3t2gSb&HT>HtS0w!1^f^6O)scB-ol_KCj|vL?_(ZK81~RhiWX-VpCt<>
zOHF)6(bdsJ(O2ZM<w^nL%u%|u;W-h-$<oD(i{F<UUf{S$HG*&l^bnOV2@mdEjIp$Q
zNoJ_Qd55Sd&Y2I2YUpA(|0gOE*<CefCq7&vn|0*d1y{Her{u-filwy7Q=-oP14<-c
A6#xJL

delta 622
zcmZvYF>ljA6vu4?qO`FTL>F8UJq1;AhM2pv9XFXU?pbHa^|f{qR~14EIBGy@qpF>{
zWa+|2WFZDNW(H_rVn<@(6R@x|^doR~s;EVrPIvG9?*IPp>AtVMUwyN+ik+rEeBLC8
zU?8MpIvs?kgI&eM({KHqE02a@)FB(33^P#cSF5nuv9Z|ohN}BPNWGZ4UAhU^L<{R9
zwq|0mofd)@qru_+@EA_U>mAVjC;>J9CD;BPNtBZI^oS{BW45axSw{Km8xJN^S(20`
zNvylF#Ig^crL#Ll_M`UYls(=r!i%@%byl9s1(`i7<5GC3Ij@(9W#{*@mlq$+>erPy
z7-`xoccgv#|NBH@Lg0=IS54DO_v)xB>DWTB9dnN+i9!2r2zDF%Alfu8Ay^KiBIl_9
z+kiLVX%Hp7n9d<skg~vIsrXGy2<-HDmjXsMBwozJFoiZM;6zZzT)>tMeHwQIuV`q&
z7Vjk#ECP(j!5)vgZa6Q0;>JFY!E7z$*Ene}xabeqB%q^4LlqMWi?Eq8O6N|qXlbm>
nelFjZ^FJ%KTNpJ!&#RUDH^r^yLFHk7Q28z6oU7~kJN40Dy%Uxf

diff --git a/lispusers/WHEELSCROLL.TXT b/lispusers/WHEELSCROLL.TXT
new file mode 100644
index 0000000000000000000000000000000000000000..8cab8ba864d0260197d41a26ba0c4cd0083c3fcb
GIT binary patch
literal 1415
zcmZ`(T~FIE6b)<>+N3=0{XVu*`KrVVZ(ZpIT7U_Vx>q;3X{;u8WIILOPusuRFJR|7
z1v-gUZR6PY<M^Co*V?z8XXlUSm$O-RKfSxnvNWAL9ReF#Z0OD!`mWkqnGw-fUbs%V
z4UJF6r$=e}P-#!TQFTqFu9;L(cnTE;3tj85p<v19&SHJgKh>h<Aw6nS*heq*oee5z
zvy5qv6?0AKsHh({7U;-2iEQjz;!6Aha32+%%2(8?B7$McRr}l;$k<4`LTVY>+2Bz&
zy}c#`)K(QNxmQ76gIz8qUH}+8$`XCkbTGS_e92}z1?cu>NHow!2aU~d=#7wv;ZO+T
zEdc`Ew~Xp&lv@*o6}(|%LfBe4Enva@s}L8n>|wIoW_&VCKT1v0H4An?NUhZ-2=r&7
zOR&W%uPCoIxIu{2k8~apUFv0p#I>qB_O#S%rc(KUsa_wz6grx==7x<(W6gP*X7C9)
z&KU_F>Z};BoiZK-fGvD~OfF98=_yHU;+_(D9g{#=vkN*`^=tiJju%k91EeY_H<m0`
zoHW3UV}ef%aKA|~EK%rEBUh>+MdcAr5GJWnZCrqXz)oH%cm*5vbT&ST&CbTBqc{ka
zMbJ(}Y|L;P1X7;BFgw?^!gHly6|=T0R7KMl)~N6OHq@J|YzS|{%f2T{_8KVyvIUb~
z8tbAFr=4@)oeVF*y{N+~bdJx7=Hg=M+32Fc{uW&bAYObcN;Gn0BV38;j}O)gZXJ7%
z6;Y#4J=~^pS#lm|@PFoqLJ+o=>q6X6Z;z`;zT+z@Iw$^?#@o_6<`{IXuzZa6BIXdn
zY<e=NGeWJw8GI!Y_M5}ta#BD}!E3H93Xn(1z{|~uSfi1H3M951(Y4YmJCa-C=P2fA
zsG=Kf5FfRR4gTFaZoLX(l+HG<AunP=#dx)WKVySXpuO)P26_NSzB<H}vjaJi&--LA
o`J5a~v&sGa)in7OC*$A#tvvSdJ4lj!8SMYr&V2Zmy!-Y0F9j#pQ2+n{

literal 0
HcmV?d00001