;; Allow the use of OS X window attributes, e.g., metal
;; Copyright 2003 AgentSheets Inc.
;; Alexander Repenning, December 12, 2003
;; updates: 
;; 12/13/03 make all MCL built in dialogs works: erase-while-live-resize-p defaults to t
;;          incorporate windoid-modality-patch to window-make-parts
;;          remove print statement preventing save-application from working    
;; 01/06/03 eliminate need for QuickDraw, suggested by Takehiko Abe           

(in-package :ccl)


;; Live window resize


(defgeneric WINDOW-BOUNDS-CHANGED-EVENT-HANDLER (view)
  (:documentation "Called during a live resize each time a window/windoid changes size"))


(defmethod WINDOW-BOUNDS-CHANGED-EVENT-HANDLER ((Self view))
  ;;; do nothing
  )


(defgeneric WINDOW-MINIMAL-GROW-SIZE (view)
  (:documentation "in: View, out: Point, minimal size of view"))


(defmethod WINDOW-MINIMAL-GROW-SIZE ((Self view))
  #@(24 24))


(let ((*Warn-If-Redefine-Kernel* nil))
(defmethod WINDOW-GROW-EVENT-HANDLER ((Self window) Where)
  (let ((Delta-Size (add-points (view-position Self) (subtract-points (view-size Self) Where)))
        (Minimal-Size (window-minimal-grow-size Self))
        (Last-Position nil))
    (with-focused-view Self
      (loop
        ;; resize
        (when (not (mouse-down-p)) 
          (return))
        (let ((Position (view-mouse-position Self)))
          (setq Position (make-point (max (point-h Position) (point-h Minimal-Size))
                                     (max (point-v Position) (point-v Minimal-Size))))
          (when (and (shift-key-p) Last-Position)         ;; use shift key as modifier to constrain vertical size
            (setq Position (make-point (point-h Position) (point-v Last-Position))))
          (when (not (equal Position Last-Position))
            (setq Last-Position Position)
            (let ((New-Size (add-points Position Delta-Size)))
              (unwind-protect
                (progn
                  (#_DisableScreenUpdates)
                  (set-view-size Self (point-h New-Size) (point-v New-Size))
                  ;; give window content a chance to adjust to new size
                  (window-bounds-changed-event-handler Self)
                  ;; erase content to be on the save side
                  (when (erase-while-live-resize-p Self)
                    (rlet ((r :rect :topleft #@(0 0) :bottomright (view-size Self))) (#_EraseRect r)))
                  (view-draw-contents Self))
                (#_QDFlushPortBuffer (#_GetWindowPort (wptr Self)) (%null-ptr))
                (#_EnableScreenUpdates))))))))))



;; missing in header files

(defconstant $kDrawerWindowClass 20)

(defconstant $kWindowCompositingAttribute 524288)

(defconstant $kWindowMetalAttribute 256)



;; Patching l1-windows.lisp

(defclass window (view)
  ((window-cursor :allocation :class :reader window-cursor)
   (window-grow-rect :allocation :class :reader window-grow-rect)
   (window-drag-rect :allocation :class :reader window-drag-rect)

   (color-list :initform nil :reader window-color-list)
   (back-color :initform nil)
   (object-name :initform nil)
   (my-item :initform nil)
   (grow-icon-p :initform nil :reader window-grow-icon-p)
   (window-do-first-click :initform nil :accessor window-do-first-click
                          :initarg :window-do-first-click)
   (window-active-p :initform nil :accessor window-active-p)
   (window-erase-region :initform (#_NewRgn) :accessor window-erase-region)
   (window-invalid-region :initform nil :accessor window-invalid-region)
   (process :initform nil :initarg :process :accessor window-process)
   (queue :initform (make-process-queue "Window") :reader window-process-queue)
   (auto-position :initarg :auto-position :initform :noAutoCenter)
   (attributes :accessor attributes :initform 0 :initarg :attributes)
   (erase-while-live-resize-p :accessor erase-while-live-resize-p :initform t :initarg :erase-while-live-resize-p)))


(let ((*Warn-If-Redefine-Kernel* nil))
(defun %new-window (type position size close-box-p visible-p color-p attributes)
  ;Leaves the procid in RefCon.
  (unless (fixnump type)
    (setq type (or (cdr (assoc type *window-type-procid-alist*))
                   (report-bad-arg type *window-type-foos*))))
  (setq position (center-window size position))
  (if (not (osx-p))
    (rlet ((wrect :rect :topleft position :bottomright (add-points-16 position size))
           (tp (:string 2)))
      (%put-word tp #x0120)
      (let ((res (if (and color-p *color-available*)
                   (#_NewCWindow 
                    (%null-ptr)
                    wrect                            ; bounds
                    tp                               ; blank title
                    visible-p                        ; visible
                    type                             ; procid
                    #-carbon-compat  ;; i dont think this is necessary - well if window isn't going to be shown it is, and elsewise doesn't hurt
                    (%int-to-ptr -1)                 ; behind  -1 means firstwindowofclass, 0 aka null-ptr means last
                    #+carbon-compat                  
                    (%null-ptr)
                    close-box-p                      ; goAwayFlag
                    type                             ; refCon
                    )
                   (#_NewWindow
                    (%null-ptr) 
                    wrect                            ; bounds
                    tp                               ; blank title
                    visible-p                        ; visible
                    type                             ; procid
                    #-carbon-compat
                    (%int-to-ptr -1)                 ; behind
                    #+carbon-compat
                    (%null-ptr)
                    close-box-p                      ; goAwayFlag
                    type                             ; refCon
                    ))))
        (if (%null-ptr-p res)
          (%err-disp #$MemFullErr)
          (progn (set-wptr-modified res nil)
                 res))))
    #-ignore
    (new-new-window type position size close-box-p visible-p attributes)
    #+ignore
    (prog ((tries 0)
           (got-pos))  ;; this is too disgusting to believe
      (declare (ignore-if-unused tries))
      again
      (rlet ((wrect :rect :topleft position :bottomright (add-points-16 position size))
             (tp (:string 2)))
        (%put-word tp #x0120)
        (let ((res (if (and color-p *color-available*)
                     (#_NewCWindow 
                      (%null-ptr)
                      wrect                            ; bounds
                      tp                               ; blank title
                      visible-p                        ; visible
                      type                             ; procid
                      #-carbon-compat  ;; i dont think this is necessary - well if window isn't going to be shown it is, and elsewise doesn't hurt
                      (%int-to-ptr -1)                 ; behind  -1 means firstwindowofclass, 0 aka null-ptr means last
                      #+carbon-compat                  
                      (%null-ptr)
                      close-box-p                      ; goAwayFlag
                      type                             ; refCon
                      )
                     (error "shouldnt"))))
          (if (%null-ptr-p res)
            (%err-disp #$MemFullErr))        
          (rlet ((contrect :rect))
            (get-cont-rect res contrect)
            (setq got-pos (pref contrect :rect.topleft)))
          ;; if its not where we requested, dump it and try again, for awhile anyway (problem specific to OSX native)
          (if (not (eql got-pos position))  ;; trying this instead
            (#_movewindow res (point-h position)(point-v position) nil))
          (return  res)
          #+ignore
          (if (or (eql got-pos position)(> tries 4)) (return res)
              (progn (incf tries)(#_disposewindow res)(go again)))
          ))))))



(let ((*Warn-If-Redefine-Kernel* nil))
(defmethod window-make-parts ((window window)
                             &key (view-position (view-default-position window) pos-p)
                             (view-size (view-default-size window) size-p)
                             (window-type :document-with-zoom wtype-p)
                             back-color
                             content-color
                             theme-background
                             procid
                             (window-title  "Untitled")
                             (close-box-p t)
                             (color-p t)
                             (grow-icon-p nil gip?))
 (unless (wptr window)
   (if procid (setq gip? nil grow-icon-p nil))
   (when gip?
     (if grow-icon-p
       (cond ((eq window-type :document) (setq window-type :document-with-grow))
             ((eq window-type :windoid) (setq window-type :windoid-with-grow))
             ((eq window-type :windoid-side)(setq window-type :windoid-side-with-grow))
             ((eq window-type :windoid-with-zoom)(setq window-type :windoid-with-zoom-grow))
             ((eq window-type :windoid-side-with-zoom)(setq window-type :windoid-side-with-zoom-grow))
             ((not (memq  window-type '(:document-with-grow :document-with-zoom
                                        :windoid-with-grow :windoid-with-zoom-grow :windoid-side-with-grow
                                        :windoid-side-with-zoom-grow)))
              (setq gip? nil grow-icon-p nil)))
       (cond ((eq window-type :document-with-grow) (setq window-type :document))
             ((eq window-type :document-with-zoom) (setq window-type :document-with-zoom-no-grow))
             ((eq window-type :windoid-with-grow) (setq window-type :windoid))
             ((eq window-type :windoid-side-with-grow)(setq window-type :windoid-side))
             ((eq window-type :windoid-side-with-zoom-grow)(setq window-type :windoid-side-with-zoom))
             ;; this is wrong?
             ((not (memq window-type '(:document :document-with-zoom)))
              (setq gip? nil grow-icon-p nil)))))
   (when wtype-p
     (when (and (not (typep window 'windoid)) (memq window-type *windoid-types*))
       ;(error "Need to make a windoid for window-type ~s." window-type)
       (change-class window 'windoid)
       (when (not pos-p)(setq view-position (view-default-position window)))
       (when (not size-p)(setq view-size (view-default-size window)))
       )
     (when (and (typep window 'windoid)(not (memq window-type *windoid-types*)))
       (when (memq window-type '(:double-edge-box))(SETQ WINDOW-TYPE :single-edge-box))  ;; weird works on OS9 but not on OSX - why does gc thermo work?
       ;(report-bad-arg window-type (cons 'member *windoid-types*))
       ))
   (let* ((wptr (%new-window (or procid window-type)
                             view-position
                             view-size
                             close-box-p
                             nil
                             color-p
                             (attributes Window)))
          (procid #-carbon-compat (rref wptr windowrecord.refCon) #+carbon-compat (#_getwrefcon wptr)))   ; %new-window leaves it there
     (setf (wptr window) wptr)
     #+ignore ;; - too slow
     (when (and nil (not pos-p) (eql view-position *window-default-position*))
       (set-view-position window #@(-3000 -3000))
       (window-show window)
       (let ((left-border (window-border-width window))
             (title-height (window-title-height window)))
         (window-hide window)
         (set-view-position window (make-point (max (1+ left-border)(point-h view-position))
                                               (max (+ title-height 2 (menubar-height)) (point-v view-position))))))
     (progn
       (set-window-title window window-title)  ;; somehow window-title louses up position of windoid by 4 pixels vertically - dunno why
       (if (and (osx-p)(typep window 'windoid)(integerp view-position))(set-view-position window view-position)))
     (setf (slot-value window 'grow-icon-p)
           (if gip? grow-icon-p (memq procid  *grow-procids*)))
     (when content-color  ;; is this used for anything?
       (set-part-color window :content content-color)
       ;(set-part-color window :title-bar *white-color*) doesnt help
       )
     (when back-color
       (setf (slot-value window 'back-color) back-color)  ; <<
       (set-back-color window back-color))
     (when (and theme-background (osx-p))
       (view-put window 'theme-background
                 (if (eq theme-background t)
                   (setq theme-background #$kThemeBrushModelessDialogBackgroundActive)
                   theme-background))
       (#_SetThemeWindowBackground wptr theme-background t))
     (when (and (osx-p)
                close-box-p
                (not (typep window 'windoid))
                (not (slot-value window 'grow-icon-p))
                (not (wptr-dialog-p wptr)))
       (Set-bubble-attributes window #$kWindowCollapseBoxAttribute))

     #+carbon-compat
     (if (typep window 'windoid)
       (progn (#_setwindowclass wptr #$kFloatingWindowClass )
              (when (not (memq window-type *windoid-types*))(setwindowmodality wptr #$kwindowmodalitynone)))
       (when (and (wptr-dialog-p wptr)) ;(find-class 'drag-receiver-dialog nil)(typep window 'drag-receiver-dialog))
         ; make it non-modal till actually used modally - for IFT or for everybody
         (#_setwindowclass wptr #$kDocumentWindowClass )  ;; do we really need both of these?
         (setwindowmodality wptr #$kWindowModalityNone)
         ))))))



(let ((*Warn-If-Redefine-Kernel* nil))
(defun new-new-window (type position size close-box-p visible-p attributes)

  (let ((wclass nil) (wattrs 0) (the-window nil) (err nil))
   
    ;; decode the type to calculate class and attributes
    
    (case type
      ((#.#$documentProc #.#$rdocproc)
       (setf wclass #$kDocumentWindowClass
             wattrs (logior #$kWindowResizableAttribute #$kWindowCollapseBoxAttribute )))
      (#.#$dBoxProc
       (setf wclass #$kAlertWindowClass
             wattrs 0))
      ((#.#$plainDBox #.#$kWindowSimpleProc)
       (setf wclass #$kAlertWindowClass
             wattrs 0))
      (#.#$altDBoxProc
       (setf wclass #$kAlertWindowClass
             wattrs 0))
      (#.#$noGrowDocProc
       (setf wclass #$kDocumentWindowClass
             wattrs 0))
      (#.#$movableDBoxProc
       (setf wclass #$kMovableAlertWindowClass ; doesn't work - err -5601 see fix below
             wattrs 0))
      (#.#$zoomDocProc
       (setf wclass #$kDocumentWindowClass
             wattrs (logior #$kWindowResizableAttribute
                            #$kWindowCollapseBoxAttribute
                            #$kWindowFullZoomAttribute)))
      (#.#$zoomNoGrow
       (setf wclass #$kDocumentWindowClass
             wattrs #$kWindowFullZoomAttribute))
      (#.#$floatProc
       (setf wclass #$kFloatingWindowClass
             wattrs 0))
      (#.#$floatGrowProc
       (setf wclass #$kFloatingWindowClass
             wattrs #$kWindowResizableAttribute))
      (#.#$floatZoomProc
       (setf wclass #$kFloatingWindowClass
             wattrs #$kWindowFullZoomAttribute))
      (#.#$floatZoomGrowProc
       (setf wclass #$kFloatingWindowClass
             wattrs (logior #$kWindowResizableAttribute
                            #$kWindowFullZoomAttribute)))
      (#.#$floatSideProc
       (setf wclass #$kFloatingWindowClass
             wattrs #$kWindowSideTitlebarAttribute))
      (#.#$floatSideGrowProc
       (setf wclass #$kFloatingWindowClass
             wattrs (logior #$kWindowSideTitlebarAttribute
                            #$kWindowResizableAttribute)))
      (#.#$floatSideZoomProc
       (setf wclass #$kFloatingWindowClass
             wattrs (logior #$kWindowSideTitlebarAttribute
                            #$kWindowFullZoomAttribute)))
      (#.#$floatSideZoomGrowProc
       (setf wclass #$kFloatingWindowClass
             wattrs (logior #$kWindowSideTitlebarAttribute
                            #$kWindowResizableAttribute
                            #$kWindowFullZoomAttribute))))
    ;(print (list wclass type))
    (when (null wclass)
      (error "unknown window class ~D" type))

    (when (and close-box-p 
               (not (memq type *dialog-procids*))) ;'#.(list #$movabledboxproc #$dboxproc))))
      (setf wattrs (logior wattrs #$kWindowCloseBoxAttribute)))
   
    (rlet ((wrect :rect :topleft 0 :bottomright size)
           (low-window :Ptr))
     
      ;; create the window
      (setf err (#_CreateNewWindow wclass (logior wattrs attributes) wrect low-window))
      (unless (zerop err)
        (error "error ~D creating window" err))

      (setf the-window (%get-ptr low-window))
     
      ;; set onscreen position
      (#_MoveWindow the-window (point-h position) (point-v position) #$false)
     
      ;; show, if needed - I think visible-p is always nil
      (when visible-p
        (#_ShowWindow the-window)
        (#_SelectWindow the-window)))
    (set-wptr-modified the-window nil)

    (#_SetWRefCon the-window type)

    the-window)))


#| Examples:

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

(defparameter *Metal-Window* (make-instance 'window 
                               :attributes (logior $kWindowMetalAttribute $kWindowCompositingAttribute)
                               :erase-while-live-resize-p nil))



|#