;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Draggable demo for Clozure Common Lisp
;;;
;;;  Written by Ron Garret, released into the public domain
;;;
;;;  Revision history:
;;;  6/8/09 - rg - Replaced tracking area with tracking rect, now works in 32-bit, and should
;;;           work on Tiger as well.  Bug fix for highlighted mixin: initialize-instance
;;;           shoule be shared-initialize (I think -- still a subtle bug somehwere: have
;;;           to click once before mouse enter and leave events handled properly)
;;;
(in-package :cl-user)

(require :cocoa)
(require :utilities)

(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 h w) (ns:make-ns-rect x y w h))

;;; Windows

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

(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))

(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)))

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

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

;;; Views

(define-class view ns-view subviews parent)
(define-objc-class (standard-view ns:ns-view) wrapper)

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

(define-method (size (v view ns-view)) (#/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 (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))

;;; 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)))))

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

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

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

;;; Events

(defmacro define-event-type (ns-event method-name)
  `(progn
     (ccl::define-objc-method ((:void ,ns-event (:id event)) standard-view)
       (with-slots (wrapper) self
         (,method-name wrapper (#/locationInWindow event))))
     (define-method (,method-name (v view) loc)
       (declare (ignore loc))
       (values))))

(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) standard-view) #$YES)

;;; Subviews

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

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

(define-method (add-subview (w window subviews) sv)
  (remove-from-parent sv)
  (push sv subviews)
  (#/addSubview: (#/contentView (window-ns-window w)) (view-ns-view sv))
  (setf (view-parent sv) 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))
   (setf loc0 loc)))

;;; 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))


#|
;;; Demo

(setf times-48-italic
      (#/convertFont:toHaveTrait:
       (#/sharedFontManager ns:ns-font-manager)
       (#/fontWithName:size: ns:ns-font #@"Times New Roman" 48.0)
       #$NSItalicFontMask))
(setf d (make-instance ns:ns-mutable-dictionary))
(#/setValue:forKey: d times-48-italic #@"NSFont")

(define-class (testview text-view))
(setf w (make-window :title "Test"))
(setf v (make-testview :text #@"Lisp Rules!" :style d))
(add-subview w v)

; This is the cool part
(define-class (testview draggable text-view))
(define-class (testview highlighted draggable text-view))

; Just for fun
(rotate v 45.0)
|#