;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Ron Garret's Cocoa utilities for Clozure Common Lisp
;;;
;;;  Written by Ron Garret, released into the public domain
;;;
(in-package :cl-user)

(require :cocoa)
(require :rg-utils)

(defun nsstr (s) (make-instance gui::ns-lisp-string :string s))
(defun nspoint (x y) (ns:make-ns-point x y))
(defun nssize (w h) (ns:make-ns-size w h))
(defun nsrect (x y w h) (ns:make-ns-rect x y w h))
(defun nsrect-size (r) (nssize (ns:ns-rect-width r) (ns:ns-rect-height r)))

;;; Windows

(define-class window ns-window subviews :shared (x0 100) (y0 100))

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

(define-objc-class window-delegate target)

(objc:defmethod (#/windowWillClose: :void) ((self window-delegate) n)
  (declare (ignore n))
  (setf (slot-value (slot-value self 'target) 'ns-window) nil))

(define-method (show (w window ns-window))
  (#/orderFront: ns-window nil)
  w)

(define-method (hide (w window ns-window))
  (#/orderOut: ns-window nil)
  w)

(define-method (size (w window ns-window))
  (nsrect-size (#/bounds (#/contentView ns-window))))

(defun make-window (&key (title "Untitled") (width 640) (height 480)
                         (style-mask +standard-window-style-mask+))
  (bb
   nsw (make-instance 'ns:ns-window
         :with-content-rect (nsrect 0 0 width height)
         :style-mask style-mask
         :backing #$NSBackingStoreBuffered
         :defer t)
   (#/setTitle: nsw (nsstr title))
   w (make-instance 'window :ns-window nsw)
   (#/setDelegate: nsw (make-window-delegate :target w))
   (with-slots (x0 y0) w
     (#/cascadeTopLeftFromPoint: nsw (nspoint (incf x0 10) (incf y0 10))))
   (show w)))


;;; Views

(define-class view ns-view subviews superview)
(define-objc-class (wrapped-ns-view ns:ns-view) wrapper)

(define-method ((initialize-instance :after) (v view ns-view) &rest args)
  (declare (ignore args))
  (setf ns-view (make-instance 'wrapped-ns-view :wrapper v))
  (#/setFrameSize: ns-view (ns:make-ns-size 100 100)))

(define-method (size (v view ns-view))
  (nsrect-size (#/bounds ns-view)))

(define-method (set-size (v view ns-view) size &optional y)
  (if y (setf size (ns:make-ns-size size y)))
  (#/setFrameSize: ns-view size))

(defsetf size set-size)

(define-method (fill-superview (v view ns-view superview))
  (#/setAutoresizingMask: ns-view (logior #$NSViewHeightSizable #$NSViewWidthSizable))
  (if superview (#/setFrameSize: ns-view (size superview))))

(define-method (rotate-to (v view ns-view) angle)
  (#/setFrameRotation: (view-ns-view v) (float angle)))

(define-method (rotation (v view ns-view)) (#/frameRotation ns-view))

(define-method (rotate (v view ns-view) delta)
  (rotate-to v (+ (rotation v) delta)))

(define-method (move-to (v view ns-view) loc &optional y)
  (if y (setf loc (ns:make-ns-point loc y)))
  (#/setFrameOrigin: ns-view loc))

(define-method (frame (v view ns-view)) (#/frame ns-view))
(define-method (bounds (v view ns-view)) (#/bounds ns-view))

(define-method (show (v view ns-view)) (#/setHidden: ns-view #$NO))
(define-method (hide (v view ns-view)) (#/setHidden: ns-view #$YES))

;;; Drawing

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

(define-method (view-draw-contents (v view) &optional rect)
  (declare (ignore rect))
  v)

(objc:defmethod (#/drawRect: :void) ((self wrapped-ns-view) (rect ns:ns-rect))
  (with-slots (wrapper) self
    (with-focused-ns-view self (view-draw-contents wrapper rect))))

(define-method (refresh (v view ns-view)) (#/setNeedsDisplay: ns-view #$YES))

;;; Events

(defvar *current-event* nil)
(defvar *multi-click-count* nil)

(defmacro define-event-type (ns-event method-name)
  `(progn
     (define-method (,method-name (v view) loc)
       (declare (ignore loc))
       (values))
     (ccl::define-objc-method ((:void ,ns-event (:id event)) wrapped-ns-view)
       (with-slots (wrapper) self
         (let ((*current-event* event)
               ,@(if (eq ns-event :mouse-down) '((*multi-click-count* (#/clickCount event)))))
           (,method-name wrapper (#/convertPoint:fromView: self (#/locationInWindow event) nil)))))
     ))

(define-event-type :mouse-down view-click-event-handler)
(define-event-type :mouse-up view-mouse-up-event-handler)
(define-event-type :mouse-dragged view-drag-event-handler)

; These require adding a tracker
(define-event-type :mouse-entered view-mouse-enter-event-handler)
(define-event-type :mouse-moved view-mouse-move-event-handler)
(define-event-type :mouse-exited view-mouse-exit-event-handler)

#|
; Leopard-only
(define-method (add-tracker (v view ns-view))
  (#/addTrackingArea:
   ns-view
   (make-instance ns:ns-tracking-area :with-rect (#/bounds ns-view)
     :options (logior #$NSTrackingMouseEnteredAndExited
                      #$NSTrackingActiveWhenFirstResponder
                      #$NSTrackingActiveInKeyWindow
                      #$NSTrackingInVisibleRect
                      )
     :owner ns-view
     :user-info nil)))
|#

(define-method (add-tracker (v view ns-view))
  (#/addTrackingRect:owner:userData:assumeInside:
   ns-view (#/bounds ns-view) ns-view ccl::+null-ptr+ #$NO))

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

;;; Subviews

(define-method (remove-from-superview (v view ns-view superview))
  (when superview
    (#/removeFromSuperview (#/retain ns-view))
    (deletef v (slot-value superview 'subviews))
    (setf superview nil))
  (values))

(define-method (add-subview (v view ns-view subviews) (sv view superview))
  (remove-from-superview sv)
  (push sv subviews)
  (#/addSubview: ns-view sv)
  (setf superview v)
  (values))

(define-method (add-subview (w window subviews) (sv view superview))
  (remove-from-superview sv)
  (push sv subviews)
  (#/addSubview: (#/contentView (window-ns-window w)) (view-ns-view sv))
  (setf superview w)
  (values))

;;; Text

(define-class (text-view view) text style)

(define-method (view-draw-contents (v text-view ns-view text style) &optional rect)
  (declare (ignore rect))
  (when text
    (#/setFrameSize: ns-view (#/sizeWithAttributes: text style))
    (#/drawAtPoint:withAttributes: text (ns:make-ns-point 0 0) style)))

(define-method (set-text (v text-view text) s)
  (setf text (if (typep s ns:ns-string) s (nsstr s)))
  (refresh v))

(define-method (set-style (v text-view style) s)
  (setf style s)
  (refresh v))

;;; Draggable

(define-class draggable loc0)

(define-method (view-click-event-handler (v draggable loc0) loc)
  (setf loc0 loc))

(define-method (view-drag-event-handler (v draggable loc0) loc)
  (bb
   f (frame v)
   x0 (ns:ns-rect-x f)
   y0 (ns:ns-rect-y f)
   dx (- (ns:ns-point-x loc) (ns:ns-point-x loc0) )
   dy (- (ns:ns-point-y loc) (ns:ns-point-y loc0) )
   (move-to v (+ x0 dx) (+ y0 dy))
   ))

;;; Highlighted

(define-class highlighted border)

(define-method ((shared-initialize :after) (h highlighted) new-slots &rest args)
  (declare (ignore new-slots args))
  (add-tracker h))

(define-method (view-draw-contents (v highlighted border) &optional rect)
  (declare (ignore rect))
  (if border (#/strokeRect: ns:ns-bezier-path (bounds v)))
  (call-next-method))

(define-method (view-mouse-enter-event-handler (v highlighted border) loc)
  (declare (ignore loc))
  (setf border t)
  (refresh v))

(define-method (view-mouse-exit-event-handler (v highlighted border) loc)
  (declare (ignore loc))
  (setf border nil)
  (refresh v))

;;; PDF

(objc:load-framework "Quartz" :quartz)

(defun pdf-from-url (url)
  (make-instance ns:pdf-document :init-with-url
    (make-instance ns:ns-url :init-with-string url)))

(defun pdf-from-file (filename)
  (make-instance ns:pdf-document :init-with-data
    (make-instance ns:ns-data :init-with-contents-of-file (nsstr filename))))

(define-class (pdf-view view))
(define-objc-class (wrapped-pdf-view ns:pdf-view) wrapper)

(define-method ((initialize-instance :after) (v pdf-view ns-view) &rest args)
  (declare (ignore args))
  (setf ns-view (make-instance 'wrapped-pdf-view :wrapper v)))

(define-method (set-content (pv pdf-view ns-view) doc)
  (#/setDocument: ns-view doc))

(define-method (add-overlay (pv pdf-view) (overlay view))
  (bb
   scrollview (#/objectAtIndex: (#/subviews pv.ns-view) 0)
   clipview (#/objectAtIndex: (#/subviews scrollview) 0)
   mview (#/objectAtIndex: (#/subviews clipview) 0)
   dview (#/objectAtIndex: (#/subviews mview) 0)
   (#/addSubview: dview overlay.ns-view)
   (#/setAutoresizingMask: overlay.ns-view (logior #$NSViewHeightSizable #$NSViewWidthSizable))
   (#/setFrameSize: overlay.ns-view (nsrect-size (#/bounds dview)))
   (refresh pv)))

;;; Images

(define-class (image-view view) image)

(define-method (view-draw-contents (iv image-view image) &optional rect)
  (#/drawInRect:fromRect:operation:fraction: image rect rect #$NSCompositeCopy 1.0))

(define-method (set-content (iv image-view image) img)
  (setf image img)
  (set-size iv (#/size img))
  (refresh iv))

(defun image-from-url (url)
  (#/initWithContentsOfURL: (#/alloc ns:ns-image)
                            (#/URLWithString: ns:ns-url url)))

(defun image-from-file (filename)
  (make-instance ns:ns-image :init-with-data
    (make-instance ns:ns-data :init-with-contents-of-file (nsstr filename))))


(provide 'rg-cocoa-utils)