November 10th, 2008

Vecto flavor

Here's something I threw together in a matter of a few minutes. It's not polished or cute but it does something I thought was amusing, and it shows how to draw something. Unfortunately, the code uses an unreleased library, Vectometry, for a lot of things, but I hope it's interesting as an example of a quick off-the-cuff drawing program. Once the program worked, I didn't go back and clean anything up or factor anything out, I'm just posting it as-is.

This sort of simple program often turns into a wigflip.com toy. The drawing code of EasyStreet is even shorter.

The general idea is simple enough. I saw a "BABY ON BOARD!" sign somewhere and said to myself, "Hey, that's Futura Bold Extra Black Condensed. I should draw one of those with Vecto." Here's the result:

Here's the Lisp code ("bob" is "baby on board"):

;;;; bob.lisp

(defpackage #:bob
  (:use #:cl
        #:vectometry))

(in-package #:bob)

(defvar *font* (zpb-ttf:open-font-loader "font.ttf"))

(defun words-bounding-box (size words)
  (let* ((em (zpb-ttf:units/em *font*))
         (scale (/ size em)))
    (let ((height (* size (length words)))
          (box (string-bounding-box (first words) size *font*)))
      (dolist (string (rest words))
        (setf box (combine box (string-bounding-box string size *font*))))
      (box (xmin box) (ymin box)
           (xmax box) height))))
             
(defclass diamond ()
  ((north
    :initarg :north
    :accessor north)
   (south
    :initarg :south
    :accessor south)
   (east
    :initarg :east
    :accessor east)
   (west
    :initarg :west
    :accessor west)))

(defmethod bounding-box ((diamond diamond))
  (box (x (west diamond)) (y (south diamond))
       (x (east diamond)) (y (north diamond))))

(defun enclosing-diamond (box)
  (let* ((center (centerpoint box))
         (length (+ (/ (width box) 2)
                    (/ (height box) 2)))
         (v (point 0 length))
         (h (point length 0)))
    (make-instance 'diamond
                   :north (add center v)
                   :south (sub center v)
                   :east (add center h)
                   :west (sub center h))))

(defun edge-length (diamond)
  (distance (north diamond) (east diamond)))

(defmethod centerpoint ((diamond diamond))
  (midpoint (north diamond) (south diamond)))

(defun sign (size words file)
  (let* ((box (words-bounding-box size words))
         (min (add (ypoint (* size 1/6)) (neg (minpoint box))))
         (center (centerpoint box))
         (k1 (* size 1/8))
         (k2 (* size 1/5)))
    (setf box (displace box (neg center)))
    (let* ((diamond (enclosing-diamond (expand box k2)))
           (edge (edge-length diamond)))
      (with-box-canvas (expand (bounding-box diamond) k2)
        (with-graphics-state
          (rotate-degrees 45)
          (let* ((halfedge (/ edge 2))
                 (b1 (box (- halfedge) (- halfedge)
                          halfedge halfedge)))
            (rectangle (expand b1 k1))
            (set-fill-color (hsv-color 60 1 1))
            (fill-path)
            (rounded-rectangle b1
                               k2 k2)
            (set-line-width k1)
            (stroke)))
        (set-fill-color *black*)
        (set-font *font* size)
        (let ((p (add (minpoint box)
                      (xpoint (/ (width box) 2)))))
          (dolist (word (reverse words))
            (draw-centered-string (add min p) word)
            (setf p (add p (point 0 size)))))
        (save-png file)))))


;; * (sign 48 '("CTHULHU" "ON" "BOARD!") "/tmp/cthulhu.png")
;; #P"/tmp/cthulhu.png"