(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 ,@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))))
'()))
,@body))))
(defmacro defcaptcha (name args ret)
`(defun ,name ,args
(with-exprs ,args ,args
(choice ,ret))))
(defmacro fmt-lambda (args &rest body)
`#'(lambda ,args (fmt ,@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)))