[quiz] [QUIZ #1] Patching my own Stupidity - quiz@common-lisp.net - mailman3.common-lisp.net

4 May 2006


      Glancing over the cl-quiz site, more specifically the examples for my
own script, I noticed I left a major bug in one of my macros. It was
leaking when I tried to remove the 0s from division problems.
Here's the fixed version, along with editing the wording to make one
of the catpchas make sense being continuous (sort of) and removing
that bogus dependency.
Apologies for not catching this the first time
~~~~~~~~~~
;;;;;;;;;;;;;;
;
;  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))))))
~~~~~~~~~~
--
~ja.