home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / examples / old / scroll.l < prev    next >
Encoding:
Text File  |  1989-07-12  |  12.7 KB  |  357 lines
  1. ;;; -*- Mode:Lisp; Package:CLUE-EXAMPLES; Base:10; Syntax:Common-Lisp -*-
  2. ;;;
  3. ;;;             TEXAS INSTRUMENTS INCORPORATED
  4. ;;;                  P.O. BOX 2909
  5. ;;;                   AUSTIN, TEXAS 78769
  6. ;;;
  7. ;;; Copyright (C) 1988 Texas Instruments Incorporated.
  8. ;;;
  9. ;;; Permission is granted to any individual or institution to use, copy, modify,
  10. ;;; and distribute this software, provided that this complete copyright and
  11. ;;; permission notice is maintained, intact, in all copies and supporting
  12. ;;; documentation.
  13. ;;;
  14. ;;; Texas Instruments Incorporated provides this software "as is" without
  15. ;;; express or implied warranty.
  16. ;;;
  17.  
  18. ;;; Description:  Scroll frame composite contact
  19. ;;; This will automagically add horizontal and/or vertical scroll bars and the
  20. ;;; accompanying scroll functionality to a user-supplied contact.
  21.  
  22. ;;; Change History:
  23. ;;; ----------------------------------------------------------------------------
  24. ;;;  6/14/88    KK    Created.
  25. ;;;  8/24/88    SLM     Change Copyright notice from restricted to "free".
  26. ;;;  8/24/88    SLM     Rewrote the initilize-instance :around method
  27. ;;;                     (clos-kludge doesnt' handle it right) to be an
  28. ;;;                     after method.
  29. ;;;  8/25/88    SLM     Rewrote manage-geometry and scroll-frame-configure.
  30. ;;;  8/26/88    SLM     Turn on compress-exposures for the scroll-frame.
  31. ;;;  8/26/88    SLM     Fix it so a VERTICAL scroll bar does NOT have to be present!
  32.  
  33.  
  34. (in-package 'clue-examples :use '(lisp xlib clos cluei))
  35.  
  36.  
  37. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38. ;;;  SCROLL-FRAME Composite definition
  39.  
  40.  
  41. (defcontact scroll-frame (virtual-composite)
  42.   ((horizontal-layout :type     (member :top :bottom nil)
  43.               :reader   scroll-frame-horizontal-layout  ;;setf defined elsewhere
  44.               :initarg  :horizontal
  45.               :initform nil)
  46.    (vertical-layout   :type     (member :left :right nil)
  47.               :reader   scroll-frame-vertical-layout    ;;setf defined elsewhere
  48.               :initarg  :vertical
  49.               :initform nil)
  50.    (default-scroll-bar-width  :type     card32
  51.               :accessor scroll-bar-width
  52.               :initarg  :default-scroll-bar-width
  53.               :initform 20)
  54.    (documentation     :initform "Press the Q key to quit"))
  55.   (:resources
  56.     documentation
  57.     (compress-exposures :initform :on)
  58.     documentation)
  59.   (:documentation "A contact that wraps scroll bars around a contact"))
  60.  
  61. (defevent scroll-frame (:key-press #\Q) (quit-scroll-frame quit-scroll "key-exit"))
  62. (defevent scroll-frame (:key-press #\q) (quit-scroll-frame quit-scroll "key-exit"))
  63. (defmethod quit-scroll-frame ((self scroll-frame) &optional (tag 'quit-scroll) value)
  64.   (format t "~%~a ~a ~a" self tag value)
  65.   (throw tag value))
  66.  
  67.  
  68. (defparameter *default-scroll-bar-width* 20
  69.   "Default pixel size of the valuators in a SCROLL-FRAME.")
  70.  
  71.  
  72. (defmethod initialize-instance :after ((self scroll-frame)
  73.                     &rest initargs
  74.                     &key (scroll-class '(vscroller hscroller))
  75.                                  scroll-initargs
  76.                          (vertical :right)
  77.                          horizontal 
  78.                          inside-width
  79.                          inside-height
  80.                          width
  81.                          height
  82.                          (border-width 1)
  83.                          default-scroll-bar-width
  84.                     &allow-other-keys)
  85.   (assert (or width inside-width)
  86.       nil "Must specify either :WIDTH or :INSIDE-WIDTH.")
  87.   (assert (or height inside-height)
  88.       nil "Must specify either :HEIGHT or :INSIDE-HEIGHT.")  
  89.   
  90.   (let* ((scroll-width  (or (getf scroll-initargs :width)
  91.                 default-scroll-bar-width
  92.                 *default-scroll-bar-width*))
  93.      (min-frame-size (+ scroll-width scroll-width border-width border-width))
  94.      (width         (max min-frame-size
  95.                  (or width
  96.                  (if vertical
  97.                      (+ inside-width scroll-width border-width)
  98.                      inside-width))))
  99.      (height        (max min-frame-size
  100.                  (or height
  101.                  (if horizontal
  102.                      (+ inside-height scroll-width border-width)
  103.                      inside-height)))))    
  104.  
  105.     (with-slots ((horizon horizontal-layout) (vert vertical-layout) (w width) (h height)) self
  106.       (setf horizon horizontal
  107.         vert vertical
  108.         w width
  109.         h height))
  110.     
  111.         
  112.  
  113.     (let ((default-initargs (nconc (copy-list scroll-initargs) initargs)))
  114.       (when (and vertical horizontal)
  115.     (setf height (max 1 (- height scroll-width))
  116.           width (max 1 (- width scroll-width))))
  117.       ;; Make scroller children.           
  118.       (when vertical    
  119.     (apply #'make-contact (first scroll-class)
  120.            :name   :vertical
  121.            :parent self
  122.            :width  scroll-width
  123.            :height height
  124.            :border-width border-width
  125.            :allow-other-keys t
  126.            default-initargs))
  127.       
  128.       (when horizontal  
  129.     (apply #'make-contact (second scroll-class)
  130.            :name   :horizontal
  131.            :parent self
  132.            :width width
  133.            :height scroll-width
  134.            :border-width border-width
  135.            :allow-other-keys t
  136.            default-initargs)))))
  137.  
  138. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  139. ;;;  Accessors
  140.  
  141. (defmethod (setf scroll-frame-horizontal-layout) (new-value (self scroll-frame))
  142.   (assert (member new-value '(:top :bottom))
  143.       nil "Horizontal scroller layout must be either :TOP or :BOTTOM.")
  144.   (setf (slot-value (the scroll-frame self) 'horizontal-layout) new-value)
  145.   (change-layout self))
  146.  
  147. (defmethod (setf scroll-frame-vertical-layout) (new-value (self scroll-frame))
  148.   (assert (member new-value '(:left :right))
  149.       nil "Vertical scroller layout must be either :LEFT or :RIGHT.")
  150.   (setf (slot-value (the scroll-frame self) 'vertical-layout) new-value)
  151.   (change-layout self))
  152.  
  153.  
  154. (defmethod scroll-frame-body ((self scroll-frame))
  155.   (with-slots (children) self
  156.     (find t children
  157.       :key #'(lambda (contact)
  158.            (let ((name (contact-name contact)))
  159.              (not (or (eq name :horizontal) (eq name :vertical)))))
  160.       :test #'eq)))
  161.  
  162.  
  163. (defmethod scroll-frame-horizontal ((self scroll-frame))
  164.   (with-slots (children) self
  165.     (find :horizontal children :key #'contact-name :test #'eq)))
  166.  
  167.  
  168. (defmethod scroll-frame-vertical ((self scroll-frame))
  169.   (with-slots (children) self
  170.     (find :vertical children :key #'contact-name :test #'eq)))
  171.  
  172.  
  173. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  174. ;;;  Management/control methods
  175.  
  176. (defmethod add-child ((self scroll-frame) contact &key)
  177.   ;;need to add some way for a user to specify what
  178.   ;;function is to be the callback for :changed-by-user.
  179.   (flet ((connect-horizontal (frame scroller body)
  180.        ;; Initialize callbacks and initial values for horizontal scroller
  181.        (add-callback body :horizontal-reset 'scroll-frame-horizontal-reset frame)
  182.        (add-callback scroller :changed-by-user 'scroll-horizontal-position body)
  183.        (scroll-frame-horizontal-reset frame scroller body))
  184.      
  185.      (connect-vertical (frame scroller body)
  186.        ;; Initialize callbacks and initial values for vertical scroller
  187.        (add-callback body :vertical-reset 'scroll-frame-vertical-reset frame)
  188.        (add-callback scroller :changed-by-user 'scroll-vertical-position body)
  189.        (scroll-frame-vertical-reset frame scroller body)))
  190.     
  191.   (with-slots (children) self
  192.     (let ((name (contact-name contact))
  193.       (body (scroll-frame-body self)))
  194.       (when 
  195.     (case name
  196.       (:horizontal
  197.        (assert (not (scroll-frame-horizontal self))
  198.            nil "Horizontal scroller for ~s already exists." self)
  199.        (when body (connect-horizontal self contact body))
  200.        t)
  201.       
  202.       (:vertical
  203.        (assert (not (scroll-frame-vertical self))
  204.            nil "Vertical scroller for ~s already exists." self)
  205.        (when body (connect-vertical self contact body))
  206.        t)
  207.       
  208.       (otherwise
  209.        (assert (not body)
  210.            nil "A body for ~s already exists." self)
  211.        (let ((h (scroll-frame-horizontal self))
  212.          (v (scroll-frame-vertical self)))
  213.          (when h (connect-horizontal self h contact))
  214.          (when v (connect-vertical self v contact)))
  215.        t))
  216.  
  217.     (setf children (nconc children (cons contact nil)))
  218.     )))
  219.   (setf (contact-state contact) :mapped)
  220.   ))
  221.  
  222.  
  223. (defmethod delete-child ((self scroll-frame) contact &key)
  224.   (with-slots (children) self
  225.     (setf children (delete contact children))
  226.     
  227.     (let ((body (scroll-frame-body self)))
  228.       (when body
  229.     (case (contact-name contact)
  230.       (:horizontal
  231.        (delete-callback body :horizontal-reset))
  232.       
  233.       (:vertical
  234.        (delete-callback body :vertical-reset)))))))
  235.  
  236. (defmethod display :after ((self scroll-frame) &optional x y width height &key)
  237.   (declare (ignore x y width height))
  238.   (dolist (child (slot-value (the scroll-frame self) 'children))
  239.     (display child)))
  240.  
  241. (defmethod manage-geometry ((self scroll-frame) contact
  242.                 cx cy cwidth cheight cborder-width
  243.                 &key)
  244.   (declare (ignore x y width height border-width))
  245.   (with-slots (x y width height border-width) (the contact contact)
  246.     (if (and (eq x cx)
  247.          (eq y cy)
  248.          (eq width cwidth)
  249.          (eq height cheight)
  250.          (eq border-width cborder-width))
  251.     (values t)
  252.     (values nil x y width height border-width))))
  253.  
  254. (defmethod resize :after ((self scroll-frame) width height border-width)
  255.   (declare (ignore width height border-width))
  256.   (change-layout self)
  257.   (display self))
  258.  
  259. (defmethod change-layout ((self scroll-frame) &optional newly-managed)
  260.   "Update child geometry according to current SELF geometry and contents."
  261.   (declare (ignore newly-managed))
  262.   (with-slots (x y width height horizontal-layout vertical-layout border-width) self
  263.     (let* ((v (scroll-frame-vertical self))
  264.        (h (scroll-frame-horizontal self))
  265.        (body (scroll-frame-body self))
  266.        (total-body-border (* 2 (contact-border-width body)))
  267.        (total-hscroll-border (if h (* 2 (contact-border-width h) 0)))
  268.        (total-vscroll-border (if v (* 2 (contact-border-width v) 0)))
  269.        (total-body-width nil)
  270.        (total-body-height nil)
  271.        (hscroll-total-height (if h (+ (contact-height h) total-hscroll-border) 0))
  272.        (vscroll-total-width (if v (+ (contact-width v) total-vscroll-border) 0))
  273.        (new-body-width (- width vscroll-total-width))
  274.        (new-body-height (- height hscroll-total-height))
  275.        )
  276.       (resize body
  277.           new-body-width
  278.           new-body-height
  279.           (contact-border-width body))
  280.       (setf total-body-width (+ (contact-width body) total-body-border)
  281.         total-body-height (+ (contact-height body) total-body-border))
  282.       (when (and vertical-layout v)
  283.     (ecase vertical-layout
  284.       (:left (move v 0 0)
  285.          (move body (+ border-width vscroll-total-width) (contact-y body)))
  286.       (:right (move v (+ border-width total-body-width) 0)
  287.           (move body 0 (contact-y body))))
  288.     (resize v vscroll-total-width new-body-height (contact-border-width v))
  289.     )
  290.       (when (and horizontal-layout h)
  291.     (ecase horizontal-layout
  292.       (:top (move h 0 0)
  293.         (move body (contact-x body) hscroll-total-height))
  294.       (:bottom (move h 0 (+ border-width total-body-height))
  295.            (move body (contact-x body) 0)))
  296.     (resize h new-body-width hscroll-total-height (contact-border-width h))
  297.     )
  298.       )))
  299.  
  300.  
  301. (defmethod scroll-frame-horizontal-reset ((self scroll-frame) &optional scroller body)
  302.   "Inquire new scrolling parameters and calibrate horizontal scroller."
  303.   (let ((body     (or body (scroll-frame-body self)))
  304.     (scroller (or scroller (scroll-frame-horizontal self))))
  305.     (when (and body scroller)
  306.       (multiple-value-bind (value minimum maximum indicator-size)
  307.       (scroll-horizontal-initialize body)
  308.     (valuator-calibrate scroller
  309.                 :value value
  310.                 :minimum minimum
  311.                 :maximum maximum
  312.                 :indicator-size indicator-size)))))
  313.  
  314.  
  315. (defmethod scroll-frame-vertical-reset ((self scroll-frame) &optional scroller body)
  316.   "Inquire new scrolling parameters and calibrate vertical scroller."
  317.   (let ((body     (or body (scroll-frame-body self)))
  318.     (scroller (or scroller (scroll-frame-vertical self))))
  319.     (when (and body scroller)
  320.       (multiple-value-bind (value minimum maximum indicator-size)
  321.       (scroll-vertical-initialize body)
  322.     (valuator-calibrate scroller
  323.                 :value value
  324.                 :minimum minimum
  325.                 :maximum maximum
  326.                 :indicator-size indicator-size)))))
  327.  
  328.  
  329. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  330. ;;;  "Generic" functions that the user will need to redefine for 
  331. ;;;  whatever contact is to be scrollable
  332. ;;;
  333. ;;;  SCROLL-HORIZONTAL-INITIALIZE
  334. ;;;  SCROLL-HORIZONTAL-POSITION
  335. ;;;  SCROLL-VERTICAL-INITIALIZE
  336. ;;;  SCROLL-VERTICAL-POSITION
  337.  
  338. (defmethod scroll-horizontal-initialize ((self contact))
  339.   ;;return four values: the initial position, the min and max
  340.   ;;values to be represented by the scroll bar, and how fine each
  341.   ;;movement of the indicator should be
  342.   (values 0 0 (contact-width self) 1)
  343.   )
  344.  
  345. (defmethod scroll-vertical-initialize ((self contact))
  346.   ;;return four values: the initial position, the min and max
  347.   ;;values to be represented by the scroll bar, and how fine each
  348.   ;;movement of the indicator should be
  349.   (values 0 0 (contact-height self) 1)
  350.   )
  351.  
  352. (defmethod scroll-horizontal-position (value (self contact))
  353.   (change-geometry self :x value :accept-p t))
  354.  
  355. (defmethod scroll-vertical-position (value (self contact))
  356.   (change-geometry self :y value :accept-p t))
  357.