;;;; written by daniele capo, 2009
;;;; feel free to improve it, if you want
;;;; if you do it, please, send me an email.
;;;; my email is capo[dot]daniele[at]gmail[dot]com
;;;; or info[at]danielecapo[dot]com

(require 'cxml)

(defun write-ufo (filename ufo)
  (let* ((path (pathname filename))
	(glyphs-plist (glyphs-plist (ufo-glyphs ufo)))
	(glyphs-path (merge-pathnames (pathname "glyphs/") path)))
    (progn
      (print glyphs-path)
      (plist-to-file (metainfo) (ensure-directories-exist (merge-pathnames 
							   #p"metainfo.plist" path)))
      (plist-to-file (ufo-fontinfo ufo) (merge-pathnames #p"fontinfo.plist" path))
      (when (ufo-groups ufo)
	(plist-to-file (ufo-groups ufo) (merge-pathnames #p"groups.plist" path)))
      (when (ufo-kerning ufo)
	(plist-to-file (ufo-kerning ufo) (merge-pathnames #p"kerning.plist" path)))
      (plist-to-file glyphs-plist (ensure-directories-exist 
				 (merge-pathnames #"content.plist" glyphs-path)))
						  
      (mapc #'(lambda (g) (glyph-to-file 
			   g (merge-pathnames (pathname (g-filename g)) glyphs-path))) 
	    (ufo-glyphs ufo))
      (print "done"))))
							   
    
    

			   

(defun ufo (fontinfo glyphs &optional groups kerning)
	   (list fontinfo groups kerning glyphs))

(defun ufo-fontinfo (ufo) (first ufo))
(defun ufo-groups (ufo) (second ufo))
(defun ufo-kerning (ufo) (third ufo))
(defun ufo-glyphs (ufo) (fourth ufo))

(defun fontinfo-basic (name stylename stylemap-stylename &key (ascender 750) (x-height 500) (cap-height 700) (real-ascender ascender)  (real-descender (- ascender 1000)) (overshoots 10) (italic 0.0))
  (let* ((units-per-em 1000)
	 (descender (- ascender units-per-em))
	 (full-name (format nil "~a ~a" name stylename))
	 (x-blue (list x-height (+ x-height overshoots)))
	 (cap-blue (list cap-height (+ cap-height overshoots)))
	 (ascender-blue (list real-ascender (+ real-ascender overshoots)))
	 (baseline-blue (list (- 0 overshoots) 0))
	 (descender-blue (list (- real-descender overshoots) real-descender)))
    (validate-plist
     (p-dict
      (p-key-value "familyName" name)
      (p-key-value "styleName" stylename)
      (p-key-value "styleMapFamilyName" name)
      (p-key-value "styleMapStyleName" stylemap-stylename)
      (p-key-value "postscriptWeightName" stylename)
      (p-key-value "postscriptFullName" full-name)
      (p-key-value "postscriptFontName" (substitute #\- #\Space full-name))
      (p-key-value "openTypeNameCompatibleFullName" full-name)
      (p-key-value "openTypeNamePreferredFamilyName" name)
      (p-key-value "openTypeNamePreferredSubfamilyName" stylename)
      (p-key-value "macintoshFONDName" name)
      (p-key-value "ascender" ascender)
      (p-key-value "descender" descender)
      (p-key-value "capHeight" cap-height)
      (p-key-value "xHeight" x-height)
      (p-key-value "openTypeOS2TypoAscender" ascender)
      (p-key-value "openTypeOS2TypoDescender" descender)
      (p-key-value "postscriptBlueFuzz" 1)
      (p-key-value "postscriptBlueScale" 0.039625)
      (p-key-value "postscriptBlueShift" 7)
      (p-key-value "postscriptBlueValues"
		   (build-blues baseline-blue x-blue cap-blue ascender-blue))
      (p-key-value "postscriptOtherBlues"
		   (build-blues descender-blue))
      (p-key-value "postscriptForceBold" nil)
      (p-key-value "italicAngle" (coerce italic 'float)))
     *fontinfo*)))
			 
(defun metainfo ()
  (p-dict
   (p-key-value "creator" "org.robofab.ufoLib")
   (p-key-value "formatVersion" 2)))

(defun group (name first-member &rest members)
  (p-key-value 
   name
   (apply #'p-array (cons first-member members))))

(defun groups (&rest groups)
  (apply #'p-dict groups))
		
(defun build-blues (&rest args)
  (apply #'p-array (reduce #'append args)))

(defun kerning-pair (first second kern)
	   (list first second kern))

(defun kern-to-dict (kerns)
  (if (every #'(lambda (kern) (equal (car kern) (caar kerns))) kerns)
      (p-key-value 
       (caar kerns)
       (apply #'p-dict
	      (mapcar 
	       #'(lambda (kern) 
		   (p-key-value (second kern) (third kern)))
	       kerns)))
      (error "not omogeneous kerning list")))


(defun build-kerning (&rest kerning-pairs)
  (labels ((extract (kerns) (remove-if-not #'(lambda (x) (equal (car x) (caar kerns))) kerns))
	   (retain (kerns) (remove-if #'(lambda (x) (equal (car x) (caar kerns))) kerns)))
    (let ((result (list (extract kerning-pairs))))
      (do ((i (retain kerning-pairs) (retain i)))
	  ((null i) (mapcar #'kern-to-dict result))
	(nconc result (list (extract i)))))))

(defmacro kerning (&rest kerning-pairs)
  `(build-kerning ,@(mapcar #'(lambda (k) `(kerning-pair ,@k)) kerning-pairs)))



(defun glyphs-plist (glyphs)
  (apply #'p-dict
   (mapcar #'(lambda (glyph) (p-key-value (g-name glyph) (g-filename glyph)))
	   glyphs)))

;; glyph constructors

(defun glyph (name unicode width &optional height contours components)
  (list name unicode width height contours components (build-glyph-filename name)))

(defun split-on-underscore (name)
  (do ((coll nil (append coll (list (subseq name start pos))))
	      (start 0 (1+ pos))
       (pos (position #\_ name) (position #\_ name :start (1+ pos))))
      ((null pos) (append coll (list (subseq name start))))
    (print start)))

(defun build-glyph-filename (name)
  (labels ((uppercase (part)
	     (if (upper-case-p (char part 0))
		 (format nil "~a_" part)
		 part)))
    (let* ((splitted (split-on-underscore name))
	   (s (uppercase (car splitted))))
	   (progn
	     (mapc 
	      #'(lambda (p) (setq s (format nil "~a_~a" s (uppercase p))))
	    (cdr splitted))
	   (concatenate 'string s ".glif")))))


(defun get-unicode (char)
  char)

(defun component (base transform)
  (cons base transform))

(defun transformation-matrix (&key (x-scale 1) (xy-scale 0) (yx-scale 0) (y-scale 1) (x-offset 0) (y-offset 0))
  (list x-scale xy-scale yx-scale y-scale x-offset y-offset))

(defun contour (&rest points)
  (if (null points) (error "You must supply some points")
      points))

(defun point (x y &key (type :offcurve) (smooth :no) name)
  (list (cons x y) type smooth name))

;; some glyph and related accessors

(defun g-name (glyph) (first glyph))
(defun g-unicode (glyph) (second glyph))
(defun g-width (glyph) (third glyph))
(defun g-height (glyph) (fourth glyph))
(defun g-contours (glyph) (fifth glyph))
(defun g-components (glyph) (sixth glyph))
(defun g-filename (glyph) (seventh glyph))

(defun comp-base (comp) (car comp))
(defun comp-transform (comp) (cdr comp))

(defun closed-p (cont)
  (not (eq :move (p-type (first cont)))))

(defun p-coord (point) (first point))
(defun p-x (point) (car (p-coord point)))
(defun p-y (point) (cdr (p-coord point)))
(defun p-type (point) (second point))
(defun p-smooth (point) (third point))
(defun smooth-p (point)
  (let ((smooth (p-smooth point)))
    (cond ((eq smooth :yes) t)
	  ((eq smooth :no) nil)
	  (t (error "invalid smooth value")))))

(defun p-name (point) (fourth point))

(defun x-scale (comp) (first (comp-transform comp)))
(defun xy-scale (comp) (second (comp-transform comp)))
(defun yx-scale (comp) (third (comp-transform comp)))
(defun y-scale (comp) (fourth (comp-transform comp)))
(defun x-offset (comp) (fifth (comp-transform comp)))
(defun y-offset (comp) (sixth (comp-transform comp)))

;;glyph writer

(defun point-to-xml (point)
  (cxml:with-element "point"
     (cxml:attribute "x" (write-to-string (coerce (p-x point) 'short-float)))
     (cxml:attribute "y" (write-to-string (coerce (p-y point) 'short-float)))
     (cxml:attribute "type" 
		     (let ((type (p-type point)))
		       (cond ((eq type :move) "move")
			     ((eq type :line) "line")
			     ((eq type :offcurve) "offcurve")
			     ((eq type :curve) "curve")
			     ((eq type :qcurve) "qcurve")
			     (t (error "wrong type")))))
     (when (smooth-p point) (cxml:attribute "smooth" "yes"))
     (when (p-name point) (cxml:attribute "name" (p-name point)))))

(defun contour-to-xml (contour)
  (cxml:with-element "contour"
    (mapcar #'point-to-xml contour)))

(defun contours-to-xml (contours)
  (when contours
    (mapcar #'contour-to-xml contours)))

(defun component-to-xml (component)
  (cxml:with-element "component"
    (cxml:attribute "base" (comp-base component))
    (cxml:attribute "xScale" (write-to-string (x-scale component)))
    (cxml:attribute "xyScale" (write-to-string (xy-scale component)))
    (cxml:attribute "yxScale" (write-to-string (yx-scale component)))
    (cxml:attribute "yScale" (write-to-string (y-scale component)))
    (cxml:attribute "xOffset" (write-to-string (x-offset component)))
    (cxml:attribute "yOffset" (write-to-string (y-offset component)))))

(defun components-to-xml (components)
  (when components
    (mapcar #'component-to-xml components)))

(defun glyph-to-xml (sink glyph)
  (cxml:with-xml-output sink
    (cxml:with-element "glyph"
      (cxml:attribute "format" "1")
      (cxml:attribute "name" (g-name glyph))
      (cxml:with-element "advance"
	(cxml:attribute "width" (g-width glyph))
	(when (g-height glyph) (cxml:attribute "height" (g-height glyph))))
    (cxml:with-element "unicode"
      (cxml:attribute "hex" (g-unicode glyph)))
    (cxml:with-element "outline"
      (contours-to-xml (g-contours glyph))
      (components-to-xml (g-components glyph))))))

(defun glyph-to-string (glyph)
  (glyph-to-xml (cxml:make-string-sink :indentation 1 :canonical nil) glyph))
	
(defun glyph-to-file (glyph file)
  (with-open-file (s file  :element-type '(unsigned-byte 8)  :direction :output) 
    (glyph-to-xml (cxml:make-octet-stream-sink s :indentation nil :canonical nil)
		  glyph)))


; helper function to write (apple?) property lists

(defmacro with-plist (sink &body body)
  `(cxml:with-xml-output ,sink
     (cxml:doctype "plist" "-//Apple Computer//DTD PLIST 1.0//EN"
		   "http://www.apple.com/DTDs/PropertyList-1.0.dtd")
    (cxml:with-element "plist"
      (cxml:attribute "version" "1.0")
      ,@body)))

(defun plist-to-string (plist)
  (with-plist (cxml:make-string-sink :indentation 1 :canonical nil)
    (get-plist plist)))


(defun plist-to-file (plist file)
  (with-open-file (s file  :element-type '(unsigned-byte 8)  :direction :output) 
    (with-plist (cxml:make-octet-stream-sink s :indentation nil :canonical nil)
      (get-plist plist))))


(defun get-plist (plist)
  (if (atom plist) (get-plist-atoms plist)
      (if (consp (car plist))
	  (cxml:with-element "dict"
	    (mapcar 
	     #'(lambda (el)
		 (cxml:with-element "key" (cxml:text (car el)))
		 (get-plist (cdr el)))
	     plist))
	  (cxml:with-element "array" 
	    (mapcar #'get-plist-atoms plist)))))


(defun get-plist-atoms (a)
  (cxml:with-element
   (cond ((integerp a) "integer")
	 ((floatp a) "real")
	 ((stringp a) "string")
	 ((null a) "false")
	 ((eq t a) "true"))
   (if (and (not (null a)) (not (eq t a))) 
       (cxml:text 
	(if (numberp a) 
	    (write-to-string a) 
	    a)) 
	nil)))


(defun validate-plist (plist definitions)
  (mapc #'(lambda (el)
	    (let ((definition 
		   (get-def-from-key definitions (key el))))
	      (if definition
		  (if (functionp (test definition))
		      (when (not (funcall (test definition) (content el)))
			(error "wrong type"))
		      (validate-plist (content el) (test definition)))
		  (error "wrong key"))))
	plist))


;; property list constructurs 

(defun p-key-value (key value)
  (if (stringp key) (cons key value)
      (error "Key is not a string")))


(defun p-array (&rest args)
  (if (some #'listp args)
      (error "An array must be a flat list")
      args))

(defun p-dict (&rest args)
  (if (some #'atom args)
      (error "A dictionary must be a list of pairs")
      args))

(defmacro add-to-p-dict (key-value-pair dict)
  `(push ,key-value-pair ,dict))

;; property list accessors

(defun get-from-key (dict key)
  (assoc key dict :test 'string=))

(defun key (obj)
  (car obj))

(defun content (obj)
  (cdr obj))

;; definitions constructors
(defmacro make-definition-list (&rest defs)
	   `(list ,@(mapcar #'(lambda (x) (cons 'make-def x)) defs)))

;; is this needed?
(defmacro add-def (def deflist)
  `(push ,def ,deflist))


(defun make-def (name &optional test coercer)
  (list name test coercer))


;; definitions accessors
(defun get-def-from-key (dict key)
  (let ((fn (key (car dict))))
    (if (functionp fn)
	(if (funcall fn key) 
	    (car dict)
	    nil)
	(assoc key dict :test 'string=))))

(defun test (obj)
  (second obj))

(defun plist-coercer (obj)
  (third obj))

;; tests and test generators
(defun is-in (&rest items)
  #'(lambda (item)
      (not (null (find item items :test 'equal)))))

(defun in-range (min max)
  #'(lambda (obj)
      (and (>= obj min) (<= obj max))))

(defun number-list-p (obj)
  (every #'numberp obj))

(defun bool-p (obj)
	   (or (eq t obj) (null obj))) 

;; simple (too much simple) float parser to use later (maybe)

(defun split-float-string (s)
	   (let ((p (position #\. s)))
	     (values
	      (subseq s 0 p)
	      (if p (subseq s (1+ p) nil)))))

(defun parse-float (s)
	   (multiple-value-bind (i d) (split-float-string s)
	     (if d
		 (+ (float (parse-integer i))
		    (/ (float (parse-integer d)) (expt 10 (length d))))
	    (float (parse-integer i)))))


(defvar *fontinfo* 
  (make-definition-list
   ("familyName" #'stringp)
   ("styleName" #'stringp)
   ("styleMapFamilyName" #'stringp)
   ("styleMapStyleName" (is-in "regular" "italic" "bold" "bold italic"))
   ("versionMajor" #'integerp)
   ("versionMinor" #'integerp)
   ("year" #'integerp)
   ("copyright" #'stringp)
   ("trademark" #'stringp)
   ("unitsPerEm" #'numberp)
   ("descender" #'numberp)
   ("xHeight" #'numberp)
   ("capHeight" #'numberp)
   ("ascender" #'numberp)
   ("italicAngle" #'floatp)
   ("openTypeHeadCreated" #'stringp)
   ("openTypeHeadLowestRecPPEM" #'numberp)
   ("openTypeHeadFlags" #'number-list-p)
   ("penTypeHheaAscender" #'numberp)
   ("openTypeHheaDescender" #'numberp)
   ("openTypeHheaLineGap" #'numberp)
   ("openTypeHheaCaretSlopeRise" #'integerp)
   ("openTypeHheaCaretSlopeRun" #'integerp)
   ("openTypeHheaCaretOffset" #'numberp)
   ("openTypeNameDesigner" #'stringp)
   ("openTypeNameDesignerURL" #'stringp)
   ("openTypeNameManufacturer" #'stringp)
   ("openTypeNameManufacturerURL" #'stringp)
   ("openTypeNameLicense" #'stringp)
   ("openTypeNameLicenseURL" #'stringp)
   ("openTypeNameVersion" #'stringp)
   ("openTypeNameUniqueID" #'stringp)
   ("openTypeNameDescription" #'stringp)
   ("openTypeNamePreferredFamilyName" #'stringp)
   ("openTypeNamePreferredSubfamilyName" #'stringp)
   ("openTypeNameCompatibleFullName" #'stringp)
   ("openTypeNameSampleText" #'stringp)
   ("openTypeNameWWSFamilyName" #'stringp)
   ("openTypeNameWWSSubfamilyName" #'stringp)
   ("openTypeOS2WidthClass" (in-range 1 9))
   ("openTypeOS2WeightClass" #'integerp)
   ("openTypeOS2Selection" #'number-list-p)
   ("openTypeOS2VendorID" #'(lambda (obj)
			      (and (stringp obj) (= 4 (length obj)))))
   ("openTypeOS2Panose" #'(lambda (obj)
			    (and (= 10 (length obj)) (every #'integerp obj))))
   ("openTypeOS2FamilyClass" #'(lambda (obj)
				 (and 
				  (= 2 (length obj))
				  (funcall (in-range 0 14) (first obj))
				  (funcall (in-range 0 15) (second obj)))))
   ("openTypeOS2UnicodeRanges" #'number-list-p)
   ("openTypeOS2CodePageRanges" #'number-list-p)
   ("openTypeOS2TypoAscender" #'numberp)
   ("openTypeOS2TypoDescender" #'numberp)
   ("openTypeOS2TypoLineGap" #'numberp)
   ("openTypeOS2WinAscent" #'numberp)
   ("openTypeOS2WinDescent" #'numberp)
   ("openTypeOS2Type" #'number-list-p)
   ("openTypeOS2SubscriptXSize" #'numberp)
   ("openTypeOS2SubscriptYSize" #'numberp)
   ("openTypeOS2SubscriptXOffset" #'numberp)
   ("openTypeOS2SubscriptYOffset" #'numberp)
   ("openTypeOS2SuperscriptXSize" #'numberp)
   ("openTypeOS2SuperscriptYSize" #'numberp)
   ("openTypeOS2SuperscriptXOffset" #'numberp)
   ("openTypeOS2SuperscriptYOffset" #'numberp)
   ("openTypeOS2StrikeoutSize" #'numberp)
   ("openTypeOS2StrikeoutPosition" #'numberp)
   ("openTypeVheaVertTypoAscender" #'numberp)
   ("openTypeVheaVertTypoDescender" #'numberp)
   ("openTypeVheaVertTypoLineGap" #'numberp)
   ("openTypeVheaCaretSlopeRise" #'integerp)
   ("openTypeVheaCaretSlopeRun" #'integerp)
   ("openTypeVheaCaretOffset" #'numberp)
   ("postscriptFontName" #'stringp)
   ("postscriptFullName" #'stringp)
   ("postscriptSlantAngle" #'floatp)
   ("postscriptUniqueID" #'integerp)
   ("postscriptUnderlineThickness" #'numberp)
   ("postscriptUnderlinePosition" #'numberp)
   ("postscriptIsFixedPitch" #'bool-p)
   ("postscriptBlueValues" #'(lambda (obj)
			       (and (<= (length obj) 14)
				    (evenp  (length obj))
				    (every #'integerp obj))))
   ("postscriptOtherBlues" #'(lambda (obj)
			       (and (<= (length obj) 10)
				    (evenp  (length obj))
				    (every #'integerp obj))))
   ("postscriptFamilyBlues" #'(lambda (obj)
			       (and (<= (length obj) 14)
				    (evenp  (length obj))
				    (every #'integerp obj))))
   ("postscriptFamilyOtherBlues" #'(lambda (obj)
			       (and (<= (length obj) 10)
				    (evenp  (length obj))
				    (every #'integerp obj))))
   ("postscriptStemSnapH" #'(lambda (obj)
			       (and (<= (length obj) 12)
				    (every #'numberp obj))))
   ("postscriptStemSnapV" #'(lambda (obj)
			       (and (<= (length obj) 12)
				    (every #'numberp obj))))
   ("postscriptBlueFuzz" #'numberp)
   ("postscriptBlueShift" #'numberp)
   ("postscriptBlueScale" #'floatp)
   ("postscriptForceBold" #'bool-p)
   ("postscriptDefaultWidthX" #'numberp)
   ("postscriptNominalWidthX" #'numberp)
   ("postscriptWeightName" #'stringp)
   ("postscriptDefaultCharacter" #'stringp)
   ("postscriptWindowsCharacterSet" (in-range 1 20))
   ("macintoshFONDFamilyID" #'integerp)
   ("macintoshFONDName" #'stringp)))