home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / brutal-utils / QuickDraw-u.lisp < prev    next >
Encoding:
Text File  |  1992-07-15  |  11.7 KB  |  275 lines
  1. (in-package :oou)
  2. (oou-provide :QuickDraw-u)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; QuickDraw-u.lisp
  5. ;;
  6. ;; Copyright ⌐ 1992 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; utilities for quickdraw
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies
  15.  :records-u)
  16.  
  17. (export '( with-pen-state
  18.            with-text-state with-font-spec
  19.            with-back-pat with-back-pix-pat
  20.            with-hilite-color
  21.            with-current-portBits
  22.            with-clip-rgn
  23.            with-QDProcs
  24.            move-region-to
  25.            frame-rect-3D
  26.            ))
  27.  
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29. ;;; macros
  30.  
  31. (eval-when (:compile-toplevel :load-toplevel :execute)
  32.   
  33.   (defmacro with-pen-state ((&key pnLoc pnSize pnMode pnPat pnPixPat) &body body)
  34.     (let ((state (gensym)))
  35.       `(rlet ((,state :PenState))
  36.          (require-trap #_GetPenState ,state)
  37.          (unwind-protect
  38.            (progn
  39.              ,@(when pnLoc    `((require-trap #_MoveTo (point-h ,pnLoc) (point-v ,pnLoc))))
  40.              ,@(when pnSize   `((require-trap #_PenSize (point-h ,pnSize) (point-v ,pnSize))))
  41.              ,@(when pnMode   `((require-trap #_PenMode ,pnMode)))
  42.              ,@(when pnPat    `((require-trap #_PenPat ,pnPat)))
  43.              ,@(when pnPixPat `((require-trap #_PenPixPat ,pnPixPat)))
  44.              ,@body)
  45.            (require-trap #_SetPenState ,state)))))
  46.  
  47.   ;;;;;;;;;;
  48.   ;;font macros
  49.  
  50.   (defmacro with-text-state ((&key txFont txFace txMode txSize) &body body)
  51.     (let ((thePort (gensym))
  52.           (old-font (gensym))
  53.           (old-face (gensym))
  54.           (old-mode (gensym))
  55.           (old-size (gensym)))
  56.       `(with-macptrs ((,thePort (%getport)))
  57.          (let(,@(when txFont `((,old-font (pref ,thePort :GrafPort.txFont))))
  58.               ,@(when txFace `((,old-face (pref ,thePort :GrafPort.txFace))))
  59.               ,@(when txMode `((,old-mode (pref ,thePort :GrafPort.txMode))))
  60.               ,@(when txSize `((,old-size (pref ,thePort :GrafPort.txSize)))))
  61.              (unwind-protect
  62.                (progn
  63.                  ,@(when txFont `((require-trap #_TextFont ,txFont)))
  64.                  ,@(when txFace `((require-trap #_TextFace ,txFace)))
  65.                  ,@(when txMode `((require-trap #_TextMode ,txMode)))
  66.                  ,@(when txSize `((require-trap #_TextSize ,txSize)))
  67.                  ,@body)
  68.                ,@(when txFont `((require-trap #_TextFont ,old-font)))
  69.                ,@(when txFace `((require-trap #_TextFace ,old-face)))
  70.                ,@(when txMode `((require-trap #_TextMode ,old-mode)))
  71.                ,@(when txSize `((require-trap #_TextSize ,old-size))))))))
  72.  
  73.   (defmacro with-font-spec (font-spec &body body)
  74.     (if (and (listp font-spec) (every #'constantp font-spec))
  75.       (multiple-value-bind (ff ms) (font-codes font-spec)
  76.         `(with-font-codes ,ff ,ms ,@body))
  77.       (let ((ff (gensym))
  78.             (ms (gensym)))
  79.         `(multiple-value-bind (,ff ,ms) (font-codes ,font-spec)
  80.            (with-font-codes ,ff ,ms ,@body)))))
  81.  
  82.   ;;;;;;;;;;
  83.   ;; macros for getting an appropriate ptr from the current port to pass to CopyBits
  84.   ;; Note: this works with both GrafPort's AND CGrafPort's
  85.  
  86.   (defmacro with-current-portBits (portBits &body body)
  87.     `(with-macptrs ((,portBits (pref (%getport) :GrafPort.portBits)))
  88.        ,@body))
  89.  
  90.  
  91.   ;;;;;;;;;;
  92.   ;; BackPat macros
  93.   ;; Note: these both work with GrafPort's AND CGrafPort's
  94.   
  95.   (defmacro with-back-pat (pattern &body body)
  96.     (let ((fn (gensym)))
  97.       `(flet ((,fn () (require-trap #_BackPat ,pattern) ,@body))
  98.          (declare (dynamic-extent #',fn))
  99.          (call-with-back-pat-saved #',fn))))
  100.  
  101.   (defmacro with-back-pix-pat (pix-pat &body body)
  102.     (let ((fn (gensym))
  103.           (data_p (gensym)))
  104.       `(flet ((,fn ()
  105.                 (if (zerop (href ,pix-pat PixPat.patType))
  106.                   (with-dereferenced-handles ((,data_p (href ,pix-pat PixPat.patData)))
  107.                     (require-trap #_BackPat ,data_p))
  108.                   (require-trap #_BackPixPat ,pix-pat))
  109.                 ,@body))
  110.          (declare (dynamic-extent #',fn))
  111.          (call-with-back-pat-saved #',fn))))
  112.  
  113.   ;;;;;;;;;;
  114.   ;; hilite color macro
  115.   (defmacro with-hilite-color (color &body body)
  116.     (let ((fn  (gensym))
  117.           (rgb (gensym)))
  118.       `(flet ((,fn () ,@body))
  119.          (declare (dynamic-extent #',fn))
  120.          (with-rgb (,rgb ,color)
  121.            (call-with-hilite-color ,rgb #',fn)))))
  122.  
  123.   ;;;;;;;;;;
  124.   ;;clip macros
  125.   
  126.   (defmacro with-clip-rgn (clip-rgn &body body)
  127.     (let ((old-clip (gensym)))
  128.       `(with-macptrs ((,old-clip (require-trap #_NewRgn)))
  129.          (unwind-protect
  130.            (progn
  131.              (require-trap #_GetClip ,old-clip)
  132.              (require-trap #_SetClip ,clip-rgn)
  133.              ,@body)
  134.            (require-trap #_SetClip ,old-clip)
  135.            (require-trap #_DisposeRgn ,old-clip)))))
  136.  
  137.   ;;;;;;;;;;
  138.   ;;QDProc macro
  139.   ;; Note: these both work with GrafPort's AND CGrafPort's
  140.  
  141.   (defmacro with-QDProcs ((&key textProc lineProc rectProc rRectProc ovalProc arcProc polyProc
  142.                                 rgnProc bitsProc commentProc txMeasProc getPicProc putPicProc
  143.                                 opCodeProc newProc1 newProc2 newProc3 newProc4 newProc5 newProc6
  144.                                 )
  145.                           &body body)
  146.     ;;GrafPorts & CGrafPorts are handled identically! This works because:
  147.     ;; - the first 13 fields of a CQDProc are a QDProc
  148.     ;; - both GrafPorts & CGrafPorts use the same stdProcs for these 13 fields.     
  149.     (let ((thePort (gensym))
  150.           (old-procs (gensym))
  151.           (new-procs (gensym)))
  152.       `(with-macptrs ((,thePort (%getport))
  153.                       (,old-procs (pref ,thePort :GrafPort.grafProcs)))
  154.          (rlet ((,new-procs :CQDProcs))
  155.            (if (%null-ptr-p ,old-procs)
  156.              (require-trap #_SetStdCProcs ,new-procs)
  157.              (require-trap #_BlockMove ,old-procs ,new-procs (rlength :CQDProcs)))
  158.            ,@(when textProc    `((pset ,new-procs :CQDProcs.textProc    ,textProc   )))
  159.            ,@(when lineProc    `((pset ,new-procs :CQDProcs.lineProc    ,lineProc   )))
  160.            ,@(when rectProc    `((pset ,new-procs :CQDProcs.rectProc    ,rectProc   )))
  161.            ,@(when rRectProc   `((pset ,new-procs :CQDProcs.rRectProc   ,rRectProc  )))
  162.            ,@(when ovalProc    `((pset ,new-procs :CQDProcs.textProc    ,ovalProc   )))             
  163.            ,@(when arcProc     `((pset ,new-procs :CQDProcs.arcProc     ,arcProc    )))
  164.            ,@(when polyProc    `((pset ,new-procs :CQDProcs.polyProc    ,polyProc   )))
  165.            ,@(when rgnProc     `((pset ,new-procs :CQDProcs.rgnProc     ,rgnProc    )))
  166.            ,@(when bitsProc    `((pset ,new-procs :CQDProcs.bitsProc    ,bitsProc   )))
  167.            ,@(when commentProc `((pset ,new-procs :CQDProcs.commentProc ,commentProc)))
  168.            ,@(when txMeasProc  `((pset ,new-procs :CQDProcs.txMeasProc  ,txMeasProc )))
  169.            ,@(when getPicProc  `((pset ,new-procs :CQDProcs.getPicProc  ,getPicProc )))
  170.            ,@(when putPicProc  `((pset ,new-procs :CQDProcs.putPicProc  ,putPicProc )))
  171.            ,@(when opCodeProc  `((pset ,new-procs :CQDProcs.opCodeProc  ,opCodeProc )))
  172.            ,@(when newProc1    `((pset ,new-procs :CQDProcs.newProc1    ,newProc1   )))
  173.            ,@(when newProc2    `((pset ,new-procs :CQDProcs.newProc2    ,newProc2   )))
  174.            ,@(when newProc3    `((pset ,new-procs :CQDProcs.newProc3    ,newProc3   )))
  175.            ,@(when newProc4    `((pset ,new-procs :CQDProcs.newProc4    ,newProc4   )))
  176.            ,@(when newProc5    `((pset ,new-procs :CQDProcs.newProc5    ,newProc5   )))
  177.            ,@(when newProc6    `((pset ,new-procs :CQDProcs.newProc6    ,newProc6   )))
  178.            (unwind-protect
  179.              (progn
  180.                (pset ,thePort :CGrafPort.grafProcs ,new-procs)
  181.                ,@body)
  182.              (pset ,thePort :CGrafPort.grafProcs ,old-procs))))))
  183.   
  184.   )
  185.  
  186.  
  187. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  188.  
  189.  
  190. (defun call-with-back-pat-saved (fn)
  191.   (with-macptrs ((thePort (%getport)))
  192.     (let ((pat-type 0))
  193.       (declare (dynamic-extent pat-type))
  194.       (rlet ((old-pat :Pattern))
  195.         (if (wptr-color-p thePort)
  196.           (with-macptrs ((ppat (pref thePort :CGrafPort.bkPixPat)))
  197.             (setf pat-type (href ppat PixPat.patType))
  198.             (if (zerop pat-type)
  199.               (with-dereferenced-handles ((data_p (href ppat PixPat.patData)))
  200.                 (pset old-pat :Pattern data_p))
  201.               (%setf-macptr old-pat (pref thePort :CGrafPort.bkPixPat))))
  202.           (#_BlockMove (pref thePort :GrafPort.bkPat) old-pat (rlength :Pattern)))
  203.         (unwind-protect
  204.           (funcall fn)
  205.           (if (zerop pat-type)
  206.             (#_BackPat old-pat)
  207.             (#_BackPixPat old-pat)))))))
  208.  
  209. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  210.  
  211. (defun call-with-hilite-color (rgb fn)
  212.   (with-macptrs ((thePort (%getport)))
  213.     (if (wptr-color-p thePort)
  214.       (rlet ((old-hiliteRGB :RGBColor))
  215.         (with-dereferenced-handles ((grafVars (pref thePort :CGrafPort.grafVars)))
  216.           (pset old-hiliteRGB :RGBColor (pref grafVars :GrafVars.rgbHiliteColor)))
  217.         (unwind-protect
  218.           (progn
  219.             (#_HiliteColor rgb)
  220.             (funcall fn))
  221.           (#_HiliteColor old-hiliteRGB)))
  222.       (rlet ((old-hiliteRGB :RGBColor))
  223.         (with-macptrs ((global-hilite-rgb (%int-to-ptr #$HiliteRGB)))
  224.           (pset old-hiliteRGB :RGBColor global-hilite-rgb)
  225.           (unwind-protect
  226.             (progn
  227.               (pset global-hilite-rgb :RGBColor rgb)
  228.               (funcall fn))
  229.             (pset global-hilite-rgb :RGBColor rgb)))))))
  230.  
  231. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  232.  
  233. (defun move-region-to (rgn-handle h &optional v)
  234.   (let* ((delta (make-point h v))
  235.          (dh (point-h delta))
  236.          (dv (point-v delta)))
  237.     (#_OffsetRgn rgn-handle (- dh (href rgn-handle :Region.rgnBBox.left))
  238.                             (- dv (href rgn-handle :Region.rgnBBox.top )))))
  239.  
  240. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  241.  
  242. ;;Mac human interface guidlines specify that the light source is in the
  243. ;;upper-left corner. Hence and botRight shadow gives a "popped out" look
  244. ;;and a topLeft shadow gives a "pushed in" look.
  245.  
  246. (defun frame-rect-3D (rect frame-width shadow-position)
  247. ;;Frame's the specified Rect with a 3D look.
  248. ;;Note: this effect only looks right over patterned or colored backgrounds
  249.     (let* ((%top   (pref rect :Rect.top   ))
  250.            (%left  (pref rect :Rect.left  ))
  251.            (%bot   (pref rect :Rect.bottom))
  252.            (%right (pref rect :Rect.right )))
  253.       (with-pen-state (:pnSize (make-point frame-width frame-width)
  254.                                :pnMode #$patCopy
  255.                                :pnLoc (make-point %left (- %bot frame-width)))       
  256.         ;;left & top edges
  257.         (#_PenPat (ecase shadow-position (:topLeft *black-pattern*) (:botRight *white-pattern*)))
  258.         (#_LineTo %left %top)
  259.         (#_LineTo (- %right frame-width) %top)
  260.         
  261.         ;;right & bottom edges
  262.         (#_PenPat (ecase shadow-position (:topLeft *white-pattern*) (:botRight *black-pattern*)))
  263.         (#_LineTo (- %right frame-width) (- %bot frame-width))
  264.         (#_LineTo %left (- %bot frame-width))
  265.         
  266.         ;;topRight & botLeft corners
  267.         (#_PenPat (ecase shadow-position (:topLeft *black-pattern*) (:botRight *white-pattern*)))
  268.         (#_PenSize 1 1)
  269.         (#_MoveTo (- %right frame-width) (+ %top frame-width -2))
  270.         (dotimes (i (1- frame-width)) (#_Line i 0) (#_Move (- i) -1))
  271.         (#_MoveTo %left (1- %bot))
  272.         (dotimes (i frame-width) (#_Line i 0) (#_Move (- i) -1)))))
  273.  
  274. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  275.