;;; photofont.lisp - A program to generate photofonts
;;; Dec 5, 2008 by Max-Gerd Retzlaff <m.retzlaff@gmx.net>
;;; Version 1
;;;
;;; See http://www.photofont.com/ for more information.
;;; The "Photofont format specification" is here:
;;;                     http://www.photofont.com/photofont/devel/
;;;
;;; Example call:
;;;   (photofont "Teelichter256" "font-spec-256" "Teelichter256.phf" :indent nil)
;;;
;;; The font-spec file is expected to contain lines like this one:
;;; ! Teelichter-256/!_dscf5475.jpg.png
;;; (single character, a single space, filename with relative path, newline character)   

(require :xmls)
(require :cl-mime)
(require :s-base64)
(require :png) ;; cl-png

(defun png->mime (pathname)
  (with-output-to-string (mime-out)
    (let ((png (with-open-file (in pathname
                                   :element-type '(unsigned-byte 8))
                 (with-output-to-string (out)
                   (s-base64:encode-base64 in out)))))
      (mime:print-mime mime-out
                       (make-instance 'mime:text-mime
                                      :type "image"
                                      :subtype "png"
                                      :charset "US-ASCII"
                                      :content-encoding :base64
                                      :encoding :base64
                                      :content png)
                       t nil))))
;; (png->mime "Teelichter/256/A_dscf5380.jpg.png")

(defun png-dimensions (pathname) 
  (let ((png (with-open-file (in pathname
                                 :element-type '(unsigned-byte 8))
               (png:decode in))))
    (values (png:image-width png)
            (png:image-height png))))

(defun root (children)
  (xmls:make-node :name "PhF" :attrs '(("version" "1.0"))
                  :children children))

#+(or)
(defun header ()
  (xmls:make-node :name "header"
                  (make-node :name "version" :attrs (xmls:make-node :name "type" :attrs "string"))
                  (make-node :name)
                  ))
(defun header (fontname &key (encoding "ISO 8859- 1 Latin 1 (Western)")
                             (ascender 256)
                             (descender 51)
                             (internal-leading 77)
                             (upm 256))
  `("header" NIL ("version" (("type" "string")))
    ("family" (("type" "string")) ,fontname)
    ("full_name" (("type" "string")) ,fontname)
    ("codepage" (("type" "string")) ,(princ-to-string encoding))
    ("ascender" (("type" "int")) ,(princ-to-string ascender))
    ("descender" (("type" "int")) ,(princ-to-string descender))
    ("internal_leading" (("type" "int")) ,(princ-to-string internal-leading))
    ("upm" (("type" "int")) ,upm)))

(defun letter->id (letter)
  "More or less a bugfix, as the photofont plug-in for Adobe Photoshop CS3 (Windows),
seems to have a problem with XML encodings like \"&#xA7;\"... Otherwise I would just
use STRING."
  (let ((code (char-code letter)))
    (if (< 127 code)
        (char-name letter)
        ;; (format nil "~a+0x80" (code-char (- code 128)))
        (string letter))))

(defun mapping (letter)
  `("map" (("unc" ,(princ-to-string (char-code letter))) ("id" ,(letter->id letter)))))

(defun all-mappings (letters)
  (mapcar #'mapping letters))

(defun globals (all-mappings)
  `("globals" NIL
              ("unicode_mapping" (("subtype" "map_unicode") ("type" "array"))
                                 ,@all-mappings)))
;; (globals  (all-mappings (coerce "ABCDß!§$" 'list)))

(defun glyph (letter pathname)
  (multiple-value-bind (width height)
      (png-dimensions pathname)
    (let ((width-string (princ-to-string width))
          (height-string (princ-to-string height)))
      `("glyph" (("id" ,(letter->id letter)))
                ("image" (("type" "photo")
                          ("id" "v0"))
                         ("shape" (("embedded" ,(file-namestring pathname)))
                                  ("ppm" (("int" ,height-string)))
                                  ("bbox" (("height" ,height-string) ("width" ,width-string)
                                           ("y" "0") ("x" "0")))
                                  ("base" (("y" ,height-string) ("x" "0")))
                                  ("delta" (("y" "0") ("x" ,(princ-to-string (- width 2)))))))))))

(defun all-glyphs (list)
  (xmls:make-node :name "glyphs"
                  :children (mapcar (lambda (glyph-spec)
                                      (apply #'glyph glyph-spec))
                                    list)))
#+(or)
(all-glyphs '((#\A #p"Teelichter/256/A_dscf5380.jpg.png")
                       (#\B #p"Teelichter/256/B_dscf5702.jpg.png")))

(defun image (pathname)
  (xmls:make-node :name "image" :attrs `(("id" ,(file-namestring pathname)))
                  :children (list (png->mime pathname))))
;; (image "Teelichter/256/A_dscf5380.jpg.png")

(defun all-images (pathnames)
  (xmls:make-node :name "data"
                  :children (list (xmls:make-node :name "photo"
                                             :children (mapcar #'image pathnames)))))
#+(or)
(all-images (list "Teelichter/256/A_dscf5380.jpg.png"
                  "Teelichter/256/B_dscf5702.jpg.png"))

(defun parse-fontspec (pathname)
  (let ((glyph-specs))
    (with-open-file (file pathname)
      (do ((line (read-line file nil 'eof)
                 (read-line file nil 'eof)))
          ((eq line 'eof))
        (push  (list (elt line 0)
                     (subseq line 2))
               glyph-specs)))
    (nreverse glyph-specs)))


(defun generate-photofont (fontname pathname)
  (let ((glyph-specs (parse-fontspec pathname)))
    (multiple-value-bind (width height)
        (png-dimensions (second (first glyph-specs)))
        (declare (ignore height))
      (root
       (list 
        (header fontname
                :ascender (princ-to-string width)
                :upm (princ-to-string width))
        (globals  (all-mappings (mapcar #'car glyph-specs)))
        (all-glyphs glyph-specs)
        (all-images (mapcar #'second glyph-specs)))))))

(defun photofont (fontname source target &key indent)
  (with-open-file (out target :direction :output :if-exists :overwrite :if-does-not-exist :create)
    (princ "<?xml version=\"1.0\" ?>
" out)
    (xmls:write-xml (generate-photofont fontname source) out :indent indent)))
;; (photofont "Teelichter256" "font-spec-256" "Teelichter256.phf" :indent nil)
;; (princ (xmls:toxml * :indent  t))