;;;;;;;;;;;;;;
;
;  CAPTCHA
;  -------
;  A Completely Automated Public Turing test
;    to tell Computers and Humans Apart
;    generator.
;  Generates simple written arithmatic problems.
;
;  AUTHOR: Joseph Abrahamson
;  YEAR:   2006
;
;;;;;;;;;;;;;;

(defpackage :captcha
 (:use :cl)
 (:export #:generate-captcha))

(in-package :captcha)


(defconstant +numbermax+ 10)

(defvar *query-strings* '((* "what is ~r times ~r?"
                           (gennumber gennumber))
                          (* "what is the product of ~r and ~r?"
                           (gennumber gennumber))
                          (* "what is the area of a ~r by ~r rectangle?"
                           (gennumber gennumber))
                          (* "If you have ~r card~:p in a deck, then give the deck away,
how many cards do you have?~*"
                           (gennumber 0))
                          (+ "what is ~r plus ~r?"
                           (gennumber gennumber))
                          (+ "what is the sum of ~r, ~r, and ~r?"
                           (gennumber gennumber gennumber))
                          (+ "if you have ~r apricot~:p and buy ~r more, how many do you have?"
                           (gennumber gennumber))
                          (- "what is ~r less ~r?"
                           (gennumber gennumber))
                          (- "what is the difference between ~r and ~r?"
                           (gennumber gennumber))
                          (- "if you have ~r dollar~:p but owe ~r, you effectively have how many?"
                           (gennumber gennumber))
                          (/ "what is ~r over ~r?"
                           (gennumber gennumber))
                          (/ "what is the quotient of ~r and ~r"
                           (gennumber gennumber))
                          (/ "if you could split ~r watch~:*~[es~;~:;es~] into ~r equal
group~:p, how many are in each group?"
                           (gennumber gennumber))))
; Etc...

(defun gennumber (&optional (max +numbermax+) (min 0))
 (+ (random (- max min)) min))

(defclass query ()
 ((text
   :initarg :text
   :initform (error "Query must have text.")
   :documentation "FORMAT string to convert to captcha query.")
  (string-types
   :initarg :string-types
   :initform (error "Query must have FORMAT args.")
   :documentation "Arguments of generator functions which will
produce values for captcha.")
  ))

(defclass query+ (query) ())
(defclass query- (query) ())
(defclass query* (query) ())
(defclass query/ (query) ())

;; DATABASE AND SUCH

(defun generate-query-database (&optional (data *query-strings*))
 (loop
  for query in data
  collect (let ((type   (first query))
                 (string (second query))
                 (args   (third query)))
             (make-instance (intern (concatenate 'string
                                                 "QUERY"
                                                 (symbol-name type)))
                            :text string
                            :string-types args))))

(defvar *db* (generate-query-database))

;; PERFORM QUERY
;
;  Returns a string to print and a string to be compared against as the answer.
(defgeneric perform (q &optional string-args)
 (:documentation "PERFORM analyzes passed query and generates a
questionform and its
  cooresponding answerform."))

(defmacro once-only ((&rest names) &body body)
 ;; Peter Seibel's Implementation of ONCE-ONLY
 ;; from PCL.
 (let ((gensyms (loop for n in names collect (gensym))))
   `(let (,@(loop for g in gensyms collect `(,g (gensym))))
     `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
       ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
              ,@body)))))

(defmacro perform-values (q fn string-args)
 (once-only (q fn string-args)
   `(values (apply #'format (append (list nil (slot-value ,q 'text))
                              ,string-args))
            (format nil "~a" (reduce ,fn ,string-args)))))

(defmethod perform :around ((q query) &optional string-args)
 (call-next-method q (or string-args
                          (mapcar (lambda (x)
                                    (typecase x
                                      (list (apply (car x) (cdr x)))
                                      (symbol (if (fboundp x)
                                                  (funcall x)
                                                  (error "Symbol ~A is not bound to function. Must be removed
from args list of query ~a" x q)))
                                      (t x)))
                                  (slot-value q 'string-types)))))

(defmethod perform ((q query/) &optional (string-args ()))
                         ; Avoid division by 0.
 (perform-values q #'/ (substitute-if (gennumber +numbermax+ 1)
#'zerop  string-args)))

(defmethod perform ((q query*) &optional (string-args ()))
 (perform-values q #'* string-args))

(defmethod perform ((q query+) &optional (string-args ()))
 (perform-values q #'+ string-args))

(defmethod perform ((q query-) &optional (string-args ()))
 (perform-values q #'- (sort (copy-list string-args) #'>)))

;; GENERATE-CAPTCHA
(defun generate-captcha (&key type (db *db*))
 "Produces a random CAPTCHA from DB. If TYPE is supplied, only CAPTCHAs of that
  type may be returned."
 (let ((db (remove-if (if type
                           (lambda (x)
                             (not (eq (type-of x) type)))
                           (constantly nil))
                       db)))
   (perform (elt db (random (length db))))))