[quiz] Another solution

[Pablo Barenbaum]

I post my solution here.
It is ugly I know...

Examples:

"Maryh as as many grapes as tentacles in 0 + five octopuess  she gets as many gr
apes as seas  inthe world how many grapes does Mary have?"
=> "47"

"sbustract six BAZs rfom: two BAZs"
=> "-4"

"John has as many lemons as minutes in II hours. Sarah has as many
lemons as day s in IV weeks  and Sarah givesa  lemon for eac khing in
a deck of cards how many lemons does Sarah have?"
=> "24"


;;;;

(let ((rs (make-random-state t)))
 (defun rand (n)
	(random n rs)))

(defun choice (l)	
	(elt l (rand (length l))))

(defun fmt (&rest args)
 (apply #'format nil args))

(defun mksym (&rest args)
 (read-from-string (apply #'fmt args)))

(defmacro with-exprs (exprs vals &body body)
  (let ((gensyms (mapcar #'(lambda (x) (gensym)) vals)))
	`(destructuring-bind ,gensyms (list , at vals)
		(let ,(loop for x in exprs
								for y in gensyms
								nconcing
								(if (eq (aref (symbol-name x) 0) #\=)
									(let ((rest (subseq (symbol-name x) 1)))
										(list (list (mksym "n~A" rest) `(first ,y))
													(list (mksym "v~A" rest) `(second ,y))))
									'()))
			, at body))))

(defmacro defcaptcha (name args ret)
	`(defun ,name ,args
		 (with-exprs ,args ,args
			 (choice ,ret))))

(defmacro fmt-lambda (args &rest body)
 `#'(lambda ,args (fmt , at body)))

(defcaptcha num ()
 '(("zero" 0) ("0" 0)
	 ("one" 1) ("I" 1)
	 ("two" 2) ("II" 2)
	 ("three" 3) ("III" 3)
	 ("four" 4) ("IV" 4)
	 ("five" 5) ("V" 5)
	 ("six" 6) ("VI" 6)
	 ("seven" 7) ("VII" 7)
	 ("eight" 8) ("VIII" 8)
	 ("nine" 9) ("IX" 9)
	 ("ten" 10) ("X" 10)))

(defcaptcha bags ()
 '("bags" "boxes" "packages" "packs" "sacks"))

(defcaptcha simple-num ()
 `(,(num)
	 ,(with-exprs (=n =m) ((num) (num))
					 (list (fmt "~A + ~A" nn nm) (+ vn vm)))
	 ,(with-exprs (=n =m) ((num) (num))
					 (list (fmt "~A plus ~A" nn nm) (+ vn vm)))
	 ,(with-exprs (=n =m) ((num) (num))
					 (list (fmt "~A times ~A" nn nm) (* vn vm)))
	 ,(with-exprs (=n =m) ((num) (num))
					 (list (fmt "~A ~A of ~A" nn (bags) nm) (* vn vm)))
	))

(defcaptcha as-many-as (a mul b)
 `(,(fmt-lambda (x) "as many ~As as ~As in ~A ~A" x a mul b)
	 ,(fmt-lambda (x) "a ~A for each ~A in ~A ~A" x a mul b)
	))

(defcaptcha as-many-as* (a)
 `(,(fmt-lambda (x) "as many ~A as ~A" x a)
	))

(defun rand-word ()
 (concatenate 'string
	(loop for i from 1 to (+ (rand 8) 2)
							 collecting (code-char (+ (char-code #\A) (rand 26))))))

(defcaptcha rand-word-num ()
 (let* ((w (rand-word))
				(r (rand (length w)))
				(s (subseq w r (1+ r)))
				(c (aref w r)))
	`((,(as-many-as s "the word" w) ,(count c w))
 	 )))

(defcaptcha mul-num (=mul)
 `((,(as-many-as "finger" nmul "hands") ,(* 5 vmul))
   (,(as-many-as "day" nmul "weeks") ,(* 7 vmul))
   (,(as-many-as "hour" nmul "days") ,(* 24 vmul))
   (,(as-many-as "minute" nmul "hours") ,(* 60 vmul))
   (,(as-many-as "tentacle" nmul "octopuses") ,(* 8 vmul))
   (,(as-many-as "king" "a" "deck of cards") 4)
   (,(as-many-as "sea" "the" "world" ) 7)
   (,(as-many-as* "commandments") 10)
	 ))

(defcaptcha fnum ()
 (let ((n (simple-num)))
 `((,(fmt-lambda (x) "~A ~As" (first n) x) ,(second n))
	 ,(mul-num n)
	 ,(rand-word-num))))

(defcaptcha how-many (p x)
 `(,(fmt "how many ~As does ~A have?" x p)
	 ,(fmt "now ~A has ..... ~As" p x)
	 ,(fmt "~A has ..... ~As" p x)))

(defcaptcha fruit ()
	'("apple" "banana" "grape" "pear" "peach" "plum"
		"pineapple" "nectarine" "orange" "lemon" "apricot"))

(defcaptcha person ()
 '("John" "Mary" "William" "Elizabeth" "James" "Thomas"
		 "Sarah" "Margaret" "Henry" "Joseph" "Beatrice"))

(defcaptcha to-get ()
 '("get" "buy" "find" "create"))

(defcaptcha to-lose ()
 '("lose" "sell" "give" "smoke" "burn" "throw" "trash"))

(defcaptcha he (p)
 `(,p "he" "she"))

(defcaptcha foo ()
 `("foo" "bar" "baz"))

(defcaptcha and-he-xs (p f)
 `(,(fmt " and ~A ~As" (he p) (funcall f))
	 ,(fmt " then ~A ~As" (he p) (funcall f))
	 ,(fmt " ~A ~As" (he p) (funcall f))))

(defcaptcha and-name-xs (p f)
 `(,(fmt " and ~A ~As" p (funcall f))
	 ,(fmt " then ~A ~As" p (funcall f))
	 ,(fmt " ~A ~As" p (funcall f))))

(defun another (gen &rest banned)
	(do ((x (funcall gen) (funcall gen)))
		((apply #'string/= x banned) x)))

(defcaptcha x-has-y (x n y)
	`(,(fmt "~A has ~A" x (funcall n y))))

(defcaptcha x-has-y-2 (x n1 y1 n2 y2)
	`(,(fmt "~A has ~A, ~A" x (funcall n1 y1) (funcall n2 y2))
    ,(fmt "~A has ~A, ~A" x (funcall n2 y2) (funcall n1 y1))))

(defcaptcha x1-x2-have-y1-y2 (x1 n1 y1 x2 n2 y2)
	`(,(fmt "~A. ~A" (x-has-y x1 n1 y1) (x-has-y x2 n2 y2))
		,(fmt "~A. ~A" (x-has-y x2 n2 y2) (x-has-y x1 n1 y1))))

(defcaptcha x-gets-y (x n y)
 `(,(fmt "~A ~A" (and-he-xs x #'to-get) (funcall n y))))

(defcaptcha name-gets-y (x n y)
 `(,(fmt "~A ~A" (and-name-xs x #'to-get) (funcall n y))))

(defcaptcha x-loses-y (x n y)
 `(,(fmt "~A ~A" (and-he-xs x #'to-lose) (funcall n y))))

(defcaptcha name-loses-y (x n y)
 `(,(fmt "~A ~A" (and-name-xs x #'to-lose) (funcall n y))))

(defcaptcha expr+ (=x =y)
 (let* ((result (+ vx vy))
				(fruit (fruit))
				(name (person))
				(fruit1 (another #'fruit fruit))
				(name1 (another #'person name))
				(rand-1 (first (fnum)))
				(rand-2 (first (fnum)))
				(foo (foo)))
		 `((,(fmt "~A plus ~A" (funcall nx foo) (funcall ny foo)) ,result)
			 (,(fmt "add ~A and ~A" (funcall nx foo) (funcall ny foo)) ,result)
			 (,(fmt "~A ~A ~A"
					(x-has-y name nx fruit) (x-gets-y name ny fruit) (how-many name
fruit)) ,result)
			 (,(fmt "~A ~A ~A"
					(x-has-y-2 name nx fruit rand-1 fruit1)
					(x-gets-y name ny fruit) (how-many name fruit)) ,result)
			 (,(fmt "~A ~A ~A"
					(x1-x2-have-y1-y2 name nx fruit name1 rand-1 fruit)
					(name-gets-y name ny fruit) (how-many name fruit)) ,result)
			 (,(fmt "~A ~A ~A"
					(x1-x2-have-y1-y2 name nx fruit name1 rand-1 fruit)
					(name-gets-y name1 ny fruit) (how-many name fruit)) ,vx)
			 )))

(defcaptcha expr- (=x =y)
 (let* ((result (- vx vy))
				(fruit (fruit))
				(name (person))
				(fruit1 (another #'fruit fruit))
				(name1 (another #'person name))
				(rand-1 (first (fnum)))
				(rand-2 (first (fnum)))
				(foo (foo)))
		 `((,(fmt "~A minus ~A" (funcall nx foo) (funcall ny foo)) ,result)
			 (,(fmt "substract ~A from: ~A" (funcall ny foo) (funcall nx foo)) ,result)
			 (,(fmt "~A ~A ~A"
					(x-has-y name nx fruit) (x-loses-y name ny fruit) (how-many name
fruit)) ,result)
			 (,(fmt "~A ~A ~A"
					(x-has-y-2 name nx fruit rand-1 fruit1)
					(x-loses-y name ny fruit) (how-many name fruit)) ,result)
			 (,(fmt "~A ~A ~A"
					(x1-x2-have-y1-y2 name nx fruit name1 rand-1 fruit)
					(name-loses-y name ny fruit) (how-many name fruit)) ,result)
			 (,(fmt "~A ~A ~A"
					(x1-x2-have-y1-y2 name nx fruit name1 rand-1 fruit)
					(name-loses-y name1 ny fruit) (how-many name fruit)) ,vx)
			 )))

(defcaptcha captcha ()
	`(,(expr+ (fnum) (fnum))
	  ,(expr- (fnum) (fnum))))

(defun lower-or-blank-p (x)
 (or (lower-case-p x) (char= x #\Space)))

(defun obfuscate (str &optional (times 5))
 (do ((str str) (i 0 (1+ i)) (l (1- (length str))))
	   ((>= i times) str)
		 (let ((r (rand (1- l))))
			(if (and (lower-or-blank-p (aref str r)) (lower-or-blank-p (aref
str (1+ r))))
				(rotatef (aref str r) (aref str (1+ r)))))))

(defun generate-captcha ()
 (with-exprs (=c) ((captcha))
	(values (obfuscate nc) vc)))


;;;;

Happy captching!