Re: Quickdraw, graphics questions

["Mark A. Tapia" <markt@dgp.toronto.edu>]

On Fri 22 APR 1994, Noel Rappin writes:
   1)  MCL does not seem to support color QuickDraw at all -- is there
   someone or someplace that has implemented this?

   2)  MCL provides two functions for bitmaps, make-bitmap and copy-bits.
   Neither of these is ever called with a view, and it doesn't seem like
   you can draw into them, so how do you get information into a bitmap.

   3)  With that in mind, what is the best way to do "rubber-banding" in
   MCL -- where, for example, the line you are drawing is updated on the
   screen as you drag the mouse, without destroying the underlying
   picture.
(1) Ted Rees answered the first question, stating that MCL
"is mostly a thin veneer over the basic QuickDraw" routines.
If you want to create a color window, you'll have to request a color
window specifically:
  (make-instance 'window :color-p t)
The default is a monochrome window. A majority of the color routines are
in the interface folder within the library folder in the quickdraw.lisp
file.

(2) Creating and manipulating bitmaps is fairly straightforward.
The following code creates a snappshot of the pixmap corresponding to
the menubar of the screen. The snapshot is a picture which can then
be displayed in a view.

(3) One method to draw a rubber band line is to to use the xor mode when
drawing the outline. Code that draws the selection rectangle within a view
appears at the end of this message. You'll need the macro with-pen-mode
in (2) to run this code.

mark

#|
The following code is extracted from the archive file
menu-enhancement.sit.hqx in the directory /pub/MCL2/contrib/,
available by anonymous ftp from cambridge.apple.com. The code
is in the file oou-utils.lisp.

The example allows you to take a snapshot of the menubar and
display it within the window corresponding to (first (windows))

|#
(in-package ccl)

(require 'quickdraw)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GDevice-u.Lisp
;;
;; Copyright ) 1991 Northwestern University Institute for the Learning Sciences
;; All Rights Reserved
;;
;; author: Michael S. Engber
;;
;; utilities for working with g-devices
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun get-max-device (&optional globalRect)
  (if globalRect
    (#_GetMaxDevice :ptr globalRect)
    (with-dereferenced-handles ((GrayRgn_p (%get-ptr (%int-to-ptr #$GrayRgn))))
      (#_GetMaxDevice :ptr (pref GrayRgn_p :Region.rgnBBox)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; QuickDraw-u.lisp
;;
;; Copyright ) 1991 Northwestern University Institute for the Learning Sciences
;; All Rights Reserved
;;
;; author: Michael S. Engber
;;
;; utilities for quickdraw
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro with-clip-rgn (clip-rgn &body body)
  (let ((old-clip (gensym)))
    `(with-macptrs ((,old-clip (require-trap #_NewRgn)))
       (unwind-protect
         (progn
           (require-trap #_GetClip :ptr ,old-clip)
           (require-trap #_SetClip :ptr ,clip-rgn)
           ,@body)
         (require-trap #_SetClip :ptr ,old-clip)
         (require-trap #_DisposeRgn :ptr ,old-clip)))))

(defmacro with-pen-state ((&key pnLoc pnSize pnMode pnPat pnPixPat) &body body)
  (let ((state (gensym)))
    `(rlet ((,state :PenState))
       (require-trap #_GetPenState :ptr ,state)
       (unwind-protect
         (progn
           ,@(when pnLoc    `((require-trap #_MoveTo :long ,pnLoc)))
           ,@(when pnSize   `((require-trap #_PenSize :long ,pnSize)))
           ,@(when pnMode   `((require-trap #_PenMode :signed-integer ,pnMode)))
           ,@(when pnPat    `((require-trap #_PenPat :ptr ,pnPat)))
           ,@(when pnPixPat `((require-trap #_PenPixPat :ptr ,pnPixPat)))
           ,@body)
         (require-trap #_SetPenState :ptr ,state)))))


;;;;;;  end of utilities
(defun get-gport (view)
  ;; retrieves the underlying port-pixmap, and the two corners of
  ;; the port-rect for a view which possibly straddles screens
  (let ((port (wptr view)))
    (when port
      (let* ((port-rect (rref port :grafport.portrect))
             (screen-gdevice (get-max-device port-rect))
             (screen-top (rref screen-gdevice :gdevice.gdrect.topLeft))
             (screen-bottom (rref screen-gdevice :gdevice.gdrect.bottomRight))
             (port-pmap (rref screen-gdevice :gdevice.gdpmap)))
        (values port-pmap               ; the screen pixmap
                screen-top              ; the top left corner of the screen port
rect
                screen-bottom           ; the bottom right corner
                )))))

(unless (fboundp 'empty-rect-p)
  (defun empty-rect-p (left &optional top right bot)
    (with-rectangle-arg (r left top right bot)
      (#_EmptyRect r))))

(defun save-screen-map (view clip-rect1)
  ;; saves the portion of the screen corresponding to the  global rectangle
  ;; clip-rect1 which overlaps the gdevice associated with the view
  (when (pointerp (wptr view))
    (multiple-value-bind (pixmap topLeft bottomRight)
                         (get-gport view)
      (when pixmap
        (rlet ((r :rect :topLeft topLeft :bottomRight bottomRight))
          (intersect-rect clip-rect1 r r)
          (unless (empty-rect-p r)
            (let ((pict (#_OpenPicture :ptr clip-rect1)))
              (ccl::with-macptrs ((pixMap_h pixmap))
                (with-dereferenced-handles ((pixMap_p pixMap_h))
                  (#_CopyBits :ptr pixmap_p
                   :ptr pixmap_p
                   :ptr clip-rect1
                   :ptr clip-rect1
                   :word 0        ;transfer mode
                   :ptr (%null-ptr))
                  (#_ClosePicture))
                pict))))))))

|#
(setq picture (rlet ((r :rect :topLeft #@(0 0)
                        :bottomRight (make-point *screen-width*
                                                 *menubar-bottom*)))
                (save-screen-map (first (windows)) r)))

(draw-picture (first (windows)) picture)

(kill-picture picture)

|#

>>>> code for creating a selection rectangle within a view
(defclass drag-view (view) 
  ((dragging :initform nil)
   (drag-end-action :initarg :drag-end-action)))

(defclass dragger-window (drag-view window) ())

(defmethod drag-corners ((self view))
  (view-corners self))

(defmethod drag-end-action ((view drag-view) topLeft bottomRight)
  (if (and (slot-exists-p view 'drag-end-action)
           (slot-boundp view 'drag-end-action))
    (funcall (slot-value view 'drag-end-action) topLeft bottomRight)
    (values topLeft bottomRight)))

(defmethod mouse-position ((self view) &optional point)
  ;; returns either point or the current view mouse position in view coordinates
  (or point (view-mouse-position self)))

(defun constrain-point1 (drag-rect point last-point)
  (let* ((topLeft (rref drag-rect :rect.topLeft))
         (bottomRight (rref drag-rect :rect.bottomRight))
         (top (point-v topLeft))
         (bottom (point-v bottomRight))
         (left (point-h topLeft))
         (right (point-h bottomRight))
         (h (point-h point))
         (v (point-v point))
         (real-h h)
         (real-v v)
         (last-h (when last-point
                   (point-h last-point)))
         (last-v (when last-point
                   (point-v last-point))))
      (cond ((< v top) (setq real-v top))
            ((> v bottom) (setq real-v bottom)))
      (cond ((< h left) (setq real-h left))
            ((> h right) (setq real-h right)))
      (cond ((and (= h real-h) (= v real-v)) point)
            ((null last-point) (make-point real-h real-v))
            ((and (= real-h last-h) (= real-v last-v)) last-point)
            (t (make-point real-h real-v)))))

(defmethod view-click-event-handler ((view dragger-window) where) 
  ;; handles mouse clicks in dragger-window
  ;; in the content area (e.g. not in the title/thumb/scrollbar/grow box/size 
box)
  ;; If the menu is enabled, displays the marking menu
  ;; otherwise drags out a rectangle within the scrolling area
  (call-next-method view where)
  (track-and-hilite view where))

(defmethod track-and-hilite ((view drag-view) start-point)
  ;; Draws a grey outline around the rectangle with the top left and
  ;; bottom right corners at start-point and the current point
  ;; continue until the mouse botton is released.
  ;; constrain-point1 ensures that point remains inside the drag rectangle.
  ;; 
  (multiple-value-bind (topLeft bottomRight)
                       (drag-corners view)
    (rlet ((drag-rect :rect)
           (r :rect :topLeft start-point :bottomRight start-point))
      (points-to-rect topLeft bottomRight drag-rect)
      (let* ((last-point (constrain-point1 drag-rect start-point nil))
             (point last-point)
             (corner-point last-point))
        (with-pen-state (:pnMode #$patxor :pnpat *gray-pattern*)
          (loop with continue = t
                unless (require-trap #_WaitMouseUp)
                do (setq continue nil)
                while continue
                finally (when last-point
                          (require-trap #_frameRect r)
                          ;(require-trap #_invertRect r)
                          )
                do (setq point (mouse-position view))
                
                unless (equal last-point point)
                do (when last-point
                     (without-interrupts 
                      (setq point (constrain-point1 drag-rect point last-point))
                      (unless (equal point last-point)
                        (when last-point
                          (require-trap #_frameRect r))
                        ;(require-trap #_invertRect r)
                        (when point
                          (points-to-rect corner-point point r)
                          (require-trap #_frameRect r))
                        ;(require-trap #_invertRect r)
                        ))
                     (setq last-point point))))
        (if (and (slot-boundp view 'dragging) (slot-value view 'dragging))
          (drag-end-action view (rref r :rect.topLeft) (rref r 
:rect.bottomRight))
          t)))))

#|
(make-instance 'dragger-window)
|#