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