(in-package :mt)

#| #######################################################################

 Assorted tools for manipulating pixmaps, bitmaps, and PICTs

Copyright © 1994-96 Michael Travers 

Permission is given to use and modify this code
as long as the copyright notice is preserved.

Send questions, comments, and fixes to mt@media.mit.edu.

10/6/95 3:59:  new-pixmap forces an 8-bit-deep map, rather than losing
10/14/95 18:54 view-pixmap defaults size properly
11/7/95 12:45: added pixmap-inspector, added color-p to pm-inspect-window
11/13/96 16:17 changed make-bitmap to make-bitmap* to avoid quickdraw conflict
1/19/97 1:28   removed mask stuff to own file (clip-pict.lisp)
3/24/97 23:26  changed name of make-gworld to make-gworld* to avoid alanr conflict, sigh
-------------------------------------------------------------------------

Contents:
Pixmap hack for inspector (see also inspector-extensions.lisp)
Pixmap dialog items
PICT dialog item
Offscreen gworld creation
Conversion:
 Pixmap<->pict
 Pixmap<->array
Pixmap rotation

Limitations: some of the functions only work on pixmaps that are 8 bits deep
and zero-based.  Others are funky in other ways.

The pixmap and pict inspect windows can cause crashes if the object
they refer to is killed.

####################################################################### |#


(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :mcl-hacks)                  ; for rref*
  (require :closstar)
  (use-package :clos*))

;;; Utility functions

;;; Inside Mac says to always set fore/back colors to black/white.  But in 
;;; some cases, this makes the image come out blank.  I have no idea why.
(defun copybits (pixmap wptr &optional srcrect dstrect (setcolors t))
  (with-port wptr
    (ccl:with-pointers ((source pixmap)
                        (dest (ccl:rref wptr windowrecord.portbits)))
      (unless srcrect
        (setf srcrect (rref source pixmap.bounds :storage :pointer)))
      (unless dstrect
        (setf dstrect srcrect))
      (when setcolors
        (#_BackColor *white-color*)
        (#_ForeColor *black-color*))
      (#_CopyBits source dest
       srcrect dstrect #$srccopy (%null-ptr)))))

(defun pict-zero-based? (pict)
  (zerop (rref pict picture.picframe.topleft)))

(defun pixmap-zero-based? (pm)
  (zerop (rref* pm :pixmap.bounds.topleft)))

(defun pixmap-byte-sized? (pm)
  (= 8 (rref* pm :pixmap.pixelsize)))

;;; Pixmap insepctor

(defclass* pm-inspect-window (window)
  (pixmap)
  :initable-instance-variables
  (:default-initargs :color-p t))

(defmethod view-draw-contents ((w pm-inspect-window))
  (with-slots (wptr pixmap) w
    (copybits pixmap wptr nil nil nil)))

;;; For temporary pixmaps
(defun view-pm (pixmap &optional (w (make-instance 'window 
                                      :window-title (princ-to-string pixmap)
                                      :view-size (rref* pixmap :pixmap.bounds.bottomright))))
  (let ((wptr (slot-value w 'wptr)))
    (validate-view w)
    (with-port wptr 
      (copybits pixmap wptr))))

(defun inspector::inspect-pm (pm)
  (let* ((w (rref* pm pixmap.bounds.right))
         (h (rref* pm pixmap.bounds.bottom)))
    (make-instance 'pm-inspect-window
      :pixmap pm :view-size (make-point w h) :window-title (princ-to-string pm))))

;;; PICT insepctor

(defclass* pict-inspect-window (window)
  (pict)
  :initable-instance-variables
  (:default-initargs :color-p t))

(defmethod view-draw-contents ((w pict-inspect-window))
  (with-slots (pict) w
    (with-dereferenced-handles ((h pict))
      (#_DrawPicture pict (rref h picture.picframe :storage :pointer)))))

(defun inspector::inspect-pict (pict)
  (let* ((w (rref* pict picture.picframe.right))
         (h (rref* pict picture.picframe.bottom)))
    (make-instance 'pict-inspect-window
      :pict pict :view-size (make-point w h) :window-title (princ-to-string pict))))


;;; Pixmap dialog-item

(defclass* pixmap-dialog-item (dialog-item)
  (pixmap
   (dispose nil))                       ; GWorld, or T to dispose of pixmap, or NIL
  :initable-instance-variables)

(defmethod* initialize-instance :after ((pmdi pixmap-dialog-item) &rest ignore)
  (when pixmap
    (set-view-size pmdi (view-default-size pmdi))))

(defmethod* view-default-size ((pmdi pixmap-dialog-item))
  (when pixmap
    (make-point (rref pixmap pixmap.bounds.right)
                (rref pixmap pixmap.bounds.bottom))))

(defmethod* view-draw-contents ((pmdi pixmap-dialog-item))
  (let ((x (point-h view-position))
        (y (point-v view-position)))
    (rlet ((dest-rect rect
                      :top y :left x
                      :bottom (+ y (point-v view-size))
                      :right (+ x (point-h view-size))))
      (copybits pixmap wptr nil dest-rect nil))))       ; Have to skip the color stuff. God knows. why.

;;; This presumes the pixmap is a screen buffer, and isn't in use somewhere else.
(defmethod* remove-view-from-window ((pmdi pixmap-dialog-item))
  (cond ((eq dispose t) 
         (#_disposescreenbuffer pixmap))        ; will this work on other pixmaps?  Who knows?
        (dispose                        ; non-nil non-t means it's a gworld
         (#_DisposeGWorld dispose)))
  (call-next-method))

;;; Pict dialog item

(defclass* pict-dialog-item (dialog-item)
  (pict
   (dispose nil))                       ; T to dispose of pict, or NIL
  :initable-instance-variables)

(defmethod* initialize-instance :after ((pdi pict-dialog-item) &rest ignore)
  (when pict
    (set-view-size pdi (view-default-size pdi))))

(defmethod* view-default-size ((pdi pict-dialog-item))
  (when pict
    (subtract-points (rref pict picture.picframe.bottomright)
                     (rref pict picture.picframe.topleft))))

(defmethod* view-draw-contents ((pdi pict-dialog-item))
  (with-port wptr
      (let* ((topleft view-position)
             (bottomright (add-points topleft view-size)))
        (rlet ((dest-rect rect
                          :topleft topleft :bottomright bottomright))
          (#_Drawpicture pict dest-rect)))))

;;; This presumes the pixmap is a screen buffer, and isn't in use somewhere else.
(defmethod* remove-view-from-window ((pdi pict-dialog-item))
  (if dispose
    (#_KillPicture pict))
  (call-next-method))

(defun pict-to-file (pict-handle pathname)
  (with-open-file (stream pathname
                          :direction :output
                          :element-type '(unsigned-byte 32))
    (dotimes (n 128) (write-byte 0 stream))     ; write the pict file header
    (let ((PICT-size (#_GetHandleSize pict-handle)))
      (with-dereferenced-handles ((pict-pointer pict-handle))
        (dotimes (long (ceiling pict-size 4))
          (write-byte (%get-unsigned-long pict-pointer (* 4 long)) stream)))))
  (set-mac-file-type pathname :|PICT|)
  (set-mac-file-creator pathname :|ttxt|))

(defun make-gworld* (w h &optional (depth 0))
  (rlet ((bounds-rect :rect :top 0 :left 0 :right w :bottom h)
         (gworldp :pointer))
    (unless (zerop (#_NewGWorld gworldp depth bounds-rect (ccl:%null-ptr) (ccl:%null-ptr) 0))
      (error "Failed to make gworld"))
    (ccl:%get-ptr gworldp)))

(defun dispose-gworld (gworld)
  (#_DisposeGworld gworld))

(defmacro with-gworld (gworld &body body)
  `(rlet ((cgrafptr :pointer) (gdhandle :pointer))
     (require-trap #_GetGWorld cgrafptr gdhandle)
     (let* ((pixmap (require-trap #_GetGWorldPixMap ,gworld)))
       (unwind-protect
         (progn
           (require-trap #_SetGworld ,gworld (ccl:%null-ptr))
           (require-trap #_LockPixels pixmap)
           (require-trap #_EraseRect (ccl:rref ,gworld cgrafport.portrect))
           ,@body))
       (require-trap #_UnLockPixels pixmap)
       (require-trap #_SetGWorld (ccl:%get-ptr cgrafptr) (ccl:%get-ptr gdhandle)))))

;;; Body should consist of low-level Quickdraw calls, which will be performed on the generated bitmap.
;;; Bugs:  doesn't deallocate gworld (because doing so flushes the pixmap as well)
;;; Temporary fix: return gworld as second value so higher level can dispose of it someday.
(defmacro make-pixmap ((w h &optional (depth 0)) &body body)
  `(rlet ((cgrafptr :pointer) (gdhandle :pointer))
     (require-trap #_GetGWorld cgrafptr gdhandle)
     (let* ((gworld (make-gworld* ,w ,h ,depth))
            (pixmap (require-trap #_GetGWorldPixMap gworld)))
       (with-gworld gworld
         ,@body)
       (values pixmap gworld))))

(defmethod picture-to-window  
  ((self window) picture &optional left top right bottom)
  (when picture
    (with-focused-view self
      (with-port (wptr self)
        (cond ((null left)
               (with-pointers ((pict-point picture))
                 (#_DrawPicture picture (rref pict-point picture.picframe :storage :pointer))))
              ((rlet ((r :rect :left left :top top :right right :bottom bottom))
                 (#_DrawPicture picture r))))))))

(defun window-snapshot (window &optional box (scale 1) frame)
  (let* ((wptr (slot-value window 'wptr))
         (source-rect (or box (rref wptr windowrecord.portrect)))
         (w-width (- (rref source-rect rect.right)
                     (rref source-rect rect.left)))
         (w-height (- (rref source-rect rect.bottom)
                      (rref source-rect rect.top))))
    (make-pixmap ((round (* w-width scale))
                  (round (* w-height scale)))
      (with-pointers ((source (rref wptr windowrecord.portbits))
                      (dest (rref (ccl::%getport) windowrecord.portbits)))                 
       (#_CopyBits source
                  dest
                  source-rect
                  (rref (ccl::%getport) windowrecord.portrect)
                  0 (%null-ptr))
       (when frame
         (#_FrameRect (rref (ccl::%getport) windowrecord.portrect)))))))

;;; Pixmap conversions

(defun pict->pixmap (pict &optional (depth 0))
  (let ((w (- (rref pict picture.picframe.right)
                   (rref pict picture.picframe.left)))
        (h (- (rref pict picture.picframe.bottom)
                   (rref pict picture.picframe.top))))
    (make-pixmap (w h depth)
      (rlet ((bounds rect :topleft #@(0 0) :bottomright (make-point w h)))
        (#_DrawPicture pict bounds)))))

;;; not working - comes out blank?  With or without setting fore/back colors, apparently.  Damn.
(defun pixmap->pict (pm w)
  (with-focused-view w
    (with-pointers ((source pm))
      (let* ((bounds (rref source :pixmap.bounds :storage :pointer))
             (pict (#_OpenPicture bounds)))
        (#_ClipRect bounds)
        (copybits pm (wptr w) nil nil nil)
;        (#_PenSize 4 4) (#_MoveTo 20 0) (#_LineTo 0 20)
        (#_ClosePicture)
        pict))))

;;; for a 1-bit array
(defun array->pixmap (array)
  (let* ((dims (array-dimensions array)))
    (with-rgb (white *white-color*)
      (with-rgb (black *black-color*)
        (make-pixmap ((car dims) (cadr dims) 1)
          (dotimes (y (cadr dims))
            (dotimes (x (car dims))
              (#_SetCPixel x y (if (zerop (aref array x y)) white black)))))))))
                    
(defmacro with-locked-pm ((pm) &body body)
  `(unwind-protect 
     (progn (#_LockPixels ,pm)
            ,@body)
     (#_UnLockPixels ,pm)))

;;; assumes 8-bit, zero-based
(defun pixmap->array (pm)
  (with-locked-pm (pm)
    (let* ((width (rref pm :pixmap.bounds.right))
           (height (rref pm :pixmap.bounds.bottom))
           (array (make-array (list width height) :element-type '(byte 8))))
      (dotimes (x width)
        (dotimes (y height)
          (setf (aref array x y)
                (pixmap-byte pm x y))))
      array)))

(defun bitmap->array (bm)
  (let* ((width (rref bm :bitmap.bounds.right))
         (height (rref bm :bitmap.bounds.bottom))
         (base (rref bm :bitmap.baseaddr))
         (rowbytes (rref bm :bitmap.rowbytes))
         (array (make-array (list width height) :element-type 'bit))
         (roworg 0))
    (dotimes (y height)
      (let ((x 0))
        (dotimes (b rowbytes)
          (let ((byte (%get-byte base (+ roworg b))))
            (dotimes (k 8)                       
              (setf (aref array x y) (ldb (byte 1 7) byte))
              (setq byte (ash byte 1))
              (incf x))
            (when (>= x width) (return)))
          (when (>= x width) (return))))
      (setq roworg (+ roworg rowbytes)))
    array))


;;; Assumes an 8-bit pm, must be locked
(defun pixmap-byte (pm h v)
  (let ((baseaddr (rref pm :pixmap.baseaddr))
        (rowbytes (logand (rref pm :pixmap.rowbytes) #x1fff))
        (left (rref pm :pixmap.bounds.left))
        (top (rref pm :pixmap.bounds.top)))
    (with-dereferenced-handles ((basep baseaddr))
      (%get-byte basep (+& (*& rowbytes (-& v top)) (-& h left))))))

(defun pixmap-byte-addr (rowbytes h v top left)
  (+& (*& rowbytes (-& v top)) (-& h left)))

;;; Also assumes an 8-bit locked pm
(defun set-pixmap-byte (pm h v newv)
  (let ((baseaddr (rref pm :pixmap.baseaddr))
        (rowbytes (logand (rref pm :pixmap.rowbytes) #x1fff))
        (left (rref pm :pixmap.bounds.left))
        (top (rref pm :pixmap.bounds.top)))
    (with-pointers ((basep baseaddr))
      (%put-byte basep newv (+& (*& rowbytes (-& v top)) (-& h left))))
    newv))

(defsetf pixmap-byte set-pixmap-byte)

(defun rotate-pixmap (pm theta &optional hot-x hot-y)
  (let ((cos (cos theta))
        (sin (sin theta))
        (xsiz (rref pm pixmap.bounds.right))
        (ysiz (rref pm pixmap.bounds.bottom)))
    (unless (and (pixmap-zero-based? pm)
                 (pixmap-byte-sized? pm))
      (error "Sorry, only works on zero-based, 8-bit-deep pixmaps"))
    (flet ((rotated-x (x y)
             (- (* x cos) (* y sin)))
           (rotated-y (x y)
             (+ (* x sin) (* y cos)))
           (unrotated-x (x y)
             (+ (* x cos) (* y sin)))
           (unrotated-y (x y)
             (- (* y cos) (* x sin))))
      (let ((n-xmin (floor (min 0 (rotated-x 0 ysiz) (rotated-x xsiz 0) (rotated-x xsiz ysiz))))
            (n-xmax (ceiling (max 0 (rotated-x 0 ysiz) (rotated-x xsiz 0) (rotated-x xsiz ysiz))))
            (n-ymin (floor (min 0 (rotated-y 0 ysiz) (rotated-y xsiz 0) (rotated-y xsiz ysiz))))
            (n-ymax (ceiling (max 0 (rotated-y 0 ysiz) (rotated-y xsiz 0) (rotated-y xsiz ysiz)))))
        (let* ((n-pm (new-pixmap (- n-xmax n-xmin) (- n-ymax n-ymin) pm))
               (rowbytes (logand (rref pm :pixmap.rowbytes) #x1fff))
               (n-rowbytes (logand (rref n-pm :pixmap.rowbytes) #x1fff)))
          (with-pointers ((pm-base (rref pm :pixmap.baseaddr))
                          (n-pm-base (rref n-pm :pixmap.baseaddr)))
            (flet ((pixmap-byte (base rowbytes h v)
                     (%get-byte base (+& (*& rowbytes v) h)))
                   (set-pixmap-byte (base rowbytes h v newval)
                     (%put-byte base newval (+& (*& rowbytes v) h))))
              (loop for nx from n-xmin below n-xmax do
                    (loop for ny from n-ymin below n-ymax do
                          (let* ((ox (round (unrotated-x nx ny)))
                                 (oy (round (unrotated-y nx ny)))
                                 (val (if (and (< -1 ox xsiz)
                                               (< -1 oy ysiz))
                                        (pixmap-byte pm-base rowbytes ox oy)
                                        0)))
                            (set-pixmap-byte n-pm-base n-rowbytes (- nx n-xmin) (- ny n-ymin) val)
                            val)
                          )))
            (values n-pm
                    (round (- (rotated-x hot-x hot-y) n-xmin))
                    (round (- (rotated-y hot-x hot-y) n-ymin)))))))))
  
        
;;; this works a lot better when bits are in a relocatable block. Dunno why.
(defun new-pixmap (h v &optional source)
  (let ((pm (#_NewPixMap))
        (rowbytes (* 4 (ceiling h 4)))) 
    (unless (pixmap-byte-sized? pm)     ; force to 8 bits (and cross fingers)
      (setf (rref pm :pixmap.pixelsize) 8
            (rref pm :pixmap.cmpsize) 8))
    (when source (#_CopyPixmap source pm))      
    (let ((bits (#_NewHandle (* rowbytes v))))
      (setf (rref pm pixmap.baseaddr) bits
            (rref pm pixmap.rowbytes) (logior #x8000 rowbytes)
            (rref pm pixmap.bounds.right) h
            (rref pm pixmap.bounds.bottom) v))
    pm))


;;; was make-bitmap, but that conflicts with Quickdraw library
(defun make-bitmap* (size)
  (let* ((rowbytes (* 2 (ceiling (point-h size) 16)))         ; has to be even
         (bits (#_NewPtr (* rowbytes (point-v size)))))
    (declare (type macptr bits))
    (make-record :bitmap
                 :baseaddr bits
                 :rowbytes rowbytes 
                 :bounds.topleft 0
                 :bounds.bottomright size)))

(defun kill-bitmap (bm)
  (#_DisposePtr (rref bm bitmap.baseaddr))
  (#_DisposePtr bm))

    
(provide :pixmap-utils)