home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / examples / old / demo / scroller.l < prev    next >
Encoding:
Text File  |  1989-07-12  |  7.7 KB  |  205 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. ;;;  8/26//88    SLM    Created.
  25.  
  26.  
  27.  
  28. (in-package 'clue-examples :use '(lisp xlib clos cluei))
  29.  
  30.  
  31.  
  32. (defcontact scrollable-pixmap-window (contact)
  33.   ((pixmap :type (or null pixmap) :accessor pixmap :initform nil :initarg :pixmap)
  34.    (pixmap-width :type integer :accessor pixmap-width :initform 0 :initarg :pixmap-width)
  35.    (pixmap-height :type integer :accessor pixmap-height :initform 0 :initarg :pixmap-height)
  36.    (foreground :type (or pixel pixmap) :accessor foreground :initarg :foreground :initform 0)
  37.    (scroll-increment :type integer :reader scroll-increment :initarg :scroll-increment :initform 1)
  38.    (scrolled-to-x :type integer :accessor scrolled-to-x :initform 0)
  39.    (scrolled-to-y :type integer :accessor scrolled-to-y :initform 0))
  40.   (:resources
  41.     (compress-exposures :initform :on)
  42.     foreground)
  43.   )
  44.  
  45. (defmethod display ((self scrollable-pixmap-window) &optional x y width height &key)
  46.   (with-slots ((contact-x x) (contact-y y)
  47.            pixmap-width pixmap-height
  48.            foreground background pixmap
  49.            scrolled-to-x scrolled-to-y) self
  50.     (let ((startx (or x scrolled-to-x))
  51.       (starty (or y scrolled-to-y))
  52.       (draw-w (or width pixmap-width))
  53.       (draw-h (or height pixmap-height)))
  54.       (using-gcontext (gc :drawable self
  55.               :foreground foreground
  56.               :background background)
  57.     ;;(clear-area self)
  58.     (copy-area pixmap gc startx starty draw-w draw-h self contact-x contact-y)))
  59.     ))
  60.      
  61.  
  62. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  63. ;;;  "Generic" functions that the user will need to redefine for 
  64. ;;;  whatever contact is to be scrollable
  65. ;;;
  66. ;;;  SCROLL-HORIZONTAL-INITIALIZE
  67. ;;;  SCROLL-HORIZONTAL-POSITION
  68. ;;;  SCROLL-VERTICAL-INITIALIZE
  69. ;;;  SCROLL-VERTICAL-POSITION
  70.  
  71. (defmethod scroll-horizontal-initialize ((self scrollable-pixmap-window))
  72.   ;;return four values: the initial position, the min and max
  73.   ;;values to be represented by the scroll bar, and how fine each
  74.   ;;movement of the indicator should be
  75.   (with-slots (scroll-increment pixmap-width) self
  76.     (values 0 0 (* pixmap-width scroll-increment) scroll-increment)
  77.     ))
  78.  
  79. (defmethod scroll-vertical-initialize ((self scrollable-pixmap-window))
  80.   ;;return four values: the initial position, the min and max
  81.   ;;values to be represented by the scroll bar, and how fine each
  82.   ;;movement of the indicator should be
  83.   (with-slots (pixmap scroll-increment pixmap-height) self
  84.     (values 0 0 (* pixmap-height scroll-increment) scroll-increment))
  85.     )
  86.  
  87. (defmethod scroll-horizontal-position (value (pixmap-window scrollable-pixmap-window))
  88.   (with-slots (scroll-increment scrolled-to-x) (the scrollable-pixmap-window pixmap-window)
  89.     (setf scrolled-to-x (round (/ value scroll-increment))))
  90.   (display pixmap-window)
  91.   )
  92.  
  93. (defmethod scroll-vertical-position (value (pixmap-window scrollable-pixmap-window))
  94.   (with-slots (scroll-increment scrolled-to-y scrolled-to-x) (the scrollable-pixmap-window pixmap-window)
  95.     (setf scrolled-to-y (round (/ value scroll-increment))) 
  96.   (display pixmap-window scrolled-to-x scrolled-to-y))
  97.   )
  98.  
  99. ;; Cache the last image
  100. (defvar *bitmap-cache* nil) ;; list of (pathname image)
  101.  
  102. (defun get-bitmap (thing)
  103.   (etypecase thing
  104.     (image thing)
  105.     ((or pathname string)
  106.      (let ((pathname (parse-namestring thing)))
  107.        (if (equal pathname (first *bitmap-cache*))
  108.        (second *bitmap-cache*)
  109.      (let ((image (read-bitmap-file pathname)))
  110.        (setq *bitmap-cache* (list pathname image))
  111.        image))))))
  112.  
  113. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  114. ;;;  Main routine to use all the above stuff...
  115.  
  116. (defun scroll-a-bitmap (display bitmap &optional
  117.             &key (foreground "black") (background "white")
  118.             (horizontal :bottom) (vertical :right))
  119.   "Display BITMAP in a scrollable window.  
  120. BITMAP is either a bitmap, or the pathname of a bitmap file.
  121. HORIZONTAL can be either :TOP or :BOTTOM
  122. VERTICAL can be either :LEFT or :RIGHT
  123. FOREGROUND and BACKGROUND can be any string identifying a color that the server knows about."
  124.  
  125.   (setf (display-image-lsb-first-p display) nil)
  126.   (setq bitmap (get-bitmap bitmap))
  127.       
  128.   (let* ((pmap nil)
  129.      
  130.      (pwidth (xlib:image-width bitmap))
  131.      (pheight (xlib:image-height bitmap))
  132.      (scroll (make-contact 'scroll-frame :parent display
  133.                    :name 'bitmap-scroller
  134.                    :horizontal horizontal :vertical vertical
  135.                    :x 20 :y 20 :inside-width pwidth :inside-height pheight
  136.                    :foreground 0 :background 1 
  137.                    :compress-exposures :on))
  138.      (window (make-contact 'scrollable-pixmap-window :parent scroll
  139.                    :x 0 :y 0
  140.                    :width pwidth :height pheight 
  141.                    :foreground (convert scroll foreground 'pixel)
  142.                    :background (convert scroll background 'pixel) 
  143.                    :scroll-increment 0.2
  144.                    :pixmap-width pwidth
  145.                    :pixmap-height pheight))
  146.      )
  147.     (add-mode scroll :exclusive 'ignore-action)
  148.     (setf (contact-state scroll) :mapped)
  149.     (update-state display)
  150.     (setf (slot-value (the scrollable-pixmap-window window) 'pixmap)
  151.       (setf pmap (create-pixmap :width pwidth :height pheight
  152.                     :depth (contact-depth window) :drawable window))
  153.       )
  154.     (using-gcontext (gc :drawable pmap
  155.             :foreground (convert scroll foreground 'pixel)
  156.             :background (convert scroll background 'pixel))
  157.       (put-image pmap gc bitmap :x 0 :y 0 :bitmap-p t))
  158.     (display window)
  159.     
  160.     ;(add-before-action display 'scroll-frame 'trace :motion-notify)
  161.     ;(add-before-action display 'scrollable-pixmap-window 'TRACE :motion-notify)
  162.     ;(SETF (DISPLAY-after-function display) #'xlib:display-finish-output)
  163.     (unwind-protect
  164.     (catch 'quit-scroll 
  165.       (do ()
  166.           (())
  167.         (process-next-event display)))
  168.       (destroy window)
  169.       (destroy scroll))))
  170.  
  171.  
  172. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  173. ;;;  For those of us who just want a bitmap displayed, use this...
  174.  
  175. (defun display-a-pixmap (display bitmap)
  176.   (setq bitmap (get-bitmap bitmap))
  177.   (let* ((window (make-contact 'contact
  178.                   :parent display
  179.                   :width (xlib:image-width bitmap)
  180.                   :height (xlib:image-height bitmap)
  181.                   :x 0 :y 0 :background 1 :foreground 0
  182.                   :state :mapped))
  183.      (pixmap nil)
  184.      (pwidth (xlib:image-width bitmap))
  185.      (pheight (xlib:image-height bitmap))
  186.      )
  187.     (setf (contact-state window) :mapped)
  188.     (update-state display)
  189.     (setf pixmap (create-pixmap :width pwidth :height pheight :drawable window :depth (contact-depth window)))
  190.     (using-gcontext (gc :drawable pixmap
  191.             :foreground (convert window 0 'pixel)
  192.             :background (convert window 1 'pixel))
  193.       (put-image pixmap gc bitmap :x 0 :y 0 :width pwidth :height pheight :bitmap-p t))
  194.     (using-gcontext (gc :drawable window
  195.             :foreground (convert window 0 'pixel)
  196.             :background (convert window 1 'pixel))
  197.       (copy-area pixmap gc 0 0 pwidth pheight window 0 0))
  198.     (setf (contact-state window) :mapped)
  199.     (unwind-protect
  200.     (do ()
  201.         (())
  202.       (process-next-event display))
  203.       (destroy window))))
  204.  
  205.