;;-*-Lisp-*-
(in-package goal)
(require "engine/nav/navigate.gc")
(require "pc/pckernel.gc")
(require "engine/anim/aligner.gc")

#|
  Code for the PC port anim tester. It's like their original anim tester tool, but actually functional, and with
  different features.
|#

;; debug-only file!
(declare-file (debug))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; constants
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; types and enums
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;------------------------
;;  settings
;;;------------------------

(deftype atx-item (basic)
  ((next  atx-item)
   (text  string)
   (extra basic)
   (group art-group :overlay-at extra)
   (jgeo  art-joint-geo :overlay-at extra)
   (janim art-joint-anim :overlay-at extra)
   (mgeo  merc-ctrl :overlay-at extra))
  (:methods
   (new (symbol type string basic) _type_)))

(defmethod new atx-item ((allocation symbol) (type-to-make type) (text string) (extra basic))
  "make a new atx-item"
  (let ((obj (object-new allocation type-to-make (the int (-> type-to-make size)))))
    (set! (-> obj next) #f)
    (set! (-> obj text) text)
    (set! (-> obj extra) extra)
    obj))

(deftype atx-list (structure)
  ((head      atx-item)
   (tail      atx-item)
   (selection int16)
   (offset    int16)
   (func      (function atx-item object))))

(defenum atx-flags
  :bitfield #t
  :type int32
  (eye)
  (blerc)
  (show-joints))

(deftype anim-tester-x-settings (structure)
  ((speed     float)
   (frame-num float)
   (mode      symbol)
   (flags     atx-flags)
   (list-ctrl atx-list :inline)))

(define *ATX-settings* (new 'static 'anim-tester-x-settings :speed 1.0 :mode 'loop :flags (atx-flags)))

(deftype atx-item-art-group (atx-item)
  ((ja-list atx-list :inline)
   (jg-list atx-list :inline)
   (mg-list atx-list :inline))
  (:methods
   (new (symbol type string art-group) _type_)))

;;;----------------------------------
;;  process
;;;----------------------------------

(defenum atx-edit-mode
  :type uint8
  (none)
  (art-group)
  (anim)
  (mgeo)
  (jgeo))

(deftype anim-tester-x (process-drawable)
  ((edit-mode          atx-edit-mode)
   (cur-list           atx-list)
   (selected-art-group atx-item-art-group)
   (cur-art-group      art-group)
   (cur-joint-geo      art-joint-geo)
   (cur-mesh-geo       merc-ctrl)
   (cur-joint-anim     art-joint-anim)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; list functions and macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro do-atx-list (bindings &rest body)
  "iterate through an atx-list."
  (with-gensyms (next)
    `(let ((,(car bindings) (-> ,(cadr bindings) head)))
      (while ,(car bindings)
        (let ((,next (-> ,(car bindings) next))) ,@body (set! ,(car bindings) ,next))))))

(defun atx-list-init! ((lst atx-list))
  "initialize an atx-list"
  (set! (-> lst head) #f)
  (set! (-> lst tail) #f)
  (set! (-> lst selection) 0)
  (set! (-> lst offset) 0)
  (set! (-> lst func) (the (function atx-item object) nothing))
  lst)

(defun atx-list-size ((lst atx-list))
  "return size of an atx-list"
  (let ((items 0)) (do-atx-list (item lst) (1+! items)) items))

(defun atx-list-append ((lst atx-list) (item atx-item))
  "append an item to a list. returns the added item."
  (if (not (-> lst head)) (set! (-> lst head) item))
  (if (-> lst tail) (set! (-> lst tail next) item))
  (set! (-> lst tail) item)
  item)

(defun atx-list-remove ((lst atx-list) (item atx-item))
  "remove an item from a list. removes all instances of that item. but it's weird if you have multiple..."
  (cond
    ((= (-> lst head) item) (set! (-> lst head) (-> item next)) (if (= (-> lst tail) item) (set! (-> lst tail) #f)))
    (else
     (let ((last (the atx-item #f))
           (i 0))
       (do-atx-list (it lst)
                    (when (= it item)
                      (if (>= (-> lst selection) i) (1-! (-> lst selection)))
                      (set! (-> last next) (-> it next))
                      (set! it last))
                    (set! last it)))))
  0)

(defun atx-list-remove-by-object ((lst atx-list) (obj basic))
  "remove all items with a specific object from a list."
  (do-atx-list (it lst) (if (= (-> it extra) obj) (atx-list-remove lst it)))
  0)

(defun atx-list-get-by-index ((lst atx-list) (idx int))
  "get an item by its index."
  (let ((items 0)) (do-atx-list (item lst) (if (= items idx) (return item)) (1+! items)) items)
  (the atx-item #f))

(defun atx-list-get-by-name ((lst atx-list) (name string))
  "get an item by its index."
  (do-atx-list (item lst) (if (string= (-> item text) name) (return item)))
  (the atx-item #f))

(defmacro atx-interface-square-to-menu ()
  `(when (cpad-pressed? 0 square)
    (cpad-clear! 0 square)
    (true! *camera-read-buttons*)
    (set! (-> self edit-mode) (atx-edit-mode none))
    (set! (-> *debug-menu-context* is-hidden) #f)))

(defun atx-list-interface ((lst atx-list) (title string) (warning string) (sel-obj basic))
  "run interface and draw an atx-list"
  (let ((items-drawn (-> lst offset))
        (i 0)
        (color (font-color menu))
        (text-len 0.0))
    (with-dma-buffer-add-bucket ((buf (-> (current-frame) debug-buf)) (bucket-id debug-no-zbuf))
      (when (nonzero? (length title))
        (set! text-len (draw-string-xy title buf 9 (+ 28 4 (* items-drawn 8)) (font-color menu) (font-flags shadow kerning)))
        (1+! items-drawn))
      (do-atx-list (item lst)
                   (let ((selected? (= i (-> lst selection))))
                     (set! color (if (= (-> item extra) sel-obj) (font-color menu-flag-on) (font-color menu)))
                     (let ((this-len (draw-string-xy (-> item group name) buf 21 (+ 28 4 (* items-drawn 8)) color (font-flags shadow kerning))))
                       (if (> this-len text-len) (set! text-len this-len)))
                     (if selected? (draw-string-xy ">" buf 9 (+ 28 4 (* items-drawn 8)) color (font-flags shadow kerning)))
                     (1+! items-drawn)
                     (1+! i)))
      (when (not (-> lst head))
        (draw-string-xy warning buf 21 (+ 28 4 8) (font-color red) (font-flags shadow kerning))
        (1+! items-drawn)))
    (with-dma-buffer-add-bucket ((buf (-> (current-frame) debug-buf)) (bucket-id debug))
      (draw-sprite2d-xy buf
                        6
                        (+ 28 (* (-> lst offset) 8))
                        (+ 6 12 12 (the int text-len))
                        (+ 8 (* 8 (- items-drawn (-> lst offset))))
                        (static-rgba 0 0 0 64))))
  (when (-> lst head)
    (if (cpad-pressed? 0 down) (+! (-> lst selection) 1))
    (if (cpad-pressed? 0 right) (+! (-> lst selection) 5))
    (if (cpad-pressed? 0 up) (-! (-> lst selection) 1))
    (if (cpad-pressed? 0 left) (-! (-> lst selection) 5))
    (if (< (-> lst selection) 0) (set! (-> lst selection) (1- (atx-list-size lst))))
    (if (>= (-> lst selection) (atx-list-size lst)) (set! (-> lst selection) 0))
    (if (cpad-pressed? 0 x) ((-> lst func) (atx-list-get-by-index lst (-> lst selection))))
    (when (< 16 (+ (-> lst selection) (-> lst offset)))
      (set! (-> lst offset) (- 16 (-> lst selection))))
    (when (< (+ (-> lst selection) (-> lst offset)) 0)
      (set! (-> lst offset) (- 0 (-> lst selection)))))
  0)

(defbehavior atx-list-art-group-func anim-tester-x ((item atx-item-art-group))
  (if (not (and (type-type? (-> item type) atx-item-art-group)
                (-> item group)
                (-> item ja-list head)
                (-> item jg-list head)
                (-> item mg-list head)))
    (return #f))
  (set! (-> self selected-art-group) item)
  (set! (-> self edit-mode) (atx-edit-mode anim))
  (set! (-> self cur-art-group) (-> item group))
  (set! (-> self cur-joint-anim) (-> item ja-list head janim))
  (set! (-> self cur-joint-geo) (-> item jg-list head jgeo))
  (set! (-> self cur-mesh-geo) (-> item mg-list head mgeo))
  (ja-no-eval :frame-num 0.0)
  0)

(defbehavior atx-list-joint-anim-func anim-tester-x ((item atx-item))
  (if (not (-> item janim)) (return #f))
  (set! (-> self cur-joint-anim) (-> item janim))
  (ja-no-eval :frame-num 0.0)
  0)

(defbehavior atx-list-joint-geo-func anim-tester-x ((item atx-item))
  (if (not (-> item janim)) (return #f))
  (set! (-> self cur-joint-geo) (-> item jgeo))
  0)

(defbehavior atx-list-mesh-geo-func anim-tester-x ((item atx-item))
  (if (not (-> item janim)) (return #f))
  (set! (-> self cur-mesh-geo) (-> item mgeo))
  0)

(defmethod new atx-item-art-group ((allocation symbol) (type-to-make type) (text string) (ag art-group))
  "make a new atx-item"
  (let ((obj (object-new allocation type-to-make (the int (-> type-to-make size)))))
    (set! (-> obj next) #f)
    (set! (-> obj text) text)
    (set! (-> obj group) ag)
    (atx-list-init! (-> obj ja-list))
    (atx-list-init! (-> obj jg-list))
    (atx-list-init! (-> obj mg-list))
    (set! (-> obj ja-list func) atx-list-joint-anim-func)
    (set! (-> obj jg-list func) atx-list-joint-geo-func)
    (set! (-> obj mg-list func) atx-list-mesh-geo-func)
    obj))

;;;----------------------------------------------
;;  globals
;;;----------------------------------------------

;; initialize the lists in the static defs
(atx-list-init! (-> *ATX-settings* list-ctrl))

(set! (-> *ATX-settings* list-ctrl func) atx-list-art-group-func)

;; the actual process.
(define-perm *atx* (pointer anim-tester-x) #f)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;  states
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defbehavior anim-tester-x-reset anim-tester-x ()
  "reset the anim tester to default settings"
  (format #t "resetting anim tester~%")
  (set! (-> self edit-mode) (atx-edit-mode none))
  (set! (-> self selected-art-group) #f)
  (set! (-> self cur-art-group) #f)
  (set! (-> self cur-joint-anim) #f)
  (set! (-> self cur-joint-geo) #f)
  (set! (-> self cur-mesh-geo) #f)
  0)

(defbehavior clean-art-groups anim-tester-x ()
  "purge possible invalid art groups automatically."
  (do-atx-list (it (-> *ATX-settings* list-ctrl))
               (when (!= (-> it group type) art-group)
                 (when (= it (-> self selected-art-group))
                   (anim-tester-x-reset))
                 (atx-list-remove (-> *ATX-settings* list-ctrl) it))))

(defbehavior anim-tester-x-interface anim-tester-x ()
  "UI controls for anim tester"
  (set! (-> *debug-menu-context* is-hidden) #t)
  (set! (-> self cur-list) #f)
  (case (-> self edit-mode)
    (((atx-edit-mode none)) (set! (-> *debug-menu-context* is-hidden) #f))
    (((atx-edit-mode art-group))
     (set! (-> self cur-list) (-> *ATX-settings* list-ctrl))
     (atx-list-interface (-> self cur-list)
                         "---- pick art group ----"
                         "Add an art group with atx-add-group"
                         (-> self cur-art-group))
     (atx-interface-square-to-menu))
    (((atx-edit-mode anim))
     (set! (-> self cur-list) (-> self selected-art-group ja-list))
     (atx-list-interface (-> self cur-list) "---- pick anim ----" "" (-> self cur-joint-anim))
     (atx-interface-square-to-menu))
    (((atx-edit-mode jgeo))
     (set! (-> self cur-list) (-> self selected-art-group jg-list))
     (atx-list-interface (-> self cur-list) "---- pick skeleton ----" "" (-> self cur-joint-geo))
     (atx-interface-square-to-menu))
    (((atx-edit-mode mgeo))
     (set! (-> self cur-list) (-> self selected-art-group mg-list))
     (atx-list-interface (-> self cur-list) "---- pick mesh ----" "" (-> self cur-mesh-geo))
     (atx-interface-square-to-menu)))
  0)

(defstate anim-tester-x-process (anim-tester-x)
  :trans
    (behavior ()
      (clean-art-groups)
      (if (= *master-mode* 'menu) (anim-tester-x-interface) (set! *camera-read-buttons* #f))
      (when (!= *master-mode* 'menu)
        (add-debug-x #t (bucket-id debug-no-zbuf) (-> self root trans) *color-white*))
      (none))
  :code
    (behavior ()
      (let ((need-update #f)
            (lst (the-as atx-list #f)))
        (loop
          (when (and (-> self cur-joint-geo) (!= (-> self cur-joint-geo) (-> self draw jgeo)))
            (process-disconnect self)
            (set! (-> self draw art-group) (-> self cur-art-group))
            (set! (-> self draw cur-lod) -1)
            (set! (-> self draw jgeo) (-> self cur-joint-geo))
            (set! (-> self draw sink-group) (-> *level* level-default foreground-sink-group 1))
            (set! (-> self draw lod-set lod 0 geo) (-> self cur-mesh-geo))
            (set! (-> self draw lod-set lod 0 dist) (meters 999999))
            (set! (-> self draw bounds w) (meters 10))
            (set! (-> self draw data-format) (the-as uint 1))
            (vector-copy! (-> self draw color-mult) (new 'static 'vector :x 1.0 :y 1.0 :z 1.0 :w 1.0))
            (vector-copy! (-> self draw color-emissive) (new 'static 'vector))
            (set! (-> self draw secondary-interp) 0.0)
            (set! (-> self draw shadow) #f)
            (set! (-> self draw shadow-ctrl) #f)
            (set! (-> self draw ripple) #f)
            (set! (-> self draw level-index) (the-as uint 2))
            (set! (-> self node-list) (make-nodes-from-jg (-> self draw jgeo) *default-skel-template* 'debug))
            (if (not (-> self skel effect)) (set! (-> self skel effect) (new 'process 'effect-control self)))
            (fill-skeleton-cache self)
            (lod-set! (-> self draw) 0)
            (ja-channel-set! 0)
            (set! lst (-> self selected-art-group ja-list)))
          (cond
            ((-> self cur-joint-geo)
             (if (> 1 (-> self skel active-channels)) (ja-channel-set! 1))
             (set! (-> self draw lod-set lod 0 geo) (-> self cur-mesh-geo))
             (ja-no-eval :group! (-> self cur-joint-anim))
             (when (!= *master-mode* 'menu)
               (case (-> *ATX-settings* mode)
                 (('loop) (ja :num! (loop! (-> *ATX-settings* speed))))
                 (('identity) (ja :num! (identity (-> *ATX-settings* frame-num))))
                 (('seek) (ja :num! (seek! max (-> *ATX-settings* speed))))))
             (compute-alignment! (-> self align))
             (align! (-> self align)
                     (align-opts adjust-x-vel adjust-y-vel adjust-xz-vel keep-other-velocities adjust-quat)
                     1.0
                     1.0
                     1.0))
            (else (if (!= *master-mode* 'menu) (format *stdcon* "~%~%no art selected~%"))))
          (when (and lst (-> lst head) (!= *master-mode* 'menu))
            (cond
              ((cpad-pressed? 0 left) (cpad-clear! 0 left) (-! (-> lst selection) 1) (set! need-update #t))
              ((cpad-pressed? 0 right) (cpad-clear! 0 right) (+! (-> lst selection) 1) (set! need-update #t)))
            (cond
              ((< (-> lst selection) 0) (set! (-> lst selection) (1- (atx-list-size lst))))
              ((>= (-> lst selection) (atx-list-size lst)) (set! (-> lst selection) 0)))
            (when need-update
              ((-> lst func) (atx-list-get-by-index lst (-> lst selection)))
              (set! need-update #f)))
          (suspend))))
  :post
    (behavior ()
      (when (-> self cur-joint-geo)
        (ja-post)
        (when (!= *master-mode* 'menu)
          (when (logtest? (-> *ATX-settings* flags) (atx-flags show-joints))
            (draw-joint-spheres self))
          (format *stdcon* "~%~%")
          (debug-print-channels (-> self skel) (the-as symbol *stdcon*))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; helper functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defbehavior anim-tester-x-init-by-other anim-tester-x ()
  "external initializer for anim-tester-x process"
  (logclear! (-> self mask) (process-mask menu))
  (set! (-> self root) (new 'process 'trsqv))
  (set! (-> self draw) (new 'process 'draw-control self (the art-joint-geo #f)))
  (set! (-> self draw dma-add-func) dma-add-process-drawable)
  (set! (-> self skel) (new 'process 'joint-control 24)) ;; allocate 24 anim channels
  (set! (-> self align) (new 'process 'align-control self))
  (quaternion-identity! (-> self root quat))
  (vector-identity! (-> self root scale))
  (position-in-front-of-camera! (-> self root trans) (meters 10) (meters 1))
  (anim-tester-x-reset)
  (go anim-tester-x-process)
  (none))

(defun atx-stop ()
  "kill the anim tester process"
  (kill-by-type anim-tester-x *default-pool*)
  (set! *camera-read-buttons* #t)
  (set! *atx* (the (pointer anim-tester-x) #f)))

(defun atx-start ()
  "start the anim tester process"
  (when *atx*
    (atx-stop))
  (if *target* (stop 'play))
  (set! *atx* (process-spawn anim-tester-x :from *pc-dead-pool*))
  (set! *camera-orbit-target* *atx*)
  (send-event *camera* 'change-state cam-free-floating 0))

(defun atx-add-new-art-group ((ag art-group))
  (let ((ag-item (the atx-item-art-group (atx-list-append (-> *ATX-settings* list-ctrl) (new 'debug 'atx-item-art-group (-> ag name) ag)))))
    (dotimes (i (-> ag length))
      (when (-> ag data i)
        (case (-> ag data i type)
          ((art-joint-geo) (atx-list-append (-> ag-item jg-list) (new 'debug 'atx-item (-> ag name) (-> ag data i))))
          ((merc-ctrl) (atx-list-append (-> ag-item mg-list) (new 'debug 'atx-item (-> ag name) (-> ag data i))))
          ((art-joint-anim) (atx-list-append (-> ag-item ja-list) (new 'debug 'atx-item (-> ag name) (-> ag data i)))))))
    ag-item))

(defun atx-add-group ((name string) (level-name symbol))
  (protect ((-> *level* log-in-level-bsp))
    (set! (-> *level* log-in-level-bsp) (aif (level-get *level* level-name) (-> it bsp)))
    (let ((ag (load-to-heap-by-name (-> *level* level-default art-group) name #t debug 0)))
      (cond
        (ag (if (not *atx*) (atx-start)) (atx-add-new-art-group ag))
        (else (format #t "ERROR: no art-group ~A~%" name)))))
  0)

(defun atx-append-group ((append-to string) (name string) (level-name symbol))
  (protect ((-> *level* log-in-level-bsp))
    (set! (-> *level* log-in-level-bsp) (aif (level-get *level* level-name) (-> it bsp)))
    (let ((ag (load-to-heap-by-name (-> *level* level-default art-group) name #t debug 0)))
      (cond
        (ag
         (if (not *atx*) (atx-start))
         (let ((ag-item (the atx-item-art-group (atx-list-get-by-name (-> *ATX-settings* list-ctrl) append-to))))
           (when (not ag-item)
             (format #t "ERROR: art-group ~A not loaded~%" append-to)
             (return #f))
           (dotimes (i (-> ag length))
             (when (-> ag data i)
               (case (-> ag data i type)
                 ((art-joint-geo) (atx-list-append (-> ag-item jg-list) (new 'debug 'atx-item (-> ag name) (-> ag data i))))
                 ((merc-ctrl) (atx-list-append (-> ag-item mg-list) (new 'debug 'atx-item (-> ag name) (-> ag data i))))
                 ((art-joint-anim) (atx-list-append (-> ag-item ja-list) (new 'debug 'atx-item (-> ag name) (-> ag data i)))))))))
        (else (format #t "ERROR: no art-group ~A~%" name)))))
  0)

(defun atx-add-level-group ()
  (if (not *atx*) (atx-start))
  (do-atx-list (item (-> *ATX-settings* list-ctrl))
               (dotimes (i (-> *level* length))
                 (when (and (>= (-> item group) (-> *level* level i heap base)) (< (-> item group) (-> *level* level i heap top)))
                   (atx-list-remove (-> *ATX-settings* list-ctrl) item)
                   (set! i (-> *level* length)))))
  (dotimes (i (-> *level* length))
    (doarray (ag (-> *level* level i art-group data-array)) (atx-add-new-art-group (the art-group ag)))))

(defun atx-add-common-group ()
  (if (not *atx*) (atx-start))
  (doarray (ag (-> *level* level (-> *level* length) art-group data-array)) (atx-add-new-art-group (the art-group ag))))
