;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Reason: No longer leave images of the scroll bar outline of a Mac-style scroll bar on the ;;; screen everytime the scroll region is refreshed while the user is dragging the ;;; scroll bar. ;;; RESTRICTED RIGHTS LEGEND ;;; ;;; Use, duplication, or disclosure by the Government is subject to ;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;; Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909, M/S 2151 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1989 Texas Instruments Incorporated. ;;; All rights reserved. ;;; Written 06/15/89 08:17:36 by GRENINGER, ;;; while running on MX23 from band P608 ;;; With SYSTEM 6.5, GC 6.2, VIRTUAL-MEMORY 6.1, MICRONET 6.0, MICRONET-COMM 6.1, ;;; DISK-IO 6.0, DISK-LABEL 6.0, BASIC-PATHNAME 6.0, MAC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, ;;; BASIC-NAMESPACE 6.0, BASIC-FILE 6.2, RPC 6.1, NFS 6.0, EH 6.2, MAKE-SYSTEM 6.0, ;;; MEMORY-AUX 6.0, COMPILER 6.2, TV 6.8, NVRAM 6.0, UCL 6.0, INPUT-EDITOR 6.0, MACTOOLBOX 2.0, ;;; METER 6.0, ZWEI 6.1, DEBUG-TOOLS 6.0, WINDOW-MX 6.2, PRINTER 6.1, MAC-PRINTER-TYPES 6.1, ;;; CLIPBOARD 6.0, NETWORK-PATHNAME 6.0, NETWORK-NAMESPACE 6.0, DATALINK 6.0, CHAOSNET 6.0, ;;; NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, MX-DATALINK 6.0, ;;; NAMESPACE-EDITOR 6.0, IP 3.46, NFS-SERVER 6.0, MX-SERIAL 6.0, PRINTER-TYPES 6.0, ;;; IMAGEN 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0, TELNET 6.0, VT100 6.0, STREAMER-TAPE 6.2, ;;; DECNET 1.68, VISIDOC 6.1, PROFILE 6.1, TI-CLOS 6.5, CLEH 6.3, Experimental CLX 6.1, ;;; CLUE 6.5, Experimental BUG 11.8, microcode 138, Band Name: Rel 6.0 mxnet 6/8 #!C ; From file SCROLL-BAR.LISP#> WINDOW; Sys: #10R W#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "W")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; SCROLL-BAR.#" (DEFMETHOD (scroll-bar-mixin :scroll-drag) (y-init &optional &key (continuous nil)) "Drag scrolling. Three modes are available :bar drags the bar, :window drags the bar and the buffer in real time, and :line drags a line at a time." (UNLESS (ZEROP (mouse-buttons)) (MULTIPLE-VALUE-BIND (ignore n-lines ln-height ignore) (SEND self :scroll-position) (SETF (GETF scroll-bar-draw-state :bar-outline-needs-erasing) nil) (LOOP with box-top = (scroll-bar-region-box-top scroll-bar-region) with bar-height = (scroll-bar-region-bar-height scroll-bar-region) with bar-width = (scroll-bar-region-bar-width scroll-bar-region) with bar-range = (scroll-bar-region-bar-range scroll-bar-region) with bar-pattern = (SELECT *scroll-bar-shade* (25%-gray 75%-gray) (12%-gray 88%-gray) (33%-gray 66%-gray) (0%-gray 100%-gray) (75%-gray 25%-gray) (88%-gray 12%-gray) (66%-gray 33%-gray) (100%-gray 0%-gray) (:otherwise (BIT-NOT *scroll-bar-shade*))) with lower-limit = (+ box-top bar-range) with current-bar-top = (scroll-bar-region-bar-top scroll-bar-region) with bar-left = (scroll-bar-region-bar-left scroll-bar-region) with mouse-y-init = (+ y-init (CADR (MULTIPLE-VALUE-LIST (sheet-calculate-offsets self mouse-sheet)))) with last-y = mouse-y with lines-to-scroll for y = (MIN lower-limit (MAX box-top (- mouse-y mouse-y-init (- current-bar-top)))) ;; This just drags the scroll bar while the mouse is down. ;; When the mouse is released the window scrolls to the new bar position. when (OR (NULL continuous) (EQ continuous :bar)) do (UNLESS (EQL y last-y) (tv:prepare-sheet (self) (tv:prepare-color (self scroll-bar-color) (IF (GETF scroll-bar-draw-state :bar-outline-needs-erasing) ;Do it this way so bar is off as short a time as possible (draw-hollow-rectangle bar-width bar-height bar-left last-y 1. alu-sub self bar-pattern) ;; else... (SETF (GETF scroll-bar-draw-state :bar-outline-needs-erasing) t)) (draw-hollow-rectangle bar-width bar-height bar-left y 1. alu-add self bar-pattern)))) (SETF last-y y) (PROCESS-WAIT "Mouse" #'(lambda (y) (OR (NEQ y mouse-y) (ZEROP (mouse-buttons)))) mouse-y) ;; This is like :bar but actually drags the window in real time. Real useful in the inspector. when (EQ continuous :window) do (SEND self :scroll-to (TRUNCATE (* n-lines (FLOAT (/ (- y box-top) (MAX 1 bar-range))))) :absolute) (PROCESS-WAIT "Mouse" #'(lambda (y) (OR (NEQ y mouse-y) (ZEROP (mouse-buttons)))) mouse-y) ;; This is like grabbing a line and draging it with the mouse. Unlike :bar and :window ;; the line moves in the direction of mouse movement. when (EQ continuous :line) do (WHEN (PLUSP (ABS (SETF lines-to-scroll (TRUNCATE (- last-y mouse-y) ln-height)))) (SETF last-y mouse-y) (SEND self :scroll-to lines-to-scroll :relative)) (PROCESS-WAIT "Mouse" #'(lambda (y) (OR (NEQ y mouse-y) (ZEROP (mouse-buttons)))) mouse-y) until (ZEROP (mouse-buttons)) finally ; Cleanup for :bar case (WHEN (OR (NULL continuous) (EQ continuous :bar)) (tv:prepare-sheet (self) (tv:prepare-color (self scroll-bar-color) (draw-hollow-rectangle bar-width bar-height bar-left last-y 1. alu-sub self bar-pattern))) (UNLESS (EQL y current-bar-top) (SEND self :scroll-to (TRUNCATE (* n-lines (FLOAT (/ (- y box-top) (MAX 1 bar-range))))) :absolute))))))) )) #!C ; From file SCROLL-BAR.LISP#> WINDOW; Sys: #10R W#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "W")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; SCROLL-BAR.#" (DEFMETHOD (scroll-bar-mixin :scroll-bar-draw-box-and-bar) (bar-top &optional (readout 1)) "Draws the scroll box and bar. If bar-top is NIL the scroll box is cleared." (LET ((box-left (scroll-bar-region-bar-left scroll-bar-region)) (box-width (scroll-bar-region-width scroll-bar-region)) (box-top (scroll-bar-region-box-top scroll-bar-region)) (box-height (scroll-bar-region-box-height scroll-bar-region)) (bar-width (scroll-bar-region-bar-width scroll-bar-region)) (bar-height (scroll-bar-region-bar-height scroll-bar-region))) (PREPARE-SHEET (self) (tv:prepare-color (self scroll-bar-color) (IF bar-top ;; THEN...Draw the scroll-bar and box. ;; Clear a spot for the scroll bar (LET* ((mac-adjust (IF (mac-window-p self) 1 0)) ;Why??? (upper-box-height (- bar-top box-top (- mac-adjust))) (bar-bottom (+ bar-top bar-height)) (lower-box-height (- box-height (- bar-bottom box-top) (- mac-adjust)))) (sys:%draw-rectangle bar-width bar-height box-left bar-top alu-setz self) ;; Draw line around the bar (draw-hollow-rectangle bar-width bar-height box-left bar-top 1 alu-seta self) ;; Draw digital page readout in the bar (LET* ((readout-font fonts:tiny) (readout-font-height (tv:font-char-height readout-font)) (readout-string (FORMAT nil "~d" readout)) (readout-length (LENGTH readout-string)) (bits (* readout-length (tv:font-char-width readout-font))) x y (bug-fix (tv:font-char-width readout-font)) (*dont-clip-at-the-margins* t)) (WHEN (> bits bar-width) (SETF readout-string "*") (SETF readout-length 1) (SETF bits (* readout-length (tv:font-char-width readout-font)))) (WHEN (>= bar-height readout-font-height) (SETF x (+ box-left (- (TRUNCATE box-width 2) (TRUNCATE bits 2)))) (SETF y (MAX bar-top (+ bar-top (CEILING bar-height 2) (- (TRUNCATE readout-font-height 2))))) (tv:draw-string-internal self readout-string 0 readout-length x y (+ x bar-width ;;; **** HACK ALERT **** ;;; BUG in draw-string-internal clips character at wrong place... remove this when fixed bug-fix ;Temporary fudge factor!!! ) readout-font alu-transp))) ;; Shade the scroll box (WHEN (PLUSP upper-box-height) (draw-shaded-rectangle bar-width upper-box-height box-left box-top alu-seta self *scroll-bar-shade*)) (WHEN (PLUSP lower-box-height) (draw-shaded-rectangle bar-width lower-box-height box-left bar-bottom alu-seta self *scroll-bar-shade*))) ;; ELSE... just clear the scroll-box (sys:%draw-rectangle bar-width box-height box-left box-top alu-setz self)) (SETF (GETF scroll-bar-draw-state :bar-outline-needs-erasing) nil))))) )) #!C ; From file SCROLL-BAR.LISP#> WINDOW; Sys: #10R W#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "W")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; SCROLL-BAR.#" (DEFUN Mac-style-scroll-bar-update (refresh) "If the scroll-bar-region-bar-top is different than the new scroll position then this draws the scroll box and bar at the new scroll position." (DECLARE (self-flavor scroll-bar-mixin)) (WITHOUT-INTERRUPTS (UNLESS (scroll-bar-region-valid-p scroll-bar-region) (SEND self :compute-region) (SETF refresh t)) (WHEN refresh (SEND self :scroll-bar-draw-region) (SEND self :scroll-bar-draw-icon :point-up t :solid nil) (SEND self :scroll-bar-draw-icon :point-up nil :solid nil)) (MULTIPLE-VALUE-BIND (top-line n-lines ignore n-screen-lines) (SEND self :scroll-position) (LET ((current-bar-top (scroll-bar-region-bar-top scroll-bar-region)) (new-bar-top (WHEN (OR (PLUSP top-line) (> n-lines n-screen-lines)) (+ (scroll-bar-region-box-top scroll-bar-region) (IF (>= top-line (1- n-lines)) ;;...THEN last line is at top - force bar to bottom (scroll-bar-region-bar-range scroll-bar-region) ;;...ELSE proportionally position the bar (TRUNCATE (* (scroll-bar-region-bar-range scroll-bar-region) top-line) n-lines))))) (page-lines (MAX 1 (1- n-screen-lines)))) (WHEN (OR refresh (NOT (EQL new-bar-top current-bar-top)) (ZEROP (REM top-line page-lines)) ;Page boundary? ;; This test should also cover case of scrolling past a boundary without ;; actually hitting it!! This needs to be fixed sometime. ) (SEND self :scroll-bar-draw-box-and-bar new-bar-top (CEILING (+ 1 top-line (ASH page-lines -1)) page-lines)) (SETF (scroll-bar-region-bar-top scroll-bar-region) new-bar-top)))))) ))