Digit cubes

p90.lisp

@@ -0,0 +1,54 @@
+(defparameter *two-digit-squares* (loop for n upfrom 1
+					for square = (* n n)
+					while (<= square 99)
+					collect square))
+
+(defparameter *two-digit-pairs*
+  (loop for square in *two-digit-squares*
+	collect (list (if (<= square 9)
+			  0
+			  (floor square 10))
+		      (mod square 10))))
+
+(defun subsets (set count)
+  "Returns a list of all subsets of SET of size COUNT"
+  (ret (subsets nil)
+    (labels ((recurse (set count tail)
+	       (cond ((= count 0) (push tail subsets))
+		     (t (loop for (item . rest) on set
+			      do (recurse rest (1- count) (cons item tail)))))))
+      (recurse set count nil))))
+
+(defun valid-digit-p (digit set)
+  "Returns non-NIL if DIGIT is in SET, with the special rule that 6 matches 9 and vice versa"
+  (if (or (= digit 9) (= digit 6))
+      (or (member 9 set) (member 6 set))
+      (member digit set)))
+
+(defun solutionp (cube1 cube2)
+  "Returns non-NIL if CUBE1 and CUBE2 can make all squares"
+  (loop for (a b) in *two-digit-pairs*
+	do (unless (or (and (valid-digit-p a cube1)
+			    (valid-digit-p b cube2))
+		       (and (valid-digit-p a cube2)
+			    (valid-digit-p b cube1)))
+	     (return nil))
+	finally (return t)))
+
+(defun cube-digit-pairs ()
+  (let* ((digits (loop for n from 0 upto 9 collect n))
+	 (cubes (subsets digits 6))
+	 (solutions (make-hash-table :test 'equal))
+	 (solution-count 0))
+    (loop for cube1 in cubes do
+      (loop for cube2 in cubes
+	    do (when (solutionp cube1 cube2)
+		 ;; Check for *both* orderings of cubes
+		 (let ((a (append cube1 cube2))
+		       (b (append cube2 cube1)))
+		   (unless (or (gethash a solutions)
+			       (gethash b solutions))
+		     (incf solution-count)
+		     (setf (gethash a solutions) t)
+		     (setf (gethash b solutions) t))))))
+    solution-count))

shared.lisp

@@ -1,5 +1,9 @@
+(defmacro ret ((variable value) &body body)
+  `(let ((,variable ,value))
+     ,@body
+     ,variable))
+
 (defmacro with-gensyms ((&rest names) &body body)
-  "Creates variables named NAMES via GENSYM and runs BODY"
   `(let ,(loop for name in names collect `(,name (gensym)))
      ,@body))
 
@@ -15,6 +19,9 @@
 	do (setf result (append form (list result)))
 	finally (return result)))
 
+(defmacro multf (place multiplier)
+  `(setf ,place (* ,place ,multiplier)))
+
 (defun get-primes (max)
   "Return a list of the first primes up to MAX"
   (let ((primes nil)
@@ -44,3 +51,12 @@
   "Returns non-NIL if I is on the interval [0, MAX)"
   (and (>= i 0)
        (< i max)))
+
+(defun factorial (n)
+  (ret (product 1)
+    (loop for x from n above 1 do
+      (multf product x))))
+
+(defun n-choose-r (n r)
+  (/ (factorial n)
+     (* (factorial r) (factorial (- n r)))))