;; see blog post for documentation of what follows:
;;   http://nklein.com/2009/12/rendering-text-with-cl-opengl-and-zpb-ttf

(defun draw-quad (bx1 by1 bx2 by2)
  (gl:with-primitives :quads
    (gl:vertex bx1 by1)
    (gl:vertex bx2 by1)
    (gl:vertex bx2 by2)
    (gl:vertex bx1 by2)))

(defun make-interpolator (ss cc ee)
  (let ((xx (+ ss (* -2 cc) ee))
	(yy (* 2 (- cc ss))) 
	(zz ss))
    #'(lambda (tt)
	(+ (* xx tt tt) (* yy tt) zz))))

(defun interpolate (sx sy ex ey int-x int-y &optional (st 0) (et 1))
  (let ((mx (/ (+ sx ex) 2.0))
	(my (/ (+ sy ey) 2.0))
	(mt (/ (+ st et) 2.0)))
    (let ((nx (funcall int-x mt))
	  (ny (funcall int-y mt)))
      (let ((dx (- mx nx))
	    (dy (- my ny)))
	(when (< 1 (+ (* dx dx) (* dy dy)))
	  (interpolate sx sy nx ny int-x int-y st mt)
	  (gl:vertex nx ny)
	  (interpolate nx ny ex ey int-x int-y mt et))))))

(defun render-glyph (glyph mode)
  (zpb-ttf:do-contours (contour glyph)
    (gl:with-primitives mode
      (zpb-ttf:do-contour-segments (start ctrl end) contour
	(let ((sx (zpb-ttf:x start))
	      (sy (zpb-ttf:y start))
	      (cx (when ctrl (zpb-ttf:x ctrl)))
	      (cy (when ctrl (zpb-ttf:y ctrl)))
	      (ex (zpb-ttf:x end))
	      (ey (zpb-ttf:y end)))
	  (gl:vertex sx sy)
	  (when ctrl
	    (let ((int-x (make-interpolator sx cx ex))
		  (int-y (make-interpolator sy cy ey)))
	      (interpolate sx sy ex ey int-x int-y)))
	  (gl:vertex ex ey))))))

(defun render-string (string font-loader fill)
  (loop :for pos :from 0 :below (length string)
     :for cur = (zpb-ttf:find-glyph (aref string pos) font-loader)
     :for prev = nil :then cur
     :do (when prev
	   (gl:translate (- (zpb-ttf:kerning-offset prev cur font-loader)
			    (zpb-ttf:left-side-bearing cur))
			 0 0))
	 (render-glyph cur (if fill :polygon :line-strip))
         (gl:translate (zpb-ttf:advance-width cur) 0 0)))

(defun draw-string (font-loader string &key (size 48) (filled t))
  (gl:with-pushed-matrix
    (let* ((box (zpb-ttf:string-bounding-box string font-loader :kerning t))
	   (bx1 (aref box 0))
	   (by1 (aref box 1))
	   (bx2 (aref box 2))
	   (by2 (aref box 3)))

      (let ((ss (/ size (zpb-ttf:units/em font-loader))))
	(gl:scale ss ss 1))

      (gl:translate (/ (- bx1 bx2) 2) (/ (- by1 by2) 2) 0)

      (gl:with-pushed-attrib (:current-bit :color-buffer-bit :line-bit
					   :hint-bit :stencil-buffer-bit)
	;; antialias lines
      (gl:enable :blend)
      (gl:blend-func :src-alpha :one-minus-src-alpha)
      (gl:enable :line-smooth)
      (gl:hint :line-smooth-hint :nicest)
      (gl:with-pushed-matrix
	  (render-string string font-loader nil))

      (when filled
	;; fill stencil buffer with filled-in-glyph
	(gl:color-mask nil nil nil nil)
	(gl:enable :stencil-test)
	(gl:stencil-mask 1)
	(gl:clear-stencil 0)
	(gl:clear :stencil-buffer-bit)
	(gl:stencil-func :always 1 1)
	(gl:stencil-op :invert :invert :invert)
	(gl:with-pushed-matrix
	    (render-string string font-loader t))

	;; fill in area subject to stencil
	(gl:color-mask t t t t)
	(gl:stencil-func :equal 1 1)
	(draw-quad bx1 by1 bx2 by2))))))