From 57680d588dcba4f6ab42fa26000b917028434641 Mon Sep 17 00:00:00 2001
From: rmkaplan <ron.kaplan@post.harvard.edu>
Date: Wed, 17 Feb 2021 22:52:31 -0800
Subject: [PATCH] WHEELSCROLL: no action if the wheel moves while in a pop-up
 scroll bar

---
 lispusers/WHEELSCROLL      |   2 +-
 lispusers/WHEELSCROLL.LCOM | Bin 3301 -> 2587 bytes
 2 files changed, 1 insertion(+), 1 deletion(-)

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

(FILECREATED "16-Feb-2021 22:36:05" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;11
 5620   

      changes to%:  (FNS \TEDIT.WHEELSCROLL \SCROLLBARTOMAIN?)

      previous date%: "16-Feb-2021 16:10:43" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;8)


(PRETTYCOMPRINT WHEELSCROLLCOMS)

(RPAQQ WHEELSCROLLCOMS
 [(FNS ENABLEWHEELSCROLL WHEELSCROLL INSTALL-WHEELSCROLL 
                                 LISPINTERRUPTS.WHEELSCROLL CREATESCROLLBARWINDOW \SCROLLBARTOMAIN?)
                            (FNS \TEDIT.WHEELSCROLL)
                            (INITVARS (WHEELSCROLLDELTA 10))
                            (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 (UP)
                                          (* ; "Edited 16-Feb-2021 15:35 by rmk:")

    (LET ((W (\SCROLLBARTOMAIN?
)))
         (CL:WHEN W
             (SCROLLW W 0 (CL:IF UP
                              (IMINUS WHEELSCROLLDELTA)
                              WHEELSCROLLDELTA)))])

(INSTALL-WHEELSCROLL

  [LAMBDA NIL
                                           (* ; "Edited 16-Feb-2021 14:38 by rmk:")

    (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL)
        (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG)
        (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS))
    (INTERRUPTCHAR 520 '(WHEELSCROLL
 T)
           T)
    (INTERRUPTCHAR 521 '(WHEELSCROLL
 NIL)
           T)
    (CHANGENAME 'SCROLL.HANDLER 'CREATEW 'CREATESCROLLBARWINDOW)
    (CL:WHEN (BOUNDP 'TEDIT.READTABLE)

        (* ;; "These actions are invoked when the caret is in the Tedit window.  Otherwise the generic function is called on the Tedit window if the cursor is inside it.")


        (TEDIT.SETFUNCTION 520 [FUNCTION (LAMBDA NIL
                                           (\TEDIT.WHEELSCROLL
 T]
               TEDIT.READTABLE)
        (TEDIT.SETFUNCTION 521 [FUNCTION (LAMBDA NIL
                                           (\TEDIT.WHEELSCROLL
 NIL]
               TEDIT.READTABLE))
    (CL:WHEN (GETP 'SEDIT 'FILEDATES)
        (SEDIT:ADD-COMMAND 520 '(WHEELSCROLL
 T))
        (SEDIT:ADD-COMMAND 521 '(WHEELSCROLL
))
        (SEDIT:RESET-COMMANDS))])

(LISPINTERRUPTS.WHEELSCROLL

  [LAMBDA NIL
                                           (* ; "Edited 15-Feb-2021 14:50 by rmk:")


    (* ;; "So wheelscroll interrupts will be installed in every process")


    (APPEND [LIST (LIST 520 '(WHEELSCROLL
 T))
                  (LIST 521 '(WHEELSCROLL
]
           (LISPINTERRUPTS.WSORIG])

(CREATESCROLLBARWINDOW

  [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG PROPS)
     (* ; "Edited 16-Feb-2021 14:37 by rmk:")


    (* ;; "This replaces CREATEW inside SCROLL.HANDLER.  WINDOW should be bound to the window that this scroll bar will control.  The purpose is to create an unreferenced (LOC) pointer from the controller to the controllee, so that wheel scrolling in the scrollbar can be redirected to the controllee.")


    (DECLARE
 (USEDFREE WINDOW))
    (LET ((SBW (CREATEW REGION TITLE BORDERSIZE NOOPENFLG PROPS)))
         (WINDOWPROP SBW 'CONTROLLEELOC (LOC WINDOW))
         SBW])

(\SCROLLBARTOMAIN?

  [LAMBDA NIL
                                           (* ; "Edited 16-Feb-2021 22:13 by rmk:")


    (* ;; "Returns the window that should be wheel scrolled, moving from a scrollbar to its scrollee if necessary.")


    (LET ((W (WHICHW)))
         (CL:WHEN W
             (CL:WHEN (WINDOWPROP W 'CONTROLLEELOC)
                 [SETQ W (VAG (WINDOWPROP W 'CONTROLLEELOC]
                 (GETMOUSESTATE)
                 (\CURSORPOSITION [IPLUS 10 (FETCH
 LEFT OF
 (WINDOWPROP W 'REGION]
                        LASTMOUSEY)
                 (SETCURSOR DEFAULTCURSOR)
                 (GETMOUSESTATE)))

         (* ;; "IN/SCROLL/BAR? in WINDOWSCROLL does nothing if the window doesn't have a SCROLLFN, even though SCROLLW applies SCROLLBYREPAINTFN as a default in that case.  So a direct call to SCROLLW might scroll a window that can't be scrolled by moving the mouse into the scrollbar (or so it seems).  If we don't exclude this, then odd things like menus would be scrolled that shouldn't be.")


         (AND (WINDOWPROP W 'SCROLLFN)
              W])
)
(DEFINEQ

(\TEDIT.WHEELSCROLL

  [LAMBDA (UP)
                                          (* ; "Edited 16-Feb-2021 22:35 by rmk:")


    (* ;; "Called from the TEDIT.READTABLE when the wheel moves and the caret is in the TEDIT (WHICHW) window or its scrollbar.")


    (LET ((WINDOW (\SCROLLBARTOMAIN?
)))
         (CL:WHEN WINDOW
             [PROCESS.EVAL (FIND.PROCESS 'MOUSE)
                    `(SCROLLW ,WINDOW 0 ,(CL:IF UP
                                             (IMINUS WHEELSCROLLDELTA)
                                             WHEELSCROLLDELTA)])])
)

(RPAQ? WHEELSCROLLDELTA
 10)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(INSTALL-WHEELSCROLL
)

(ENABLEWHEELSCROLL
 T)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (875 4891 (ENABLEWHEELSCROLL 885 . 1310) (WHEELSCROLL 1312 . 1636) (INSTALL-WHEELSCROLL 
1638 . 2819) (LISPINTERRUPTS.WHEELSCROLL 2821 . 3170) (CREATESCROLLBARWINDOW 3172 . 3785) (
\SCROLLBARTOMAIN? 3787 . 4889)) (4892 5475 (\TEDIT.WHEELSCROLL 4902 . 5473)))))
STOP
\ No newline at end of file
+(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
diff --git a/lispusers/WHEELSCROLL.LCOM b/lispusers/WHEELSCROLL.LCOM
index 4dca4a1dcb9ed46a749d9d56e26f087b90b278cf..f3c48249f5b7fd0308ab6d52cb58f4996952a6cd 100644
GIT binary patch
literal 2587
zcmb_dPjBN?5O>N2SXnCC3(BDyA|cs_SpE~oNkHAc*e}gf9ow~?MvE$>ZWFbEw27J)
zu^?{y1vu~pICEGEd*+DvHv18n_nb{$lCoN)jU3xEZ{EC_-*0BD1+>E=TJ5lqR$0`E
zVK1d5$Voe-P+?I{(~xCJ1@;o+ACbc~rLJmxpN~6o8bHPJs-4lZs%_d9*mleDTBcP2
zt#UrSnvEx;Axy8K0_u-JcJ$Mi{rTu-zW?pnY;tzJA5PEDCi_>T;bipOG2H!&@olw`
z_9x@{>`vGYx|D{QpT=QmeBoF+`f66m>;?}sO|TkxTFbHVfM++O<&mTBXE*cDTOe(Q
zF^16-X8|4tox8~dvgh;Z-7Ux|7=}@S;n^()uCC=~IW5=1tMYCDysw18_39>^U!GlG
zjOK7V#jLbWlz}Scro-%J^xb%RHy4qk$y(&d3cs4~iv_!(t2E-pBE<l$prL9EOo$^L
zl(wQMrGxv=F7T;L`R!wV+Yom*<PC9G(drHy(Wk`ESsX#FAqkEx36{4KkRR89gakG?
z4gTbHS;(Fc(E!{AXzVbGQwjzYFFMqm2b8u4n&x70<6oDIEnDbK)SHrCmx(DrNf49)
zFt8w?VNUSPgn*?~B!yW0TvC*s4>>%al$7r9*WZ;FA93lQy+42G9tccc{~{hQ#9biy
z$JgRr7%pt?D?-&B-aj6WU;pOpzIs$BF3aU_$YuHETh@u-s9Y`!=ew5(y;U<INn@X8
znL$rT2yPQ_Yy`$a2{jJ}D8~a-B-n~@%A%~F(n1L}Y(M6A2MD)?1RVF{oPuS#P;~PE
zn&v|3IZIvLg%g_Q%;)FTpcnTu3N;(Lamv1mqns>eL7SwVI0dJ^G%vg^^mcQp=WJV8
zESjn7Dh7xy!s=Gxa*h~ukRxeHOv1FE<QcBmfa8wk#&S|3b62IEMNJDH76hzF`b)e@
z^6|^ou*6v|b$9UEDLvvu7iNWvPrD^ye~AXjTRAN(9`Ahc>Tk|Uv$=>Pqj{$v6^-H5
zp&j?5AOXa08MWUfDaWoCp9Emn#q$X?;j|e4L4wdUTnI_89T4!W%>=>mfPV*;4l_U;
z*ENO&7hscYu4c&FAz1Z|1uTwD%hjC6uypmmmy4$A@TOYrS;dI7s0wyeB08!lXDntD
zPDzr`2&V$3yq1+Q5K-!C#6o_wmZUV#pZakxNzt!-4C*p8NE32=ys5`=zz6g8WR${0
za<&WbExGEToscvGP4cly6||zM_<S<gY~HNA=_P&bdm+Y<4mo<~gH3k6y-{O57WFeZ
z+hRX=z<;0}hH;yOB2any71K_N97{G2Y0i2SH?fH2Te%fmEF7qEP^*35Vi$v^2GkEp
zO7Tk<;85Vx=^%_rfRZ04PeDt#|1G3(=QcY<5)W`H<NOW)OL=bMD}(aC0WKnYvV}j6
W(nTe%t*v8)U*rd1P#=Url>fi+c7b~U

literal 3301
zcmb_e&2HO95SCh`NKz0;uRa75p#jK)R4pm$udQR6TuE#wk|rq&E_{d+3yE6AGAz4j
zP!#Ap^xCH|a>&i+zCrso{dQNfsGp=ok-(uiv%{I4*>ApC-QyiU<mHYZ@UkCvB6^r`
z$IG1kfK$m2GoA!~8kgu{?6^;z?uydTbn%^wFEZ{?iPg)U(etudH5r*^+p4##c8T=T
zi|On0@nm#L(=#fO_KTN3{q>u{Y;-Z({qf{{a&opCOkbQ#c3+Q9C!;r3#om26zAP(g
zcQT%xUrF0xkMkgPlPCx(Uo&RFSF7xtUm#$$O03zgvbJR+!1IgIZOGBj=NGfbZ92vd
z{j8GnL1XNuFGCVyQs-(iq4dpcdUZ*xw#=kbsg&sS<P!VWO8EtowQXc+mHt~DK33jj
z*Uc)ucy)62ax|mMDU#DWVM^MT6pvN8_MIe)`i>tyG3fka^wW5HHIpgf+m%ye^){=v
zYu3j)rKX|rP+%!v_qNy6bf2meg$5P&3xz^)@A}b8{1&F-abG;v#0P8gn)slg*DZR=
zj~qAiqmXLNoM4$bfi;!_&ds(cc07};ruY@GRdPd$Fd(~0y59|>gj0poi$OJOi_&b6
zuG_#q{u?=CW=ee(`f5&ZXd6X|QIsKx(hOqi5Tl%h$Aip4y>^PlLh-IB(HF%+@AQu!
z_I^J-`1`km&xHzgFfCGtKBO9Lp1&6Qfu<XpAEucT1m#==2W`YioDOWLAY+X0&E48t
zI>`7JXXcu-SO3?U^rLrB7uChL6oq=cD-`Ewk>0OM5*qR$fpoJjpM7#y!fY%ncJ|4=
zoV2u+Z_+}(Dc^)|r5MYV8+@D><-2^y$ZsDlLP>EENeZ&KI4#y>lnQ2QCp_g@*^T;r
zC-hQcjrx4S@w|na7*MXvSG0h8muE3CKwVV`zB+?YH3I|Yw`g(J`_UluVrnsRdrsIz
ztM)lH7)jnw25|;;LUv<KQ8TF@9eQNe<?j<}(XpB%UW}Gu=ngR#JWK^7g4U8-CI<WW
zz|JJbMA-LWvQ=L{cxu*3&7E6@8~ULa4G9HR3qukmRO15Kc>zzzYLFObxA~=nimhr^
zMg*F9eKm~|zl(!dTR^j|TQ0|y;1Pzp>bY(+hzV-RX(%(OZm+7)i3ZuLU&7AN-XCn)
zbdN>vE-?6NXJ>&xyy8znP=XOSw7?Zk9P<!dXtp*|kx9?n9g}utj|PGFR?{%F?PnvI
zUyxk7FKDhtaT3KT-Yg2E2+=!17m^8JCLT{x|9cLRQRZj3jtE{%cvtYd<VJbkV1N=B
z@y?#J?|RxDk+I-K*@XwPYh|nUM2=O82bqG22u!9;LF5vvE)XNY+afm#GjYklZ6k7_
zGPDgERfMGITI>brcLqV`4iZ!fTY82qDFT%wef`~%6|TQko0FB78+<2E;%0KcC&fQM
zEB^IN<RL9?R1!DJW^VED?WZE4W|NN5GlPULu@4^TM}w53lQQ(OjozDYi|Q~}JB*{$
zmvhp_v9EZj*@8)O9;_A}I$Z)jpjTnwJyG>zTa+~nE#K`8Q8<uQ;H1jik$}}oWknCI
zC{(F8?`gNFnP>Uo`S{h!e0=+*th_9&eCsXdB|2bdX9543grdvSw89UafN;UWwb-j5
zO`+UANp;|7F>09&Dnwyq4tkvMEIR_1#|fw=KgFR-VUxtp!NIy7w*+yI+q^L4n`;Y4
z(uc@kdn0ZD+E91M%_}4p{Ls%1og~#(+Fag8&^rb!JnjZg!f~7Q&^w}ndqL!QklZLf
lB0UyPHn<%hZswX9nt^|+L{IW1x($fS;}&Pyc4y+c^A9(m2#Wv!