home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / brutal-utils / PICT-u.lisp < prev    next >
Encoding:
Text File  |  1992-05-06  |  9.5 KB  |  226 lines
  1. (in-package :oou)
  2. (oou-provide :PICT-u)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; PICT-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 PICTs
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies
  15.  :records-u
  16.  :QuickDraw-u
  17.  :+Files
  18.  :+Devices)
  19.  
  20. (export '(get-picture-from-file
  21.           write-picture-to-file
  22.           get-PICT-file-info
  23.           draw-picture-from-file
  24.           ))
  25.  
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27.  
  28.  
  29. (eval-when (:compile-toplevel :load-toplevel :execute)
  30.   
  31.   (defmacro with-PICT-file ((pathname refNum PICT-size PICT-record
  32.                                       &key
  33.                                       (direction         :input)
  34.                                       (if-does-not-exist (ecase direction (:input :error) (:output :create)))
  35.                                       (if-exists         :error)
  36.                                       (creator           "????"))
  37.                             &body body)
  38.     (let ((fn (gensym)))
  39.       `(flet ((,fn (,refNum ,PICT-size ,PICT-record) ,@body))
  40.          (declare (dynamic-extent #',fn))
  41.          (call-with-PICT-file ,pathname #',fn
  42.                               :direction         ,direction
  43.                               :if-does-not-exist ,if-does-not-exist
  44.                               :if-exists         ,if-exists
  45.                               :creator           ,creator))))
  46.   
  47.   )
  48.  
  49. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  50.  
  51.  
  52. (defun get-picture-from-file (pathname)
  53.   ;;Returns a PICT handle from the specified PICT file.
  54.   (with-PICT-file (pathname refnum PICT-size PICT-record)
  55.     (let ((PICT-handle (#_NewHandle PICT-size)))
  56.       (if (%null-ptr-p PICT-handle)
  57.         (error "unable to allocate a ~a byte PICT handle for ~s." PICT-size pathname)
  58.         (with-dereferenced-handles ((PICT_p PICT-handle))
  59.           (pset PICT_p :Picture PICT-record)
  60.           (%incf-ptr PICT_p (rlength :Picture))
  61.           (rlet ((byteCount_p :long (- PICT-size (rlength :Picture))))
  62.             (let ((ecode (#~FSRead refnum byteCount_p PICT_p)))
  63.               (unless (and (zerop ecode) (= (- PICT-size (rlength :Picture)) (%get-long byteCount_p)))
  64.                 (error "(~a) calling FSRead. Read ~a/~a bytes of PICT data from ~s."
  65.                        ecode (%get-long byteCount_p) PICT-size pathname))))))
  66.       PICT-handle)))
  67.  
  68.  
  69. (defun write-picture-to-file (PICT-handle pathname &key (creator "????") (if-exists :error))
  70.   ;;Creates a PICT file containing PICT-handle.
  71.   (with-PICT-file (pathname refNum dummy-size PICT-record
  72.                             :direction :output
  73.                             :if-exists if-exists
  74.                             :creator   creator)
  75.     (declare (ignore dummy-size PICT-record))
  76.     (let ((PICT-size (#_GetHandleSize PICT-handle)))
  77.       (rlet ((byteCount_p :long PICT-size))
  78.         (with-dereferenced-handles ((PICT_p PICT-handle))
  79.           (let ((ecode (#~FSWrite refnum byteCount_p PICT_p)))
  80.             (unless (and (zerop ecode) (= PICT-size (%get-long byteCount_p)))
  81.               (error "(~a) calling FSWrite. Wrote ~a/~a bytes of PICT data from ~s."
  82.                      ecode (%get-long byteCount_p) PICT-size pathname)))))
  83.       pathname)))
  84.  
  85.  
  86. (defun get-PICT-file-info (pathname picture-record-ptr)
  87. ;;Returns the size (in bytes) of the PICT in the specified PICT file.
  88. ;;picture-record-ptr's picFrame is filled in.
  89.   (with-PICT-file (pathname refnum PICT-size PICT-record)
  90.     (declare (ignore refnum))
  91.     (pset picture-record-ptr :Picture PICT-record)
  92.     PICT-size))
  93.  
  94.  
  95. ;;QuickDraw bottle neck routine for getPicProc that reads PICT
  96. ;;data from an open file. see IM V pp. 87-89
  97. (defpascal dpfd-StdGetPic (:ptr dataPtr :word byteCount)
  98.   (declare (special *dpfd-refNum*))
  99.   (rlet ((byteCount_p :long byteCount))
  100.     (#~FSRead *dpfd-refNum* byteCount_p dataPtr)))
  101.  
  102.  
  103. (defun draw-picture-from-file (pathname rect &optional (scale-to-rect-p t))
  104.   ;;Draws the specfied PICT file either scaledd to rect or at the topLeft
  105.   ;;corner of rect. The PICT size (in bytes) is returned.
  106.   (let ((PICT_h (#_NewHandle (rlength :Picture))))
  107.     (when (%null-ptr-p PICT_h)
  108.       (error "unable to allocate a ~a temporary picture record handle (~a bytes) for ~s." (rlength :Picture) pathname))
  109.     (unwind-protect
  110.       (with-PICT-file (pathname refnum PICT-size PICT-record)
  111.         (with-dereferenced-handles ((PICT_p PICT_h))
  112.           (pset PICT_p :Picture PICT-record))
  113.         (rlet ((r :Rect
  114.                   :topLeft (pref rect :Rect.topLeft)
  115.                   :botRight (if scale-to-rect-p
  116.                               (pref rect :Rect.botRight)
  117.                               (add-points (pref rect :Rect.topLeft)
  118.                                           (subtract-points (href PICT_h :Picture.picFrame.botRight)
  119.                                                            (href PICT_h :Picture.picFrame.topLeft))))))
  120.           (let ((*dpfd-refNum* refNum))
  121.             (declare (special *dpfd-refNum*))
  122.             (without-interrupts
  123.              (with-QDProcs (:getPicProc dpfd-StdGetPic)
  124.                (#_DrawPicture PICT_h r)))))
  125.         PICT-size)
  126.       (#_DisposeHandle PICT_h))))
  127.  
  128. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  129.  
  130.  
  131. (defun call-with-PICT-file (pathname fn &key
  132.                                      (direction         :input)
  133.                                      (if-does-not-exist (ecase direction (:input :error) (:output :create)))
  134.                                      (if-exists         :error)
  135.                                      (creator           "????"))
  136.   (let ((set-EOF-p nil))
  137.     (if (probe-file pathname)
  138.       (ecase direction
  139.         (:input )
  140.         (:output (ecase if-exists
  141.                    (:error     (error "~s already exists." pathname))
  142.                    (:overwrite (setf set-EOF-p t)))))
  143.       (ecase direction
  144.         (:input  (error "~s doesn't exist - can't open for input." pathname))
  145.         (:output (ecase if-does-not-exist
  146.                    (:error  (error "~s does not exist." pathname))
  147.                    (:create (with-pstrs ((filename (mac-namestring pathname)))
  148.                               (let ((ecode (#~Create filename 0 creator "PICT")))
  149.                                 (unless (zerop ecode)
  150.                                   (error "(~a) attempting to create ~s." ecode pathname))))
  151.                             (setf set-EOF-p t))))))
  152.     
  153.     (unless (eq (mac-file-type pathname) :PICT)
  154.       (error "~s is not a PICT file." pathname))
  155.     
  156.     (let ((refNum (with-pstrs ((fileName (mac-namestring pathname)))
  157.                     (rlet ((refNum_p :integer))
  158.                       (let ((ecode (#~FSOpen fileName 0 refNum_p)))
  159.                         (unless (zerop ecode) (error "(~a) opening file: ~s." ecode pathname))
  160.                         (%get-word refNum_p))))))
  161.       (unwind-protect
  162.         (rlet ((PICT-record :Picture))
  163.           
  164.           (when set-EOF-p
  165.             (let ((ecode (#~SetEOF refNum 512)))
  166.               (unless (zerop ecode) (error "(~a) calling SetEOF on ~s." ecode pathname))))
  167.           
  168.           (let ((file-size (rlet ((logicalEOF_p :long))
  169.                              (let ((ecode (#~GetEOF refNum logicalEOF_p)))
  170.                                (unless (zerop ecode) (error "(~a) calling GetEOF on ~s." ecode pathname))
  171.                                (%get-long logicalEOF_p)))))
  172.             
  173.             (ecase direction
  174.               (:input
  175.                ;read the PICT header & leave file position just beyond (+ 512 (rlength :Picture))
  176.                (let ((ecode (#~SetFPos refNum #$fsFromStart 512)))
  177.                  (unless (zerop ecode) (error "(~a) calling SetFPos (preparing to read picture record) on ~s." ecode pathname)))
  178.                (rlet ((byteCount_p :long (rlength :Picture)))
  179.                  (let ((ecode (#~FSRead refnum byteCount_p PICT-record)))
  180.                    (unless (and (zerop ecode) (= (rlength :Picture) (%get-long byteCount_p)))
  181.                      (error "(~a) calling PBRead. Read ~a bytes of PICT header data from ~s."
  182.                             ecode (%get-long byteCount_p) pathname)))))
  183.               (:output
  184.                ;set the file position to 512 & invalidate PICT-record passed to fn
  185.                (%setf-macptr PICT-record (%null-ptr))
  186.                (let ((ecode (#~SetFPos refNum #$fsFromStart 512)))
  187.                  (unless (zerop ecode) (error "(~a) calling SetFPos (preparing to write picture record) on ~s." ecode pathname)))))
  188.             
  189.             
  190.             (funcall fn refNum (- file-size 512) PICT-record)))
  191.         (#~FSClose refNum)))))
  192.  
  193. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  194.  
  195. #|
  196.  
  197. (defparameter *test-w* (make-instance 'window :color-p t))
  198.  
  199. (with-focused-view *test-w*
  200.   (rlet ((r :Rect :topLeft 0 :botRight (view-size *test-w*)))
  201.     (draw-picture-from-file "oou:examples;MrT.PICT" r nil)))
  202.  
  203. (invalidate-view *test-w* t)
  204.  
  205. (defparameter *p-handle* (get-picture-from-file "oou:examples;MrT.PICT"))
  206.  
  207. (rlet ((r :Rect :topLeft #@(100 100) :botRight #@(300 300)))
  208.   (with-focused-view *test-w* (#_DrawPicture *p-handle* r)))
  209.  
  210. (invalidate-view *test-w* t)
  211.  
  212. (write-picture-to-file *p-handle* "HD:temp")
  213.  
  214. (with-focused-view *test-w*
  215.   (rlet ((r :Rect :topLeft 0 :botRight (view-size *test-w*)))
  216.     (draw-picture-from-file "HD:temp" r nil)))
  217.  
  218. (#_DisposeHandle *p-handle*)
  219.  
  220. (rlet ((p :Picture))
  221.   (print (get-PICT-file-info "oou:examples;MrT.PICT" p))
  222.   (terpri)
  223.   (print-record (pref p :Picture.picFrame) :Rect)
  224.   (print (pref p :Picture.picSize)))
  225.  
  226. |#