First commit of wheel-mouse scrolling

lispusers/WHEELSCROLL

@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")

(FILECREATED "15-Feb-2021 18:24:12" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;1
 3088   

      changes to%:  (VARS WHEELSCROLLCOMS)
                    (FNS ENABLEWHEELSCROLL INSTALL-WHEELSCROLL)

      previous date%: "15-Feb-2021 16:52:28" {DSK}<Users>kaplan>lisp>WHEELSCROLL.;8)


(PRETTYCOMPRINT WHEELSCROLLCOMS)

(RPAQQ WHEELSCROLLCOMS
 [(FNS ENABLEWHEELSCROLL WHEELSCROLL INSTALL-WHEELSCROLL 
                                 LISPINTERRUPTS.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 15-Feb-2021 16:23 by rmk:")

    (LET ((W (WHICHW)))
         (CL:WHEN W
             (SCROLLW W 0 (CL:IF UP
                              (IMINUS WHEELSCROLLDELTA)
                              WHEELSCROLLDELTA)))])

(INSTALL-WHEELSCROLL

  [LAMBDA NIL
                                           (* ; "Edited 15-Feb-2021 18:18 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)
    (CL:WHEN (BOUNDP 'TEDIT.READTABLE)

        (* ;; 

 "This doesn't seem to help the fact that it doesn't scroll when the caret is in the Tedit window.")


        (TEDIT.SETFUNCTION 520 [FUNCTION (LAMBDA NIL
                                           (WHEELSCROLL
 T]
               TEDIT.READTABLE)
        (TEDIT.SETFUNCTION 521 [FUNCTION (LAMBDA NIL
                                           (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])
)

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

(INSTALL-WHEELSCROLL
)

(ENABLEWHEELSCROLL
 T)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (792 2943 (ENABLEWHEELSCROLL 802 . 1227) (WHEELSCROLL 1229 . 1538) (INSTALL-WHEELSCROLL 
1540 . 2590) (LISPINTERRUPTS.WHEELSCROLL 2592 . 2941)))))
STOP