quiz

quiz@common-lisp.net

25 discussions

[quiz] [SPOILER] Quiz #2
by Ivan Boldyrev 09 May '06

09 May '06

I can't run test because FiveAM from Gentoo portage (1.2.3) has no FOR-ALL (or is it from other package?). But I tested it manually. ---------------------------------------------------------------------- ;;; Copyright (C) 2006 Ivan Boldyrev ;;; This code is freely redistributable. (cl:defpackage #:quiz2 (:use #:cl)) (cl:in-package #:quiz2) (defvar *stack* nil "Stack for parsed objects") (defun tab-ws (pos) #-dont-blame-tabspace(warn "Tabular is found at pos ~S" pos) (* 8 (floor (+ pos 8) 8))) (defun count-ws (input-stream) (loop :for cnt := 0 :then (case char ((#\Space) (1+ cnt)) ((#\Tab) (tab-ws cnt)) ((#\Return #\Linefeed) ;; Space-only line! Just ignore it (return-from count-ws (count-ws input-stream))) (otherwise (unread-char char input-stream) (return-from count-ws cnt))) :for char := (read-char input-stream))) (defun combine-lines (first rest) (cons first (nreverse rest))) (defun reduce-forms (offset) (let ((tail (cdr (pop *stack*)))) (if (> offset (car (first *stack*))) (push (list offset (nreverse tail)) *stack*) (let ((first (pop (cdr (first *stack*))))) (progn (push (combine-lines first tail) (cdr (first *stack*))) *stack*))))) (defun read-the-line (input-stream) (let ((space-offset (count-ws input-stream)) (data (read-preserving-whitespace input-stream))) ;; Perform all reductions (loop :while (and (rest *stack*) (< space-offset (car (first *stack*)))) :do (reduce-forms space-offset)) (cond ((and (symbolp data) (string= (symbol-name data) "!#")) (throw 'thats-all-folks (cons 'progn (loop :while (rest *stack*) :do (reduce-forms 0) :finally (return (nreverse (cdr (first *stack*)))))))) ((and *stack* (= space-offset (car (first *stack*)))) (push data (cdr (first *stack*))) *stack*) (t (push (cons space-offset (list data)) *stack*))))) (defun read-off-side (stream subchar parameter) (declare (ignore subchar parameter)) (let ((*stack* nil)) ;; Catch is duty hack here. Do not repeat at home! (catch 'thats-all-folks (loop (read-the-line stream))))) ---------------------------------------------------------------------- -- Ivan Boldyrev Ok people, move along, there's nothing to see here.

1 0

[quiz] (Partial?) solution to the second quiz
by Pablo Barenbaum 09 May '06

09 May '06

I post a partial solution to the off-side-reader quiz. I say "partial" because, even though it reads in off-side mode, I'm not sure if it works as it is supposed in every case, i.e.: - what about blank lines? - what about comments? - the !# is supposed to be alone in a single line? - ... I'm afraid I tend overuse format and loop. It is also possibly very inefficient: it generates a new string with the "correct", inherent, parens made explicit, then reads it. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage :quiz2) (in-package :quiz2) (defvar *blanks* '(#\Space #\Tab #\Newline #\Return)) (defun distance (str prev-dist) (if (zerop (length (string-left-trim *blanks* str))) prev-dist (do ((col 0 (1+ col))) ((not (member (aref str col) *blanks* :test #'char=)) col)))) (defun read-off-side-to-string (stream) (let ((prev-line "") (prev-dists '()) (prev-dist 0)) (with-output-to-string (s) (format s "(progn ") (loop for line = (read-line stream nil 'eof) while (not (or (eq line 'eof) (string= line "!#"))) do (let ((dist (distance line prev-dist))) (when (> dist prev-dist) (push dist prev-dists) (format s "(")) (format s "~A~%" prev-line) (loop while (and (not (null prev-dists)) (< dist (car prev-dists))) do (pop prev-dists) do (format s ")")) (setf prev-line line) (setf prev-dist dist))) (format s "~A~%" prev-line) (loop while (not (null prev-dists)) do (pop prev-dists) do (format s ")")) (format s ")~%")))) (defun read-off-side (stream c n) (nth-value 0 (read-from-string (read-off-side-to-string stream)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

2 1

[quiz] Shamefully...
by Pablo Barenbaum 08 May '06

08 May '06

The "partial"-solution was not a solution at all! Sorry about the noise...

1 0

[quiz] Quiz #2 - Argh! The parenthesis! They burn my eyes!
by Marco Baringer 07 May '06

07 May '06

Argh! The parenthesis! They burn my eyes! ----------------------------------------- Overview ======== One of the more common complaints people have against the lisp language family is the abbundance of parenthesis is source code. "To hell with 'em!" I hear you say, and you're right, but it still makes for an interesting quiz. Goal ==== You're going to prove that common lisp really is the "Programmable Programming Language"[1] by changing the syntax to use less parenthesis. Write a function quiz2::read-off-side which allows python-style whitspace-sensitive source code (this is sometimes called the "off side" rule[2]). This function will be bound to the #! dispatching macro character and so must have this api (the test suite assumes this): (quiz2::read-off-side stream subchar parameter) => form The easiest way to explain how the syntax works is to show it. Example 1: #! when t (do-stuff) !# => (progn (when t (do-stuff))) Example 2: 1:#! 2:cond 3: (zerop a) 4: (write-line "A is zero.") 5: (plusp a) 6: (write-line "A is positive.") 7: t 8: (write-line "A is negative.") 9:(write-line "Done.") b:!# => (progn (cond ((zerop a) (write-line "A is zero.")) ((plusp a) (write-line "A is positive.")) (t (write-line "A is negative."))) (write-line "Done.")) If you doubts on how a form should be parsed see the print-off-sides function in the test suite. Test Suite ========== A test suite is available at: http://common-lisp.net/project/quiz/quizzes/quiz2/test.lisp You'll need to load your code before that file, it assumes the quiz2 package, and read-off-side function, already exist. After you've loaded the file execute (5am:run! :quiz2) to run the test suite, it uses my FiveAM[3] test suite. If you want to rewrite the test suite using another framework go ahead, I'll add a link to your rewrite here. [1] - John Foderaro, CACM, September 1991 [2] - http://en.wikipedia.org/wiki/Off-side_rule [3] - http://common-lisp.net/project/bese/FiveAM.html -- -Marco Ring the bells that still can ring. Forget the perfect offering. There is a crack in everything. That's how the light gets in. -Leonard Cohen

1 0

[quiz] quiz1 non-summary
by Marco Baringer 05 May '06

05 May '06

just to let people know that, unlike perl's quiz of the week or rubyquiz i don't think i'm going to write up an explicit summary report over and above what's already on the site. -- -Marco Ring the bells that still can ring. Forget the perfect offering. There is a crack in everything. That's how the light gets in. -Leonard Cohen

1 0

[quiz] [QUIZ #1] Patching my own Stupidity
by Tel 04 May '06

04 May '06

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.

3 4

[quiz] Another solution
by Pablo Barenbaum 04 May '06

04 May '06

I post my solution here. It is ugly I know... Examples: "Maryh as as many grapes as tentacles in 0 + five octopuess she gets as many gr apes as seas inthe world how many grapes does Mary have?" => "47" "sbustract six BAZs rfom: two BAZs" => "-4" "John has as many lemons as minutes in II hours. Sarah has as many lemons as day s in IV weeks and Sarah givesa lemon for eac khing in a deck of cards how many lemons does Sarah have?" => "24" ;;;; (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))) ;;;; Happy captching!

1 0

[quiz] Re: [QUIZ #1] Solution by Joseph Abrahamson
by Tel 03 May '06

03 May '06

> > From: Marco Baringer <mb(a)bese.it> > > > ; -- DEPENDS on: > > ; "Iterate":http://common-lisp.net/project/iterate/ > > this isn't true is it? > > i'm putting up all the solutions, as i get them, on the archive: > > http://common-lisp.net/project/quiz/quizzes/quiz1/quiz1.html > > -- > -Marco > Ring the bells that still can ring. > Forget the perfect offering. > There is a crack in everything. > That's how the light gets in. > -Leonard Cohen > Oer, no, no it isn't. I used to have more looping constructs in it where I was using iterate, but then I removed them and just implemented in LOOP as to not need any extra libraries. You have my full and complete permission to change that when posted on the quiz site. Thanks. -- ~ja.

1 0

[quiz] [QUIZ #1] Solution by Stuart Sierra
by Stuart Sierra 03 May '06

03 May '06

This is very similar to Joseph Abrahamson's solution. The main difference is that I use separate databases for each part of the question: the initial set-up, the operation (addition or subtraction), and the final question. I also got a little silly with the text of the questions. This code can be extended to other operations by adding to the *operations* list and creating another *Xstrings* list, where X is the symbol name of the operation (e.g. +, -, *, ...). My goal was to add enough "noise" to the question that it could not be solved by simple text calculators such as Google. It's still pretty easy to crack this once you know the algorithm -- just scan the question string for numbers, add or subtract them, and you've got a 50% chance of getting the right answer. Code attached. -Stuart ;; CAPTCHA.TEXT.ARITHMETIC ;; version 1, released 3 May 2006 ;; A text-based CAPTCHA (completely automated public Turing test to ;; tell computers and humans apart) in ANSI Common Lisp. ;; This Lisp package has one public function, GENERATE-CAPTCHA, called ;; with no arguments. It returns two strings, the first containing a ;; question and the second containing the answer. The answer will ;; always be in the form of numerical digits. ;; Example: ;; > (generate-captcha) ;; "You started out with three Lisp Machines. You bought ten. In the ;; end, how many did you have?" ;; "13" ;; Copyright 2006 Stuart Sierra ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ;; CAPTCHA is a trademark of Carnegie Mellon University (in-package :common-lisp-user) ;; package names should be descriptive ;) (defpackage :com.stuartsierra.captcha.text.arithmetic (:nicknames :captcha) (:use :common-lisp) (:export #:generate-captcha)) (in-package :com.stuartsierra.captcha.text.arithmetic) (defvar *min-initial-value* 12) (defvar *max-initial-value* 50) (defvar *min-delta-value* 2) (defvar *max-delta-value* 10) (defvar *operations* (list '+ '-)) (defvar *initial-state-strings* (list "You started out with ~a." "Before, you had ~a." "In the beginning, there were ~a." "Once upon a time, you had ~a." "You were in possession of ~a." "In the vague, distant past, ~a were your pride and joy.")) (defvar *+strings* (list "Beneficent aliens from planet Grog gave you ~a." "Your third cousin Warrl died and you inherited his ~a." "By devious and suble means, you acquired an additional ~a." "You quit your job and got ~a as part of your severance package." "You lost them all in a stock deal, but then you got them all back plus ~a." "You bought ~a.")) (defvar *-strings* (list "When you least expected it, your best friend turned on you and stole ~a." "Just as you were starting to enjoy them, ~a ran away." "But, tragically, ~a went off to that big something-or-other in the sky." "However, ~a didn't feel like sticking around, and left." "After a few years, ~a and you didn't get along any more, so they left." "Not through any fault of your own, you lost ~a.")) (defvar *question-strings* (list "When all is said and done, what did you end up with?" "How many did you have after that?" "By the end of the story, you had how many?" "Years later, when you were reflecting on this whole sordid process, you counted up how many you had. What was the result?" "What number did you have then, after you got over the emotional shock?" "Tell me how many you had when you finished.")) (defvar *nouns* (list "apples" "ponies" "pieces of fruit" "PDP-10s" "laptops" "clones of William Shatner" "Lisp Machines" "ice cream cones" "lollipops" "oranges" "brown paper packages tied up with string" "first-edition Superman comic books" "pairs of stiletto heels")) (defun pick-random (list) (nth (random (length list)) list)) (defun random-range (min max) (+ min (random (- max min)))) (defun format-quantity (number noun) (format nil "~r ~a" number noun)) (defun generate-initial-state-string (initial-value noun) (format nil (pick-random *initial-state-strings*) (format-quantity initial-value noun))) (defun generate-change-string (operation delta-value noun) (format nil (pick-random (symbol-value (find-symbol (concatenate 'string "*" (symbol-name operation) (symbol-name :strings*)) ; to allow for lowercase readers :com.stuartsierra.captcha.text.arithmetic))) (format-quantity delta-value noun))) (defun generate-question (operation initial-value delta-value) (let ((noun (pick-random *nouns*))) (format nil "~a ~a ~a" (generate-initial-state-string initial-value noun) (generate-change-string operation delta-value noun) (pick-random *question-strings*)))) (defun generate-answer (operation initial-value delta-value) (format nil "~d" (funcall operation initial-value delta-value))) (defun generate-captcha () (let ((initial-value (random-range *min-initial-value* *max-initial-value*)) (operation (pick-random *operations*)) (delta-value (random-range *min-delta-value* *max-delta-value*))) (values (generate-question operation initial-value delta-value) (generate-answer operation initial-value delta-value))))

4 5

[quiz] [QUIZ #1] Solution by Joseph Abrahamson
by Tel 03 May '06

03 May '06

Here's my take at it, though it's obviously the work of a beginner. CL-USER> (captcha:generate-captcha) "what is six plus four?" "10" CL-USER> (captcha:generate-captcha) "what is the difference between five and four?" "1" CL-USER> (loop for x from 1 to 1000 do (captcha:generate-captcha)) NIL ~~~~~~~~~~ ;;;;;;;;;;;;;; ; ; CAPTCHA ; ------- ; A Completely Automated Public Turing test ; to tell Computers and Humans Apart ; generator. ; Generates simple written arithmatic problems. ; ; -- DEPENDS on: ; "Iterate":http://common-lisp.net/project/iterate/ ; ; ; 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 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 perform-values (q fn string-args) (let ((s-a string-args)) `(values (apply #'format (append (list nil (slot-value ,q 'text)) ,s-a)) (format nil "~a" (reduce ,fn ,s-a))))) (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)))))) ~~~~~~~~~~ Cheers. -- ~ja.

3 2

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

quiz