This week's meeting of my art class, last night, I actually enjoyed. I made a couple drawings that weren't total crap.

A few years ago a book came out named Oi, Robot, a collection of competition results from Fantasy and Science Fiction magazine. The title was from one of the competitions -- the game was to find a book title that could be changed by just one letter into a new, maximally silly one. So after I wrote that spelling correction code I used it to find some new title-changes. Here are some of the better results -- see if you can recognize the originals:

So you want to bed a wizard
Last and first fen
The man whom was Thursday
Evolution and the theory of gases
The howl service
His master's vice
Ban American childhood!
The thirteen cocks
Steering the crafty
Proofs and reputations
A mutter of oaths
The princes of the Nair
Software toils
Inevitable allusions
The rubber bride
Buddhism: pain and simple
The bully from the sea
The Blight that failed
Bloody Zones
The sneerswoman
The lord of toe rings
The Laughing Corps
This boor needs no title
Adjusting the moo

And here's the code to generate 'em. You add it to the spelling package I linked to before.

; Given a phrase (e.g. a book title) find all distance-1 misspellings
; of any of its words.  Output all the titles containing exactly one
; such misspelling.

(define (print-entries phrase)
  (for-each print (competition-entries phrase)))

(define (competition-entries phrase)
  (let ((words (map symbol->string phrase))
	(each-string->symbol
	 (lambda (strings) (map string->symbol strings))))
    (map each-string->symbol
	 (all-picks words (map find-misspellings words)))))

; Pre: (length WORDS) = (length MISSPELLINGS)
;      and MISSPELLINGS is a list of lists.
; Return a list of all ways to make a phrase with each word from either
; WORDS or MISSPELLINGS in the same position, such that each phrase has
; exactly one choice from MISSPELLINGS.
(define (all-picks words misspellings)
  (if (null? words)
      '()
      (append (map (lambda (misspelling)
		     (cons misspelling (cdr words)))
		   (car misspellings))
	      (map (lambda (rest) (cons (car words) rest))
		   (all-picks (cdr words) (cdr misspellings))))))

(define (find-misspellings word)
  (uniquify (map chars->word
		 (corrections dictionary (word->chars word) 1))))

(define chars->word list->string)

(define (uniquify ls)
  (let ((adjoin (lambda (x xs)
		  (if (member x xs) xs (cons x xs)))))
    (foldr adjoin '() ls)))