[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: extending scrolling-window to include copy-bits or scroll-region
- To: pshannon@iapetus.cv.nrao.edu
- Subject: Re: extending scrolling-window to include copy-bits or scroll-region
- From: "Mark A. Tapia" <markt@dgp.toronto.edu>
- Date: Wed, 1 Sep 1993 10:53:14 -0400
- Cc: info-mcl@cambridge.apple.com
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
color.
There are two files required - alert-box.lisp which was on the first
distribution for MCL and my code.
mark
;;; alert-box.lisp
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;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))
(call-next-method)
(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)))
(new-dialog
(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
:dialog-item-action
#'(lambda (item)
item
(return-from-modal-dialog t))
:default-button t)
(make-instance 'static-text-dialog-item
:view-position (make-point (+ text-offset 11)
4)
: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))
(modal-dialog
new-dialog
)
))
#|
;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
*note-icon*)
(alert-box "I hope you don't regret erasing your hard disk!" :icon
*caution-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))
(:default-initargs
: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
"CCL:Examples;:pict-scrap")
nil)
;; define copy-handle if not already defined and export it
;; (copy-handle handle) creates a copy of the handle
(unless (fboundp 'copy-handle)
(progn
(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)
`(progn
(when (valid-picture ,picture-var)
(without-interrupts
(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
picture
(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))
(:default-initargs
: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
(call-next-method))
(call-next-method)))))
|#
(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
v))))))))
;; 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)
right
(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
'scroll-bar-correction)))
grow-rect))
(defmethod window-close ((self pic-window))
(with-slots (scale-rect) self
(clear-picture self)
(when scale-rect
(without-interrupts
(dispose-record scale-rect :rect))
(setq scale-rect nil)))
(call-next-method))
#|
(defmethod view-draw-contents ((self pic-window))
(without-interrupts
(with-slots (window-picture
zoom-factor
scale-rect
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.picframe.BottomRight))
(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
picture-size)))
(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))))))
(call-next-method))))
|#
(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))
(without-interrupts
(with-slots (window-picture
zoom-factor
scale-rect
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.picframe.BottomRight))
(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
my-scroller))))
(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)
(progn
(rset r :rect.topLeft picture-top)
(rset r :rect.bottomRight picture-bottom)
(view-draw-picture self window-picture r)))))))
(call-next-method))))
;;
;; repaint the graphical contents of a pic-window
;;
(defmethod repaint-picture ((self pic-window))
(without-interrupts
(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))
nil)
(defun peek-scrap (type)
(cond ((eq type :internal)
*scrap-state*)
((eq type :external)
*external-scrap*)))
(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))
(without-interrupts
(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))
new-pict)
(when (valid-picture pict)
(when
(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)
t)
;; 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
(alert-box
(format nil
"Picture operation halted:~&~6t~5,,' d bytes
available~%~6t~5,,' d requested"
actual request)
:icon *caution-icon*)
(return-from check-request nil))
t)))
;;
;; 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))
(with-dereferenced-handles
((pict-point window-picture))
(copy-record (rref pict-point :picture.picframe
:storage :pointer)
:rect
new-rect)
(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)
new-size)))
(rset new-rect :rect.bottomRight
new-bottom)
;(print-record new-rect :rect) (terpri)
(copy-record new-rect :rect scale-rect)
new-size))))))
(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)
my-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)
zoom-factor))
(round (* (/ (point-v view-origin) old-zoom)
zoom-factor))))
(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))
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))
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)))
(without-interrupts
(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)))
window-picture))))
(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*)))
(make-demo)
;; 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
scale-factor
;; heap requests
check-request
heap-stats
;; scale a point by a given factor
scale-a-point
;; convert a point from window coordinates to actual coordinates of
the picture
from-scaled-point
;; Edit routines for pictures
clear
copy
cut
paste
;; change the picture scale
scale-change
set-scale-pict
;; 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
zoom-in
zoom-out
normal-size
;; manipulate scrolling pictures
repaint-picture
clear-picture
store-picture
pict-scrap-p
copy-picture))