;;; -*- package: ccl -*-
;*********************************************************************
;*                                                                   *
;*    PROGRAM      I M A G E   B U T T O N   D I A L O G   I T E M   *
;*                                                                   *
;*********************************************************************
   ;* Author    : Alexander Repenning (alexander@agentsheets.com)    *
   ;*             http://www.agentsheets.com                         *
   ;* Copyright : (c) 1996-2005, AgentSheets Inc.                    *
   ;* Filename  : 05/17/04                                           *
   ;* Version   :                                                    *
   ;*   1.0     :  02/23/04                                          *
   ;*   1.1     :  03/17/05 auto on image from off image             *
   ;*   1.2     :  09/26/05 scaling control                          *
   ;* HW/SW     : G4,  MCL 5, OS X 10.3.8                            *
   ;* Abstract  : Buttons using On/Off images including alpha.       *
   ;*    Items that can  be loaded from most types of files          *
   ;*    including: GIF, JPEG, PNG, PICT, JFIF, PDF, MacPaint,       *
   ;*               Flash 5, Photoshop, QuickTime Image File, BMP,   *
   ;*               SGI, Targa, TIFF, and FlashPix                   *
   ;******************************************************************

;; All File Formats: http://www.apple.com/quicktime/products/qt/specifications.html

(in-package :ccl)

(export '(image-button-dialog-item turn-on turn-off restore-background))

(defclass IMAGE-BUTTON-DIALOG-ITEM (dialog-item)
  ((turned-on-p :accessor turned-on-p :initform nil :initarg :turned-on-p)
   (on-importer :accessor on-importer :initform nil :initarg :on-importer)
   (off-importer :accessor off-importer :initform nil :initarg :off-importer)
   (on-image-pathname :accessor on-image-pathname :initform nil :initarg :on-image-pathname)
   (off-image-pathname :accessor off-image-pathname :initform nil :initarg :off-image-pathname)
   (when-pressed-fn :accessor when-pressed-fn :initform nil :initarg :when-pressed-fn)
   (when-released-fn :accessor when-released-fn :initform nil :initarg :when-released-fn)
   (scale-image :accessor scale-image :initform t :initarg :scale-image))
  (:documentation "Two state button using 32 bit RGBA images"))


(defmethod GET-GRAPHICS-IMPORTER ((Self image-button-dialog-item) Pathname &key Scale)
  (rlet ((&importer :handle)
         (Fsspec :fsspec)
         (&bounds :rect))
    ;; Set File Spec
    (let ((File (probe-file Pathname)))
      (unless File (error "cannot find image file ~A" Pathname))
      (with-pstrs ((Name (mac-namestring File)))
        (unless (zerop (#_FSMakeFSSpec 0 0 Name Fsspec))
          (error "Invalid file reference ~A" Pathname))
        ;; Read Image, access dimensions 
        (#_GetGraphicsImporterForFile Fsspec &importer))
      (let ((Importer (%get-ptr &importer)))
        (let ((Err (#_GraphicsImportGetNaturalBounds Importer &bounds)))
          (unless (zerop Err) (error "GraphicsImportGetNaturalBounds")))
        ;; Enable alpha-channel drawing mode
        (let ((Err (#_GraphicsImportSetGraphicsMode importer #$graphicsModeStraightAlpha (%null-ptr))))
          (unless (zerop Err) (error "GraphicsImportSetGraphicsMode")))
        ;; ignore actual image size and resize to view size
        (when (or Scale (scale-image Self))
          (rlet ((rect :rect :topleft #@(0 0) :botright (view-size Self)))
            (#_GraphicsImportSetBoundsRect Importer rect)))
        Importer))))


(defmethod INITIALIZE-INSTANCE ((Self image-button-dialog-item) &rest Initargs)
  (declare (ignore Initargs))
  (call-next-method)
  (when (on-image-pathname Self)
    (setf (on-importer Self) (get-graphics-importer Self (on-image-pathname Self))))
  (when (off-image-pathname Self)
    (setf (off-importer Self) (get-graphics-importer Self (off-image-pathname Self))))
  ;; if garbage collected free the importers
  (terminate-when-unreachable Self))


(defmethod SET-VIEW-SIZE ((Self image-button-dialog-item) H &optional V)
  (call-next-method)
  (rlet ((&rect :rect :topleft #@(0 0) :botright (make-point H V)))
    (when (on-importer Self) 
      (#_GraphicsImportSetBoundsRect (on-importer Self) &rect))
    (when (off-importer Self) 
      (#_GraphicsImportSetBoundsRect (off-importer Self) &rect))))
    

(defmethod RESTORE-BACKGROUND ((Self image-button-dialog-item))
  ;; specialize this for more complex backgrounds
  (with-focused-view Self
    (rlet ((&rect :rect :topleft #@(0 0) :botright (view-size Self)))
      (#_EraseRect &rect))))


(defmethod VIEW-DRAW-CONTENTS ((Self image-button-dialog-item))
  (with-focused-view Self
    (restore-background Self)
    (cond
     ;; ON
     ((turned-on-p Self)
      (cond
       ;; there is an ON image: use it
       ((on-importer Self)
        (#_GraphicsImportSetGWorld (on-importer Self) (#_GetWindowPort (wptr Self)) (%null-ptr))
        (#_GraphicsImportDraw (on-importer Self)))
       ;; no ON image: use a dimmed version of the OFF image
       ((off-importer Self)
        (#_GraphicsImportSetGWorld (off-importer Self) (#_GetWindowPort (wptr Self)) (%null-ptr))
        ;; hack blend over xor-ed image
        (with-rgb (&color *Black-Color*)
          (#_GraphicsImportSetGraphicsMode (off-importer Self) #$notSrcXor &color))
        (#_GraphicsImportDraw (off-importer Self))
        (with-rgb (&color #.(make-color 40000 40000 40000))
          (#_GraphicsImportSetGraphicsMode (off-importer Self) #$graphicsModeStraightAlphaBlend &color))
        (#_GraphicsImportDraw (off-importer Self))
        (with-rgb (&color *White-Color*)
          (#_GraphicsImportSetGraphicsMode (off-importer Self) #$graphicsModeStraightAlphaBlend &color)))))
     ;; OFF
     (t
      (when (off-importer Self)
        (#_GraphicsImportSetGWorld (off-importer Self) (#_GetWindowPort (wptr Self)) (%null-ptr))
        (#_GraphicsImportDraw (off-importer Self)))))))


(defmethod TURN-ON ((Self image-button-dialog-item))
  (setf (turned-on-p Self) t)
  (view-draw-contents Self)
  (#_QDFlushPortBuffer (#_GetWindowPort (wptr Self)) (%null-ptr)))


(defmethod TURN-OFF ((Self image-button-dialog-item))
  (setf (turned-on-p Self) nil)
  (view-draw-contents Self)
  (#_QDFlushPortBuffer (#_GetWindowPort (wptr Self)) (%null-ptr)))


(defmethod VIEW-CLICK-EVENT-HANDLER ((Self image-button-dialog-item) Where)
  (declare (ignore Where))
  (call-next-method)
  (when (when-pressed-fn Self) (funcall (when-pressed-fn Self) Self))
  (loop (unless (mouse-down-p) (return)))
  (when (when-released-fn Self) (funcall (when-released-fn Self) Self)))


(defmethod TERMINATE ((Self image-button-dialog-item))
  ;;(format t "disposed Importer: ~A" Self)
  (when (on-importer Self) (#_CloseComponent (on-importer Self)))
  (when (off-importer Self) (#_CloseComponent (off-importer Self))))


#| Examples:

;; Momentary Push in

(defparameter *Window* (make-instance 'window))

(add-subviews *Window*
  (make-instance 'image-button-dialog-item
    :view-position #@(50 50)
    :view-size #@(32 32)
    :off-image-pathname "ccl:Resources;images;SEStopScriptImage.tiff"
    :when-pressed-fn #'turn-on
    :when-released-fn #'turn-off)
  (make-instance 'image-button-dialog-item
    :view-position #@(90 50)
    :view-size #@(32 32)
    :off-image-pathname "ccl:Resources;images;SERunScriptImage.tiff"
    :when-pressed-fn #'turn-on
    :when-released-fn #'turn-off))


;; Toggle one button

(defparameter *Window2* (make-instance 'window))

(add-subviews *Window2*
  (make-instance 'image-button-dialog-item
    :view-position #@(50 50)
    :view-size #@(32 32)
    :on-image-pathname "ccl:Resources;images;SERunScriptImage.tiff"
    :off-image-pathname "ccl:Resources;images;SEStopScriptImage.tiff"
    :when-pressed-fn #'(lambda (Button) 
                         (if (turned-on-p Button) (turn-off Button) (turn-on Button)))))

  
;; Toggle multiple  buttons

(defparameter *Window3* (make-instance 'window))


(defparameter *Button1* 
  (make-instance 'image-button-dialog-item
    :turned-on-p t
    :view-position #@(50 50)
    :view-size #@(100 25)
    :on-image-pathname "ccl:Resources;images;on-button.png"
    :off-image-pathname "ccl:Resources;images;off-button.png"))


(defparameter *Button2* 
  (make-instance 'image-button-dialog-item
    :turned-on-p nil
    :view-position #@(50 90)
    :view-size #@(100 25)
    :on-image-pathname "ccl:Resources;images;on-button.png"
    :off-image-pathname "ccl:Resources;images;off-button.png"))


(setf (when-pressed-fn *Button1*) #'(lambda (Button) (turn-on Button) (turn-off *Button2*)))
(setf (when-pressed-fn *Button2*) #'(lambda (Button) (turn-on Button) (turn-off *Button1*)))


(add-subviews *Window3* *Button1* *Button2*)


|#