# lisp-random / rainbow-dosh.lisp

 ``` 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213``` ```;;;; rainbow-dosh.lisp ;;;; Copyright (c) 2012 Robert Smith ;;; You are given 3 stacks of coins. The only operation you are ;;; permitted to perform is doubling one stack by taking that many ;;; from another. Prove (or devise an algorithm which you can show is ;;; correct) that shows you can always empty one of the stacks. ;;; Utilities (defun sum (v) (reduce #'+ v)) ;;; Representation (deftype move () `(cons (integer 0 2) (integer 0 2))) (defun make-move (a b) "Make a new move." (the move (cons a b))) (defun from-stack (move) "Get the number of the stack to subtract from." (declare (type move move)) (car move)) (defun to-stack (move) "Get the number of the stack to add to." (declare (type move move)) (cdr move)) (deftype state () `(simple-array fixnum (3))) (defun normalize-state! (state) "Normalize the state STATE." (declare (type state state)) (sort state #'<)) (defun reduceablep (state) "Can STATE be reduced?" (/= 1 (gcd (aref state 0) (aref state 1) (aref state 2)))) (defun reduce-state (state) "Reduce STATE to contain the smallest numbers possible. Return a second value dictating whether a reduction occurred." (let* ((a (aref state 0)) (b (aref state 1)) (c (aref state 2)) (gcd (gcd a b c))) (values (make-state (floor a gcd) (floor b gcd) (floor c gcd)) (/= 1 gcd)))) (defun make-state (a b c) "Make new state with piles of size A, B, and C. The piles will be normalized." (normalize-state! (make-array 3 :element-type 'fixnum :initial-contents (list a b c)))) (defun copy-state (state) "Make a copy of STATE." (declare (type state state)) (copy-seq state)) ;;; Operations (defun valid-move-p (state move) "Is it valid to move coins from the FROM-STACK to the TO-STACK?" (declare (type state state) (type move move)) (<= (aref state (to-stack move)) (aref state (from-stack move)))) (defun do-move (state move) "Move the coins from the stack numbered FROM-STACK to the stack numbered TO-STACK." (declare (type state state) (type move move)) (let* ((from-stack (from-stack move)) (to-stack (to-stack move)) (to (aref state to-stack)) (new-state (copy-state state))) (decf (aref new-state from-stack) to) (incf (aref new-state to-stack) to) (normalize-state! new-state))) ;;; Solution (defun solution-space-size (coin-sum) "The number of solutions given a sum of COIN-SUM." ;; This actually computes an upper bound of the solution space size. ;; Number of 1- and 2-partitions of an integer (DLMF 26.9.3) (+ 2 (floor coin-sum 2))) (defun state-space-size (coin-sum) "The number of possible states given a sum of COIN-SUM." ;; This actually computes an upper bound of the state space size. ;; Number of 3-partitions of an integer (DLMF 26.9.3) (+ (1+ (floor (* coin-sum (+ coin-sum 6)) 12)) (solution-space-size coin-sum))) (defun solvedp (state) "Check if STATE is solved." (declare (type state state)) (some #'zerop state)) (defun almost-solved-p (state) "Check if STATE is almost solved, that is, if it has two equal piles." (declare (type state state)) (let ((a (aref state 0)) (b (aref state 1)) (c (aref state 2))) ;; We needn't check if A = C because if that is the case, and we ;; have A <= B <= C, then that imples A = B = C. (cond ((= a b) (make-move 1 0)) ((= b c) (make-move 2 1)) (t nil)))) ;;; We could have 6 moves here, however, since we have A <= B <= C, we ;;; will never swap lower to higher. (defparameter *moves* '((2 . 1) (1 . 0) (2 . 0))) (defun solve (state) (let ((table (make-hash-table :test 'equalp))) (labels ((rec (state moves) ;; Have we reached this state yet? If not, skip it. (unless (gethash state table) ;; Is it solved? If so, return the solution and the ;; final state. (when (solvedp state) (return-from solve (values (nreverse moves) state))) ;; Mark this position as visited. (setf (gethash state table) t) ;; Avoid trying all moves when we know we are in the ;; winning state. (let ((winning-move (almost-solved-p state))) (when winning-move (rec (do-move state winning-move) (cons winning-move moves)))) ;; Brute force... try all moves. (dolist (m *moves*) (when (valid-move-p state m) (rec (do-move state m) (cons m moves))))))) (rec state nil)))) (defun count-solutions (state) (let ((table (make-hash-table :test 'equalp)) (solns 0)) (labels ((rec (state moves) ;; Have we reached this state yet? If not, skip it. (unless (gethash state table) ;; Is it solved? If so, return the solution and the ;; final state. (when (solvedp state) (incf solns) ;; (return-from solve (values (nreverse moves) state)) ) ;; Mark this position as visited. (setf (gethash state table) t) ;; Avoid trying all moves when we know we are in the ;; winning state. (let ((winning-move (almost-solved-p state))) (when winning-move (rec (do-move state winning-move) (cons winning-move moves)))) (let ((reduceables (loop :for m :in *moves* :when (reduceablep (do-move state m)) :collect m))) ;; Brute force... try all moves. (dolist (m (or reduceables *moves*)) (when (valid-move-p state m) (let ((old-state (do-move state m))) (multiple-value-bind (reduced-state reduced?) (reduce-state old-state) (when reduced? (format t "Reduced state: ~A --> ~A [~A --> ~A]~%" old-state reduced-state (sum old-state) (sum reduced-state))) (rec reduced-state (cons m moves)))))))))) (rec (reduce-state state) nil) (values solns (hash-table-count table))))) (defun apply-moves (initial-state moves) (loop :for move :in moves :for state := (do-move initial-state move) :then (do-move state move) :collect state)) (defun solve-and-print (puzzle-state) (let ((solution (solve puzzle-state))) (format t "Start --> ~A~%" puzzle-state) (loop :for move :in solution :for state :in (apply-moves puzzle-state solution) :do (format t "~A --> ~A~%" move state)))) ```
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.