(cl:in-package :cl-bodge.text)


(defgeneric font-atlas-texture (resource))
(defgeneric font-ascender-height (resource))
(defgeneric font-descender-height (resource))
(defgeneric font-line-gap (resource))
(defgeneric find-glyph (resource character))
(defgeneric find-kerning (this-glyph that-glyph))

(defgeneric glyph-character (resource))
(defgeneric glyph-origin (resource))
(defgeneric glyph-bounding-box (resource))
(defgeneric glyph-advance-width (resource))


(defclass glyph ()
  ((character :initarg :character :reader glyph-character)
   (origin :initarg :origin :reader glyph-origin)
   (bounding-box :initarg :bounding-box :reader glyph-bounding-box)
   (advance-width :initarg :advance-width :reader glyph-advance-width)
   (kerning-table :initform nil)))


(defmethod initialize-instance :after ((this glyph) &key kernings)
  (setf (slot-value this 'kerning-table) (alist-hash-table kernings :test 'equal)))


(defmethod find-kerning ((this glyph) (that character))
  (with-slots (kerning-table) this
    (gethash that kerning-table 0)))


(defmethod find-kerning ((this glyph) (that glyph))
  (find-kerning this (glyph-character that)))


(defclass font (disposable)
  ((glyph-table :initform (make-hash-table :test 'equal))
   (atlas :initarg :atlas :reader font-atlas-texture)
   (ascender-height :initarg :ascender-height :reader font-ascender-height)
   (descender-height :initarg :descender-height :reader font-descender-height)
   (line-gap :initarg :line-gap :reader font-line-gap)))


(defmethod initialize-instance :after ((this font) &key glyphs)
  (with-slots (glyph-table) this
    (loop for g in glyphs
       do (setf (gethash (glyph-character g) glyph-table) g))))


(define-destructor font (atlas)
  (dispose atlas))


(defmethod find-glyph ((this font) character)
  (with-slots (glyph-table) this
    (gethash character glyph-table)))


(defun make-glyph (character origin bounding-box advance-width kernings)
  (make-instance 'glyph
                 :character character
                 :origin origin
                 :bounding-box bounding-box
                 :advance-width advance-width
                 :kernings kernings))


(define-system-function bake-font graphics-system (atlas-image glyphs ascender-height
                                                               descender-height
                                                               line-gap)
  (make-instance 'font
                 :glyphs glyphs
                 :atlas (make-2d-texture atlas-image :grey :generate-mipmaps-p nil)
                 :ascender-height ascender-height
                 :descender-height descender-height
                 :line-gap line-gap))


(defun walk-string (string font &optional walker)
  (let* ((line-height (+ (font-ascender-height font)
                         (font-descender-height font)
                         (font-line-gap font)))
         (len (length string))
         (atlas (font-atlas-texture font)))
    (destructuring-bind (atlas-w atlas-h) (texture-dimensions atlas)
      (loop with y = 0.0 and x-max = 0.0 and idx = 0 and size = 0
         for next-idx = (or (position #\Newline string :start idx) len)
         for x = 0.0
         for prev-g = nil
         append (loop for i from idx below next-idx
                   for c = (aref string i)
                   for g = (find-glyph font c)
                   for (x0-box y0-box x1-box y1-box) = (glyph-bounding-box g)
                   for (x-orig y-orig) = (glyph-origin g)
                   for advance = (glyph-advance-width g)
                   collect (let ((kerning (if prev-g (find-kerning prev-g g) 0)))
                             (prog1
                                 (when walker
                                   (let ((x-offset (f (- x x-orig)))
                                         (y-offset (f (- y y-orig))))
                                     (funcall walker
                                              x-offset
                                              y-offset
                                              (f (+ x-offset (- x1-box x0-box)))
                                              (f (+ y-offset (- y1-box y0-box)))

                                              (f (/ x0-box atlas-w))
                                              (f (/ (- atlas-h y1-box) atlas-h))
                                              (f (/ x1-box atlas-w))
                                              (f (/ (- atlas-h y0-box) atlas-h)))))
                               (setf x (+ x kerning advance)
                                     prev-g g)))
                   into line-result
                   finally
                     (when (> x x-max) (setf x-max x))
                     (incf y line-height)
                     (incf size (- next-idx idx))
                     (setf idx (1+ next-idx))
                     (return line-result))
         into result
         until (= next-idx len)
         finally (return (values size x-max (abs y)))))))


(defun measure-string (string font)
  (multiple-value-bind (size width height) (walk-string string font)
    (declare (ignore size))
    (list width height)))