#!/bin/sh
: ; exec klone $0 "$@"
; The above line finds the klone executable in the $PATH
(setq args (getopts "USAGE: kfortress
An implementation in Klone + Tk of the game Fortress
In fact a litteral traduction of the version of Yves Lafon: 'Web Fortress'
"
    ("-v" () verbose "verbose operation")
))

;;=============================================================================
;;                    KFortress
;;=============================================================================

(defun main ()
  (init_constants)
  (ascii-main-loop)
)

;;=============================================================================
;;                    game algorithms
;;=============================================================================

(defun init_constants ()			; initialize constants
  (setqn
    DEF_RATE          7
    ATT_RATE          6
    POS_RATE          4
    CONTROL_SQUARE    3
    SCORE_RATE        5
    PLAY_OPP_FLAG     20
    
    MY_PROTECT_RATE   3
    OPP_PROTECT_RATE  1
    MY_SCORE_RATE     2
    OPP_SCORE_RATE    2
    
    END_POS_TURN      16
    END_CONTROL_TURN  8
    MIN_MAX_START     41
    MAX_COUPS         43
))

(defun init_play ()
  (setqn
    last_computer_move [0 0]
    last_player_move [0 0]
    thinking_time 0
))

(defun init ()				;(re-)init current board
  (setqn
    player 1
    coups 1
    play_board (narray:def 0 8 8)
    calc_board (narray:def 0 8 8)
))

(defun Board:save ()			;returns a context to save boards in fact
  `(player ,player
    coups ,coups
    play_board ,play_board
    calc_board ,calc_board
))

(defun Board:copy (b &aux			;re-copy from saved context
    (orig-play_board (getn b 'play_board))
    (orig-calc_board (getn b 'calc_board))
  )
  (setq player (getn b 'player))
  (setq coups (getn b 'coups))
  (dolist (i range_1-7) (dolist (j range_1-7)
      (setq #[play_board i j] #[orig-play_board i j])
      (setq #[calc_board i j] #[orig-calc_board i j])
  ))
)

(setq range_1-7 '(1 2 3 4 5 6))		;numbers from 1 to 6

(defmacrod next_player () '(setq player (- player)))

(defun next_play () (incf coups) (next_player))

(defun turn () (/ (+ coups 1) 2))

(defun game_over () (>= coups MAX_COUPS))

(defun get_play (x y) (get (get play_board x) y))
(defun get_calc (x y) (get (get calc_board x) y))

(defmacrod valid (x y)
  `(and 
    (< coups MAX_COUPS)
    (not 
      (or (< (* player #[play_board ,x ,y]) 0)
	(= (* player #[play_board ,x ,y]) 3)
))))

(defun calc ()
  (dolist (i range_1-7) (dolist (j range_1-7)
      (setq #[calc_board i j] #[play_board i j])
  ))
  (dolist (i range_1-7) (dolist (j range_1-7)
      (if (/= 0 #[play_board i j]) 
	(with (play_board_i_j #[play_board i j])
	  (incf #[calc_board (- i 1) j] play_board_i_j)
	  (incf #[calc_board (+ i 1) j] play_board_i_j)
	  (incf #[calc_board i (- j 1)] play_board_i_j)
	  (incf #[calc_board i (+ j 1)] play_board_i_j)
)))))

(defun _prise (&aux
    (ok t)
  )
   (dolist (i range_1-7) (dolist (j range_1-7)
      (if (< (* #[play_board i j] #[calc_board i j] ) 0) (progn
	  (setq #[play_board i j] 0)
	  (setq ok ())
  ))))
  ok
)

(defun prise (&aux
    (done (_prise))
  )
  (while (not done)
    (calc)
    (setq done (_prise))
))

(defmacrod play (x y)
  `(if (valid ,x ,y) (progn
      (incf #[play_board ,x ,y] player)
      (calc)
      (prise)
      t
    )
    ()
))
  
(defun score (&aux 
    (value 0)
  )
  (dolist (i range_1-7) (dolist (j range_1-7)
      (if (/= 0 (+ #[play_board i j] #[calc_board i j]))
	(if (> (+ #[play_board i j] #[calc_board i j]) 0)
	  (incf value)
	  (incf value -1)
  ))))
  value
)

(defun white_score (&aux
    (value 0)
  )
  (dolist (i range_1-7) (dolist (j range_1-7)
      (if (> (+ #[play_board i j] #[calc_board i j]) 0)
	(incf value)
  )))
  value
)

(defun black_score (&aux
    (value 0)
  )
  (dolist (i range_1-7) (dolist (j range_1-7)
      (if (< (+ #[play_board i j] #[calc_board i j]) 0)
	(incf value)
  )))
  value
)

(defun stratscore (x y &aux
    (board_score 0)
    (the_score 0)
  )
  (dolist (i range_1-7) (dolist (j range_1-7)
      (if (/= 0 (+ #[play_board i j] #[calc_board i j]))
	(if (> (* player (+ #[play_board i j] #[calc_board i j])) 0)
	  (incf board_score MY_SCORE_RATE)
	  (incf board_score (- OPP_SCORE_RATE))
      ))
      ;; on teste si on est en danger (avec une valeur 0)
      ;; donc plus on est danger,plus le score diminue 
      (if (and (> (* player #[play_board i j]) 0) (= 0 #[calc_board i j]))
	(incf board_score (- MY_PROTECT_RATE))
      )
      (if (and (< (* player #[play_board i j]) 0) (= 0 #[calc_board i j]))
	(incf board_score OPP_PROTECT_RATE)
      )
  ))
  (setq the_score (* board_score SCORE_RATE))

  (if (< board_score 1) (setq board_score 1))

  (if (< (* player #[calc_board x y]) 0)
    (incf the_score (- (* board_score PLAY_OPP_FLAG)))
  )
  (if (or
      (and (> (* player #[play_board x y]) 0) (= 0 #[calc_board x y]))
      (and (> (* player #[play_board (+ x 1) y]) 0) 
	(= 0 #[calc_board (+ x 1) y]))
      (and (> (* player #[play_board (- x 1) y]) 0) 
	(= 0 #[calc_board (- x 1) y]))
      (and (> (* player #[play_board x (+ y 1)]) 0) 
	(= 0 #[calc_board x (+ y 1)]))
      (and (> (* player #[play_board x (- y 1)]) 0) 
	(= 0 #[calc_board x (- y 1)]))
    )
    (incf the_score (* board_score DEF_RATE))
  )
  (if (or
      (and (< (* player #[play_board x y]) 0) (= 0 #[calc_board x y]))
      (and (< (* player #[play_board (+ x 1) y]) 0) 
	(= 0 #[calc_board (+ x 1) y]))
      (and (< (* player #[play_board (- x 1) y]) 0) 
	(= 0 #[calc_board (- x 1) y]))
      (and (< (* player #[play_board x (+ y 1)]) 0) 
	(= 0 #[calc_board x (+ y 1)]))
      (and (< (* player #[play_board x (- y 1)]) 0) 
	(= 0 #[calc_board x (- y 1)]))
    )
    (incf the_score (* board_score ATT_RATE))
  )
  (if (< coups END_POS_TURN)
    (if (and (/= x 1) (/= x 6) (/= y 1) (/= y 6))
      (incf the_score (* board_score POS_RATE))
  ))
  (if (< coups END_CONTROL_TURN)
    (if (or (= x 2) (= x 5) (= y 2) (= y 5))
      (incf the_score (* board_score CONTROL_SQUARE))
  ))

  (setq the_score (+ (* the_score 10) (mod (random 1000) 10)))
)

(defun minmax (&aux
    (saved_board (Board:save))		;context, save original board
    (dump_score -1000)
    (i0 0)
    (j0 0)
    (min_max_score -1000)
  )
  (calc)
  (with saved_board			;will restore original board on exit
    (init)
    (dolist (i range_1-7) (dolist (j range_1-7)
	(Board:copy saved_board)		;create temp board
	(if (play i j) (progn
	    (next_play)
	    (minmax)
	    (setq dump_score (score))
	  )
	  (if (>= coups MAX_COUPS)
	    (setq dump_score (score))
	))
	(if (> dump_score min_max_score)
	  (setq i0 i)
	  (setq j0 j)
	  (setq min_max_score dump_score)
	)
  )))
  (play i0 j0)
  (setq last_computer_move (vector i0 j0))
  (next_play)
)

(defun alphabeta (&aux
    (saved_board (Board:save))		;context, save original board
    (alpha -100000)
    beta
    dump_score
    (i0 0)
    (j0 0)
  )
  (calc)
  (with saved_board			;will restore original board on exit
    (init)
    (Board:copy saved_board)		;create temp board
    (dolist (i range_1-7) (dolist (j range_1-7)
	(setq beta 1000000)
	(if (valid i j) 
	  (catch 'NOT_OK
	    (dolist (di range_1-7) (dolist (dj range_1-7)
		(next_player)		;toggle pour l'autre joueur (2)
		(if (and (valid di dj) (or (/= i di) (/= j dj))) (progn
		    (next_player)	; on revient au premier
		    (play i j)
		    (next_player)	; puis au second
		    (play di dj)
		    (next_player)	; on revient au premier
		    (setq dump_score (stratscore i j))
;		    (PV i j di dj dump_score beta alpha) (? ": ")(read-line)
		    (if (< dump_score beta)
		      (setq beta dump_score)
		    )
		    (Board:copy saved_board)
		    (if (< beta alpha) (throw 'NOT_OK))
		  )
		  (next_player)		; remettre sur le premier
	    )))
	    (if (> beta alpha) (progn
		(setq alpha beta)
		(setq i0 i)
		(setq j0 j)
	    ))
	))
  )))
  (play i0 j0)
  (setq last_computer_move (vector i0 j0))
  (next_play)
)

(defun compuplay ()
  (if (< coups MIN_MAX_START)
    (alphabeta)
    (minmax)
))

;;=============================================================================
;;                    User interface
;;=============================================================================

;; an ascii one for testing

(defun ascii-main-loop ()
  (init_play)
  (init)
  (while (not (game_over))
    (ascii-print-board)
    (if (apply play (ascii-get-input)) 
      (with (start-time (get-internal-run-time))
	(next_play)
	(compuplay)
	(setq thinking_time (- (get-internal-run-time) start-time))
      )
      (PF "*********** INVALID MOVE! *********\n")
  ))
  (ascii-print-board)
  (if (> (score) 0) (PF "You WON!\n")
    (< (score) 0) (PF "You LOST!\n")
    (PF "A Draw!\n")
  )
)

(defun ascii-get-input (&aux ok line i j
    (re (regcomp "^[ \t\n]*([1-6])[ \t\n]*([1-6])[ \t\n]*$"))
  )
  (while (not ok)
    (? "Your move (xy): ")
    (with (read_eof t)
      (catch 'EOF
	(setq line (read-line))
	(setq read_eof ())
      )
      (if read_eof (progn (PF "\nOk, Bye...\n") (exit 0)))
    )
    (if (regexec re line) (progn
	(setq i (Int (regsub re 1)))
	(setq j (Int (regsub re 2)))
	(if (and (> i 0) (< i 7) (> j 0) (< j 7))
	  (setq ok t)
  ))))
  (setq last_player_move (vector i j))
)

(with (inverse (lambda (s) (+ "\e[7m" s "\e[m"))) ;inverse on a vt100 (xterm)
  (setqn 
    image:empty "   "
    image:white_flag " P "
    image:black_flag (inverse image:white_flag)
    image:white_castle_warn_1 "_*_"
    image:black_castle_warn_1 (inverse image:white_castle_warn_1)
    image:white_castle_warn_2 "*_*"
    image:black_castle_warn_2 (inverse image:white_castle_warn_2)
    image:white_castle_warn_3 "***"
    image:black_castle_warn_3 (inverse image:white_castle_warn_3)
    image:white_castle_1 "_#_"
    image:black_castle_1 (inverse image:white_castle_1)
    image:white_castle_2 "#_#"
    image:black_castle_2 (inverse image:white_castle_2)
    image:white_castle_3 "###"
    image:black_castle_3 (inverse image:white_castle_3)
))

(defun ascii-print-board ()
  (PF "  x 1  2  3  4  5  6\ny /------------------\\\n")
  (dolist (y range_1-7) 
    (PF "%0 |" y)
    (dolist (x range_1-7)
      (if (= 0 #[play_board x y]) (progn
	  (if (= 0 #[calc_board x y])
	    (write image:empty)
	    (> #[calc_board x y] 0)
	    (write image:white_flag)
	    (write image:black_flag)
	))
	(= 0 #[calc_board x y])
	(write (get {vector image:black_castle_warn_3 image:black_castle_warn_2
	    image:black_castle_warn_1 () image:white_castle_warn_1
	    image:white_castle_warn_2 image:white_castle_warn_3}
	    (+ 3 #[play_board x y])
	))
 	(write (get {vector image:black_castle_3 image:black_castle_2
	    image:black_castle_1 () image:white_castle_1
	    image:white_castle_2 image:white_castle_3}
	    (+ 3 #[play_board x y])
	))
    ))
    (PF "| %0\n" y)
  )
  (PF "  \\------------------/\n    1  2  3  4  5  6\n")
  (PF "Turn: %0/21 - Score: %1/%2 - Your move: %3 - Computer move: %4 in %5s\n"
    (turn) (white_score) (black_score) last_player_move last_computer_move
    (/ thinking_time 1000.0)
  )
)

;;=============================================================================
;;                    Utilities
;;=============================================================================

;; vectors with multiple indices. simple vectors of vectors so that C code
;; tab[i][j][k] is translated into (get (get (get tab i) j) k), or more readably
;; and efficiently to #[tab i j k]
;; (narray:def () 2 3 4) defines a 3x4 array, which an array of 3 vectors of 4
;; elements. Actually a vector of 4 vectors, the 4th one being a label storing
;; the definition parameters for debugging

;; defines one. all vectors are created, but with size 0
;; a vector of [:narray dimensions initvalue sizes...] is appended to the end 
;; for self-containance...

(defun narray:def (initval &rest sizes &aux
    (dimensions (length sizes))
    array
  )
  (if (not (typep #[sizes 0] Number))
    (error "narray:def args must be numbers!")
  )
  (setq array (narray::init initval #[sizes 0] (subseq sizes 1))) ;init vectors
  (lappend array `[:narray  ,dimensions ,initval ,@sizes]) ;label at the end
  array
)

(defun narray::init (initval size sizes &aux
    (v (vector! (make-list size initval)))
  )
  (if sizes
    (dotimes (i size)
      (put v i (narray::init initval #[sizes 0] (subseq sizes 1)))
    ))
  v
)

;; deep copy
(defun narray:copy (array &aux 
    (sizes (list! (subseq #[array -1] 3)))
    newarray
  )
  (setq newarray (narray::subcopy array #[sizes 0] (subseq sizes 1)))
)

(defun narray::subcopy (array size sizes &aux
    (v (copy array))
  )
  (if sizes
    (dotimes (i size)
      (put v i (narray::subcopy #[array i] #[sizes 0] (subseq sizes 1)))
    )
  )   
  v      
)

;;=============================================================================
;;                    Main
;;=============================================================================

(main)

;;; EMACS MODES
;;; Local Variables: ***
;;; mode:lisp ***
;;; End: ***

