Clojure TTF

core.clj

(ns ttftest.core
  (:require 
    [taoensso.timbre :as log]
    [clojure.java.io :as jio])
  (:import
    (java.nio ByteBuffer)
    (org.lwjgl BufferUtils)
    (org.lwjgl.system MemoryStack)
    (org.lwjgl.stb STBTruetype STBTTFontinfo)
    (org.apache.commons.io IOUtils)))

(defmacro defn-ms [name [memory-stack & args] & body]
  `(defn ~name [~memory-stack ~@args]
     (.push ~memory-stack)
     (try
       ~@body
       (finally
         (.pop ~memory-stack)))))

(defn make-font
  [x]
  ;; Load font from file
  (let [info         (STBTTFontinfo/calloc)
        buffer       (-> x
                       jio/input-stream
                       IOUtils/toByteArray
                       ByteBuffer/wrap)
       direct-buffer (BufferUtils/createByteBuffer (.limit buffer))]
    (doto direct-buffer
      (.put buffer)
      (.flip))
    (if (zero? (STBTruetype/stbtt_InitFont info direct-buffer))
      (throw (RuntimeException. (str "Error loading font " x)))
      info)))

(def cjk-blocks
  (set
    (concat (range 0x2E80 0x2EFF)
            (range 0x3000 0x9FFF)
            (range 0xAC00 0xD7AF)
            (range 0xF900 0xFAFF))))


;; A sequence of [character underline?]
(defn- displayable-characters [^STBTTFontinfo font]
  "Returns a map from codepoint to glyph index"
  (into {}
    (reduce (fn [m codepoint]
             (let [glyph-index (STBTruetype/stbtt_FindGlyphIndex font (int codepoint))]
               (if  (and (pos? glyph-index)
                         (not (contains? cjk-blocks codepoint)))
                 (assoc m codepoint glyph-index)
                 m)))
          {}
          (range 0x0000 0xFFFF))))



(defn-ms hmetrics [^MemoryStack ms ^STBTTFontinfo font-info glyph-index]
  (let [advance-width     (.mallocInt ms 1)
        left-side-bearing (.mallocInt ms 1)]
    (STBTruetype/stbtt_GetGlyphHMetrics font-info (int glyph-index) advance-width left-side-bearing)
    [(.get advance-width) (.get left-side-bearing)]))

(defn-ms vmetrics [^MemoryStack ms ^STBTTFontinfo font-info]
  (let [ascent   (.mallocInt ms 1)
        descent  (.mallocInt ms 1)
        line-gap (.mallocInt ms 1)]
    (STBTruetype/stbtt_GetFontVMetrics font-info ascent descent line-gap)
    [(.get ascent) (.get descent) (.get line-gap)]))

(defn-ms glyph-bitmap-box [^MemoryStack ms ^STBTTFontinfo font-info scale glyph-index]
  (let [ix0 (.mallocInt ms 1)
        iy0 (.mallocInt ms 1)
        ix1 (.mallocInt ms 1)
        iy1 (.mallocInt ms 1)]
    (STBTruetype/stbtt_GetGlyphBitmapBox
      font-info
      (int glyph-index)
      (float scale)
      (float scale)
      ix0
      iy0
      ix1
      iy1)
    [(.get ix0) (.get iy0) (.get ix1) (.get iy1)]))



(defn- char-image [ms font-info char-width char-height ascent scale codepoint glyph-index]
  (let [;scale 0.015625
        [x0 y0 x1 y1]         (glyph-bitmap-box ms font-info scale glyph-index)
        baseline              (int (* ascent scale))
        [_ left-side-bearing] (map (partial * scale) (hmetrics ms font-info glyph-index))
        y                     (+ baseline y0)
        img                   (BufferUtils/createByteBuffer (* char-width char-height 1))]
    (log/info "char-width" (char codepoint) "(" (int codepoint) ")" char-width char-height
            "ascent" ascent "scale" scale "baseline" baseline
            "left-side-bearing" left-side-bearing "y" y)
    ;(log/info "x0" x0 "y0" y0 "x1" x1 "y1" y1)
    ;; draw greyscale font
    (STBTruetype/stbtt_MakeGlyphBitmapSubpixel
      font-info
      img
      char-width
      char-height
      char-width
      scale
      scale
      0.0
      0.0
      (int glyph-index))))

(defn -main [& args]
    (let [ms (MemoryStack/create)
          path                       (first args)
          size                       (Integer/parseInt (second args))
          ^STBTTFontinfo font-info   (make-font path)
          scale                      (STBTruetype/stbtt_ScaleForPixelHeight
                                       font-info
                                       size)
          [advance
           left-side-bearing]        (map (partial * scale)
                                       (hmetrics ms
                                                 font-info
                                                 (STBTruetype/stbtt_FindGlyphIndex
                                                   font-info
                                                   (int \M))))
          characters                 (displayable-characters font-info)
          char-width                 (int (Math/ceil advance))
          char-height                size
          [ascent
           descent
           line-gap]                 (vmetrics ms font-info)
          antialias  true]
      (log/info characters)
      #_(log/info "char-idxs" char-idxs)
      ;(log/info "characters" (vec characters))
      ;(log/info "character-idxs" (vec (character-idxs characters)))
      ;; Loop through each character, drawing it
      (doseq [[codepoint glyph-index] characters]
        (char-image ms font-info char-width char-height ascent scale codepoint glyph-index))))