#|
 Source Code for MCLgui, an attempt to give Clozure Common Lisp a simple
 interface to cocoa gui functionality that looks similar to what MCL formerly
 provided.  however, we do give up the mcl convention that windows are views
 we follow cocoa-ref and make only the content-view a view.

 window will be a CLOS object with a slot pointing to the cocoa window, an
 mclgui-cocoa-window, and a pointer back, clos-ref.

 view will be a CLOS object with a slot pointing to the cocoa view.  in this case, 
 in order to use auto-redrawing with view-draw-contents and #/drawRect, the 
 cocoa view should be an instance of the objc class mclgui-cocoa-view.  
 mclgui-cocoa-view is a subclass of ns:ns-view with an additional instance
 variable that is a pointer back to its CLOS view.  mclgui-cocoa-view will have a
 generic drawRect routine that invokes the lisp method view-draw-contents
 on its CLOS-view.

 need to figure out how to deal with line widths.

 need to figure out how to make key and click event handlers.

 maybe i should finish this by making more cocoa functionality available in
 lisp friendly form.  maybe: make-path, path-stroke, path-fill, etc.

 now i am thinking that the best way to get g working is to leave it more as
 it is, with g doing the coordinate transforms.  the ultimate coordinate systems
 remain in pixels, so nothing need be done to the line widths.

 in mcl, the window is a view, and it can have subviews.  in cocoa, the window
 is not a view, but it has a content-view which plays the same role as the 
 window-as-view in mcl.
|#

(defstruct (POINT (:constructor make-point (x y)))
  x y)

(defun point-h (p) (point-x p))
(defun point-v (p) (point-y p))

(defun add-points (a b)
  (make-point (+ (point-x a) (point-x b))
              (+ (point-y a) (point-y b))))

(let ((screen-frame-rect (#/frame (#/mainScreen ns:ns-screen))))
  (defparameter *screen-width* (ns:ns-rect-width screen-frame-rect))
  (defparameter *screen-height* (ns:ns-rect-height screen-frame-rect)))

(defconstant +title-bar-height+ 22)

(defun non-null-macptr (thing)
  (not (eql +null-ptr+ thing)))


;;; methods for NS:NS-VIEW

(defmethod subviews ((v ns:ns-view))
  (loop for i below (#/count (#/subviews v))
    collect (#/objectAtIndex: (#/subviews v) i)))

(defmethod add-subviews ((v ns:ns-view) &rest subviews)
  (loop for subv in subviews do
    (#/addSubview: v subv))
  (subviews v))

(defmethod view-window ((v ns:ns-view))
  (and (non-null-macptr (#/window v))
       (#/window v)))

(defmethod view-container ((v ns:ns-view))
  (and (non-null-macptr (#/superview v))
       (#/superview v)))

; currently, re-setting an existing container is not allowed
(defmethod set-view-container ((v ns:ns-view) (new-container ns:ns-view))
  (if (view-container v)
    (break "can't set-view-container because ~a already has container ~a" 
           v (view-container v))
    (add-subviews new-container v)))

(defmethod remove-subviews ((v ns:ns-view) &rest subviews)
  (loop for subv in subviews do
    (if (eq v (view-container subv))
      (#/removeFromSuperviewWithoutNeedingDisplay subv)
      (break "~%can't remove ~a from subviews of ~a" subv v)))
  (subviews v))

(defmethod content-view-p ((v ns:ns-view))
  (and (view-window v) 
       (eql v (content-view (view-window v)))))

(defmethod view-size ((v ns:ns-view))
  (let ((r (#/frame v)))
    (make-point (ns:ns-rect-width r)
                (ns:ns-rect-height r))))

(defmethod set-view-size ((v ns:ns-view) width &optional height)
  (#/setFrameSize: v (if height
                       (ns:make-ns-size width height)
                       (ns:make-ns-size (point-x width) (point-y width)))))

(defmethod view-position ((v ns:ns-view))
  (let ((r (#/frame v)))
    (make-point (ns:ns-rect-x r)
                (ns:ns-rect-y r))))

(defmethod set-view-position ((v ns:ns-view) x &optional y)
  (#/setFrameOrigin: v (if y
                         (ns:make-ns-point x y)
                         (ns:make-ns-point (point-x x) (point-y x)))))

(defmethod view-bounds ((v ns:ns-view))
  (let ((r (#/bounds v)))
    (values (ns:ns-rect-x r)
            (ns:ns-rect-y r)
            (ns:ns-rect-width r)
            (ns:ns-rect-height r))))

(defmethod set-view-bounds ((v ns:ns-view) x y width height)
  (#/setBounds: v (ns:make-ns-rect x y width height)))

(defmethod local-to-global ((view ns:ns-view) x &optional y)
  (let ((global (#/convertPointToBase: 
                 view (if y
                        (ns:make-ns-point x y)
                        (ns:make-ns-point (point-x x) (point-y x))))))
    (make-point (ns:ns-point-x global)
                (ns:ns-point-y global))))

(defmethod global-to-local ((view ns:ns-view) x &optional y)
  (let ((local (#/convertPointFromBase: 
                 view (if y
                        (ns:make-ns-point x y)
                        (ns:make-ns-point (point-x x) (point-y x))))))
    (make-point (ns:ns-point-x local)
                (ns:ns-point-y local))))


;;; methods for NS:NS-WINDOW

(defmethod window-center ((w ns:ns-window))
  (#/center w))

(defmethod window-show ((w ns:ns-window))
  (#/makeKeyAndOrderFront: w nil)
  w)

(defmethod window-close ((w ns:ns-window))
  (#/close w))

(defun window-select (w)
  (window-show w))

(defmethod window-title ((w ns:ns-window))
  (ccl::lisp-string-from-nsstring (#/title w)))

(defmethod set-window-title ((w ns:ns-window) new-title)
  (let (nsstring)
    (unwind-protect 
        (progn
          (setq nsstring (make-instance 'gui::ns-lisp-string :string new-title))
          (#/setTitle: w nsstring))
      (when nsstring (ccl::send nsstring 'dealloc))))
  new-title)

(defmethod window-position ((w ns:ns-window))
  (let ((r (#/frame w)))
    (make-point (ns:ns-rect-x r)
                (ns:ns-rect-y r))))

(defmethod set-window-position ((w ns:ns-window) x &optional y)
  (#/setFrameOrigin: w (if y
                         (ns:make-ns-point x y)
                         (ns:make-ns-point (point-x x) (point-y x)))))
  ;; if using setFrameOrigin, then the position is at the bottom-left
  ;; if using setFrameTopLeftPoint, then the position is at the top-left


; window sizes are in terms of the size of their content area -- not including
; the titlebar

(defmethod window-size ((w ns:ns-window))
  (let ((r (#/frame w)))
    (make-point (ns:ns-rect-width r)
                (- (ns:ns-rect-height r) +title-bar-height+))))

(defmethod set-window-size ((w ns:ns-window) width &optional height)
  (let ((pos (window-position w)))
    (#/setFrame:display: w 
                         (ns:make-ns-rect 
                          (point-x pos) (point-y pos)
                          (if height width (point-x width))
                          (+ +title-bar-height+ (if height height (point-y width))))
                         t)))

(defmethod content-view ((w ns:ns-window))
  (#/contentView w))

(defmethod set-content-view ((w ns:ns-window) (new-content-view ns:ns-view))
  (#/setContentView: w new-content-view))

(defmethod (setf content-view) (new-content-view (w ns:ns-window))
  (#/setContentView: w new-content-view))


(defclass MCLGUI-COCOA-VIEW (ns:ns-view)
  ((clos-ref :accessor clos-ref))
  (:metaclass ns:+ns-object))

(defclass VIEW ()
  ((cocoa-ref :accessor cocoa-ref)))

(defmethod view-draw-contents ((view view)))   ;default draws nothing

(objc:defmethod (#/drawRect: :void) ((cocoa-view mclgui-cocoa-view) (rect :<NSR>ect))
  (view-draw-contents (clos-ref cocoa-view)))

(objc:defmethod (#/isFlipped :boolean) ((view mclgui-cocoa-view))
  t)

(defmethod initialize-instance ((v view) &key 
                                view-container 
                                view-size
                                view-position
                                view-subviews)
  (easygui::running-on-main-thread ()
  (call-next-method)
  (setf (cocoa-ref v) (make-instance 'mclgui-cocoa-view))
  (setf (slot-value (cocoa-ref v) 'clos-ref) v)
;  (setf (clos-ref (cocoa-ref v)) v)
  (when view-container (set-view-container v view-container))
  (when view-size (set-view-size v view-size))
  (when view-position (set-view-position v view-position))
  (apply #'add-subviews v view-subviews)                                
  v))

(defmacro with-focused-view (view &body forms)
  (let ((cocoa-view (gensym)))
    `(if (null ,view)
       (progn ,@forms)
       (let ((,cocoa-view (cocoa-ref ,view)))
         (when (#/lockFocusIfCanDraw ,cocoa-view)
           (unwind-protect
               (progn ,@forms)
             (#/unlockFocus ,cocoa-view)))))))
;             (#/flushGraphics (#/currentContext ns:ns-graphics-context))
;             (#/flushWindow (#/window ,cocoa-view))))))))

;; most of the following methods for view just pass on the cocoa-view associated 
;; with the view to analogous method for ns:ns-view.  they take care to return
;; clos values rather than cocoa-values. 

(defmethod subviews ((v view))
  (mapcar #'clos-ref (subviews (cocoa-ref v))))

(defmethod add-subviews ((v view) &rest subviews)
  (mapcar #'clos-ref 
          (apply #'add-subviews (cocoa-ref v) (mapcar #'cocoa-ref subviews)))) 

(defmethod remove-subviews ((v view) &rest subviews)
  (mapcar #'clos-ref 
          (apply #'remove-subviews (cocoa-ref v) (mapcar #'cocoa-ref subviews))))

(defmethod view-window ((v view))
  (let ((cocoa-window (view-window (cocoa-ref v))))
    (when cocoa-window (clos-ref cocoa-window))))

(defmethod view-container ((v view)) 
  (and (typep (view-container (cocoa-ref v)) 'mclgui-cocoa-view)
       (clos-ref (view-container (cocoa-ref v)))))

(defmethod set-view-container ((v view) (new-container view))
  (set-view-container (cocoa-ref v) (cocoa-ref new-container)))

(defmethod content-view-p ((v view)) 
  (content-view-p (cocoa-ref v)))

(defmethod view-size ((v view)) 
  (view-size (cocoa-ref v)))

(defmethod set-view-size ((v view) width &optional height) 
  (set-view-size (cocoa-ref v) width height))

(defmethod view-position ((v view)) 
  (view-position (cocoa-ref v)))

(defmethod set-view-position ((v view) x &optional y) 
  (set-view-position (cocoa-ref v) x y))

(defmethod view-bounds ((v view)) 
  (view-bounds (cocoa-ref v)))

(defmethod set-view-bounds ((v view) x y width height)
  (set-view-bounds (cocoa-ref v) x y width height))

(defmethod local-to-global ((v view) x &optional y) 
  (local-to-global (cocoa-ref v) x y))

(defmethod global-to-local ((v view) x &optional y) 
  (global-to-local (cocoa-ref v) x y))


(defclass MCLGUI-COCOA-WINDOW (ns:ns-window)
  ((clos-ref :accessor clos-ref))
  (:metaclass ns:+ns-object))

(defclass WINDOW ()
  ((cocoa-ref :accessor cocoa-ref)))

(defvar *windows* nil "global list of all open windows, in recently-selected order")

(defmethod window-size-parts ((window window))) ;default does nothing

(objc:defmethod (#/windowDidResize: :void) ((w mclgui-cocoa-window) (notification :id))
  (window-size-parts (clos-ref (#/object notification))))

(defmethod window-will-close ((window window))
  "hook into window closing events"
  (setf (cocoa-ref window) nil)
  (setq *windows* (remove window *windows*)))

(objc:defmethod (#/windowWillClose: :void) ((w mclgui-cocoa-window) (notification :id))
  (window-will-close (clos-ref (#/object notification))))

(defmethod window-did-become-key ((window window))
  "hook into window selecting events"
  (setq *windows* (remove window *windows*))
  (push window *windows*))

(objc:defmethod (#/windowDidBecomeKey: :void) ((w mclgui-cocoa-window) (notification :id))
  (window-did-become-key (clos-ref (#/object notification))))

(defun front-window (&key (class t))
  (first (windows :class class)))

(defun windows (&key (class t))
  (remove-if-not (lambda (w) (typep w class))
                 *windows*))

(defun target ()
  (front-window))

(defun find-window (title &optional (class t))
  (find-if 
   (lambda (w) (string-equal title (window-title w)))
   (windows :class class)))

(defun map-windows (fn &key (class t))
  (mapcar fn (windows :class class)))

(defun content-views (&key (class t))
  (remove-if-not (lambda (v) (typep v class))
                 (map-windows #'content-view)))

(defun front-content-view (&key (class t))
  (first (content-views :class class)))

(defun find-content-view (title &optional (class t))
  (find-if 
   (lambda (v) (string-equal title (window-title (view-window v))))
   (content-views :class class)))

(defmethod initialize-instance ((w window) &key
                                (view-size (make-point 400 200))
                                window-title
                                (window-type :document-with-zoom)
                                (window-do-first-click nil)
                                content-view
                                (close-box-p t))
  (declare (ignore window-type window-do-first-click))
  (call-next-method)
  (let ((content-rect  (ns:make-ns-rect 0 0 (point-h view-size) (point-v view-size)))
        (style-mask (logior #$NSTitledWindowMask 
                            #$NSMiniaturizableWindowMask
                            #$NSResizableWindowMask))
        (backing #$NSBackingStoreBuffered)
        (defer t))
    (when close-box-p (setq style-mask (logior style-mask #$NSClosableWindowMask)))
    (setf (cocoa-ref w) 
          (make-instance 'mclgui-cocoa-window
            :with-content-rect content-rect
            :style-mask style-mask
            :backing backing
            :defer defer)))
  (setf (clos-ref (cocoa-ref w)) w)
  (set-content-view w (or content-view (make-instance 'view :view-size view-size)))
  (assert (typep (content-view w) 'view))
  (set-window-title w (or window-title "Untitled"))
  (window-center w)
  (#/setDelegate: (cocoa-ref w) (cocoa-ref w)))



;; the following methods for window just pass on to the analogous methods 
;; for ns:ns-window
            
(defmethod window-center ((w window)) (window-center (cocoa-ref w)))
(defmethod window-close ((w window)) (window-close (cocoa-ref w)))
(defmethod window-show ((w window)) (window-show (cocoa-ref w)))
(defmethod window-title ((w window)) (window-title (cocoa-ref w)))
(defmethod set-window-title ((w window) new-title) 
  (set-window-title (cocoa-ref w) new-title))
(defmethod window-position ((w window)) (window-position (cocoa-ref w)))
(defmethod set-window-position ((w window) x &optional y) 
  (set-window-position (cocoa-ref w) x y))
(defmethod window-size ((w window)) (window-size (cocoa-ref w)))
(defmethod set-window-size ((w window) width &optional height) 
  (set-window-size (cocoa-ref w) width height))

(defmethod content-view ((w window)) 
  (clos-ref (content-view (cocoa-ref w))))

(defmethod set-content-view ((w window) (new-content-view view))
  (set-content-view (cocoa-ref w) (cocoa-ref new-content-view)))

(defmethod (setf content-view) (new-content-view (w window))
  (set-content-view (cocoa-ref w) (cocoa-ref new-content-view)))



(defmethod window-show ((v view))
  (when (view-window v)
    (window-show (view-window v))))
;;;;;;;;;;;;;;;;;;;

(defmethod set-needs-display ((v view) bool)
  (#/setNeedsDisplay: (cocoa-ref v) bool))

(defun stroke-line (v x1 y1 x2 y2)
  (with-focused-view v
    (let ((path (#/bezierPath ns:ns-bezier-path)))
      (#/moveToPoint: path (ns:make-ns-point x1 y1))
      (#/lineToPoint: path (ns:make-ns-point x2 y2))
      (#/stroke path))))

(defun stroke-oval-r (v x y width height &optional color)
  (with-focused-view v
    (when color (#/set color))
    (let ((path (#/bezierPathWithOvalInRect: ns:ns-bezier-path 
                                             (ns:make-ns-rect x y width height))))
      (#/setLineWidth: path 0)
      (#/stroke path))))

(defun stroke-line (v x1 y1 x2 y2 &optional color)
  (with-focused-view v
    (when color (#/set color))
    (#/strokeLineFromPoint:toPoint: ns:ns-bezier-path
                                    (ns:make-ns-point x1 y1)
                                    (ns:make-ns-point x2 y2))))


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

(defun draw-text (v text x y)
  (with-focused-view v
    (#/drawAtPoint:withAttributes: 
     (make-instance 'gui::ns-lisp-string :string text)
     (ns:make-ns-point x y)
     +null-ptr+)))
     
(defun stroke-rect-r (v x y width height &optional color)
  (with-focused-view v
    (when color (#/set color))
    (#/strokeRect: ns:ns-bezier-path (ns:make-ns-rect x y width height))))

(defun fill-rect-r (v x y width height &optional color)
  (with-focused-view v
    (when color (#/set color))
    (#/fillRect: ns:ns-bezier-path (ns:make-ns-rect x y width height))))


(defun color-rgb (r g b &optional (alpha 1))
  (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color r g b alpha))

(defun set-color (v color)
  (with-focused-view v
    (#/set color)))

(defclass my-view (view) ())

(defmethod view-draw-contents ((view my-view))
  (fill-rect-r view 10 10 50 50 (color-rgb 0 0 1)))

#|
(#/boundingRectWithSize:options:attributes: 
 #@"test string" (ns:make-ns-size 0 0) 0 +null-ptr+)

(#/sizeWithAttributes: #@"test string" +null-ptr+)



(progn (#_NSWindowList 10 ap) a)
(multiple-value-bind (la lap)
                     (make-heap-ivector 10 '(unsigned-byte 64))
        (setq a la)
        (setq ap lap)
  (values))

(set-view-bounds w 0 0 30 50)
(setq w (make-instance 'window))
(window-close w)
(setq c (color-rgb 0 1 0 1))
(set-color v c)
(#/redColor ns:ns-color)
(stroke-line v 20 20 30 40 (color-rgb 1 0 0))
(draw-text v "foo" 5 20)
(stroke-oval-r w 20 20 10 10 (color-rgb 1 0 1))
(fill-rect-r w 100 100 300 100 (color-rgb 0.6 0.5 0.3)))
(setq clos-v (make-instance 'my-view))
(set-content-view w (make-instance 'my-view))
(view-draw-contents clos-v)
(window-show w)
(setq v (content-view w))
(setq v2 (make-instance 'ns:ns-view))
(inspect w)
(inspect clos-v)
(add-subviews v v2)
(#/count (#/subviews v))
(#/objectAtIndex: (#/subviews v) 0)
(set-window-title w "foo")
(window-title w)
(subviews v2)
(#/frame w)
(window-size w)
(view-size w)
(window-position w)
(view-position v)
(#/setFrameOrigin: w (ns:make-ns-point 10 10))
(set-window-position w 20 2)
(set-window-size w 40 40)
(set-view-position v 0 0)
(set-view-size v2 100 125)
(setq bv (make-instance 'box-view
                 :position (point 15 59)
                 :size (point 35 35)))
(easygui::view-size w)
(#/title (cocoa-ref w))
(view-bounds v2)
|#
'done