(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.