;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; font objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; return font object
;;
;; ascender: number of pixels above the base line (not counting the base line itself)
;; descender: number of pixels below the base line (not counting the base line itself)
;; baseline + descender: the lowest font pixel
;; baseline - ascender: the highest font pixel
define parse-font(... cdefs)
  define height #f
  define baseline #f
  define left-mask #f
  define bitmap #nil ;make-vector({128 * height} 0)
  define kerning make-vector({256 * 256} #nil)
  define char-seen make-vector(256 #f)
  define char-width make-vector(256 0)
  define font-surface #nil
  define cbmp-width 0
  ;;
  define do-parse-char(cidx list)
    define idx
    define val
    define val1
    define wdt -1
    define was-bmp #f
    ;printf "cdef=%o\n" list
    assert {not char-seen[cidx]}
      string-append("duplicate definition for char #" number->string(cidx))
    {char-seen[cidx] := #t}
    while {not-null? list}
      case car(list)
        (width:)
          assert {wdt = -1}
            string-append("duplicate width property for char #" number->string(cidx))
          {val := cadr(list)}
          assert {{fixnum? val} and between?(val 0 255)}
            string-append("invalid width property for char #" number->string(cidx))
          {wdt := val}
          {list := cddr(list)}
        (kerning:)
          ;; kerning: prevch value
          {val := cadr(list)} ;; prev-char
          {val1 := caddr(list)} ;; kerning value
          {list := cdddr(list)}
          assert {{fixnum? val} and between?(val 0 255)}
            string-append("invalid kerning property (char code) for char #" number->string(cidx))
          assert {{fixnum? val1} and between?(val1 -127 127)}
            string-append("invalid kerning property (kerning value) for char #" number->string(cidx))
          {idx := {{cidx * 256} + val}}
          assert {null? kerning[idx]}
            string-append("duplicate kerning property (prev #"
                          number->string(val) ") for char #" number->string(cidx))
          {kerning[idx] := val1}
        (bitmap:)
          assert {not was-bmp}
            string-append("duplicate bitmap property for char #" number->string(cidx))
          {val := cadr(list)}
          {list := cddr(list)}
          {was-bmp := #t}
          iterate
            init {idx := 0}
            repeat {idx <> height}
              {bitmap[{{cidx * height} + idx}] := val[idx]}
              inc! idx
            else #void
        else
          error string-append("unknown property for char #" number->string(cidx))
    ;;
    assert {wdt >= 0}
      string-append("no width property for char #" number->string(cidx))
    assert {was-bmp}
      string-append("no bitmap property for char #" number->string(cidx))
    ;;
    {cbmp-width := max(cbmp-width wdt)}
    {char-width[cidx] := wdt}
  ;;
  ;; (settings: height: 9 base-line: 7 left-mask: 128)
  define parse-settings(list)
    ;pprint(list)
    assert (and {pair? list}
                {car(list) eq? settings:}) "\"settings:\" expected"
    {list := cdr(list)}
    define name
    define value
    while {not-null? list}
      {name := car(list)}
      {value := cadr(list)}
      {list := cddr(list)}
      case name
        (height:)
          assert {boolean? height} "duplicate \"height:\" setting"
          assert {{fixnum? value} and between?(value 1 128)} "invalid \"height:\" setting"
          {height := value}
        (base-line:)
          assert {boolean? baseline} "duplicate \"base-line:\" setting"
          assert {{fixnum? value} and between?(value 0 128)} "invalid \"base-line:\" setting"
          {baseline := value}
        (bitmap-width:)
          assert {boolean? left-mask} "duplicate \"bitmap-width:\" setting"
          assert {{fixnum? value} and between?(value 1 30)} "invalid \"bitmap-width:\" setting"
          {left-mask := bit-shl(1 {value - 1})}
        else error("unknown setting")
    assert {fixnum? height} "no \"height:\" setting"
    assert {fixnum? baseline} "no \"base-line:\" setting"
    assert {fixnum? left-mask} "no \"bitmap-width:\" setting"
    assert {baseline < height} "invalid \"base-line:\" setting"
  ;;
  define do-parse(cdefs)
    parse-settings car(cdefs)
    {cdefs := cdr(cdefs)}
    {bitmap := make-vector({256 * height} 0)}
    let loop <* cidx 0 \\ cdef car(cdefs) \\ rest cdr(cdefs) *>
      do-parse-char cidx cdef
      if {not-null? rest}
        loop {cidx + 1} car(rest) cdr(rest)
    ;; fix kerning.
    ;; add 1, because it is always there
    define idx
    iterate
      init {idx := 0}
      repeat {idx <> vector-length(kerning)}
        if {null? kerning[idx]}
          {kerning[idx] := 1}
          {kerning[idx] := {kerning[idx] + 1}}
        inc! idx
      else #void
  ;;
  define fix-unknown-chars(ch-repl)
    define copy-char-bmp(src dest)
      define left height
      define sidx {src * left}
      define didx {dest * left}
      while {positive? left}
        {bitmap[didx] := bitmap[sidx]}
        inc! sidx
        inc! didx
        dec! left
    ;;
    define copy-char-kerning(src dest)
      define left 256
      define sidx {src * 256}
      define didx {dest * 256}
      while {positive? left}
        {kerning[didx] := kerning[sidx]}
        inc! sidx
        inc! didx
        dec! left
    ;;
    define ch 0
    while {ch <> 256}
      if {not char-seen[ch]}
        then
          copy-bitmap ch-repl ch
          copy-char-kerning ch-repl ch
      inc! ch
    ;;
    {char-seen := #nil}
  ;;
  define make-surface()
    define surf sdl:new-surface({16 * {cbmp-width + 2}} {16 * {height + 2}})
    sdl:surface-fill-rect surf 0 0 sdl:surface-width(surf) sdl:surface-height(surf) #@color:transparent
    define x
    define y
    define wdt
    define hgt
    define byte
    define mask
    define cv
    define ch 0
    while {ch <> 128}
      {y := {{{ch div 16} * {height + 2}} + 1}}
      {hgt := height}
      while {positive? hgt}
        {wdt := cbmp-width}
        {byte := bitmap[{{ch * height} + {height - hgt}}]}
        {mask := left-mask}
        {x := {{{ch mod 16} * {cbmp-width + 2}} + 1}}
        while {positive? wdt}
          ;{cv := {1.0 - {0.3 * {hgt / height}}}}
          ;{cv := 1.0}
          {cv := {1.14 - {0.5 * {hgt / height}}}}
          if {not-zero? bit-and(byte mask)}
            sdl:surface-set-pixel surf x y sdl:rgbf(cv cv cv)
          inc! x
          {mask := bit-shr(mask)}
          dec! wdt
        inc! y
        dec! hgt
      inc! ch
    ;;
    {font-surface := surf}
    {bitmap := #nil}
  ;;
  do-parse(cdefs)
  make-surface()
  ;;
  method-lambda
    free-surface: (self)
      if {not-null? font-surface}
        sdl:free-surface font-surface
      {font-surface := #nil}
      self
    ;;
    make-texture: (self window)
      sdl:new-texture-from-surface(window font-surface)
    ;;
    char-width-table: (self)
      char-width
    char-kerning-table: (self)
      kerning
    ;;
    char-width: (self ch)
      assert {{fixnum? ch} and between?(ch 0 255)} "invalid font char code"
      char-width[ch]
    ;;
    ;; add 1 if prevch is fixnum
    char-kerning: (self prevch ch)
      assert {{fixnum? ch} and between?(ch 0 255)} "invalid font char code"
      if {{fixnum? prevch} and between?(prevch 0 255)}
        kerning[{{ch * 256} + prevch}]
        0
    ;;
    height: (self)
      height
    base-line: (self)
      baseline
    ;; positive
    ascender: (self)
      {baseline - 1}
    ;; positive
    descender: (self)
      {height - baseline - 1}
    ;;
    char-tx: (self ch)
      assert {{fixnum? ch} and between?(ch 0 255)} "invalid font char code"
      {{{ch mod 16} * {cbmp-width + 2}} + 1}
    char-ty: (self ch)
      assert {{fixnum? ch} and between?(ch 0 255)} "invalid font char code"
      {{{ch div 16} * {height + 2}} + 1}
    char-tw: (self ch)
      assert {{fixnum? ch} and between?(ch 0 255)} "invalid font char code"
      char-width[ch]
    char-th: (self ch)
      assert {{fixnum? ch} and between?(ch 0 255)} "invalid font char code"
      height


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; create real font object from the parsed font
;;
;; ascender: number of pixels above the base line (not counting the base line itself)
;; descender: number of pixels below the base line (not counting the base line itself)
;; baseline + descender: the lowest font pixel
;; baseline - ascender: the highest font pixel
;;
;; advance: calculate x advance to print the next char
;; char-width: return char width without side bearings
;; draw-char: return advance
define create-font(pfont window)
  define hgt pfont[height:]
  define asc pfont[ascender:]
  define dsc pfont[descender:]
  define yofs pfont[ascender:]
  define base pfont[base-line:]
  define font-texture pfont[make-texture: window]
  define char-tcoords make-vector({256 * 4})
  define char-width pfont[char-width-table:]
  define kerning pfont[char-kerning-table:]
  ;;
  sdl:set-texture-blend-mode font-texture 'BLEND
  ;;
  define setup-char-tcoords(pfont tcv)
    define idx 0
    define ch 0
    while {ch <> 256}
      {tcv[idx] := pfont[char-tw: ch]}
      inc! idx
      {tcv[idx] := pfont[char-th: ch]}
      inc! idx
      {tcv[idx] := pfont[char-tx: ch]}
      inc! idx
      {tcv[idx] := pfont[char-ty: ch]}
      inc! idx
      inc! ch
  setup-char-tcoords pfont char-tcoords
  ;;
  method-lambda
    destroy!: (self)
      if {not-null? font-texture}
        then
          sdl:free-texture font-texture
          {font-texture := #nil}
      {pfont := #nil}
      {window := #nil}
    ;;
    color-set!: (self color)
      sdl:set-texture-color-mod font-texture color
      self
    height: (self)
      hgt
    base-line: (self)
      base
    ;; positive
    ascender: (self)
      asc
    ;; positive
    descender: (self)
      dsc
    char-width: (self ch)
      assert {{fixnum? ch} and between?(ch 0 255)} "invalid font char code"
      char-width[ch]
    char-kerning: (self prevch ch)
      assert {{fixnum? ch} and between?(ch 0 255)} "invalid font char code"
      if {{fixnum? prevch} and between?(prevch 0 255)}
        kerning[{{ch * 256} + prevch}]
        0
    ;; return x offset for the next char
    advance: (self prevch ch)
      assert {{fixnum? ch} and between?(ch 0 255)} "invalid font char code"
      if {{fixnum? prevch} and between?(prevch 0 255)}
        {char-width[ch] + kerning[{{ch * 256} + prevch}]}
        char-width[ch]
    ;; return advance
    draw-char: (self x y prevch ch)
      assert {{fixnum? ch} and between?(ch 0 255)} "invalid font char code"
      define dx 0
      if {{fixnum? prevch} and between?(prevch 0 255)}
        {dx := kerning[{{ch * 256} + prevch}]}
      define tidx bit-shl(ch 2)
      define ctw char-tcoords[tidx]
      define cth char-tcoords[{tidx + 1}]
      sdl:blit-texture-rect font-texture {x + dx} {y - yofs} ctw cth
        char-tcoords[{tidx + 2}]
        char-tcoords[{tidx + 3}]
        ctw
        cth
      {dx + char-width[ch]}
