word-find.lisp

I wrote this in 2004. Given a set of words, it generates word finder puzzles & also generates a solution for that puzzle. See the bottom of this post for an example. From what I remember, the most fun part of this tiny lisp program was writing the WALKING-ALONG macro, listed below.

Given a set of words, you need to place all the words inside the words rectangle, and fill the rest with junk characters. And the word should be placed in some random spot, going in a random direction. So while constructing the puzzle, I really don't care about the direction or the spot. I try to do those randomly. And this macro helps with that process.

(defmacro walking-along ((var array &key (direction (required-argument))
                              start-x start-y)
                         &body body)
  `(block nil
     (let ((.x. ,start-x) (.y. ,start-y))
       (symbol-macrolet ((,var (aref ,array .y. .x.)))
         (loop
           (unless (array-in-bounds-p ,array .y. .x.)
             (return))
           ,@body
           (ecase ,direction
             (:UP      (decf .y.))
             (:DOWN    (incf .y.))
             (:LEFT    (decf .x.))
             (:RIGHT   (incf .x.))
             (:DL-UP   (decf .x.) (decf .y.))
             (:DL-DOWN (decf .x.) (incf .y.))
             (:DR-UP   (incf .x.) (decf .y.))
             (:DR-DOWN (incf .x.) (incf .y.))))))
    (values)))

;;; word-find.lisp -- 
;;;
;;; Author: <sri -at- asu -dot- edu>
;;; Date: 2004-02-25T16:56:51
;;;
;;; Ideas:
;;;
;;;  o All the characters in the array should be part of a word.
;;;    Find words  that are randomly made up due to the intersection
;;;    of all the words and add it to the list of words.
;;;  o Difficulties:  either have a large matrix with small words, or so
;;;    similar words (characters)  that overlap.
;;;  o Try circular ones [for the array].
;;;
;;; [Tested and implemented under
;;;  CMU Common Lisp CVS Head 2003-10-03 00:16:55]
;;;
;;; This code is
;;;     Copyright (c) 2004 by Sriram Thaiyar.
;;; The terms are: You may do as you please with this code, as long as
;;; you do not delete this notice or hold me responsible for any outcome
;;; related to its use.


(defmacro walking-along ((var array &key (direction (required-argument))
                              start-x start-y)
                         &body body)
  `(block nil
     (let ((.x. ,start-x) (.y. ,start-y))
       (symbol-macrolet ((,var (aref ,array .y. .x.)))
         (loop
           (unless (array-in-bounds-p ,array .y. .x.)
             (return))
           ,@body
           (ecase ,direction
             (:UP      (decf .y.))
             (:DOWN    (incf .y.))
             (:LEFT    (decf .x.))
             (:RIGHT   (incf .x.))
             (:DL-UP   (decf .x.) (decf .y.))
             (:DL-DOWN (decf .x.) (incf .y.))
             (:DR-UP   (incf .x.) (decf .y.))
             (:DR-DOWN (incf .x.) (incf .y.))))))
    (values)))

(defun elts-at (array x y length direction)
  (let ((elts '())
        (i -1))
    (walking-along (e array :direction direction :start-x x :start-y y)
      (when (= (incf i) length)
        (return))
      (push e elts))
    (nreverse elts)))

(defun (setf elts-at) (new array x y direction &optional (length (length new)))
  (let ((i -1) (positions '()))
    (walking-along (e array :direction direction :start-x x :start-y y)
      (when (= (incf i) length)
        (return))
      (let ((elt (elt new i)))
        (setq e elt)
        (push (list elt .x. .y.) positions)))
    positions))

(defparameter *directions*
  '(:UP :DOWN :LEFT :RIGHT :DL-UP :DL-DOWN :DR-UP :DR-DOWN))

(let ((dirs nil)
      (null-returned nil))
  (defun random-direction (&optional reset)
    (when (or reset null-returned)
      (setq dirs (copy-list *directions*)
            null-returned nil))
    (if (and (null dirs) (null null-returned))
        (progn
          (setq null-returned t)
          nil)
        (let ((dir (nth (random (length dirs)) dirs)))
          (setq dirs (delete dir dirs))
          dir)))
  )

(defparameter *colors*
  '(:RED :BLUE :GREEN :ORANGE :PURPLE :GRAY :BROWN :PINK))

(let ((cols nil))
  (defun random-color ()
    (when (null cols)
      (let ((*directions* *colors*)) ;This is code reuse ;)
        (push (random-direction t) cols)
        (loop
          (let ((next (random-direction)))
            (when (null next)
              (return))
            (push next cols)))))
    (pop cols))
  )


;;; Return values for RANDOM-FIT & FORCE-FIT:
;;;  (<seq> <col> (<c0> <x0> <y0>) ...)

(defun random-fit (seq array width height)
  (let ((x (random width))
        (y (random height))
        (len (length seq)))
    (loop
      (let ((dir (random-direction)))
        (when (null dir)
          (return nil))
        (let ((old (elts-at array x y len dir)))
          (when (and (every (complement #'characterp) old)
                     (= (length old) len))
            (return
              (list* seq
                     (random-color)
                     (setf (elts-at array x y dir) seq)))))))))

(defun force-fit (seq array)
  (let ((open-spaces '())
        (dim (array-dimensions array)))
    (dotimes (x (car dim))
      (dotimes (y (cadr dim))
        (dolist (dir *directions*)
          (let ((count 0))
            (walking-along (e array :direction dir :start-x x :start-y y)
              (if (characterp e)
                  (return)
                  (incf count)))
            (push (list count x y dir)
                  open-spaces)))))
    (setq open-spaces
          (sort open-spaces #'> :key #'first))
    (let ((len (length seq)))
      (setq open-spaces
            (delete-if (lambda (n) (< n len)) open-spaces :key #'first))
      (when open-spaces
        (let ((x (nth (random (length open-spaces)) open-spaces)))
          (list* seq
                 (random-color)
                 (setf (elts-at array (second x) (third x) (fourth x))
                       seq)))))))

(defvar *error-on-nonfit* nil)

(defun wordfind-simple (words width height)
  (setq words (sort (copy-seq words) #'< :key #'length))
  (let ((array (make-array (list height width) :initial-element nil))
        (solution '()))
    (dolist (word words)
      (dotimes (i 15 (let ((x (force-fit word array)))
                       (if x
                           (push x solution)
                           (when *error-on-nonfit*
                             (error "Unable to fit ~A in ~S" word array)))))
        (let ((x (random-fit word array width height)))
          (when x
            (push x solution)
            (return)))))
    (dotimes (i (array-total-size array))
      (unless (characterp (row-major-aref array i))
        (setf (row-major-aref array i)
              (char "ABCDEFGHIJKLMNOPQRSTUVWXYZ" (random 26))))
      (setf (row-major-aref array i)
            (char-upcase (row-major-aref array i))))
    (values array solution)))


(defun generate-html (array solution output)
  (let ((words (mapcar #'car solution))
        (solution-pathname
         (make-pathname
          :defaults output
          :name (concatenate 'string (pathname-name output) "-sol"))))
    (flet
      ((generate-html-1 (&optional solution-p)
         (with-open-file (stream (if solution-p solution-pathname output)
                                 :direction :output
                                 :if-exists :supersede)
           (html (:stream stream)
            (head ()
             (title () (if solution-p "Word Finder: Solution" "Word Finder")))
            (body ()
             (strong () "Words: ")
             (if solution-p
                 (maplist (lambda (elts)
                            (format t "<font color=\"~A\">~A</font>~@[, ~]"
                                    (cadar elts)
                                    (string-capitalize (caar elts))
                                    (cdr elts)))
                          solution)
                 (format t "~{~A~^,&nbsp; ~}"
                         (mapcar #'string-capitalize words)))
             (br ())
             (p (:align :center)
              (table (:border t :width 100 :cellpadding 5)
               (when solution-p
                 (dolist (x solution)
                   (destructuring-bind (word color . positions)
                       x
                     (declare (ignore word))
                     (dolist (pos positions)
                       (let ((x (cadr pos)) (y (caddr pos)))
                         (unless (char-equal (car pos) (aref array y x))
                           (error "Characters don't match"))
                         (setf (aref array y x)
                               (cons color (car pos))))))))
                   (let ((dim (array-dimensions array)))
                     (dotimes (x (car dim))
                       (tr ()
                        (dotimes (y (cadr dim))
                          (td (:align :center)
                           (let ((elt (aref array y x)))
                             (if (consp elt) ;Solution and part of word
                                 (format t
                                         "<strong><font color=\"~A\">~C</font>~
                                          </strong>"
                                         (car (aref array y x))
                                         (char-upcase (cdr (aref array y x))))
                                 (format t "~C" (aref array y x)))))))))))
             (br ())
             (unless solution-p
               (p (:align :center)
                (a (:href (namestring solution-pathname)) "Solution"))))))))
      (generate-html-1)
      (generate-html-1 t)
      (values))))

(defun make-wordfind (&key (total-words 300) (width 20) (height 20)
                           (dict #p"/etc/alternatives/dictionary")
                           (output #p"word-find.html"))
  (let ((*error-on-nonfit* nil)
        (words '()))
    (if (or (stringp dict) (pathnamep dict))
        (with-open-file (stream dict)
          (let ((count 0))
            (loop
              (when (> count total-words)
                (return))
              (file-position stream (random (file-length stream)))
              (loop
                (let ((next (read-char stream nil nil)))
                  (cond ((null next) (return))
                        ((char= next #\Newline)
                         (let ((word (read-line stream nil nil)))
                           (when (> (length word) 0)
                             (push word words)
                             (incf count))
                           (return)))))))))
        (setq words dict))
    (multiple-value-bind (array solution)
        (wordfind-simple words width height)
      (generate-html array solution output))
    (values)))

Here is a sample output & its solution:

---

Words: Supercomputers,  Contribution,  Conditioners,  Incendiaries,  Imprecisely,  Talkatively,  Playgrounds,  Subchannels,  Congressman,  Chronograph,  Spiritual,  Toryizes,  Coverage,  Rainfall,  Climbing,  Hostile,  Dumping,  Adjoin,  Foils,  Sighs,  Casey

R

T

A

L

K

A

T

I

V

E

L

Y

N

G

G

C

O

W

O

P

U

O

B

L

P

U

K

S

L

X

M

G

E

L

E

T

Z

Y

Y

U

V

K

R

D

L

A

D

J

O

I

N

Z

J

G

H

Q

D

T

L

C

S

U

P

E

R

C

O

M

P

U

T

E

R

S

N

L

C

J

E

O

G

H

S

E

C

F

Y

R

R

N

P

T

Q

A

T

J

H

C

S

V

S

C

O

Y

E

E

I

J

Y

A

Q

L

Z

S

G

Z

S

H

I

E

E

T

C

S

S

Y

C

F

B

U

I

P

J

S

L

U

R

P

C

R

I

Z

Z

A

T

S

I

G

H

S

Y

N

R

P

B

H

L

A

E

A

R

V

C

D

S

I

A

I

N

J

Z

E

F

C

F

C

A

R

R

G

A

E

E

D

T

J

L

W

I

O

N

O

H

A

U

N

U

G

P

E

I

I

Z

U

G

M

D

E

E

O

I

A

S

T

L

A

T

O

M

M

D

R

K

M

I

A

C

E

I

L

N

T

K

Q

H

L

I

N

I

O

N

G

E

P

R

S

F

T

B

N

D

X

U

S

I

J

R

O

O

D

E

N

X

I

E

U

I

O

E

C

X

T

D

B

B

Z

I

R

Z

J

C

I

T

N

G

D

C

L

I

T

K

J

K

I

I

V

P

H

V

C

N

B

W

G

N

S

S

V

N

L

M

K

T

R

M

R

S

C

J

P

I

M

D

O

O

I

D

P

F

B

S

F

I

W

P

X

T

L

J

H

S

I

C

O

K

F

M

H

D

T

O

R

Y

I

Z

E

S

N

A

O

U

L

A

Q

A

P

L

A

Y

G

R

O

U

N

D

S

R

V

O

M

L

C

N

A

M

S

S

E

R

G

N

O

C

J

K

E

S

P

L

C

---

Words: Supercomputers, Contribution, Conditioners, Incendiaries, Imprecisely, Talkatively, Playgrounds, Subchannels, Congressman, Chronograph, Spiritual, Toryizes, Coverage, Rainfall, Climbing, Hostile, Dumping, Adjoin, Foils, Sighs, Casey

R

T

A

L

K

A

T

I

V

E

L

Y

N

G

G

C

O

W

O

P

U

O

B

L

P

U

K

S

L

X

M

G

E

L

E

T

Z

Y

Y

U

V

K

R

D

L

A

D

J

O

I

N

Z

J

G

H

Q

D

T

L

C

S

U

P

E

R

C

O

M

P

U

T

E

R

S

N

L

C

J

E

O

G

H

S

E

C

F

Y

R

R

N

P

T

Q

A

T

J

H

C

S

V

S

C

O

Y

E

E

I

J

Y

A

Q

L

Z

S

G

Z

S

H

I

E

E

T

C

S

S

Y

C

F

B

U

I

P

J

S

L

U

R

P

C

R

I

Z

Z

A

T

S

I

G

H

S

Y

N

R

P

B

H

L

A

E

A

R

V

C

D

S

I

A

I

N

J

Z

E

F

C

F

C

A

R

R

G

A

E

E

D

T

J

L

W

I

O

N

O

H

A

U

N

U

G

P

E

I

I

Z

U

G

M

D

E

E

O

I

A

S

T

L

A

T

O

M

M

D

R

K

M

I

A

C

E

I

L

N

T

K

Q

H

L

I

N

I

O

N

G

E

P

R

S

F

T

B

N

D

X

U

S

I

J

R

O

O

D

E

N

X

I

E

U

I

O

E

C

X

T

D

B

B

Z

I

R

Z

J

C

I

T

N

G

D

C

L

I

T

K

J

K

I

I

V

P

H

V

C

N

B

W

G

N

S

S

V

N

L

M

K

T

R

M

R

S

C

J

P

I

M

D

O

O

I

D

P

F

B

S

F

I

W

P

X

T

L

J

H

S

I

C

O

K

F

M

H

D

T

O

R

Y

I

Z

E

S

N

A

O

U

L

A

Q

A

P

L

A

Y

G

R

O

U

N

D

S

R

V

O

M

L

C

N

A

M

S

S

E

R

G

N

O

C

J

K

E

S

P

L

C

convert.lisp

I rewrote convert.rb in Common Lisp; [basically it allows you to convert files from one format to another -- say, PostScript files to PDF; I need this as I sometimes work on Windows machines but want read a online papers -- this runs as a CGI program on my personal server] you can get the whole thing here. It works under CMUCL version 19d. I had forgotten how much fun it is to write programs in Common Lisp! First, some HTML macros:

(progn
  (defmacro html-tag (tag attributes end-tag-p &body body)
    `(progn
       ,(if end-tag-p
            `(format t "<~A~{ ~A=~S~}>" ',tag  (list ,@attributes))
            `(format t "<~A~{ ~A=~S~}/>" ',tag (list ,@attributes)))
       (let ((result (multiple-value-list (progn ,@body))))
         (when (and (null (rest result)) (stringp (first result)))
           (princ (first result)))
         ,(when end-tag-p `(format t "</~A>" ',tag))
         (values))))
         
  (defmacro do-tag (tag &optional end-tag-p)
    `(defmacro ,tag (attributes &body body)
       `(html-tag ,',tag ,attributes ,',end-tag-p ,@body)))


  (do-tag html t)
  (do-tag head t)
  (do-tag title t)
  (do-tag h3 t)
  (do-tag form t)
  (do-tag input)
  (do-tag b t)
  (do-tag i t)
  (do-tag br)
  (do-tag a t)
  (do-tag hr)

  )

Next, we need to decode URLs:

(defvar *url-decoders*
  '(("24" . #\$)
    ("26" . #\&)
    ("2B" . #\+)
    ("2C" . #\,)
    ("2F" . #\/)
    ("3A" . #\:)
    ("3B" . #\;)
    ("3D" . #\=)
    ("3F" . #\?)
    ("40" . #\@)
    ("20" . #\Space)
    ("22" . #\")
    ("3C" . #\<)
    ("3E" . #\>)
    ("23" . #\#)
    ("25" . #\%)
    ("7B" . #\{)
    ("7D" . #\})
    ("7C" . #\|)
    ("5C" . #\\)
    ("5E" . #\^)
    ("7E" . #\~)
    ("5B" . #\[)
    ("5D" . #\])
    ("60" . #\`)
    ))


(defun decode-url (url)
  (flet ((quit () (return-from decode-url nil)))
    (with-output-to-string (out)
      (with-input-from-string (in url)
        (loop (let ((char (or (read-char in nil nil) (return))))
                (if (not (char= char #\%))
                    (princ char out)
                    (let ((next (or (read-char in nil nil) (quit))))
                      (if (char= next #\%)
                          (princ #\% out)
                          (let ((next2 (or (read-char in nil nil) (quit))))
                            (princ (or (cdr (assoc (concatenate 'string
                                                                (string next)
                                                                (string next2))
                                                   *url-decoders*
                                                   :test #'string-equal))
                                       (quit))
                                   out)))))))))))

Here is CGI-WELCOME & CGI-MAIN; they use the HTML macros defined above:

(defun cgi-main ()
  (flet ((get-params ()
           (let* ((qs (cdr (assoc :query_string ext::*environment-list*)))
                  (ps (and qs (position #\& qs)))
                  (parts (if ps
                             (list (subseq qs 0 ps) (subseq qs (1+ ps)))
                             (list qs)))
                  (params (mapcan (lambda (x)
                                    (let ((p (position #\= x)))
                                      (and p (list (cons (subseq x 0 p)
                                                         (subseq x (1+ p)))))))
                                  parts))
                  (url (cdr (assoc :url params :test #'string-equal)))
                  (zip-only (cdr (assoc :zip_only params :test #'string-equal))))
             (values (and url (plusp (length url)) (decode-url url))
                     (string-equal zip-only :on))))
         (print-cmds (cmd)
           ;; force-output to show user this info in their browser
           ;; while the command is still running -- works under Apache
           (princ "Running: ") (b () cmd) (br ()) (force-output))
         (print-cgi-header ()
           (let ((newline (coerce '(#\Return #\Newline) 'string)))
             (format t "Content-Type: text/html~A~A" newline newline))))

    (let ((original-dir (default-directory))
          (*shell-before* #'print-cmds)
          (url)
          (zip-only))
      (multiple-value-setq (url zip-only) (get-params))
      (print-cgi-header)
      (if (not url)
          (cgi-welcome)
          (letf (((default-directory) (tmpdir)))
            (html ()
              (head () (title () "convert.lisp"))
              (shell "wget -q '~A'" url)
              (multiple-value-bind (name error)
                  (ignore-errors (convert (or (newest)
                                              (error "couldn't download ~S" url))
                                          zip-only))
                (cond (error (princ "An error occurred: ")
                             (br ())
                             (b () (apply #'format nil
                                          (simple-condition-format-control
                                           error)
                                          (simple-condition-format-arguments
                                           error))))
                      (t (hr ())
                         (let ((base (subseq name
                                             (1+ (position #\/ name :from-end t)))))
                           (shell "cp ~A ~A/data/" base (namestring original-dir))
                           (data-file-link base)))))))))))

(defun cgi-welcome ()
  (html ()
    (head () (title () "convert.lisp"))
    (h3 () "convert.lisp -- convert files to different formats")
    (form (:method "get" :action "convert.sh")
      (princ "url: ")
      (input (:type "textfield" :name "url" :size 100))
      (princ " ")
      (input (:type "checkbox" :name "zip_only"))
      (princ "[zip only] ")
      (input (:type "submit" :value "Convert")))
    (h3 () "available converters [they are searched in order]:")
    (dolist (x *all-converter*)
      (multiple-value-bind (name cp exts doc cmds)
          (decode-converter x)
        (declare (ignore cp cmds))
        (b () (string-downcase name))
        (princ " -- ")
        (i () doc)
        (princ " [exts: ")
        (format t "~{~A~^, ~}" exts)
        (princ "]")
        (br ())))
    (h3 () "converted files [newest first]:")
    (let ((converted-files (mapcar (lambda (x) (cons (or (file-write-date x) 0) x))
                                   (ignore-errors (directory  "data/")))))
      (dolist (x (sort converted-files #'> :key #'car))
        (data-file-link (cdr x))
        (br ())))
    (br ())
    (br ())
    (a (:href "convert.lisp-txt") "{mysrc}")))
    

And finally, the SHELL function that executes the different programs needed to convert files:

(defvar *shell-before*)

(defun shell (cmd &rest args)
  (let ((cmd (apply #'format nil cmd args)))
    (when (boundp '*shell-before*) (funcall *shell-before* cmd))
    (ext:run-program "/bin/bash"
                     (list "-c" cmd))))

readable MD5

I've written an implementation of the MD5 algorithm mainly for human consumption. Most implementations that I've seen, seem to derive from the RFC's sample implementation, which is optimized for performance and so isn't that readable.

readable-md5.lisp [as text] [its written in Common Lisp and has been tested with CMUCL and CLisp]

...programs must be written for people to read, and only incidentally for machines to execute.
— Structure and Interpretation of Computer Programs