(in-package "CL-USER")

#|----------------------------------------------------------------------
My (arthur.cater@ucd.ie) attempt to create a view with multiple layers
that could be independently drawn and erased.
Based on Neil Baylis's "Core Animation Demo".
Permission granted to Clozure Associates to distribute freely.

Tested only in my own environment:
Powerbook G4, MacOS 10.5.8, Clozure Common Lisp 1.5-r13651 (DarwinPPC32)
with an image built by COCOA-APPLICATION.

Explanations:
1. Loads Quartz Framework only once, and allow transparency to work.
   Loading Quartz the first time takes some appreciable time, be patient.
2. CGFL, RGBA, NSPOINT, NSAREF for shorthand.
3. The LAYERED-VIEW has an alist whose keys are layers and whose values
   are a 2-element list, first a symbolic name, second a drawing fn.
4. The drawing function should take one argument, a ns-view.
   The drawing takes place into a fresh image, whose contents are then
   extracted in a way learned from Neil Baylis's demo, and made become
   the contents of a layer housed in the view.
5. Each layer has the view as its delegate. This fact is not used.
6. (RUN-DEMO) sets the ball rolling.
   There are supposed to be two superposed layers,
   - one shows a simple grid with lines of two colours,
   - the other shows a part-transparent bluish shady rectangle.
   The drawings are inset from the margins, by different amounts.
7. Clicking in the view causes the shady rectange (only) to change.
----------------------------------------------------------------------
Some preliminaries:
Cocoa and Quartz frameworks,
Allow transparency settings have an effect,
Globals, Shorthands, With-Focused-Image and With-Converted-Image macro
----------------------------------------------------------------------|#

(require :cocoa)   ;; Unnecessary for me since I run in cocoa-application anyway
(require :easygui) ;; Ditto, needed only for its RUNNING-IN-MAIN-THREAD macro
(eval-when (:compile-toplevel :load-toplevel :execute)
  (#/setIgnoresAlpha: ns:ns-color nil)
  ;; Test below avoids multiple slow loads of the Quartz framework,
  ;; useful timesaver if making changes and reevaluating everything from Hemlock editor.
  ;; I suspect this might not work right if app is saved. Let me know ...
  (unless (find "Quartz.framework" ccl::*extension-framework-paths*
                :key #'(lambda (p) (first (last (pathname-directory p))))
                :test #'equal)
    (format t "~&;; Loading Quartz framework takes time, please be patient...~%")
    (objc:load-framework "Quartz" :quartz)))

(defparameter *w nil        "In demo, The Window we build")
(defparameter *v nil        "In demo, The view in the window that has layers.")

(defmacro cgfl (n) `(float ,n ccl::+cgfloat-zero+))

(defun nsstr (s) (make-instance 'gui::ns-lisp-string :string s))

(defun nspoint (x y) (ns:make-ns-point (cgfl x) (cgfl y)))

(defparameter +standard-window-style-mask+
  (logior #$NSTitledWindowMask
          #$NSClosableWindowMask
          #$NSMiniaturizableWindowMask
          #$NSResizableWindowMask))

(defun rgba (r g b a) (#/retain
  (#/colorWithDeviceRed:green:blue:alpha:
   ns:ns-color (cgfl r) (cgfl g) (cgfl b) (cgfl a))))

(defmacro with-focused-image (image &body forms)
  `(progn (#/lockFocus ,image)
     (unwind-protect (progn ,@forms)
       (#/unlockFocus ,image)
       (#/flushGraphics (#/currentContext ns:ns-graphics-context)))))

(defmacro with-converted-image ((conversion image) &body forms)
  (let ((repr (gensym)) (sr (gensym)))
    `(let* ((,repr (#/TIFFRepresentation ,image))
            (,sr (#_CGImageSourceCreateWithData ,repr CCL:+NULL-PTR+))
            (,conversion (#_CGImageSourceCreateImageAtIndex ,sr 0 CCL:+NULL-PTR+)))
       (unwind-protect (progn ,@forms)
         (#_CFRelease ,sr)
         (#_CGImageRelease ,conversion)))))

#|----------------------------------------------------------------------
View and Layer manipulation.
----------------------------------------------------------------------|#

(defclass layered-view (ns:ns-view)
  ((layers-alist :accessor layered-view-layers-alist :initform nil)
   (height :initarg :y)
   (width  :initarg :x))
  (:metaclass ns:+ns-object))

(defun set-layer-position (layer point)
  (let* ((pos
	  (make-record
	   :<CGP>oint x (ns:ns-point-x point) y (ns:ns-point-y point))))
    (#/removeAllAnimations layer)
    (#/setPosition: layer pos)
    (free pos)))

(defun set-layer-bounds (layer rect)
  (let* ((o (make-record :<CGP>oint
			 x (ns:ns-rect-x rect)
			 y (ns:ns-rect-y rect)))
	 (s (make-record :<CGS>ize
			 width (ns:ns-rect-width rect)
			 height (ns:ns-rect-height rect)))
	 (bounds (make-record :<CGR>ect origin o size s)))
    (#/setBounds: layer bounds)
    (free bounds)
    (free s)
    (free o)))

(defun make-ca-layer (name drawfunction view size)
  (let* ((layer (#/init (make-instance 'ns:ca-layer)))
         (rect (ns:make-ns-rect 0 0 (pref size :ns-size.width) (pref size :ns-size.height)))
         (image (make-instance 'ns:ns-image :with-size size)))
    (#/setName: layer (nsstr (string name)))
    (with-focused-image image (funcall drawfunction view))
    (with-converted-image (ir image)
      (#/setContents: layer ir)
      (#/release image))
    (set-layer-bounds layer rect)
    layer))

(defun add-layer-to-view (view layer name drawfn)
  (#/setDelegate: layer view)
  (setf (layered-view-layers-alist view)
        (nconc (layered-view-layers-alist view)
               (list (list layer name drawfn))))
  (#/addSublayer: (#/layer view) layer)
  (set-layer-position layer (nspoint (/ (slot-value view 'width) 2) (/ (slot-value view 'height) 2))))

(defmethod draw-layer-anew ((view layered-view) layername)
  (let ((entry (find layername (layered-view-layers-alist view) :key #'second)))
    (when entry
      (let* ((layer (first entry))
             (size (make-record :<CGS>ize width (slot-value view 'width) height (slot-value view 'height)))
             (image (make-instance 'ns:ns-image :with-size size)))
        (with-focused-image image (funcall (third entry) view))
        (with-converted-image (ir image)
          (#/setContents: layer ir)
          (#/release image))
        (free size)
        (#/display (#/layer view))))))

(defun create-layered-view (width height layerpairs)
  (let* ((v (make-instance 'layered-view :x width :y height))
         (size (ns:make-ns-size width height))
         (layers (mapcar #'(lambda (d) (make-ca-layer (first d) (second d) v size)) layerpairs)))
    (#/setWantsLayer: v #$YES)
    (mapc #'(lambda (layer pair) (add-layer-to-view v layer (first pair) (second pair))) layers layerpairs)
    v))
  
#|----------------------------------------------------------------------
A sample function for creating a window with a multilayered view.
----------------------------------------------------------------------|#

(defun window-with-multilayered-view (&rest layerpairs)
  (let* ((width (cgfl 900.0))
         (height (cgfl 600.0))
         (title "Layered-View Demo")
         (v (create-layered-view width height layerpairs))
         (w (make-instance 'ns:ns-window
               :with-content-rect (ns:make-ns-rect 0 0 width height)
               :style-mask +standard-window-style-mask+
               :backing #$NSBackingStoreBuffered
               :defer t)))
    (#/setTitle: w (nsstr title))
    (#/setBackgroundColor: w (rgba 0.90 0.90 1.0 1.0 ))
    (#/center w)
    (#/makeKeyAndOrderFront: w nil)
    (#/setContentView: w v)
    (setf *w w *v v) ;; For convenience of interactive experimentation
    (#/flushWindow w)))

#|----------------------------------------------------------------------
The demo has two layers, one drawn by GRID and one drawn by SHADY-AREA.
----------------------------------------------------------------------|#

(defun grid (view) "Draws red vertical lines and green horizontal lines."
  (let* ((nlines 11)
         (width (slot-value view 'width))
         (height (slot-value view 'height))
         (x0 (* width 0.025))
         (y0 (* height 0.025))
         (greenpath (#/bezierPath ns:ns-bezier-path))
         (redpath (#/bezierPath ns:ns-bezier-path)))
    (dotimes (n nlines)
      (let ((x (+ x0 (* (/ (+ n 0.5) nlines) (- width x0 x0))))
            (y (+ y0 (* (/ (+ n 0.5) nlines) (- height y0 y0)))))
        (#/moveToPoint: greenpath (nspoint x0 y))
        (#/lineToPoint: greenpath (nspoint (- width x0) y))
        (#/moveToPoint: redpath (nspoint x y0))
        (#/lineToPoint: redpath (nspoint x (- height y0)))))
    (#/setStroke (rgba 0.0 1.0 0.0 1.0))
    (#/stroke greenpath)
    (#/setStroke (rgba 1.0 0.0 0.0 1.0))
    (#/stroke redpath)))

(defparameter *colour-ring*
  (list (rgba 0.3 0.3 1.0 0.25)
        (rgba 0.3 1.0 0.3 0.25)
        (rgba 1.0 0.3 0.3 0.25)
        nil)
"Each time you click in the view the shady area changes its colour, and
disappears (is present but draws nothing at all) when colour is NIL.")

(ccl::define-objc-method ((:void :mouse-down (:id event)) layered-view)
  (declare (ignorable event))
  (setf *colour-ring* (append (rest *colour-ring*) (list (first *colour-ring*))))
  (easygui::running-on-main-thread () (draw-layer-anew *v :area1)))

(ccl::define-objc-method ((:<BOOL> accepts-first-responder) layered-view) #$YES)

(defun shady-area (view)
  (let* ((width (slot-value view 'width))
         (height (slot-value view 'height))
         (x0 (* width 0.05))
         (y0 (* height 0.05))
         (path (#/bezierPath ns:ns-bezier-path)))
    (when (first *colour-ring*)
      (#/setFill (first *colour-ring*))
      (#/moveToPoint: path (nspoint x0 y0))
      (#/lineToPoint: path (nspoint (- width x0) y0))
      (#/lineToPoint: path (nspoint (- width x0) (- height y0)))
      (#/lineToPoint: path (nspoint x0 (- height y0)))
      (#/lineToPoint: path (nspoint x0 y0))
      (#/fill path))))

(defun run-demo nil
  (setf *v nil *w nil)
  (easygui::running-on-main-thread ()
    (window-with-multilayered-view
     `(:grid1 ,#'grid)
     `(:area1 ,#'shady-area))))