(defparameter *number-of-levels* 2) (defvar *all-cases*) (defun less-seq (a b &optional (n 0)) (or (= n 4) (let ((an (elt a n)) (bn (elt b n))) (or (< an bn) (and (= an bn) (less-seq a b (1+ n))))))) (defun rotate-seq (a &optional (n 1)) (if (= n 0) a (rotate-seq (cons (car (last a)) (copy-list (butlast a))) (1- n)))) (defun standard-seq (a) "Converts a sequence to standard form." (first (sort (mapcar #'(lambda (x) (rotate-seq a x)) '(1 2 3 4)) #'less-seq))) (defun solvedp (a) (let ((first (first a))) (every #'(lambda (x) (= x first)) a))) (defun standard-seq-list (lst) "Convert every sequence in LST to standard form and deletes all solved sequences. The returned list is also sorted." (sort (remove-if #'solvedp (remove-duplicates (mapcar #'standard-seq lst) :test #'equal)) #'less-seq)) (defun push-button (a n) "Push the Nth button in A." (let ((result (copy-list a))) (setf (elt result n) (mod (1+ (elt a n)) *number-of-levels*)) result)) (defmacro defmovement (name (x lst) &body body) `(defun ,name (,lst) (standard-seq-list (mapcan #'(lambda (,x) ,@body) ,lst)))) (defmovement push-neighbouring (x lst) (iter (for i from 0 below 4) (collect (push-button (push-button x i) (mod (1+ i) 4))))) (defmovement push-opposite (x lst) (iter (for i from 0 below 4) (collect (push-button (push-button x i) (mod (+ i 2) 4))))) (defmovement push-only-one (x lst) (iter (for i from 0 below 4) (collect (push-button x i)))) (defun apply-movements (lst movements) (if (null movements) lst (let ((new-lst (case (first movements) (nei (push-neighbouring lst)) (opp (push-opposite lst)) (one (push-only-one lst))))) (apply-movements new-lst (rest movements))))) (defun init () (labels ((recgen (&optional (n 0) acc) (if (= n 4) (list acc) (iter (for i from 0 below *number-of-levels*) (appending (recgen (1+ n) (cons i acc))))))) (setf *all-cases* (standard-seq-list (recgen)))) t) ;;; (setf *number-of-levels* 2) => 2 ;;; (init) => T ;;; *all-cases* ;;; => ((0 0 0 1) (0 0 1 1) (0 1 0 1) (0 1 1 1)) ;;; (apply-movements *all-cases* '(opp)) ;;; => ((0 0 0 1) (0 0 1 1) (0 1 1 1)) ;;; (apply-movements *all-cases* '(opp nei)) ;;; => ((0 0 0 1) (0 1 0 1) (0 1 1 1)) ;;; (apply-movements *all-cases* '(opp nei opp)) ;;; => ((0 0 0 1) (0 1 1 1)) ;;; (apply-movements *all-cases* '(opp nei opp one)) ;;; => ((0 0 1 1) (0 1 0 1)) ;;; (apply-movements *all-cases* '(opp nei opp one opp)) ;;; => ((0 0 1 1)) ;;; (apply-movements *all-cases* '(opp nei opp one opp nei)) ;;; => ((0 1 0 1)) ;;; (apply-movements *all-cases* '(opp nei opp one opp nei opp)) ;;; => NIL ;;; So a solution of the 2-level case is: ;;; OPP NEI OPP ONE OPP NEI OPP. (defun find-solution (&optional (lst *all-cases*) movements (history (list *all-cases*))) "Look for all state sets that weren't looked at before." (if (null lst) (list (reverse movements)) (iter (for x in '(opp nei one)) (for new-lst = (apply-movements lst (list x))) (when (not (member new-lst history :test #'equal)) (appending (find-solution new-lst (cons x movements) (cons new-lst history))))))) ;;; (setf *number-of-levels* 2) => 2 ;;; (init) => T ;;; (find-solution) ;;; => ((OPP NEI OPP ONE OPP NEI OPP)) ;;; (setf *number-of-levels* 3) => 3 ;;; (init) => T ;;; (find-solution) => NIL ;;; (setf *number-of-levels* 4) => 4 ;;; (init) => T ;;; (find-solution) => NIL ;;; So there is no solution when level is 3 or 4, which is evident, ;;; because every state is reproduced in every movement type, there ;;; is no `stable' state.