(in-package :screamer-user)

;screamer cannot walk either symbol-macrolet or macrolet!

(defun get-instances-by-square (pm-indices-list square) ; todo: change first param name!!!
    (let ((list nil))
        (dolist (pm-idx pm-indices-list)
            (setf list (append (aref +instances-array-by-square+ pm-idx square) list)))
        list))


(defun get-most-constrained-square (board)
    (let ((square nil)
          (prev-square-freeneighbours-count 4))
        (dotimes (x 64)
            (when (square-free? x board)
                (let ((freeneighbours-count (freeneighbours-count x board)))
                    (when (<  freeneighbours-count prev-square-freeneighbours-count)
                        ;(format t "square: ~A freeneighbours: ~A ~%" x freeneighbours-count) 
                        (setf square x)
                        (setf prev-square-freeneighbours-count freeneighbours-count)))))
        square))



(defun check-board (inst board)
    (when (intersect? inst board)
        (fail)))


(defun get-a-free-side-square (side board)
    (let
        ((start 
            (ecase side 
                (:north 56) 
                ((:south :east) 0) 
                (:west 7)))
         (end 
            (ecase side 
                ((:north :west) 63) 
                (:south 7) 
                (:east 56)))
         (incr 
            (ecase side 
                ((:north :south) 1) 
                ((:west :east) 8))))
        (do
            ((square start (+ incr square)))
            ((> square end))
            (when (square-free? square board) 
                (return square)))))



#|
(defun gen-side-variant (direction &optional (pm-indices (GET-PM-INDICES-LIST)) (board +initial-bitboard+) (sols nil))
    (aif (get-a-free-side-square direction board) 
        (let ((inst (a-member-of (get-instances-by-square pm-indices it))))
            (check-board inst board)
            (gen-side-variant direction (remove (debug-gethash inst +inst-to-pm-idx-hashtable+) pm-indices)
                    (logior inst board) (cons inst sols)))
        sols))

(defun gen-side-variants ()
    (let ((side-variants (make-hash-table)))
        (dodirections (dir)
            (setf (gethash dir side-variants) (all-values (gen-side-variant dir))))
        side-variants))

|#


(defun gen-side-variants (direction *sols* &optional (pm-indices (GET-PM-INDICES-LIST)) (board +initial-bitboard+) (sol nil))
    (let ((sq (get-a-free-side-square direction board)))
        (if sq 
            (dolist (inst (get-instances-by-square pm-indices sq))
                (unless (intersect? inst board)
                    (gen-side-variants direction *sols* (remove (debug-gethash inst +inst-to-pm-idx-hashtable+) pm-indices)
                                                                  (logior inst board) 
                                                                  (cons inst sol))))
            (set *sols* (cons sol (symbol-value *sols*))))))


(defun gen-all-side-variants ()
    (let ((side-variants (make-hash-table)))
        (dodirections (dir)
            (let ((*solutions* nil))
                (declare (special *solutions*))
                (gen-side-variants dir '*solutions*)
                (setf (gethash dir side-variants) *solutions*)))
        side-variants))



(defun get-indices (instances)
    (let ((indices nil))
        (dolist (inst instances)
            (pushnew (debug-gethash inst +inst-to-pm-idx-hashtable+) indices))
        indices))

; todo: this function is plain ugly
(defun combine-side-variants (side-variants)
    (let ((n (make-variable))
          (s (make-variable))
          (w (make-variable)) 
          (e (make-variable))
          (instances nil)
          (clean-instances nil)
          (indices nil))
        (local
            (setf n (a-member-of (gethash :north side-variants)))
            (setf w (a-member-of (gethash :west side-variants)))
            (unless (= (get-corner-instance :northwest n) (get-corner-instance :northwest w))
                (fail))        
            (setf instances (append n w))
            (setf clean-instances (remove-duplicates instances))
            (setf indices (get-indices clean-instances))
            (unless (= (list-length indices) (list-length clean-instances))
                (fail))
            (when (adjacent-sides-intersect? n w)
                (fail))
            (when (detect-islands 1 (reduce #'logior clean-instances))
                (fail))
            
            
            
            
            (setf s (a-member-of (gethash :south side-variants)))
            (unless (= (get-corner-instance :southwest s) (get-corner-instance :southwest w))
                (fail))
            (setf instances (append s instances))
            (setf clean-instances (remove-duplicates instances))
            (setf indices (get-indices clean-instances))
            (unless (= (list-length indices) (list-length clean-instances))
                (fail))
            (when (adjacent-sides-intersect? s w)
                (fail))
            (when (detect-islands 2 (reduce #'logior clean-instances))
                (fail))

            
                                                
            (setf e (a-member-of (gethash :east side-variants)))
            (unless (= (get-corner-instance :northeast n) (get-corner-instance :northeast e))
                (fail))
            (setf instances (append e instances))
            (setf clean-instances (remove-duplicates instances))
            (setf indices (get-indices clean-instances))
            (unless (= (list-length indices) (list-length clean-instances))
                (fail))
            (when (adjacent-sides-intersect? n e)
                (fail))
            (when (adjacent-sides-intersect? s e)
                (fail))
            (let ((board (logior +initial-bitboard+ (reduce #'logior clean-instances))))
                (when (detect-islands 3 board) 
                    (fail))
                (let ((indices (GET-PM-INDICES-LIST)))
                    (dolist (inst clean-instances)
                        (setf indices (remove (debug-gethash inst +inst-to-pm-idx-hashtable+) indices)))
                    (setq clean-instances (fill-the-rest indices board clean-instances))))
        clean-instances)))

(defun fill-the-rest (pm-indices board sols)
    (if (null pm-indices) sols
        (let ((inst (a-member-of (get-instances-by-square pm-indices (get-most-constrained-square board)))))
            (check-board inst board)
            (fill-the-rest (remove (debug-gethash inst +inst-to-pm-idx-hashtable+) pm-indices)
                    (logior inst board) (cons inst sols)))))


(defun get-stage-subboard (stage-designator)
    "Returns a subboard-designator"
    (ecase stage-designator 
        (1 '(5 5 6 6))
        (2 '(1 5 4 6))
        (3 '(1 1 6 4))))

(defun on-subsequent-stage-border? (square stage-designator)
    (ecase stage-designator 
        (1 (member square '(37 38 44 52)))
        (2 (member square '(12 20 28 36 44 52)))
        (3 nil)))

(defun detect-islands (stage-designator board)
    (let ((iter (apply #'make-subboard-iterator (get-stage-subboard stage-designator)))
          (visited ())
          (on-border? nil))
        (labels ((create-island (square)
                    (when (and (square-free? square board)
                            (not (member square visited)))
                        (if (on-subsequent-stage-border? square stage-designator)
                            (progn
                                (setq on-border? t)
                                nil)
                            (progn
                                (push square visited)
                                ;(format t "~&visited: ~A~%" visited)
                                (cons square 
                                    (let ((result nil))
                                        (dodirections (dir)
                                            (setq result (append result (create-island (get-neighbour-index square dir)))))
                                        result)))))))
            (loop
                (multiple-value-bind (more? sq) (funcall iter)             
                    (unless more? (return))
                    (let ((island  (create-island sq)))
                        (if on-border? 
                            (setq on-border? nil)
                            (when island 
                                ;(format t "~&stage ~A~%" stage-designator)
                                ;(print-pm-inst board) 
                                ;(let ((island-board 0))
                                ;    (dolist (sq island)
                                ;        (setq island-board (logior island-board (get-bitsquare sq))))
                                ;    (print-pm-inst island-board))
                                
                                (when (< (length island) 4)
                                    (return-from detect-islands t))))))))))
    



(defun solve (&optional (all-solutions? nil))
    (let ((sv (GEN-ALL-SIDE-VARIANTS)))
        (if all-solutions?
            (all-values (COMBINE-SIDE-VARIANTS sv))
            (one-value (COMBINE-SIDE-VARIANTS sv)))))

;; $Id: //info.ravenbrook.com/user/ndl/lisp/contest/entries/denis-mashkevich/ilc-puzzle.lisp#1 $