Re: Displaying various graphics format in MCL

[ueda@shpcsl.sharp.co.jp (UEDA masaya)]

   From: straz@cambridge.apple.com (Steve Strassmann)
   Newsgroups: comp.lang.lisp.mcl
   Date: 28 Jan 1995 19:05:15 -0500

   At 3:49 PM 1/27/95, Benjamin Renaud wrote:
    >I am currently in need of some code to display images (mainly JPG, XBM,
    >TIFF and GIF) that's callable from MCL.
    >
    >Any pointers would be greatly appreciated.
    >
    >Benjamin Renaud
    >benjamin@ai.mit.edu

   The easiest thing would be to use AppleEvents to launch an app
   like JPegView or Giffer.

This code enables you to display PICT files compressed by JPEG or
other QuickTime codec components.

----- Thanks -----
UEDA Masaya	ueda@shpcsl.sharp.co.jp
Information Technology Research Lab., SHARP Co.
2613-1 Ichinomoto, Tenri, Nara 632, JAPAN

----------------------------------------------------------------
(require :interfaces)

(require :scrollers)

(define-condition trap-error (error)
  ((oserr :initarg :oserr :reader oserr)
   (trap-name :initform nil :initarg :trap-name :reader trap-name))
  (:report (lambda (c s)
             (format s "~a (~d)~@[ - ~a~]"
                     (ccl::%rsc-string (oserr c)) (oserr c) (trap-name c)))))

(defmacro noErr? (&body forms)
  (let ((errsym (gensym)))
    `(let ((,errsym (progn ,@forms)))
       (unless (= ,errsym #$noErr)
         (error 'trap-error :oserr ,errsym
                :trap-name (caar (last ',forms)))))))

(defclass picture-view-mixin ()
  ((picture :initarg :picture :reader picture)))

(defmethod initialize-instance :after ((pvm picture-view-mixin) &rest r
                                       &key picture)
  (declare (dynamic-extent r) (ignore r))
  (set-view-size pvm (subtract-points
                      (rref picture :picture.picframe.botright)
                      (rref picture :picture.picframe.topleft))))

(defmethod view-draw-contents :after ((pvm picture-view-mixin))
  (with-accessors ((picture picture)) pvm
    (with-dereferenced-handles ((picptr picture))
      (#_DrawPicture picture (pref picptr :picture.picframe)))))

(defclass picture-scroller (picture-view-mixin ccl::scroller) ())

(defmethod initialize-instance :after ((ps picture-scroller) &rest r
                                        &key picture)
  (declare (dynamic-extent r) (ignore r))
  (let ((picsize (subtract-points (rref picture :picture.picframe.botright)
                                  (rref picture :picture.picframe.topleft))))
    (setf (scroll-bar-scroll-size (ccl::v-scroller ps))
          (max 1 (ceiling (point-v picsize) 20))
          (scroll-bar-scroll-size (ccl::h-scroller ps))
          (max 1 (ceiling (point-h picsize) 20)))))

(defmethod remove-view-from-window :after ((ps picture-scroller))
  (#_KillPicture (picture ps)))

(defmethod ccl::scroll-bar-limits ((ps picture-scroller))
  (let ((limits (subtract-points
                 (rref (picture ps) :picture.picframe.botright)
                 (view-size ps)))
        (vsp (view-scroll-position ps)))
    (values (if (zerop (point-h vsp))
              (make-point 0 (point-h limits))
              (make-point 0 (point-h vsp)))
            (if (zerop (point-v vsp))
              (make-point 0 (point-v limits))
              (make-point 0 (point-v vsp))))))

(defclass scrolling-picture-window-mixin ()
  ((picture-scroller :reader picture-scroller)
   (scrolling-picture-window-grow-rect))
  (:default-initargs :color-p t
    :window-type :document-with-grow :window-show nil))

(defmethod window-grow-rect ((spwm scrolling-picture-window-mixin))
  (slot-value spwm 'scrolling-picture-window-grow-rect))

(defmethod window-close :after ((spwm scrolling-picture-window-mixin))
  (dispose-record (slot-value spwm 'scrolling-picture-window-grow-rect)))

(defmethod set-view-size :after ((spwm scrolling-picture-window-mixin)
                                 h &optional v)
  (declare (ignore h v))
  (set-view-size (picture-scroller spwm)
                 (subtract-points (view-size spwm) #@(15 15))))

(defclass scrolling-picture-window (scrolling-picture-window-mixin window) ()
  (:default-initargs :track-thumb-p t))

(defmethod initialize-instance :after ((spw scrolling-picture-window) &rest r
                                       &key picture track-thumb-p)
  (declare (dynamic-extent r) (ignore r))
  (with-dereferenced-handles ((pptr picture))
    (let ((frame (pref pptr :picture.picframe)))
      (setf (slot-value spw 'picture-scroller)
            (make-instance 'picture-scroller
              :view-container spw :view-position #@(0 0)
              :draw-scroller-outline nil :picture picture
              :track-thumb-p track-thumb-p )
            (slot-value spw 'scrolling-picture-window-grow-rect)
            (make-record :rect
              :topleft #@(32 32)
              :botright (add-points (rref frame :rect.botright)
                                    #@(16 16))))
      (set-view-size spw
                     (min (- *screen-width* 6)
                          (+ (rref frame :rect.right) 15))
                     (min (- *screen-height* *menubar-bottom* 6)
                          (+ (rref frame :rect.bottom) 15)))))
  (window-show spw))

(defun open-picture-file (fsspec &key (track-thumb-p t) window-title)
  (rlet ((refnum :signed-integer) (frame :rect) (header :OpenCPicParams))
    (noErr? (#_FSpOpenDF fsspec #$fsRdPerm refnum))
    (unwind-protect
      (progn
        (noErr? (#_GetPictureFileHeader (%get-signed-word refNum) frame header))
        (with-focused-view nil
          (#_ClipRect frame)
          (let ((picture (#_OpenCPicture header)))
            (noErr? (#_DrawPictureFile (%get-signed-word refNum) frame (%null-ptr)))
            (#_ClosePicture)
            (make-instance 'scrolling-picture-window
              :picture picture :track-thumb-p track-thumb-p
              :window-title (if window-title window-title
                                (rref fsspec :FSSpec.name))))))
      (traps::fsclose (%get-signed-word refNum)))))

(defun open-picture-file-dialog ()
  (rlet ((file-types :SFTypeList) (reply :StandardFileReply))
    (rset file-types (SFTypeList.array 0) "PICT")
    (#_StandardGetFilePreview (%null-ptr) 1 file-types reply)
    (when (rref reply :StandardFileReply.sfGood)
      (open-picture-file (rref reply :StandardFileReply.sfFile)))))

;(open-picture-file-dialog)