86 lines
2.2 KiB
Common Lisp
86 lines
2.2 KiB
Common Lisp
(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))
|