;;;
;;; Richard Newman's entry for the first cl-quiz:
;;; <http://common-lisp.net/project/quiz/quizzes/quiz1.txt>
;;; at 
;;; <http://www.holygoat.co.uk/lisp/cl-quiz/captcha.lisp>
;;;
;;; rich at holygoat dot co dot uk
;;;

(defparameter *number-limit* 10 "Maximum number to generate within a captcha expression.")
;; The list of operators from which to select.
(let ((operators '(+ - *))
      ;; A list of functions used to generate values within an expression.
      ;; In principle, this allows 'all', 'every', etc.
      (value-makers (list #'(lambda () (1+ (random *number-limit*))))))

  (defun generate-arithmetic-tree (elements &optional (depth 1))
    "Generate an arbitrary arithmetic expression. ELEMENTS is the number of
     items to manipulate; depth is how nested to make the expression."
    (flet ((pick-operator ()
             (elt operators (random (length operators))))
           (produce-value ()
             (funcall (elt value-makers (random (length value-makers))))))
      (if (eq depth 1)
        (nconc
          (list (pick-operator))
          (loop for i from 1 upto elements collect (produce-value)))
        (nconc
          (list (pick-operator))
          (loop for i from 1 upto elements collect
                (if (evenp (random 2))
                  (generate-arithmetic-tree (if (eq 0 (random 2))
                                              (1- elements)
                                              elements)
                                            (1- depth))
                  (produce-value))))))))

(defun print-arithmetic-op (op stream)
  "Trivial English printing."
  (princ (case op
           (+ " plus ")
           (- " minus ")
           (* " times ")) stream))

;; OK, I make no guarantees about precedence! :D
;; This will produce awful chains of terms which are unlikely to
;; give the correct answer when applying usual mathematical precedence
;; rules. Maybe people should use prefix notation? ;)
(defun print-arithmetic-tree (tree &optional (stream *standard-output*))
  "Print the arithmetic tree to STREAM."
  (typecase tree
    (integer (princ tree stream))
    (list
      ;; This deals with the (- 4) case.
      (if (and (eq (car tree) '-) 
               (eq 2 (length tree))
               (integerp (second tree)))
        (print-arithmetic-tree (- (second tree)) stream)

        (progn
          (dolist (number (butlast (cdr tree)))
            (print-arithmetic-tree number stream)
            (print-arithmetic-op (car tree) stream))
          (print-arithmetic-tree (car (last tree)) stream))))))

(defun generate-captcha (&key (depth 1) (elements 2))
  "Generate a simple English arithmetic captcha."
  (let* ((arithmetic-tree (generate-arithmetic-tree elements depth))
         (answer (eval arithmetic-tree)))  ; so sue me.
    (values
      (format nil "what is ~A?"
              (with-output-to-string (s) 
                (print-arithmetic-tree arithmetic-tree s)))
      (princ-to-string answer))))