[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: extending scrolling-window to include copy-bits or scroll-region

On Wed Sep  1 09:33:27 1993, Paul Shannon writes:
  My application does some rather time-consuming line drawing to a view.
  When the view is later scrolled or exposed, its view-draw-contents
  method is called, and all of the drawing takes place all over again,
  taking just as much time as it did the first time.
  ... (disucsses using scrolling-window.lisp in the examples folder to start)
  This must be a common need.  I've checked through the examples folder,
  and the cambridge ftp site.  If there's anything there, I missed it.
Here is some code that I've written to dislay a picture in a scrolling area.
I've intended to submit this for some time but have been too busy with
my dissertation. If it's useful, I'll post it to the contrib directory:
You create an offscreen picture and then use this code to redraw the picture
in a scrolling region and to reduce or enlarge it. The standard copy,
paste, clear and cut methods are defined for this window.

It would be easy to extend the concept to a pic-view (a scrolling view
containing a picture) and to display a bitmap (or pixmap) or to use
There are two files required - alert-box.lisp which was on the first
distribution for MCL and my code.

;;; alert-box.lisp
;;Copyright  1987-89, Apple Computer, Inc
;;  This file implements Macintosh alert boxes.  These are like message-dialogs
;;  except they also have icons in them.
;; comverted 9.08.1991 to use CLOS

(in-package "CCL")

(defconstant *stop-icon* 0)
(defconstant *note-icon* 1)
(defconstant *caution-icon* 2)

(defclass icon-dialog-item (view)
  ((my-icon :initarg :icon)))

(defmethod view-draw-contents ((self icon-dialog-item))
  (with-slots (my-icon) self
    (let ((icon my-icon))
      (when icon
        (with-port (with-slots (wptr)
                     (view-container self) wptr)
          (rlet ((r :rect
                    :topleft #@(0 0)
                    :bottomright #@(32 32)))
            (#_ploticon :ptr r :ptr (#_geticon :word icon))))))))

(defun alert-box (message &key (ok-text "OK")
                          (size #@(335 100))
                          (position (list :top (+ *menubar-bottom* 2)))
                          (icon nil))
  (unless (member icon
                  `(,*stop-icon* ,*note-icon* ,*caution-icon*))
    (setq icon nil))
  (let* ((text-offset (if icon 32 0))
         (message-width (- (point-h size) (+ 92 text-offset)))
          (make-instance 'window
                         :view-position position
                         :view-size size
                         :close-box-p nil
                         :window-type :double-edge-box
                         :window-show nil)))
    (add-subviews new-dialog
                  (make-instance 'button-dialog-item
                                 :view-position (subtract-points size #@(75 35))
                                 :view-size #@(62 20)
                                 :dialog-item-text ok-text
                                 #'(lambda (item) 
                                     (return-from-modal-dialog t))
                                 :default-button t)
                  (make-instance 'static-text-dialog-item
                                 :view-position (make-point (+ text-offset 11)
                                 :view-size (make-point message-width
                                                        (- (point-v size) 30))
                                 :dialog-item-text message)
                  (make-instance 'icon-dialog-item
                                 :view-position #@(4 4)
                                 :view-size #@(32 32) 
                                 :icon icon))

;some sample calls

(alert-box "Be careful, or you may be sorry!" :icon *stop-icon*)
(alert-box "Please take note:  this dialog box is for leaving messages." :icon
(alert-box "I hope you don't regret erasing your hard disk!" :icon


(export '(alert-box *stop-icon* *note-icon* *caution-icon*) "CCL")

;;; the file defining scrollable pic-windows. extend it to views if
;;; required
;;  pic-window
;;  A new class of windows with scroll-bars and a scrollable
;;  area for displaying graphics stored in PICT format
;;  A gray border is drawn around the stored picture and the
;;  picture is drawn at the requested scale.

This mixin extends scrolling-windows to windows that display pictures.

(defclass pic-window (scrolling-window)
  ((window-picture :initform nil :accessor picture)
   (zoom-factor :initarg :scale :initform 1 :accessor scale-factor)
   (scale-rect :initform nil :accessor srect)
   (min-size :initarg :min-size)
   (purge :initform t :accessor purge))
    :close-box-p nil
    :window-type :document-with-zoom
    :window-title "Display"
    :view-font '("Helvetica" 10 :plain)
    :min-size #@(80 80)))

read-pic-window                         ; a protected pic window
                                        ; does not support Edit menu-items cut,
paste or clear

pic-window                              ; a subclass of scrolling-window
Initargs (in addition to the standard scrolling-window initargs)

  :window-picture                       ; default nil
     either the empty picture (nil) or a :picture record.

   :zoom-factor                         ; default 1
     Enlargement/reduction factor for displaying the picture.

   :scale-rect                          ; default nil
     either nil or a rectangle used for scaling the picture.
     When scale-rect is nil, the scaling rectangle is the picture.picframe
   :min-size                            ; default hole-size #@(80 80)
      The minimum size for the window (excluding the title-bar and scroll-bars)

   :purge                               ; default t
      When purge is nil the storage occupied by window-picture is not released
      when the window-picture is replaced of the window is closed.
      otherwise the storage is released.

Methods of interest
(zoom-in pic-window)
   Enlarges the scale of the current view of the picture by a factor of 2. 
   The range of zooming is between 1/8x and 8x.

(zoom-out pic-window)
   Reduces the scale of the current view of the picture by a factor of 2.
   The range of zooming is between 1/8x and 8x.

(normal-size pic-window :force t)
   Sets the scale for viewing the picture to 1.
   When force or the scale is not 1, forces a redraw.
   Otherwise it does not.


(in-package "CCL")

(eval-when (eval compile)
  (Require 'quickdraw)
  (require-interface 'quickdraw)
  (Require 'scrolling-windows 
           "CCL:Examples;scrolling windows")
  (Require 'alert-box "CCL:New Examples;alert-box")
  (Require 'pict-scrap 

;; define copy-handle if not already defined and export it
;;  (copy-handle handle) creates a copy of the handle 
(unless (fboundp 'copy-handle)
    (export '(copy-handle))
    ;; wrapper for handToHand trap call
    (defun copy-handle (handle)
      "returns a handle whose contents is a copy of the input handle's contents"
      (rlet ((var :ptr))
        (%set-ptr var handle)
        (let ((errcode (require-trap #_HandToHand var)))
          (unless (eql 0 errcode)
            (%err-disp errcode))
          (%get-ptr var))))))

(unless (fboundp 'valid-picture)
  (defun valid-picture (the-picture)
    (and (macptrp the-picture) (handlep the-picture) the-picture))
  (export 'valid-picture :ccl))

(unless (fboundp 'safe-kill-picture)
  (defmacro safe-kill-picture (picture-var)
       (when (valid-picture ,picture-var)
          (require-trap #_hunlock ,picture-var)
          (require-trap #_hpurge ,picture-var)
          (require-trap #_killPicture :ptr ,picture-var)))
       (setf ,picture-var nil)))
  (export 'safe-kill-picture :ccl))

;;   scrolling data is associated with the scrolling-window object
;;       window-picture - either nil or a picture handle
;;       zoom-factor    - reduce (scale < 1) or enlarge (> 1)
;;       scale-rect     - bounding rectangle
;;       purge          - if non-nil, frees the storage associated with the
(defclass pic-window (scrolling-window)
  ((window-picture :initform nil :accessor picture)
   (zoom-factor :initarg :scale :initform 1 :accessor zoom)
   (scale-rect :initform nil :accessor srect)
   (min-size :initarg :min-size :initarg :min-size)
   (purge :initform t :accessor purge :initarg :purge))
    :close-box-p nil
    :window-type :document-with-zoom
    :window-title "Display"
    :view-font '("Helvetica" 10 :plain)
    :min-size #@(80 80)))

(defclass read-pic-window (pic-window) nil)

(defmethod ccl::window-can-do-operation ((window pic-window)
                                         operation &optional opt)
  (with-slots (window-picture) window
    (select operation
      ('cut (valid-picture window-picture))
      ('clear (valid-picture window-picture))
      (t (call-next-method window operation opt)))))

(defmethod ccl::window-can-do-operation ((window read-pic-window)
                                           operation &optional opt)
  (select operation
    ('cut nil)
    ('clear nil)
    ('paste nil)
    (t (call-next-method window operation opt))))

(defmethod adjusted-origin ((view scroller))
  (with-slots (window-picture zoom-factor) (view-container view)
    (let ((picture-origin (pict-corners window-picture)))
      (if picture-origin
        (add-points picture-origin


(defmethod local-to-real-coord ((view scroller) h &optional v)
  (let ((container (view-container view))
        (scale (scale-factor view)))
    (with-slots (window-picture) container
      (when (valid-picture window-picture)
        (multiple-value-bind (offset bottomRight)
                             (pict-corners window-picture)
          (declare (ignore bottomRight))
          (unscale-a-point scale offset
                           (add-points (view-origin view) (make-point h

;; calculate mac-heap usage
(defmacro heap-stats ()
  (let ((var (gensym)))
    `(let ((,var (require-trap #_freeMem)))
       (format t "~&Mac Heap ~dK (~d)~%"
               (round (/ ,var 1024)) ,var))))

;; Standard object functions for pic-window
(defmethod window-grow-rect ((window pic-window))
  (let (grow-rect)
    (with-slots (window-picture my-scroller min-size) window
      (setq grow-rect 
            (if (valid-picture window-picture)
              (let* ((view-origin (view-origin my-scroller))
                     (field-size (field-size my-scroller))
                     (movement (subtract-points field-size view-origin))
                     (right (+ 5 (point-h movement)))
                     (bottom (+ 5 (point-v movement)))
                     (min-h  (point-h min-size))
                     (min-v (point-v min-size)))
                (setq bottom 
                      (max bottom min-v)
                      (max right min-h))
                (make-record :rect :top 80 :left 80
                             :bottom bottom :right right))
              (make-record :rect :top 80 :left 80
                           :bottom 10000 :right 10000)))
      (require-trap #_offsetRect :ptr grow-rect :long (slot-value my-scroller

(defmethod window-close ((self pic-window))
  (with-slots (scale-rect) self
    (clear-picture self)
    (when scale-rect
       (dispose-record scale-rect :rect))
      (setq scale-rect nil)))

(defmethod view-draw-contents ((self pic-window))
   (with-slots (window-picture 
                my-scroller v-scroller h-scroller) self
     (when (valid-picture window-picture)
       (let* ((topLeft (view-origin my-scroller))
              (bottomRight (add-points topLeft (view-size my-scroller)))
              (picture-bottom (rref window-picture
              (picture-top (rref window-picture :picture.picframe.topLeft))
              (picture-size (subtract-points picture-bottom picture-top)))
         (with-focused-view my-scroller
           (rlet ((r :rect :topLeft topLeft
                     :bottomRight (add-points picture-top
                                              (scale-a-point zoom-factor
                  (clip-r :rect :topLeft topLeft
                          :bottomRight bottomRight))
             (unless (point-in-rect-p r bottomRight)
               (require-trap #_fillrect :ptr clip-r :ptr *gray-pattern*))
             (require-trap #_eraserect :ptr scale-rect)
             (require-trap #_penNormal))
           (if scale-rect
             (require-trap #_drawPicture :ptr window-picture :ptr scale-rect)
             (rlet ((r :rect :topLeft picture-top
                       :bottomRight picture-bottom))
               (require-trap #_drawPicture :ptr window-picture :ptr r))))))

(defmethod view-valid-picture ((self pic-window) window-picture)
  (valid-picture window-picture))

(defmethod view-draw-picture ((self pic-window) window-picture r)
  (safe-draw-picture window-picture r))

(defun safe-draw-picture (picture r)
  (when (valid-picture picture)
    (require-trap #_drawPicture :ptr picture :ptr r)))

(defmethod view-draw-contents ((self pic-window))
   (with-slots (window-picture 
                my-scroller v-scroller h-scroller) self
     (when (view-valid-picture self window-picture)
       (let* ((topLeft (view-origin my-scroller))
              (bottomRight (add-points topLeft (view-size my-scroller)))
              (picture-bottom (rref window-picture
              (picture-top (rref window-picture :picture.picframe.topLeft)))
         (with-focused-view my-scroller
           (rlet ((r :rect :topLeft topLeft
                     :bottomRight bottomRight)
                  (clip-r :rect :topLeft topLeft
                          :bottomRight (add-points topLeft (view-size
             (unless (point-in-rect-p r (rref clip-r :rect.bottomRight))
               (require-trap #_fillrect :ptr clip-r :ptr *light-gray-pattern*))
             (when scale-rect
               (require-trap #_eraserect :ptr scale-rect))
             (require-trap #_penNormal)
             (if scale-rect
               (view-draw-picture self window-picture scale-rect)
                 (rset r :rect.topLeft picture-top)
                 (rset r :rect.bottomRight picture-bottom)
                 (view-draw-picture self window-picture r)))))))

;; repaint the graphical contents of a pic-window
(defmethod repaint-picture ((self pic-window))
   (with-slots (wptr my-scroller) self
     (with-focused-view  self
       (with-port wptr
         ;(require-trap #_EraseRect :ptr (rref wptr :windowRecord.portrect))
         ;(require-trap #_InvalRect :ptr (rref wptr :windowRecord.portrect))
         (invalidate-view self t)
         ;(view-draw-contents my-scroller)

(defparameter *redraw-scroll* t)

(defmethod redraw-controls ((self scroller))
  (when *redraw-scroll* (view-draw-contents self)))
;; clear the object variables associated with a pic-window

(defmethod clear-picture ((self pic-window))
  (with-slots (purge window-picture zoom-factor) self
    (when purge
      (safe-kill-picture window-picture))
    (setq window-picture nil))

(defun peek-scrap (type)
  (cond ((eq type :internal)
        ((eq type :external)

(defun pict-scrap-p (type)
  (when (or (eq type :external) (eq type :internal))
    (get-scrap :pict)))

(defmethod pict-paste-update (menu-item)
  (if (or (pict-scrap-p :internal) (pict-scrap-p :external))
    (menu-item-enable menu-item)
    (menu-item-disable menu-item)))

;; scrap routines for supporting clear, copy, cut and paste pic-window
;; will handle only PICT graphics
(defmethod cut ((self pic-window))
  (copy self)
  (clear self))

(defmethod copy ((self pic-window))
  (with-slots (window-picture) self
    (let (pict old-pict)
      (when (valid-picture (setq old-pict window-picture))
         (when (setq pict (copy-picture old-pict))
           (put-scrap :pict pict)))))))

(defmethod paste ((self pic-window))
  (when (slot-value self 'purge)
    (let ((pict (get-scrap :pict))
      (when (valid-picture pict)
          (setq new-pict (copy-picture pict))
          (when new-pict
             (store-picture self new-pict :set-scale t)
             ;(set-origin self (href new-pict :picture.picframe.topLeft))
             (repaint-picture self)

(defmethod clear ((self pic-window))
  (clear-picture self)
  (repaint-picture self)

;; Underlying routines that handle cut/copy/paste/clear

(defun check-request (the-picture)
  ;; checks whether there is enough space left on the heap
  ;; to create a handle of size the-picture 
  (when (valid-picture the-picture)
    (let (request actual)
      (setq request (require-trap #_gethandlesize the-picture))
      (setq actual (require-trap #_compactmem request))
      (when (< actual request)
        ;; block of requested size does not exist. return empty picture
         (format nil
                 "Picture operation halted:~&~6t~5,,' d bytes
available~%~6t~5,,' d requested"
                 actual request)
         :icon *caution-icon*)
        (return-from check-request nil))
;; change the scale of a drawing to reproduce it a n-times scale
(defmethod scale-change ((self pic-window) n)
  (with-slots (window-picture scale-rect) self
    (if (valid-picture window-picture)
      (rlet ((new-rect :rect))
          ((pict-point window-picture))
          (copy-record (rref pict-point :picture.picframe
                             :storage :pointer)
          (let* ((size (subtract-points 
                        (rref new-rect :rect.bottomRight)
                        (rref new-rect :rect.topLeft)))
                 (new-size (make-point
                            (round (* (point-h size) n))
                            (round (* (point-v size) n))))
                 (new-bottom (add-points (rref new-rect :rect.topLeft)
            (rset new-rect :rect.bottomRight
            ;(print-record new-rect :rect) (terpri)
            (copy-record new-rect :rect scale-rect)

(defmethod set-scale-pict ((self pic-window) n)
  (with-slots (zoom-factor window-picture scale-rect my-scroller) self
    (when window-picture 
      (with-slots (field-size v-scroller h-scroller)
        (let (new-size (old-zoom zoom-factor)
                       (view-origin (view-scroll-position my-scroller)))
          (unless (<= n 0)
            (setq zoom-factor n)
            (unless scale-rect
              (setq scale-rect (make-record :rect)))
            (setq view-origin (make-point
                               (round (* (/ (point-h view-origin) old-zoom)
                               (round (* (/ (point-v view-origin) old-zoom)
            (setq new-size  (scale-change self n)
                  field-size new-size)
            (rset scale-rect :rect.topLeft #@(0 0))
            (rset scale-rect :rect.bottomRight 
                  (make-point (point-h new-size)
                              (point-v new-size)))
             (set-scroll-bar-max v-scroller (point-v field-size))
            (set-scroll-bar-max h-scroller (point-h field-size))
            (update-scroll-bars my-scroller :length t :position view-origin)
            (set-view-scroll-position my-scroller view-origin)            
            (repaint-picture self)))))))

(defmethod normal-size ((self pic-window) &key (force nil))
  (with-slots (zoom-factor) self
    (unless (and (null force) (= zoom-factor 1))
      (set-scale-pict self 1))))

(defmethod zoom-in ((self pic-window))
  (with-slots (zoom-factor) self
    (unless (> zoom-factor 4)
      (set-scale-pict self (* 2 zoom-factor))

(defmethod zoom-out ((self pic-window))
  (with-slots (zoom-factor) self
    (unless (< zoom-factor 1/4)
      (set-scale-pict self (* 1/2 zoom-factor))
;; store a new picture
(defparameter *force* nil)
(defmethod store-picture ((self pic-window) the-picture &key (purge-it t)
(set-scale t)
                          added deleted)
  (declare (ignore added deleted))
  (let (old-picture)
    (with-slots (window-picture scale-rect purge) self
      (unless scale-rect
        (setq scale-rect (make-record :rect)))
       (setq old-picture window-picture)
       (unless (eq old-picture the-picture)
         (clear-picture self)
         (setq window-picture the-picture
               purge purge-it)
         (if (or (null scale-rect) set-scale)
           (normal-size self :force t)
           (repaint-picture self)))

(defmethod from-scaled-point ((self pic-window) h &optional v)
  "convert a point in scaled coordinates to real coordinates"
  (unless v
    (setq v (point-v h)
          h (point-h h)))
  (with-slots (zoom-factor window-picture) self
    (multiple-value-bind (topLeft bottomLeft)
                         (pict-corners window-picture)
      (declare (ignore bottomLeft))
      (add-points topLeft (make-point (ceiling (/ h zoom-factor))
                                      (ceiling (/ v zoom-factor)))))))

;; Create pictures using superpaint and place in the scrap book
;; then paste pictures from the scrap book and place them in the window
;; by the selecting the window and issuing the copy command.
;; Try copy and then examine the clipboard from the Finder. It will
;; be a PICT object.
(defparameter *win* (make-instance 'pic-window :window-title "picture"))

(defun make-demo ()
       (let (the-picture)
         (unless (macptrp (wptr *win*))
           (setq *win* (make-instance 'pic-window :window-title "picture")))
         (start-picture *win*)
         (fill-rect *win* *gray-pattern* 50 50 100 150)
         (move-to *win* #@(0 0))
         (line-to *win* #@(100 200))
         (setq the-picture (get-picture *win*))
         (store-picture *win* the-picture)
         (window-select *win*)))


;; change the scale from 1/2 -> 1 -> 2 -> 1 -> 2 -> 1 -> 1/2 
(progn (window-select *win*)

       ;; change the scale explicitly
       (dolist (factor '(1/2 1 2))
         (set-scale-pict *win* factor)
         (sleep 1))

       ;; change the scale by factors of 2 or 1/2
       (normal-size *win*)
       (sleep 1)
       (zoom-out *win*)
       (sleep 1)
       (normal-size *win*)
       (sleep 1)
       (zoom-in *win*)
       (sleep 1))

(export '(pic-window
          ;; heap requests

          ;; scale a point by a given factor
          ;; convert a point from window coordinates to actual coordinates of
the picture

          ;;  Edit routines for pictures

          ;;  change the picture scale

          ;; set zoom views zoom-in (2 x current scale), zoom-out (1/2 x)
          ;;          normal (scale factor = 1)
          ;;  for scales 1/8 1/4 1/2 1 2 4 8

          ;; manipulate scrolling pictures