Data update

Task/Set-puzzle/Common-Lisp/set-puzzle.lisp

@@ -0,0 +1,86 @@
+(defparameter numbers '(one two three))
+(defparameter shadings '(solid open striped))
+(defparameter colours '(red green purple))
+(defparameter symbols '(oval squiggle diamond))
+
+(defun play (&optional (n-cards 9))
+  (find-enough-sets n-cards (floor n-cards 2)))
+
+(defun find-enough-sets (n-cards enough)
+  (loop
+    (let* ((deal (random-sample n-cards (deck)))
+           (sets (find-sets deal)))
+      (when (>= (length sets) enough)
+        (show-cards deal)
+        (show-sets sets)
+        (return t)))))
+
+(defun show-cards (cards)
+  (format t "~D cards~%~{~(~{~10S~}~)~%~}~%"
+          (length cards) cards))
+
+(defun show-sets (sets)
+  (format t "~D sets~2%~:{~(~@{~{~8S~}~%~}~)~%~}"
+          (length sets) sets))
+
+(defun find-sets (deal)
+  (remove-if-not #'is-set (combinations 3 deal)))
+
+(defun is-set (cards)
+  (every #'feature-makes-set (transpose cards)))
+
+(defun feature-makes-set (feature-values)
+  (or (all-same feature-values)
+      (all-different feature-values)))
+
+(defun combinations (n items)
+  (cond
+    ((zerop n) '(()))
+    ((null items) '())
+    (t (append
+          (mapcar (lambda (c) (cons (car items) c))
+                  (combinations (1- n) (cdr items)))
+          (combinations n (cdr items))))))
+
+;;; Making a deck
+
+(defun deck ()
+  ;; The deck has to be made only once
+  (or (get 'deck 'cards)
+      (setf (get 'deck 'cards) (make-deck))))
+
+(defun make-deck ()
+  (add-feature numbers
+    (add-feature shadings
+      (add-feature colours
+        (add-feature symbols
+          (list '()))))))
+
+(defun add-feature (values deck)
+  (mapcan (lambda (value)
+             (mapcar (lambda (card) (cons value card))
+                     deck))
+          values))
+
+;;; Utilities
+
+(defun random-sample (n items)
+  (let ((len (length items))
+        (taken '()))
+    (dotimes (_ n)
+      (loop
+        (let ((i (random len)))
+          (unless (find i taken)
+            (setq taken (cons i taken))
+            (return)))))
+    (mapcar (lambda (i) (nth i items)) taken)))
+
+(defun all-same (values)
+  (every #'eql values (rest values)))
+
+(defun all-different (values)
+  (every (lambda (v) (= (count v values) 1))
+         values))
+
+(defun transpose (rows)
+  (apply #'mapcar #'list rows))