;;-*-Lisp-*-
(in-package goal)

;; name: font-h.gc
;; name in dgo: font-h
;; dgos: GAME, ENGINE

;; The font system draws all of the strings.
;; The font textures live in the upper 8 bits of the 24-bit texture format depth buffer.

(deftype char-verts (structure)
  ((pos    vector 4 :inline :offset-assert 0)
   (color  vector 4 :inline :offset-assert 64)
   (tex-st vector 4 :inline :offset-assert 128)
   )
  :method-count-assert 9
  :size-assert         #xc0
  :flag-assert         #x9000000c0
  )

(deftype char-color (structure)
  ((color rgba 4 :offset-assert 0)
   )
  :method-count-assert 9
  :size-assert         #x10
  :flag-assert         #x900000010
  )

(define *font-default-matrix* (new 'static 'matrix
                                   :data (new 'static 'array float 16
                                       1.0 0.0 0.0 0.0
                                       0.0 1.0 0.0 0.0
                                       0.0 0.0 1.0 0.0
                                    -256.0 0.0 0.0 1.0
                                    )
   )
  )

(deftype font-context (basic)
  ((origin     vector :inline :offset-assert 16)
   (strip-gif  vector :inline :offset-assert 32)
   (width      float          :offset-assert 48)
   (height     float          :offset-assert 52)
   (projection float          :offset-assert 56)
   (color      int64          :offset-assert 64)
   (flags      uint32         :offset-assert 72)
   (mat        matrix         :offset-assert 76)
   (start-line uint32         :offset-assert 80)
   (scale      float          :offset-assert 84)
   )
  :method-count-assert 20
  :size-assert         #x58
  :flag-assert         #x1400000058
  (:methods
    (new (symbol type matrix int int float int uint) _type_ 0)
    (set-mat! (font-context matrix) font-context 9)
    (set-origin! (font-context int int) font-context 10)
    (set-depth! (font-context int) font-context 11)
    (set-w! (font-context float) font-context 12)
    (set-width! (font-context int) font-context 13)
    (set-height! (font-context int) font-context 14)
    (set-projection! (font-context float) font-context 15)
    (set-color! (font-context int) font-context 16)
    (set-flags! (font-context uint) font-context 17)
    (set-start-line! (font-context uint) font-context 18)
    (set-scale! (font-context float) font-context 19)
    )
  )

;; I don't believe these methods are called, so they might be inlined

(defmethod set-mat! font-context ((obj font-context) (mat matrix))
  (declare (inline))

  (set! (-> obj mat) mat)
  obj
  )

(defmethod set-origin! font-context ((obj font-context) (x int) (y int))
  (declare (inline))

  (set! (-> obj origin x) (the float x))
  (set! (-> obj origin y) (the float y))
  obj
  )

(defmethod set-depth! font-context ((obj font-context) (z int))
  (declare (inline))

  (set! (-> obj origin z) (the float z))
  obj
  )

(defmethod set-w! font-context ((obj font-context) (w float))
  (declare (inline))

  (set! (-> obj origin w) w)
  obj
  )

(defmethod set-width! font-context ((obj font-context) (width int))
  (declare (inline))

  (set! (-> obj width) (the float width))
  obj
  )

(defmethod set-height! font-context ((obj font-context) (height int))
  (declare (inline))

  (set! (-> obj height) (the float height))
  obj
  )

(defmethod set-projection! font-context ((obj font-context) (proj float))
  (declare (inline))

  (set! (-> obj projection) proj)
  obj
  )

(defmethod set-color! font-context ((obj font-context) (color int))
  (declare (inline))

  (set! (-> obj color) color)
  obj
  )

(defmethod set-flags! font-context ((obj font-context) (flags uint))
  (declare (inline))

  (set! (-> obj flags) flags)
  obj
  )

(defmethod set-start-line! font-context ((obj font-context) (start-line uint))
  (declare (inline))

  (set! (-> obj start-line) start-line)
  obj
  )

(defmethod set-scale! font-context ((obj font-context) (scale float))
  (declare (inline))

  (set! (-> obj scale) scale)
  obj
  )

(defmethod new font-context ((allocation symbol) (type-to-make type) (mat matrix) (x int) (y int) (z float) (color int) (flags uint))
  "Allocate a new font-context with the given parameters"

  (let ((obj (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
    (set-mat! obj mat)
    (set-origin! obj x y)
    (if (= z 0)
      (set! (-> obj origin z) (-> *math-camera* isometric data 14)) ;; inlined set-depth!
      (set! (-> obj origin z) z) ;; inlined set-depth!
      )
    (set-w! obj 1.0)
    (set-width! obj 512)
    (set-width! obj 256)
    (set-projection! obj 1.0)
    (set-color! obj color)
    (set-flags! obj flags)
    (set-start-line! obj (the-as uint 0))
    (set-scale! obj 1.0)
    obj
    )
  )

(deftype font-work (structure)
  ((font-tmpl          dma-gif-packet :inline    :offset-assert 0)
   (char-tmpl          dma-gif-packet :inline    :offset-assert 32)
   (tex1-tmpl          uint64         2          :offset-assert 64)
   (small-font-lo-tmpl uint64         2          :offset-assert 80)
   (small-font-hi-tmpl uint64         2          :offset-assert 96)
   (large-font-lo-tmpl uint64         2          :offset-assert 112)
   (large-font-hi-tmpl uint64         2          :offset-assert 128)
   (size1-small        vector         :inline    :offset-assert 144)
   (size2-small        vector         :inline    :offset-assert 160)
   (size3-small        vector         :inline    :offset-assert 176)
   (size1-large        vector         :inline    :offset-assert 192)
   (size2-large        vector         :inline    :offset-assert 208)
   (size3-large        vector         :inline    :offset-assert 224)
   (size-st1           vector         :inline    :offset-assert 240)
   (size-st2           vector         :inline    :offset-assert 256)
   (size-st3           vector         :inline    :offset-assert 272)
   (save               vector         :inline    :offset-assert 288)
   (save-color         vector         4 :inline  :offset-assert 304)
   (current-verts      char-verts     :inline    :offset-assert 368)
   (src-verts          char-verts     :inline    :offset-assert 560)
   (dest-verts         char-verts     :inline    :offset-assert 752)
   (justify            vector         64 :inline :offset-assert 944)
   (color-shadow       vector4w       :inline    :offset-assert 1968)
   (color-table        char-color     64 :inline :offset-assert 1984)
   (last-color         uint64                    :offset-assert 3008)
   (save-last-color    uint64                    :offset-assert 3016)
   (buf                basic                     :offset-assert 3024)
   (str-ptr            uint32                    :offset-assert 3028)
   (flags              uint32                    :offset-assert 3032)
   (reg-save           uint32         5          :offset-assert 3036)
   )
  :method-count-assert 9
  :size-assert         #xbf0
  :flag-assert         #x900000bf0
  )

(define *font-work* (new 'static 'font-work
   :font-tmpl (new 'static 'dma-gif-packet
    :dma-vif (new 'static 'dma-packet
     :dma (new 'static 'dma-tag :qwc #x2 :id (dma-tag-id cnt))
     :vif1 (new 'static 'vif-tag :imm #x2 :cmd (vif-cmd direct) :msk #x1)
     )
    :gif (gif-tag->static-array
      (new 'static 'gif-tag64 :nloop #x1 :eop #x1 :pre #x1 :prim #x5c :nreg #x1) ;; (new 'static 'gs-prim :prim (gs-prim-type tri-strip) :iip 1 :tme 1 :abe 1)
      (new 'static 'gif-tag-regs
        :regs0 (gif-reg-id a+d)
        ))
    )
   :char-tmpl (new 'static 'dma-gif-packet
    :dma-vif (new 'static 'dma-packet
     :dma (new 'static 'dma-tag :qwc #xe :id (dma-tag-id cnt))
     :vif1 (new 'static 'vif-tag :imm #xe :cmd (vif-cmd direct) :msk #x1)
     )
    :gif (gif-tag->static-array
      (new 'static 'gif-tag64 :nloop #x1 :eop #x1 :pre #x1 :prim #x5c :nreg #xd) ;; (new 'static 'gs-prim :prim (gs-prim-type tri-strip) :iip 1 :tme 1 :abe 1)
      (new 'static 'gif-tag-regs
        :regs0 (gif-reg-id a+d)
        :regs1 (gif-reg-id st)
        :regs2 (gif-reg-id rgbaq)
        :regs3 (gif-reg-id xyzf2)
        :regs4 (gif-reg-id st)
        :regs5 (gif-reg-id rgbaq)
        :regs6 (gif-reg-id xyzf2)
        :regs7 (gif-reg-id st)
        :regs8 (gif-reg-id rgbaq)
        :regs9 (gif-reg-id xyzf2)
        :regs10 (gif-reg-id st)
        :regs11 (gif-reg-id rgbaq)
        :regs12 (gif-reg-id xyzf2)
        ))
    )
   :tex1-tmpl (new 'static 'array uint64 2 #x60 #x14)
   :small-font-lo-tmpl (new 'static 'array uint64 2 #x0 #x6)
   :small-font-hi-tmpl (new 'static 'array uint64 2 #x0 #x6)
   :large-font-lo-tmpl (new 'static 'array uint64 2 #x0 #x6)
   :large-font-hi-tmpl (new 'static 'array uint64 2 #x0 #x6)
   :size1-small (new 'static 'vector :x 12.0 :y 0.0 :w 0.5)
   :size2-small (new 'static 'vector :x 0.0  :y 8.0 :w 8.0)
   :size3-small (new 'static 'vector :x 12.0 :y 8.0 :w 8.0)
   :size1-large (new 'static 'vector :x 24.0 :y 0.0 :w 1.0)
   :size2-large (new 'static 'vector :x 0.0  :y 16.0 :w 16.0)
   :size3-large (new 'static 'vector :x 24.0 :y 16.0 :w 16.0)
   :size-st1 (new 'static 'vector :x 0.08985 :y 0.0 :w 0.5)
   :size-st2 (new 'static 'vector :x 0.0     :y 0.06153846 :w 0.5)
   :size-st3 (new 'static 'vector :x 0.08985 :y 0.06153846 :w 0.5)
   :current-verts (new 'static 'char-verts
    :pos (new 'static 'inline-array vector 4
     (new 'static 'vector :w 1.0)
     (new 'static 'vector :w 1.0)
     (new 'static 'vector :w 1.0)
     (new 'static 'vector :w 1.0)
     )
    :tex-st (new 'static 'inline-array vector 4
     (new 'static 'vector :z 1.0)
     (new 'static 'vector :z 1.0)
     (new 'static 'vector :z 1.0)
     (new 'static 'vector :z 1.0)
     )
    )
   :src-verts (new 'static 'char-verts
    :pos (new 'static 'inline-array vector 4
     (new 'static 'vector :w 1.0)
     (new 'static 'vector :w 1.0)
     (new 'static 'vector :w 1.0)
     (new 'static 'vector :w 1.0)
     )
    :tex-st (new 'static 'inline-array vector 4
     (new 'static 'vector :z 1.0)
     (new 'static 'vector :z 1.0)
     (new 'static 'vector :z 1.0)
     (new 'static 'vector :z 1.0)
     )
    )
   :dest-verts (new 'static 'char-verts
    :pos (new 'static 'inline-array vector 4
     (new 'static 'vector :w 1.0)
     (new 'static 'vector :w 1.0)
     (new 'static 'vector :w 1.0)
     (new 'static 'vector :w 1.0)
     )
    :tex-st (new 'static 'inline-array vector 4
     (new 'static 'vector :z 1.0)
     (new 'static 'vector :z 1.0)
     (new 'static 'vector :z 1.0)
     (new 'static 'vector :z 1.0)
     )
    )
   :color-shadow (new 'static 'vector4w :x #x00 :y #x00 :z #x00 :w #x80)
   ;; TODO - make enum for this
   :color-table (new 'static 'inline-array char-color 64
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x70 #x78 #x70 #x80)
      (new-rgba #x70 #x78 #x70 #x80)
      (new-rgba #x30 #x38 #x30 #x80)
      (new-rgba #x30 #x38 #x30 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x80 #x80 #x80 #x80)
      (new-rgba #x80 #x80 #x80 #x80)
      (new-rgba #x60 #x60 #x60 #x80)
      (new-rgba #x60 #x60 #x60 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x80 #x80 #x80 #x40)
      (new-rgba #x80 #x80 #x80 #x40)
      (new-rgba #x60 #x60 #x60 #x40)
      (new-rgba #x60 #x60 #x60 #x40)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x80 #x60 #x20 #x80)
      (new-rgba #x80 #x60 #x20 #x80)
      (new-rgba #x60 #x00 #x00 #x80)
      (new-rgba #x60 #x00 #x00 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x80 #x64 #x00 #x80)
      (new-rgba #x80 #x64 #x00 #x80)
      (new-rgba #x80 #x00 #x00 #x80)
      (new-rgba #x80 #x00 #x00 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x80 #x80 #x00 #x80)
      (new-rgba #x80 #x80 #x00 #x80)
      (new-rgba #x28 #x28 #x00 #x80)
      (new-rgba #x28 #x28 #x00 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x20 #x80 #x20 #x80)
      (new-rgba #x20 #x80 #x20 #x80)
      (new-rgba #x00 #x30 #x00 #x80)
      (new-rgba #x00 #x30 #x00 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x40 #x40 #x80 #x80)
      (new-rgba #x40 #x40 #x80 #x80)
      (new-rgba #x00 #x00 #x60 #x80)
      (new-rgba #x00 #x00 #x60 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x00 #x80 #x80 #x80)
      (new-rgba #x00 #x80 #x80 #x80)
      (new-rgba #x00 #x20 #x50 #x80)
      (new-rgba #x00 #x20 #x50 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x80 #x40 #x80 #x80)
      (new-rgba #x80 #x40 #x80 #x80)
      (new-rgba #x30 #x00 #x30 #x80)
      (new-rgba #x30 #x00 #x30 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x60 #x80 #x80 #x80)
      (new-rgba #x60 #x80 #x80 #x80)
      (new-rgba #x00 #x40 #x60 #x80)
      (new-rgba #x00 #x40 #x60 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x40 #x60 #x60 #x80)
      (new-rgba #x40 #x60 #x60 #x80)
      (new-rgba #x00 #x20 #x40 #x80)
      (new-rgba #x00 #x20 #x40 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x80 #x80 #x80 #x80)
      (new-rgba #x80 #x80 #x80 #x80)
      (new-rgba #x50 #x50 #x50 #x80)
      (new-rgba #x50 #x50 #x50 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x50 #x50 #x50 #x80)
      (new-rgba #x50 #x50 #x50 #x80)
      (new-rgba #x28 #x28 #x28 #x80)
      (new-rgba #x28 #x28 #x28 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x80 #x54 #x00 #x80)
      (new-rgba #x80 #x54 #x00 #x80)
      (new-rgba #x60 #x00 #x00 #x80)
      (new-rgba #x60 #x00 #x00 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x70 #x80 #x30 #x80)
      (new-rgba #x70 #x80 #x30 #x80)
      (new-rgba #x00 #x60 #x00 #x80)
      (new-rgba #x00 #x60 #x00 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x48 #x58 #x8 #x80)
      (new-rgba #x48 #x58 #x10 #x80)
      (new-rgba #x00 #x38 #x00 #x80)
      (new-rgba #x00 #x38 #x00 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x58 #x60 #x58 #x80)
      (new-rgba #x58 #x60 #x58 #x80)
      (new-rgba #x30 #x40 #x30 #x80)
      (new-rgba #x30 #x40 #x30 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x40 #x48 #x40 #x80)
      (new-rgba #x40 #x48 #x40 #x80)
      (new-rgba #x18 #x28 #x18 #x80)
      (new-rgba #x18 #x28 #x18 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x30 #x20 #x30 #x80)
      (new-rgba #x30 #x20 #x30 #x80)
      (new-rgba #x30 #x20 #x30 #x80)
      (new-rgba #x30 #x20 #x30 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x80 #x79 #x48 #x80)
      (new-rgba #x80 #x79 #x48 #x80)
      (new-rgba #x80 #x79 #x48 #x80)
      (new-rgba #x80 #x79 #x48 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x20 #x5e #x78 #x80)
      (new-rgba #x20 #x5e #x78 #x80)
      (new-rgba #x80 #x7d #x4f #x80)
      (new-rgba #x80 #x7d #x4f #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x1d #x1d #x1d #x80)
      (new-rgba #x1d #x1d #x1d #x80)
      (new-rgba #x1d #x1d #x1d #x80)
      (new-rgba #x1d #x1d #x1d #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x40 #x40 #x40 #x80)
      (new-rgba #x40 #x40 #x40 #x80)
      (new-rgba #x40 #x40 #x40 #x80)
      (new-rgba #x40 #x40 #x40 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x7a #x4d #x65 #x80)
      (new-rgba #x7a #x4d #x65 #x80)
      (new-rgba #x7a #x4d #x65 #x80)
      (new-rgba #x7a #x4d #x65 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x7a #x34 #x34 #x80)
      (new-rgba #x7a #x34 #x34 #x80)
      (new-rgba #x7a #x34 #x34 #x80)
      (new-rgba #x7a #x34 #x34 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x10 #x65 #x4c #x80)
      (new-rgba #x10 #x65 #x4c #x80)
      (new-rgba #x10 #x65 #x4c #x80)
      (new-rgba #x10 #x65 #x4c #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x46 #x4a #x78 #x80)
      (new-rgba #x46 #x4a #x78 #x80)
      (new-rgba #x46 #x4a #x78 #x80)
      (new-rgba #x46 #x4a #x78 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x57 #x7e #x80 #x80)
      (new-rgba #x57 #x7e #x80 #x80)
      (new-rgba #x29 #x63 #x79 #x80)
      (new-rgba #x29 #x63 #x70 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x7f #x7b #x33 #x80)
      (new-rgba #x7f #x7b #x33 #x80)
      (new-rgba #x76 #x40 #x14 #x80)
      (new-rgba #x76 #x40 #x14 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x79 #x79 #x2 #x80)
      (new-rgba #x79 #x79 #x2 #x80)
      (new-rgba #x1b #x51 #x20 #x80)
      (new-rgba #x1b #x51 #x20 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x47 #x68 #x7a #x80)
      (new-rgba #x47 #x68 #x7a #x80)
      (new-rgba #x00 #x3c #x4f #x80)
      (new-rgba #x00 #x3c #x4f #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x70 #x78 #x70 #x80)
      (new-rgba #x70 #x78 #x70 #x80)
      (new-rgba #x30 #x38 #x30 #x80)
      (new-rgba #x30 #x38 #x30 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x60 #x00 #x00 #x80)
      (new-rgba #x60 #x00 #x00 #x80)
      (new-rgba #x80 #x60 #x20 #x80)
      (new-rgba #x80 #x60 #x20 #x80)
      )
     )
    (new 'static 'char-color
     :color
     (new 'static 'array rgba 4
      (new-rgba #x80 #x60 #x20 #x80)
      (new-rgba #x80 #x60 #x20 #x80)
      (new-rgba #x60 #x00 #x00 #x80)
      (new-rgba #x60 #x00 #x00 #x80)
      )
     )
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    (new 'static 'char-color)
    )
   )
  )

(defun font-set-tex0 ((ptr-tex0 (pointer gs-tex0)) (tex texture) (tex-addr uint) (psm uint) (clut-addr uint))
  "Write the TEX0 parameters for a font"

  (set! (-> ptr-tex0) (new 'static 'gs-tex0
                                  :tcc #x1
                                  :cld #x1
                                  :cbp clut-addr
                                  :th (log2 (-> tex h))
                                  :tw (log2 (-> tex w))
                                  :tbw (-> tex width 0)
                                  :tbp0 (sar tex-addr 6)
                                  :psm psm
                                  ))
  (none)
  )


(define-extern draw-string (function string dma-buffer font-context float))