;; Zorphs -- interactive ZUI views
;;
;; Zorphs add to the regular zowie nodes:
;; - a damage notification system
;; - event dispatch and models
;; as well as assuming some basic functionality, like having
;; bounds and being in a graph.

(require 'srfi-1)

;; Zorphs have their own scene-graph, but share the rendering
;; protocol with nodes.
(define-class <zorph.base> (<zorph.mixin.viewed> <zorph.mixin.bounded>) (parent child-list model controller transform))

(define-method (initialize (zorph <zorph.base>) args)
  (initialize-slots zorph (list
                           'parent #f
                           'child-list '()
                           'model #f
                           'controller #f
                           'transform #f))
  (call-next-method))

(define (zorph-transform zorph)
  (slot-ref zorph 'transform))

(define (ensure-zorph-transform zorph)
  (let ((trans (zorph-transform zorph)))
    (or trans
        (let ((newtrans (make-transform)))
          (slot-set! zorph 'transform newtrans)
          newtrans))))

(define (zorph-translate zorph dx dy)
  (transform-translate (ensure-zorph-transform zorph) dx dy))

(define (zorph-scale zorph sx sy)
  (transform-scale (ensure-zorph-transform zorph) sx sy))

(define (zorph-rotate zorph theta)
  (transform-rotate (ensure-zorph-transform zorph) theta))

(define-method (bounds (zorph <zorph.base>))
  (let ((t (zorph-transform zorph)))
    (if t
        (rect-transform-to (call-next-method) t)
        (call-next-method))))

; This default ought to apply most of the time ..
(define-method (calculate-bounds (zorph <zorph.base>))
  (let ((children (zorph-children zorph)))
    (cond
    ((null? children)
     (bounds->rect 0 0 0 0))
    (else
      (fold rects-coalesce (bounds (car children)) (map bounds (cdr children)))))))

(define-method (invalidate-bounds (zorph <zorph.base>))
  (call-next-method)
  (let ((p (zorph-parent zorph)))
    (and p (invalidate-bounds p))))

; Render this node given the context
(define-method (render (node <zorph.base>)
                       context)
  (before-render node context)
  (paint node context)
  (after-render node context))

; A helper for painting within a clipping rectangle
(define (render-to-clip node context cliprect)
  (if (rects-overlap?
       (bounds node)
       cliprect) ; %%% transform cliprect by node transform?
       (render node context)))

(define-method (before-render (node <zorph.base>)
                              cairo)
  (let ((trans (zorph-transform node)))
    (cairo-save cairo)
    (and trans
         (cairo-concat-matrix cairo (transform-to trans)))))

(define-method (paint (zorph <zorph.base>) context)
  (for-each (lambda (x) (render x context)) ; %%% clip to bounds?
            (zorph-children zorph)))

(define-method (after-render (node <zorph.base>)
                             context)
  (cairo-restore context))

(define (zorph-parent zorph)
  (slot-ref zorph 'parent))

;; Primitive operation -- doesn't keep things
;; consistent.  Use zorph-child-add! instead.
(define (zorph-parent-set! zorph parent)
  (slot-set! zorph 'parent parent))

(define (zorph-child-add! zorph child)
  (slot-set-add! zorph 'child-list child)
  (zorph-parent-set! child zorph)
  (invalidate-bounds zorph)
  (invalidate-rect zorph (bounds child)))

(define (zorph-child-remove! zorph child)
  (slot-set-remove! zorph 'child-list child)
  (invalidate-bounds zorph)
  (zorph-parent-set! child #f))

(define (zorph-children zorph)
  (slot-ref zorph 'child-list))

(define-method (zorph-model (zorph <zorph.base>))
  (slot-ref zorph 'model))

(define-method (zorph-controller (zorph <zorph.base>))
  (slot-ref zorph 'controller))

(define-method (zorph-model-set! (zorph <zorph.base>) model)
  (let ((oldmodel (zorph-model zorph)))
    (and oldmodel (model-listener-remove! oldmodel zorph)))
  (slot-set! zorph 'model model) ; %%% need to?
  (model-listener-add! model zorph)
  (let ((contro (zorph-controller zorph)))
    (and contro (controller-model-set! contro model))))

(define-method (zorph-controller-set! (zorph <zorph.base>) controller)
  (controller-model-set! controller (zorph-model zorph))
  (slot-set! zorph 'controller controller))

(define-method (zorph-model-controller-set! (zorph <zorph.base>) model controller)
  (zorph-model-set! zorph model)
  (zorph-controller-set! zorph controller))

(define-method (handle-model-changed (zorph <zorph.base>) model)
  'do-nothing) ; or invalidate?

;; %%% Dodgio ---------------------------------------

; Consider not having a generic method here if I move
; transforms into zorphs
(define-method (transform-damage-rect (zorph <zorph.base>) rect)
  (let ((trans (zorph-transform zorph)))
    (if trans
        (rect-transform-fro rect (zorph-transform zorph)) ;; fro?
        rect)))

;; Get told about damage in your co-ord system
(define-method (notify-damage (zorph <zorph.base>) rect)
  (invalidate-rect zorph rect))

;; Get told about damage in a transformed co-ord system,
;; where you are doing the transforming; e.g., a camera's
;; view-transform
(define-method (notify-view-damage (zorph <zorph.base>) rect)
  ; If I'm viewing something, I probably have something
  ; I'm supposed to do with this rect first; so only likely
  ; to be useful if specialised
  (invalidate-rect zorph rect))

(define-method (invalidate-rect (zorph <zorph.base>) rect)
  (let ((trect (transform-damage-rect zorph rect))
        (parent (zorph-parent zorph)))
    (and parent (notify-damage parent trect))
    (for-each (lambda (vwr) (notify-view-damage vwr trect))
              (viewers zorph))))

(define-method (invalidate (zorph <zorph.base>))
  (invalidate-rect zorph (bounds zorph)))
;; ------------------------------------ %%% /Dodgio -

; Lens -- a portal view onto a canvas
; --------------------------------------------------

; The view
(define-class <zorph.lens> (<zorph.base>) ())

(define-method (initialize (lens <zorph.lens>) args)
  (call-next-method)
  (or (zorph-model lens)
       (zorph-model-set! lens (make <zowie.model.camera>))))

(define-method (calculate-bounds (lens <zorph.lens>))
  (let ((model (zorph-model lens)))
    (if model
        (rect-model-rect model)
        (call-next-method))))

(define-method (paint (lens <zorph.lens>) context)
  (cairo-save context)
  (let* ((model (zorph-model lens))
         (view (camera-model-view-transform model))
         (cbounds (bounds lens)) ; could be somewhat circular, if we don't have a bounds-model
         (ztrans (zorph-transform lens))
         (cliprect (if ztrans
                       (rect-transform-fro cbounds (zorph-transform lens))
                       cbounds)))
    (cairo-new-path context)
    (apply cairo-rectangle (cons context (rect->bounds cliprect)))
    (cairo-clip context)
    (cairo-identity-matrix context)
    (and view (cairo-concat-matrix context
                                   (transform-to view)))
    (for-each (lambda (x) (render-to-clip x context cliprect))
              (camera-model-layers model)))
  (cairo-restore context)
  (call-next-method))

(define-method (handle-model-changed (lens <zorph.lens>) model args)
  ;(display "Lens model changed ")(display args)(newline)
  (let ((newbounds (rect-model-rect model)))
    (if (null? args)
        'pass
        (let ((hint (car args)))
          (cond
            ((eq? hint 'bounds)
             (invalidate-bounds lens))
            ((eq? hint 'view-transform)
             'pass)
            ((eq? hint 'layers)
             (for-each
              (lambda (layer)
                (when (subclass? (class-of layer) <zorph.mixin.viewed>)
                  (viewer-add! layer lens)))
              (camera-model-layers model)))
            (else 'pass)))) ;; %%% or ignore?
    ;; %%% do we need call-next-method?
    ;; %%% what if the newbounds are smaller?
    (invalidate-rect lens newbounds)))

; --------------------------------------------------
;
; World zorph
; --------------------------------------------------

; First, a wee type to mask over the complication that we deal with
; SDL and Cairo -- we only really need SDL to blank the screen and
; flip the buffer.  For now, keep it extremely simple :-)
(define-record gfx-context sdl cairo)

(define (redraw world context)
  (let ((sdl (gfx-context-sdl context))
        (cairo (gfx-context-cairo context)))
    (sdl-fill-rect
     sdl
     (make-sdl-rect 0 0 (sdl-surface-width sdl) (sdl-surface-height sdl))
     (sdl-map-rgb (sdl-surface-pixel-format sdl) 0 0 0))
    (render world cairo)
    (sdl-flip sdl)))

; Default controller for the top-level -- deal with navigation
; events and pass the rest on.
; %%% Hack for now -- give it the graphics context for resizing etc.
(define-class <zorph.default.world-controller> (<zw.controller.base>) (gfx))

(define-method (handle-input-event (contro <zorph.default.world-controller>) event)
  (let ((t (sdl-event-type event)))
    (cond
      ((= t SDL_QUIT)
       'done)
      ((= t SDL_VIDEORESIZE)
       (let* ((gfx (slot-ref contro 'gfx))
              (model (controller-model contro))
              (w (sdl-event-w event))
              (h (sdl-event-h event))
              (cairo (gfx-context-cairo gfx))
              (sdl (sdl-set-video-mode w h 0 (+ SDL_HWSURFACE
                                                SDL_HWPALETTE
                                                SDL_DOUBLEBUF
                                                SDL_RESIZABLE))))
         (gfx-context-sdl-set! gfx sdl)
         (cairo-set-target-image cairo
                                 (sdl-surface-pixels sdl)
                                 CAIRO_FORMAT_RGB24 w h
                                 (sdl-surface-pitch sdl))
         (if (subclass? (class-of model) <zowie.model.rect>)
             (let* ((oldbounds (rect-model-rect model))
                    (tl (rect-topleft oldbounds)))
               (rect-model-set! model (point2d-x tl) (point2d-y tl) w h)))))
      ;;
      ;; %%% RESIZE, EXPOSE, all that jazz
      ;;
      ;; %%% Pass events along to the sub-zorphs
      (else
        'do-nothing))))

; The World Zorph -- the top-level, deals with the outside world
; weirdly enough.
(define-class <zorph.world> (<zorph.lens>) (context))

; Crude but effective I guess
;; %%% Intercept here or at notify?
(define-method (invalidate-rect (world <zorph.world>) rect)
  (let* ((gfx (slot-ref world 'context))
         (cairo (gfx-context-cairo context)))
    ;(cairo-new-path cairo)
    ;(apply cairo-rectangle (cons cairo (rect->bounds rect)))
    ;(cairo-clip cairo)
    (redraw world context)))