;;;
;;; Richard Newman's entry for the first cl-quiz:
;;;
;;; at
;;;
;;;
;;; 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))))