(in-package :screamer-user)

(defconstant +pm-types-count+ 13)

(defun create-bitsquare-array ()
    (let ((array (make-array '(8 8))))
        (dotimes (x 8 array)
            (dotimes (y 8)
                (setf (aref array  x y) (expt 2 (+ (* 8 (- 7 x)) (- 7 y))))))))

(defconstant +bitsquares+ #.(CREATE-BITSQUARE-ARRAY))




(defun create-flat-bitsquare-array ()
    (let ((array (make-array 64)))
        (dotimes (x 64 array)
            (setf (aref array  x) (expt 2 x)))))

(defconstant +flat-bitsquares+ #.(CREATE-FLAT-BITSQUARE-ARRAY))


; The 'amino-acid' names are three-letter abbreviations to maintain
; a (pleasant to my heart) stylistic compatibility with the real amino-acid codes
(defconstant +dnas+
  #((crw fcr lcr rig fcr)   ; t4 
    (crb fcr lcr lcr fcr)     ; Q5 
    (crb fcr fcr lcr rig fcr) ; T5 
    (crw fcr fcr rcr lef fcr) ; F5
    (crb fcr rcr fcr rcr)     ; W5 
    (crb fcr lcr lcr lcr)     ; J5 
    (crb fcr lcr fcr)         ; s4 
    (crw fcr rcr rcr rcr)     ; L5 
    (crw fcr rcr rcr fcr)     ; N5 
    (crw fcr fcr lcr fcr)     ; S5 
    (crb fcr rcr fcr fcr)     ; Z5 
    (crb fcr lcr lcr)         ; j4 
    (crw fcr rcr rcr)))        ; l4 
    
    


(defconstant +initial-bitboard+ 515 "0000000000000000000000000000000000000000000000000000001000000011 Bitboard with only the '3'-polyomino placed")



(defun process-dna (x y dna direction)
    (let
        ((board 0))
        (labels
            ((is-black ()
                "Checks whether the square is black"
                (zerop (mod (abs (- x y)) 2)))
            (is-white ()
                "Checks whether the square is white"
                (not (is-black)))
            (create ()
                "Adds a polyomino-element to the board. The choice to call coords-ok? in cre
                is bad (ineffective) but makes the program simpler (this is the only place it needs to be called)"
                (and
                    (coords-ok? x y)
                    (not (intersect? (aref +bitsquares+ x y) +initial-bitboard+))
                    (setf board (logior board (aref +bitsquares+ x y)))))
            (forward ()
                (case direction
                    (:north (decf x))
                    (:south (incf x))
                    (:west  (decf y))
                    (:east  (incf y))))
            (left ()
                (case direction
                    (:north (decf y))
                    (:south (incf y))
                    (:west  (incf x))
                    (:east  (decf x))))
            (right ()
                (case direction
                    (:north (incf y))
                    (:south (decf y))
                    (:west  (decf x))
                    (:east  (incf x))))
            (forward-create ()
                "forward + create"
                (and (forward)(create)))
            (left-create ()
                "left + create"
                (and (left)(create)))
            (right-create ()
                "right + create"
                (and (right)(create)))
            (create-black ()
                "is-black + create"
                (and (is-black)(create)))
            (create-white ()
                "is-white + create"
                (and (is-white)(create)))
            (getfun (sym)
                 (ecase sym
                     (isb #'is-black)
                     (isw #'is-white)
                     (cre #'create)
                     (for #'forward)
                     (lef #'left)
                     (rig #'right)
                     (fcr #'forward-create)
                     (lcr #'left-create)
                     (rcr #'right-create)
                     (crb #'create-black)
                     (crw #'create-white))))
            (dolist (nuc dna board)
                (unless (funcall (getfun nuc)) (return))))))



(defun gen-instances-array ()
    (let ((instances-array (make-array +pm-types-count+)))
        (dotimes (idx +pm-types-count+)
            (let ((dna (aref +dnas+ idx))
                  (instances nil))
                (dotimes (x 8)
                    (dotimes (y 8)
                        (dodirections (dir)
                            (let ((instance (process-dna x y dna dir)))
                                (when instance 
                                    (pushnew instance instances)))))) ;pushnew is implortant here. e.g. instance 2154624 is generated in cases x 5 y 2 dir SOUTH and x 7 y 0 dir NORTH 
                (setf (aref instances-array idx) instances)))
        instances-array))


(defconstant +instances-array+ #.(gen-instances-array))


; todo: reimplement it - generate instances-array and this one in one function
(defun gen-instances-array-by-square ()
    (let ((array (make-array (list +pm-types-count+ 64) :initial-element nil)))
        (dotimes (pm-idx +pm-types-count+)
            (dolist (inst (aref +instances-array+ pm-idx))
                (dotimes (sq 64)
                    (when (intersect? inst (get-bitsquare sq)) 
                        (push inst (aref array pm-idx sq))))))
        array))

(defconstant +instances-array-by-square+ #.(gen-instances-array-by-square))



(defun gen-inst-to-pm-idx-hashtable ()
    (let ((hash (make-hash-table)))
        (dotimes (pm-idx +pm-types-count+)
            (dolist (inst (aref +instances-array+ pm-idx))
                ;(format t "~& inst ~A pm-idx ~A~%" inst pm-idx)
                (setf (gethash inst hash) pm-idx)))
        hash))

(defconstant +inst-to-pm-idx-hashtable+ #.(gen-inst-to-pm-idx-hashtable))


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