;;(make-package 'bw)
;;(in-package bw)
;;(lisp::use-package 'lisp)

;;********************************* rules **************************************
;;There is a chess board 8x8 with the numeric-numeric coordinates.
;;White king position is (8 1), black king position is (1 7) and
;;black pawn is at (1 8), cannot move, just an ocupied place.
;;White objective is to take black pawn, defended by black king.

;;1. White starts
;;2. Black pawn cannot move (it's just an objective)
;;3. Black king cannot step on position (1 8)
;;4. Kings cannot approximate (like ((4 6)(5 7))
;;******************************************************************************
;;algorythm used for whites expects:
;;1. white can always win
;;2. white can always reach bi-line using only squared cases
;;3. once done, white is always in 3-coridor
;;4. if black is not there, it cannot interfere

;;algorythm used for black expects:
;;1. black secures white on 1-line while possible
;;2. if white steps from 1-line from wrong position, it's lost

(setf position '((8 1) (1 7)))
(setf strategy 1)

;;*****************************basic functions**********************************
;;******************************************************************************

(defun format-ok (move)
"returns T if MOVE is list of two numbers i.e. (2 3) **works**"
  (and (listp move)
       (= 2 (length move))
       (numberp (first move))
       (numberp (second move))
  )
)
(defun is-inside (move)
"returns T if MOVE is inside the board i.e. values are in[1..8] **works**"
  (let ((line (first move))
        (column (second move))
       )
       (and (<= 1 line)
            (<= line 8)
            (<= 1 column)
            (<= column 8)
       )

  )
)
(defun is-black-on-pawn (move)
"returns T if MOVE is on black pawn i.e. MOVE=(1 8) **works**"
  (equal move '(1 8))
)

(defun dist-1 (case1 case2)
"returns T if CASE1 & CASE2 are _exactly_ 1 step next **works**"
  (let ((delta-l (- (first case1)
                    (first case2)))
        (delta-c (- (second case1)
                    (second case2))))
       (= 1 (max (abs delta-l)
                 (abs delta-c)))
  )
)
(defun valid (pos player move)
  "returns T if MOVE is valid, testing all above **works**
   pos is like ((1 2) (3 4)) it is (white black),
   player is 'WHITE or 'BLACK, move is like (1 2)"

  (and (format-ok move)
       (is-inside move)
       (dist-1 move (if (eq player 'black)
                        (second pos)
                        (first pos)))
       (not (dist-1 move (if (eq player 'black)
                             (first pos)
                             (second pos))))
       (if (eq player 'black)
           (not (is-black-on-pawn move))
           t)
   )
)
(defun absolute-coordinates (case shift)
"returns absolute coordinates given position and shift **works**"
  (list (+ (first case) (first shift))
        (+ (second case) (second shift))
  )
)
(defun turn-absolute (piece list)
"converts given list of shifts to absolute coordinates **works**"
  (if (null list)
      nil
      (cons (absolute-coordinates piece (first list))
            (turn-absolute piece (cdr list))
      )
  )
)
(defun delete-invalid (pos player list)
"deletes invalid moves from list **works**"
  (if (null list)
      nil
      (if (valid pos player (first list))
          (cons (first list) (delete-invalid pos player (cdr list)))
          (delete-invalid pos player (cdr list))
      )
  )
)
(defun make-move-list (pos player)
"makes list with all valid moves for given position **works**"
  (let ((all-relative-moves '((-1 -1) (-1 0) (-1 1) (0 -1)
                              (0 1) (1 -1) (1 0) (1 1)))
        (piece (if (eq player 'white)
                   (first pos)
                   (second pos))))
       (delete-invalid pos player (turn-absolute piece all-relative-moves))
  )
)
;;*****************************square part**************************************
;;******************************************************************************
(defun distance-between (case1 case2)
"returns distance between two cases **works**"
  (let ((d1 (abs (- (first case1) (first case2))))
        (d2 (abs (- (second case1) (second case2)))))
       (+ (* d1 d1) (* d2 d2))
  )
)
(defun abs-distance-between (case1 case2)
"returns absolute between two cases **works**"
  (max (abs (- (first case1) (first case2)))
       (abs (- (second case1) (second case2)))
  )
)
(defun white-is-abs-closer (pos)
"returns T if white is closer to pawn than black **works**"
  (< (abs-distance-between (first pos) '(1 8))
     (abs-distance-between (second pos) '(1 8)))
)
(defun are-squared (case1 case2)
"returns T if CASE1 & CASE2 have the same parity in each coordinates **works**"
  (and (= 0 (mod (- (first case1) (first case2)) 2))
       (= 0 (mod (- (second case1) (second case2)) 2))
  )
)
(defun make-square-list (case list)
"returns all moves, squared to CASE **works**"
  (if (null list)
      nil
      (if (are-squared case (first list))
          (cons (first list) (make-square-list case (cdr list)))
          (make-square-list case (cdr list)))
  )
)
(defun are-in-white-parity (case1 case2)
"returns T if CASE1 & CASE2 have the same parity in some coordinate,
 but not on the same line/column with pawn **works**"
  (let ((delta1 (abs (- (first case1) (first case2))))
        (delta2 (abs (- (second case1) (second case2)))))
       (and (or (= 0 (mod delta1 2))
                (= 0 (mod delta2 2)))
            (not (or (and (= 1 (first case1))
                          (= 1 (first case2)))
                     (and (= 8 (second case1))
                          (= 8 (second case2)))))
       )
  )
)
(defun make-white-parity-list (case list)
"returns all moves, with the same white-parity to CASE **works**"
  (if (null list)
      nil
      (if (are-in-white-parity case (first list))
          (cons (first list) (make-white-parity-list case (cdr list)))
          (make-white-parity-list case (cdr list)))
  )
)
(defun closest-move-to (case list)
;;INITIAL LIST SHOULDN'T BE EMPTY!!!
"returns closest move to CASE in LIST or (100 100) if list is empty! **works**"
  (if (null list)
      '(100 100)
      (let ((close (closest-move-to case (cdr list))))
           (if (< (distance-between case (first list))
                  (distance-between case close))
               (first list)
               close))
  )
)
(defun go-square-par (case sq-list par-list)
"tries to go square, if can't, goes round. Takes move, closest to CASE"
  (if (not (null sq-list))
      (closest-move-to case sq-list)
      (closest-move-to case par-list))
)
(defun on-bi-line (case)
"returns T if CASE is on 2nd line **works**"
  (or (= (first case) 2)
      (= (second case) 7))
)
;;*******************white part (never completely tested)***********************
;;******************************************************************************
(defun white-can-go-closer (pos sq-list)
"returns T if white can go _realy_ closer, preserving absolute parity
 or strategy is already 1 and black is on bi-line"
  (let ((closest-square (closest-move-to '(1 8) sq-list)))
       (or (> (abs-distance-between (first pos) '(1 8))
              (abs-distance-between closest-square '(1 8)))
           (on-bi-line closest-square))
  )
)
(defun test-strategy (pos)
"always returns NIL. Sets global variable STRATEGY to
 0-closer, go ahead! 2-in coridor, go round"
  (cond ((white-is-abs-closer pos) (setf strategy 0))
        ((on-bi-line (first pos)) (setf strategy 2))
        (T nil)
  )
)
(defun white-goes (pos)
"returns next move. Never tested enough"
  (let* ((move-list (make-move-list pos 'white))
         (white-parity-list (make-white-parity-list (second pos) move-list))
         (square-list (make-square-list (second pos) move-list)))
        (test-strategy pos)
        (cond ((= strategy 0) (closest-move-to '(1 8) move-list))
;;white-is-abs-closer
              ((or (white-can-go-closer pos square-list)
                   (= strategy 1)) (go-square-par '(1 8) square-list white-parity-list))
;;white is (upleft & 'far') | can go closer
              (t (closest-move-to '(1 8) white-parity-list))
        )
  )
)
;;*******************black part (never completely tested)***********************
;;******************************************************************************

(defun make-up-list (case list)
"returns all moves in LIST on the same vertical as CASE"
  (if (null list)
      nil
      (if (= (second case) (cadar list))
          (cons (first list) (make-up-list case (cdr list)))
          (make-up-list case (cdr list)))
  )
)
(defun are-lined-up (pos)
  (or (= (caar pos) (caadr pos))
      (= (cadar pos) (cadadr pos)))
)
(defun special-case (pos)
"optimal moves in some cases"
  (cond ((equal pos '((3 2) (1 7))) '(2 6))
        ((equal pos '((3 3) (1 6))) '(2 7))
	((equal pos '((3 4) (1 7))) '(2 6))
	((equal pos '((3 5) (1 6))) '(2 7))
;;	((equal pos '((7 2) (1 7))) '(2 7))
        (T nil)
  )
)

(defun go-square-up (pos sq-list up-list mv-list)
"treats special cases, then square then close-up then rest"
  (cond ((special-case pos) (special-case pos))
        (sq-list (closest-move-to (first pos) sq-list))
        (up-list (if (are-lined-up pos)
                     (closest-move-to '(1 8) up-list)
                     (closest-move-to (first pos) up-list)))
        (t (closest-move-to '(1 8) mv-list))
  )
)

(defun black-goes (pos)
"returns next move"
  (let* ((move-list (make-move-list pos 'black))
         (up-list (make-up-list (second pos) move-list))
         (square-list (make-square-list (first pos) move-list)))
        (go-square-up pos square-list up-list move-list)
  )
)

;;**************************interface functions*********************************
;;******************************************************************************
(defun make-move (player move)
"changes global variable POSITION"
  (if (eq player 'white)
      (setf position (list move (second position)))
      (setf position (list (first position) move)))

)
(defun branco-inicia ()
  (setf position '((8 1) (1 7)))
  (setf strategy 1)
  (make-move 'white (white-goes position))
  (first position)
)
(defun branco-responde (move)
  (make-move 'black move)
  (make-move 'white (white-goes position))
  (first position)
)
(defun preto-inicia (move)
  (setf position '((8 1) (1 7)))
  (preto-responde move)
)
(defun preto-responde (move)
  (make-move 'white move)
  (make-move 'black (black-goes position))
  (second position)
)

(defun br (l c)
"short for branco-responde"
  (branco-responde (list l c))
)
(defun pr (l c)
"short for preto-responde"
  (preto-responde (list l c))
)

;;******************************************************************************