This week I made a new wigflip toy called Thank You Mario. It lets you fake up that castle screen from Super Mario Brothers where you are told "THANK YOU MARIO! BUT OUR PRINCESS IS IN ANOTHER CASTLE!" except with your own text. Like some of the other toys, the output is an animated GIF you can save and share around. Something like this:

The core of this toy is around 300 lines of Common Lisp, supported by the Vecto, zpb-ttf, and Skippy libraries.

I figured I'd share the code, just for the heck of it.

Here's nesfont.lisp. It creates really simple nesfont objects from TrueType font files. The nesfont can be saved to disk and reloaded when the app starts. Those nesfonts are used to produce GIF image frames that are laid over the background.

;;;; nesfont.lisp
;;;; A "nesfont" file is for storing the rasterized glyphs in a
;;;; bitmap-style TTF for easy use on a GIF.
;;;; The file format is a GIF89a data stream prepended with some
;;;; metadata:
;;;;  ub32: magic value #xFAFF3337
;;;;  ub32: glyph count
;;;;  ub32[glyph count]: code point for each GIF data stream image
;;;;  ub8[until end of file]: GIF89a data stream.
;;;; The glyphs are rasterized so that index 0 is the background and
;;;; index 1 is the glyph.

(defpackage #:nesfont
  (:use #:cl
  (:shadowing-import-from #:zpb-ttf
  (:import-from #:vecto
  (:shadowing-import-from #:skippy
  (:export #:write-nesfont-file

(in-package #:nesfont)

(defun write-u32 (value stream)
  (write-byte (ldb (byte 8 0) value) stream)
  (write-byte (ldb (byte 8 8) value) stream)
  (write-byte (ldb (byte 8 16) value) stream)
  (write-byte (ldb (byte 8 24) value) stream))

(defun read-u32 (stream)
  (logior (ash (read-byte stream) 0)
          (ash (read-byte stream) 8)
          (ash (read-byte stream) 16)
          (ash (read-byte stream) 24)))

(defvar +magic+ #xFAFF3337)

(defvar *color-table*
  (make-color-table :initial-contents '(#x000000 #xFFFFFF)))

(defvar +black+ 0)
(defvar +white+ 1)

(defun vecto-to-frame ()
  (let* ((png-data (vecto::image-data *graphics-state*))
          (image (make-image :width (vecto::width *graphics-state*)
                             :height (vecto::height *graphics-state*)))
          (gif-data (image-data image)))
    (fill gif-data +black+)
    (loop for i from 0 by 4
          for j below (length gif-data)
          for psample = (aref png-data i)
          when (plusp psample)
          do (setf (aref gif-data j) +white+))

(defun save-fixup (stream)
      (file-position stream)
    (write-u32 #xFF00FF00 stream)))

(defun write-fixup (value fixup stream)
  (let ((restore (file-position stream)))
           (file-position stream fixup)
           (write-u32 value stream))
      (file-position stream restore))))
(defclass nesfont ()
    :initarg :size
    :accessor size
    "Each glyph is in a square image, SIZE pixels on each edge.")
    :initarg :glyphs
    :accessor glyphs
    :documentation "A hash table of glyph images, keyed by integer
    code points.")))

(defmethod print-object ((font nesfont) stream)
  (print-unreadable-object (font stream :type t)
    (format stream "~Dx~:*~D, ~D glyph~:P"
            (size font)
            (hash-table-count (glyphs font)))))

(defun write-nesfont-file (loader file &key (size 8))
  (with-open-file (stream file
                   :direction :output
                   :element-type '(unsigned-byte 8)
                   :if-exists :supersede)
    (let ((glyph-count 0)
          (glyph-count-fixup 0))
      (write-u32 +magic+ stream)
      (write-u32 size stream)
      (setf glyph-count-fixup (save-fixup stream))
      (let ((ds (make-data-stream :height size :width size
                                  :color-table *color-table*))
            (origin (truncate size 8)))
        (dotimes (i (glyph-count loader) ds)
          (let* ((glyph (index-glyph i loader))
                 (code-point (and glyph (code-point glyph))))
            (when code-point
              (incf glyph-count)
              (write-u32 code-point stream)
              (with-canvas (:width size :height size)
                (set-font loader size)
                (set-rgb-fill 0 0 0)
                (set-rgb-fill 1 1 1)
                (draw-string 0 origin (vector code-point))
                (add-image (vecto-to-frame) ds)))))
        (write-data-stream ds stream)
        (write-fixup glyph-count glyph-count-fixup stream)))))

(defun load-nesfont (file)
  (with-open-file (stream file :element-type '(unsigned-byte 8))
    (assert (= +magic+ (read-u32 stream)))
    (let* ((size (read-u32 stream))
           (glyph-count (read-u32 stream))
           (code-points (make-array glyph-count)))
      (dotimes (i glyph-count)
        (setf (aref code-points i) (read-u32 stream)))
      (let ((ds (read-data-stream stream))
            (glyphs (make-hash-table)))
        (map nil (lambda (code-point image)
                   (setf (gethash code-point glyphs) image))
             (images ds))
        (make-instance 'nesfont
                       :glyphs glyphs
                       :size size))))) 
(defgeneric missing-glyph (nesfont)
  (:method (nesfont)
    (gethash 0 (glyphs nesfont))))

(defgeneric char-glyph (char nesfont)
  (:method ((char integer) nesfont)
    (gethash char (glyphs nesfont) (missing-glyph nesfont)))
  (:method ((char character) nesfont)
    (char-glyph (char-code char) nesfont)))

(defgeneric glyph-canvas (font width height)
  (:method (font width height)
    (let ((size (size font)))
      (make-image :width (max size (* width size))
                  :height (max size (* height size))))))

(defgeneric lines-image (lines font)
  (:method (lines font)
    (let* ((max-width (reduce #'max lines :key #'length))
           (image (glyph-canvas font max-width (1- (* 2 (length lines)))))
           (size (size font)))
      (loop for y from 0
            for line in lines do
            (loop for x from 0
                  for char across line do
                  (composite (char-glyph char font) image
                             :dx (* x size)
                             :dy (* y size 2))))

(defgeneric string-image (string font)
  (:method (string font)
    (lines-image (list string) font)))

(defgeneric blank-image (width height font)
  (:method (width height font)
    (let ((size (size font)))
      (make-image :width (* width size)
                  :height (* height size)))))

Here's thankyoumario.lisp. This uses nesfont to put together the final image.

;;;; thankyoumario.lisp

(defpackage #:thankyoumario
  (:use #:cl #:skippy #:nesfont)
  (:export #:make-mario-image

(in-package #:thankyoumario)

(defvar *resource-base*
  (merge-pathnames #p"../resources/"
                   (or *compile-file-truename*

(defun resource-file (file)
  (merge-pathnames file *resource-base*))

(defparameter *base-image*
  (load-data-stream (resource-file "base.gif")))

(defparameter *big-base-image*
  (load-data-stream (resource-file "base512.gif")))

(defparameter *font*
  (load-nesfont (resource-file "8x8.tym")))

(defparameter *big-font*
  (load-nesfont (resource-file "16x16.tym")))

(defstruct (point
            (:conc-name %p)
            (:constructor point (x y)))
  x y)

(defparameter *name-point* (point 24 8))

(defparameter *title-y* 72)

(defparameter *lines-point* (point 40 104))

(defparameter *scale* 1)

(defun px (point)
  (* (%px point) *scale*))

(defun py (point)
  (* (%py point) *scale*))

(defun add-image-at (frame ds point)
  (setf (left-position frame) (px point)
        (top-position frame) (py point))
  (add-image frame ds))

(defun add-centered-at (frame ds y)
  (let ((x (truncate (- (width ds) (width frame)) 2)))
    (add-image-at frame ds (point (truncate x *scale*) y))))

(defun composite-at (source target point)
  (composite source target
             :dx (px point)
             :dy (py point)))

(defun draw-line-at (string target point)
  (let ((image (string-image string *font*)))
    (composite-at image target point)))

(defun dumb-clone (image)
  (make-image :height (height image)
              :width (width image)
              :image-data (copy-seq (image-data image))))

(defun first-image (ds)
  (aref (images ds) 0))

(defun draw-name (name ds)
  (let ((padded-name (make-string 12 :initial-element #\Space)))
    (replace padded-name name)
    (draw-line-at padded-name (first-image ds) *name-point*)))

(defun fresh-base ()
  (make-data-stream :initial-images (list (dumb-clone (first-image *base-image*)))
                    :width (width *base-image*)
                    :height (height *base-image*)
                    :color-table (color-table *base-image*)))

(defvar *title-delay* 150)
(defvar *intertext-delay* 500)
(defvar *intertext-blank-delay* 25)
(defvar *end-delay* 1000)

(defun make-mario-image (&key
             (name "MARIO")
             (title "THANK YOU MARIO!")
             (lines '("BUT OUR PRINCESS IS IN" "ANOTHER CASTLE!"))
  (let ((ds (fresh-base))
        (*default-delay-time* 1))
    (draw-name name ds)
    (add-centered-at (string-image title *font*) ds *title-y*)
    (add-delay *title-delay* ds)
    (loop for (a b c d) on lines by #'cdddr
          for lines = (remove-if #'null (list a b c d))
          for first = t then nil
          unless first
          (add-image-at (blank-image 22 7 *font*) ds *lines-point*)
          (add-delay *intertext-blank-delay* ds)
          (add-image-at (lines-image lines *font*) ds *lines-point*)
          (add-delay *intertext-delay* ds))
    (add-delay *end-delay* ds)
    (setf (loopingp ds) t)
    (output-data-stream ds output)))

(defun make-doubled-mario-image (&rest args &key name title lines output)
  (declare (ignorable name title lines output))
  (let ((*scale* 2)
        (*font* *big-font*)
        (*base-image* *big-base-image*))
    (apply #'make-mario-image args)))

This is what's running on wigflip. There's some extra glue to wire it up to the web page, but that's just a mess of my own TBNL-oriented web code and isn't very interesting.

I haven't cleaned this up in any way, it's pretty much the minimum stuff I needed to write to get something working. If you think you see something weird or awkward in it, you probably do...

Tags: ,




WarWeasle salutes you!

But I got a preview a week or so ago so...
this code makes me puke. i could do that in one line of perl.


Let's See It, Archon

@archon - let's see it (you do realize that if you don't post a real code response within the next hour or two, everyone is going to know you're completely full of shit, and assume you're a douche-bag too, right?).

I look forward to seeing your code.

Re: Let's See It, Archon

I wonder how you get so many great toy ideas, and it's nice to see the code this time!


8-bit presentations?

It seems you are half the way here:

Might you go all the way?



"A Functional I/O System, Or, Fun for Freshman Kids"

Have you been at ICFP? There was a great talk about graphics and I/O. The paper is also linked at LtU and contains lots of sample lisp code:

His first example in his talk was also Super Mario:)

July 2014

Powered by