Timg [Common Lisp]

This piece of software translates a custom-made text format into a BMP image. This is what the format looks like,
SPACE is white
A is RED
B is BLACK
C is #16r56FF32
.

CCCCCCCCCC
C AA C
C ABBA C
C ABAABA C
C ABBA C
C AA C
CCCCCCCCCC

!end

Comments here, after the '!end' line (which is optional, for the addition of comments like this one).
Above .timg should create a 10x7 of red/black/cyan/white pixels.

and this is the result .bmp (it's really small, zoom in!),
http://a.pomf.se/fzvhpm.bmp

Enjoy the code, /prog/riders.

;; Timg - create bitmaps from text images
;; timg format:
;; mappings of char->colour first in file, as in
;; CHAR is COLOUR
;; where CHAR is A-Za-z0-9 or SPACE for ' ', and COLOUR is
(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied))
"Return a list of subsequences in seq delimited by delimiter.

If :remove-empty-subseqs is NIL, empty subsequences will be included
in the result; otherwise they will be discarded. All other keywords
work analogously to those for CL:SUBSTITUTE. In particular, the
behaviour of :from-end is possibly different from other versions of
this function; :from-end values of NIL and T are equivalent unless
:count is supplied. The second return value is an index suitable as an
argument to CL:SUBSEQ into the sequence indicating where processing
stopped."
(let ((len (length seq))
(other-keys (nconc (when test-supplied
(list :test test))
(when test-not-supplied
(list :test-not test-not))
(when key-supplied
(list :key key)))))
(unless end (setq end len))
(if from-end
(loop for right = end then left
for left = (max (or (apply #'position delimiter seq
:end right
:from-end t
other-keys)
-1)
(1- start))
unless (and (= right (1+ left))
remove-empty-subseqs) ; empty subseq we don't want
if (and count (>= nr-elts count))
;; We can't take any more. Return now.
return (values (nreverse subseqs) right)
else
collect (subseq seq (1+ left) right) into subseqs
and sum 1 into nr-elts
until (< left start)
finally (return (values (nreverse subseqs) (1+ left))))
(loop for left = start then (+ right 1)
for right = (min (or (apply #'position delimiter seq
:start left
other-keys)
len)
end)
unless (and (= right left)
remove-empty-subseqs) ; empty subseq we don't want
if (and count (>= nr-elts count))
;; We can't take any more. Return now.
return (values subseqs left)
else
collect (subseq seq left right) into subseqs
and sum 1 into nr-elts
until (>= right end)
finally (return (values subseqs right))))))

(defun create-from-timg (timg)
"Display a timg"
(sdl:with-init ()
(let ((colours (parse-file timg))
(out (concatenate 'string timg ".bmp")))
(destructuring-bind (y x)
(array-dimensions colours)
(sdl:window x y
:bpp 8
:flags '(sdl:SDL-SW-SURFACE))
(loop for i below y
do (loop for j below x
do (sdl:draw-pixel (sdl:point :x j :y i)
:color (aref colours i j))))
(sdl:update-display)
(sdl:save-image sdl:*default-display*
out))
out)))


(defun read-file (filename)
(with-open-file (s filename)
(loop for line = (read-line s nil nil)
until (or (null line)
(string-equal line "!end"))
collect line)))

(defparameter *parse-colour-ending* ".")

(defun max-metric (metric list)
(apply #'max (mapcar metric list)))

(defun parse-file (filename)
"Do the dirty work!!!"
(let ((lines (read-file filename)))
(multiple-value-bind (colour-mappings next)
(parse-colour-mappings lines)
(parse-text-image (subseq lines (1+ next))
colour-mappings))))

(defun parse-text-image (lines colour-mappings)
"Parse the text image"
(let* ((maxlen (max-metric #'length lines))
(array (make-array (list (length lines)
maxlen)
:initial-element (cdr (assoc #\space
colour-mappings)))))
(loop for line in lines
for i from 0
do (loop for char across line
for j from 0
do (setf (aref array i j)
(cdr (assoc char colour-mappings))))
finally (return array))))

(defun parse-colour-mappings (lines)
(let ((end-of-mappings (position-if (lambda (line)
(string-equal line
*parse-colour-ending*))
lines)))
(when end-of-mappings
(values
(mapcar (lambda (line)
(read-char-colour (string-trim " " line)))
(subseq lines 0 end-of-mappings))
end-of-mappings))))

(defun tokenize (line)
(split-sequence #\space line))

(defun read-char-colour (string)
"read a CHAR is COLOUR and return (CHAR . COLOUR)"
(destructuring-bind (char _ colour)
(tokenize string)
(when (string-equal _ "is")
(cons (translate-char char)
(translate-colour colour)))))

(defun translate-char (s)
(if (string-equal s "space")
#\space
(char s 0)))

(defun char-to-hexnum (char)
(position (string char)
"0123456789abcdef"
:test #'string-equal))

(defparameter *colour-list*
`(("BLUE" . ,sdl:*blue*)
("RED" . ,sdl:*red*)
("GREEN" . ,sdl:*green*)
("BLACK" . ,sdl:*black*)
("WHITE" . ,sdl:*white*)
("MAGENTA" . ,sdl:*magenta*)
("YELLOW" . ,sdl:*yellow*)))

(defun translate-colour (s)
(let ((assoc (assoc s *colour-list*
:test #'string-equal)))
(if assoc
(cdr assoc)
(with-input-from-string (s s)
(let ((s (read s)))
(sdl:color :r (mod s 256)
:g (mod (floor
(/ s 8))
256)
:b (mod (floor
(/ s 64))
256)))))))

What motivated you to write this?