;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Constants & global variables

(defconstant mhz 866.0)

(defconstant open_block '-)
(defconstant closed_block '*)
(defconstant player1 'x)
(defconstant player2 'o)
(defconstant player3 'v)
(defconstant player4 'z)
(defconstant d8 '((0 -1) (1 -1) (1 0) (1 1) (0 1) (-1 1) (-1 0) (-1 -1)))

;; note that this is only used by the sample player
(defconstant ms-per-node-est (/ (* 0.003 mhz) 866.0))

;; global var for current top level legal moves
(defvar *current-legal-top-level-moves* nil)
(defun be-get-current-legal-top-level-moves ()
  *current-legal-top-level-moves*)
(defun be-pick-some (list prob)
  (let* ((len (length list))
	 (newlen (ceiling (* len prob))))
    (if (< newlen 1) 
	list
      (subseq (permute list) 0 newlen))))

(defun permute (list &optional faclen)
  (let* ((len (length list))
	 (rn (random (or faclen (factorial len))))
	 (olist (reconstruct-deck rn len))
	 (ret))
    (dolist (i olist ret)
      (push (nth (nth i olist) list) ret))))
	
(unless (boundp 'verbose) (defparameter verbose t))

(setq first-round? t)

(defmacro make-blockem-instance (board pieces)
  `#'(lambda (maxtime p1 p2 p3 p4)
       (let ((winners (begame maxtime p1 p2 p3 p4 ,board ,pieces)))
	 (mapcar #'(lambda (winner)
		     (cond ((equal winner 'x) p1)
			   ((equal winner 'o) p2)
			   ((equal winner 'v) p3)
			   ((equal winner 'z) p4)
			   (t 'UNKNOWN)))
		 winners))))

(defmacro make-rblockem-instance (board pieces)
  `#'(lambda (maxtime p1 p2 p3 p4)
       (let ((winners (begame maxtime p1 p2 p3 p4 ,board ,pieces t)))
	 (mapcar #'(lambda (winner)
		     (cond ((equal winner 'x) p1)
			   ((equal winner 'o) p2)
			   ((equal winner 'v) p3)
			   ((equal winner 'z) p4)
			   (t 'UNKNOWN)))
		 winners))))

(defun begame (max-time player1-func player2-func player3-func player4-func 
			board pieces &optional randomize?)
  (let ((xpos (copy-list pieces))
        (opos (copy-list pieces))
	(vpos (copy-list pieces))
	(zpos (copy-list pieces))
        (xtime max-time)
        (otime max-time)
	(vtime max-time)
	(ztime max-time)
	(p1-in-play t)
	(p2-in-play t)
	(p3-in-play t)
	(p4-in-play t)
        (turn player1)
        (move)(start-time)(ms)(allmoves)(current-legal-top-level-moves))

    (when verbose
      (format t "~A vs. ~A vs. ~A vs. ~A~%" 
	      player1-func player2-func player3-func player4-func)
      (format t "Starting position:~%")
      (be-print-board board))

    ;; mark as first round
    (setq first-round? t)

    (do ((n 4 (1+ n)))
        (nil)

      ;; (sleep 1)

      ;; check to see if three players are out of play
      (let ((in-play (be-check-in-play 
		      (list p1-in-play p2-in-play p3-in-play p4-in-play)
		      (list player1 player2 player3 player4))))
	(unless in-play 
	  (return-from begame (be-winner board xpos opos vpos zpos)))
      
      (setf start-time (get-time-ms))

      ;; make a move for player 1
      (when (and (equal turn player1) p1-in-play)
        (if verbose (format t "Round ~A: Player ~A to move... (~Ams left)~%"
                            (floor (/ n 4)) player1 xtime))

	;; Figure out the current legal moves
	(setf allmoves (be-gen-moves player1 xpos board))
	(setf *current-legal-top-level-moves*
	      (copy-list
	       (setf current-legal-top-level-moves
		     (if randomize?
			 (be-pick-some allmoves .5)
		       allmoves))))
	

        (setf move (funcall player1-func turn xpos opos vpos zpos xtime board))
        (setf ms (- (get-time-ms) start-time))
        (setf xtime (- xtime ms))
        (when (< xtime 0)
          (format t "Player ~A used too much time (~Ams)...~%"
                  player1 ms)
	  (setf p1-in-play nil)
	  (sleep 1)
	  )

	;(format t "Player X has chosen move: ~A~%" move)
	;; when move is nil, the player cannot move and has lost
	(when (not (first move))
	  (format t "Player ~A can no longer move his ~a pieces.~%" 
		  player1 (length xpos))
	  (setf p1-in-play nil)
	  (sleep 1)
	  )
        (when (and p1-in-play 
		   (not (member move current-legal-top-level-moves :test #'equal)))
	  (format t "Player ~A made an illegal move and is now out of play.~%" player1)
	  (setf p1-in-play nil)
	  (sleep 1)
	  )
	(when p1-in-play 
	  (let ((changes (be-effect-move turn xpos move board)))
	    (setf board (car changes))
	    (setf xpos (cadr changes))))
	(when verbose (be-pretty-move turn ms move xpos))
	)

      ;; make a move for player 2
      (when (and (equal turn player2) p2-in-play)
        (if verbose (format t "Round ~A: Player ~A to move... (~Ams left)~%"
                            (floor (/ n 4)) player2 otime))

	;; Figure out the current legal moves
	(setf allmoves (be-gen-moves player2 opos board))
	(setf *current-legal-top-level-moves*
	      (copy-list
	       (setf current-legal-top-level-moves
		     (if randomize?
			 (be-pick-some allmoves .5)
		       allmoves))))

        (setf move (funcall player2-func turn xpos opos vpos zpos otime board))
        (setf ms (- (get-time-ms) start-time))
        (setf otime (- otime ms))
        (when (< otime 0)
          (format t "Player ~A used too much time (~Ams)...~%"
                  player2 ms)
	  (setf p2-in-play nil)
	  (sleep 1)
	  )

	;(format t "Player O has chosen move: ~A~%" move)
	;; when move is nil, the player cannot move and has lost
	(when (not (first move))
	  (format t "Player ~A can no longer move his ~a pieces.~%" 
		  player2 (length opos))
	  (setf p2-in-play nil)
	  (sleep 1)
	  )
        (when (and p2-in-play 
		   (not (member move current-legal-top-level-moves :test #'equal)))
	  (format t "Player ~A made an illegal move and is now out of play.~%" player2)
	  (setf p2-in-play nil)
	  (sleep 1)
	  )
	(when p2-in-play 
	  (let ((changes (be-effect-move turn opos move board)))
	    (setf board (car changes))
	    (setf opos (cadr changes))))
	(when verbose (be-pretty-move turn ms move opos))
	)

      ;; make a move for player 3
      (when (and (equal turn player3) p3-in-play)
        (if verbose (format t "Round ~A: Player ~A to move... (~Ams left)~%"
                            (floor (/ n 4)) player3 vtime))

	;; Figure out the current legal moves
	(setf allmoves (be-gen-moves player3 vpos board))
	(setf *current-legal-top-level-moves*
	      (copy-list
	       (setf current-legal-top-level-moves
		     (if randomize?
			 (be-pick-some allmoves .5)
		       allmoves))))

        (setf move (funcall player3-func turn xpos opos vpos zpos vtime board))
        (setf ms (- (get-time-ms) start-time))
        (setf vtime (- vtime ms))
        (when (< vtime 0)
          (format t "Player ~A used too much time (~Ams)...~%"
                  player3 ms)
	  (setf p3-in-play nil)
	  (sleep 1)
	  )

	;(format t "Player V has chosen move: ~A~%" move)
	;; when move is nil, the player cannot move and has lost
	(when (not (first move))
	  (format t "Player ~A can no longer move his ~a pieces.~%" 
		  player3 (length vpos))
	  (setf p3-in-play nil)
	  (sleep 1)
	  )
        (when (and p3-in-play 
 		   (not (member move current-legal-top-level-moves :test #'equal)))
	  (format t "Player ~A made an illegal move and is now out of play.~%" player3)
	  (setf p3-in-play nil)
	  (sleep 1)
	  )
	(when p3-in-play 
	  (let ((changes (be-effect-move turn vpos move board)))
	    (setf board (car changes))
	    (setf vpos (cadr changes))))
	(when verbose (be-pretty-move turn ms move vpos))
	)


      ;; make a move for player 4
      (when (and (equal turn player4) p4-in-play)
        (if verbose (format t "Round ~A: Player ~A to move... (~Ams left)~%"
                            (floor (/ n 4)) player4 ztime))

	;; Figure out the current legal moves
	(setf allmoves (be-gen-moves player4 zpos board))
	(setf *current-legal-top-level-moves*
	      (copy-list
	       (setf current-legal-top-level-moves
		     (if randomize?
			 (be-pick-some allmoves .5)
		       allmoves))))

        (setf move (funcall player4-func turn xpos opos vpos zpos ztime board))
        (setf ms (- (get-time-ms) start-time))
        (setf ztime (- ztime ms))
        (when (< ztime 0)
          (format t "Player ~A used too much time (~Ams)...~%"
                  player4 ms)
	  (setf p4-in-play nil)
	  (sleep 1)
	  )

	;(format t "Player V has chosen move: ~A~%" move)
	;; when move is nil, the player cannot move and has lost
	(when (not (first move))
	  (format t "Player ~A can no longer move his ~a pieces.~%" 
		  player4 (length zpos))
	  (setf p4-in-play nil)
	  (sleep 1)
	  )
        (when (and p4-in-play 
		   (not (member move current-legal-top-level-moves :test #'equal)))
	  (format t "Player ~A made an illegal move and is now out of play.~%" player4)
	  (setf p4-in-play nil)
	  (sleep 1)
	  )
	(when p4-in-play 
	  (let ((changes (be-effect-move turn zpos move board)))
	    (setf board (car changes))
	    (setf zpos (cadr changes))))
	(when verbose (be-pretty-move turn ms move zpos))
	)


      (be-print-board board)
      
      (format t "Player ~A has completed his turn.~%" turn)
      
      (cond ((equal turn player1) (setf turn player2))
         ((equal turn player2) (setf turn player3))
         ((equal turn player3) (setf turn player4))
	 ;; if player 4 just finished, also set first-round? to nil
         ((equal turn player4) (setf turn player1) (setq first-round? nil))
	 )
      ))
    ))

(defun be-pretty-move (turn ms move left)
  (when (first move)
    (format t "Player ~A used ~Ams deciding to move ~%" turn ms)
    (be-print-board (nth (nth 3 move) (nth 2 move)))
    (format t "to ~a~%" (list (nth 0 move) (nth 1 move)))))

(defun be-pretty-move0 (turn ms move left)
  (when (first move)
    (format t "Player ~A used ~Ams deciding to move ~%" turn ms)
    (be-print-board (nth (nth 3 move) (nth 2 move)))
    (format t "to ~a, leaving:~a~%" (list (nth 0 move) (nth 1 move))
	    left)))

(defun be-check-in-play (b p) 
  (let ((ret nil))
    (while b
      (when (car b) (push (car p) ret))
      (setf b (cdr b))
      (setf p (cdr p)))
    ret))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Code for a sample player for testing purposes

(defun be-random-player (turn xpos opos vpos zpos time-left board)
  (let* ((moves (be-get-current-legal-top-level-moves))
	 (nMoves (length moves)))
    (cond ((= nMoves 0) (setq ret '(nil nil nil nil)))
	  (t (setq ret (nth (random nMoves) moves))))
    ret
    ))

(defun be-random-player0 (turn xpos opos vpos zpos time-left board)
  (let* ((my-pos)(moves)(nMoves))

    (when (equal turn player1) (setf my-pos xpos))
    (when (equal turn player2) (setf my-pos opos))
    (when (equal turn player3) (setf my-pos vpos))
    (when (equal turn player4) (setf my-pos zpos))

    (setq moves (be-gen-moves turn my-pos board))
    (setq nMoves (length moves))
    (cond ((= nMoves 0) (setq ret '(nil nil nil nil)))
	  (t (setq ret (nth (random nMoves) moves))))
    ret
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internally used functions

;; who won?
(defun be-winner (board xpos opos vpos zpos)
  (let* ((scores (be-scores board xpos opos vpos zpos))
	 (best (apply #'max scores))
	 (players (list player1 player2 player3 player4))
	 (ret))
    (when verbose (format t "~%Scores were: ~a~%" scores))
    (while players
      (when (= (car scores) best) (push (car players) ret))
      (pop scores)
      (pop players))
    ret))

(defun be-scores (board xpos opos vpos zpos)
  (let ((xs (if (= (length xpos) 0) 15 0))
	(os (if (= (length opos) 0) 15 0))
	(vs (if (= (length vpos) 0) 15 0))
	(zs (if (= (length zpos) 0) 15 0))
	(bptr board))
    (while bptr
      (let ((cptr (pop bptr)))
	(while cptr
	  (let ((sq (pop cptr)))
	    (cond ((eq sq player1) (incf xs))
		  ((eq sq player2) (incf os))
		  ((eq sq player3) (incf vs))    
		  ((eq sq player4) (incf zs)))))))
    (list xs os vs zs)))

(defun be-get-where (r c piece)
  (let ((ret nil)
	(curr 0)
	(pptr piece))
    (dolist (row piece)
      (let ((curc 0))
	(dolist (sq row)
	  (when (eq sq closed_block)
	    (push (list (+ r curr) (+ c curc)) ret))
	  (incf curc)))
      (incf curr))
    ret))

;; is the given position on the board?
(defun be-on-board? (allrc board)
  (let ((cols (be-board-width board))
        (rows (be-board-height board)))
    (dolist (rc allrc)
      (let* ((r (nth 0 rc))
	     (c (nth 1 rc)))
	(unless (and (> r 0) (> c 0) (<= r rows) (<= c cols))
	  (return-from be-on-board? nil))))
    t))

(defun be-open? (allrc board)
  (dolist (rc allrc)
    (unless (equal (be-get-square rc board) open_block)
      (return-from be-open? nil)))
  t)

;; Assumes that be-open? has been called
;; Assumes that be-touch-side? has been called (and returned false)
(defun be-touch-start-square? (turn allrc board)
  (let ((ss (be-start-square turn board)))
    (dolist (rc allrc)
      (when (equal ss rc) (return-from be-touch-start-square? t)))
    nil))

(defun be-touch-corner? (turn allrc board)
  (dolist (rc allrc)
    (let* ((r (nth 0 rc))
	   (c (nth 1 rc))
	   (cl (1- c))
	   (cr (1+ c))
	   (ra (1- r))
	   (rb (1+ r)))
      (when (or (equal (be-get-square (list ra cl) board) turn)
		(equal (be-get-square (list ra cr) board) turn)
		(equal (be-get-square (list rb cl) board) turn)
		(equal (be-get-square (list rb cr) board) turn))
	(return-from be-touch-corner? t))))
  nil)

;; Assumes that be-open? has been called
(defun be-touch-side? (turn allrc board)
  (dolist (rc allrc)
    (let* ((r (nth 0 rc))
	   (c (nth 1 rc))
	   (cl (1- c))
	   (cr (1+ c))
	   (ra (1- r))
	   (rb (1+ r)))
      (when (or (equal (be-get-square (list r cl) board) turn)
		(equal (be-get-square (list r cr) board) turn)
		(equal (be-get-square (list ra c) board) turn)
		(equal (be-get-square (list rb c) board) turn))
	(return-from be-touch-side? t))))
  nil)



;; is the given move be-legal?
;;(defun be-legal? (turn pieces move board)
;;  (be-legal-internal? turn pieces (be-hack-fix move) board))

(defun be-legal? (turn pieces move board)
  ;(format t "start: ~A  move: ~A~%" start move)
  ;; GET THE PIECE FROM THE MOVE
  (let ((r (nth 0 move))
	(c (nth 1 move))
	(po (nth 2 move))
	(which (nth 3 move))
	(piece) (allrc))
    (and (member po pieces)
	 (>= which 0)
	 (< which (length po))
	 (setf piece (nth which po))
	 (setf allrc (be-get-where r c piece))
	 (be-on-board? allrc board)
	 (be-open? allrc board)
	 (not (be-touch-side? turn allrc board))
	 (or (be-touch-start-square? turn allrc board)
	     (be-touch-corner? turn allrc board)))))

;; given a player and his move, update the board
;;(be-effect-move turn xpos move board)

;;(defun be-effect-move (player pieces move board)
;;  (be-effect-move-internal player pieces (be-hack-fix move) board))

(defun be-effect-move (player pieces move board)
  (let* ((r (nth 0 move))
	 (c (nth 1 move))
	 (po (nth 2 move))
	 (which (nth 3 move))
	 (piece (nth which po))
	 (allrc (be-get-where r c piece))
	 (rc))
    (dolist (rc allrc)
      (setf board (be-set-board-pos player rc board)))
    (let* ((k (position po pieces :test #'equal))
	   (npieces (if k (append (subseq pieces 0 k) (subseq pieces (1+ k)))
		      pieces)))
      ;;(format t "be-effect-move found position at ~a~%" k)
      (list board npieces))))

;; set the square at the given position (xy) to symbol
(defun be-set-board-pos (symbol xy board)
  (let ((x (be-get-x xy))
        (y (be-get-y xy)))
    (cond ((null board) nil)
          ((<= y 1) (cons (be-set-row-pos symbol x (first board)) (rest board)))
          (t (cons (first board)
                   (be-set-board-pos symbol (be-addm xy '(-1 0)) (rest board)))))))

;; set the xth position of the row to symbol
(defun be-set-row-pos (symbol x row)
  (cond ((null row) nil)
        ((<= x 1) (cons symbol (rest row)))
        (t (cons (first row) (be-set-row-pos symbol (1- x) (rest row))))))

;; make a board with the given size representing the playable area
(defun be-make-board (width height)
  (cons (be-make-row closed_block (+ width 2))
        (append
         (be-make-interior-rows (+ width 2) height)
        (list (be-make-row closed_block (+ width 2))))))

;; helper function to make a board
(defun be-make-interior-rows (width n)
  (cond ((<= n 0) nil)
        (t (cons (be-make-row open_block width)
                 (be-make-interior-rows width (1- n))))))

;; create a row filled with the given block symbol
(defun be-make-row (block width)
  (cons closed_block (append (nlist block (- width 2)) (list closed_block))))

;; pretty print a board
(defun be-print-board (board)
  (mapcar #'(lambda (x) (format t "~A~%" x)) board)
  (format t "~%"))

;; return the symbol at the given position on the board
(defun be-get-square (move board)
  (let ((x (1- (be-get-x move)))
        (y (1- (be-get-y move))))
    (nth x (nth y board))))

;; return the x coordinate (column) of a position
(defun be-get-x (move)
  (second move))
;;(defun be-get-x-internal (move)
;;  (first move))

;; return the y coordinate (row) of a position
(defun be-get-y (move)
  (first move))
;;(defun be-get-y-internal (move)
;;  (second move))

;; return the width of a board
(defun be-board-width (board)
  (length (first board)))

;; return the height of a board
(defun be-board-height (board)
  (length board))

;; add to moves together
(defun be-addm (x y)
  (list (+ (first x) (first y))
        (+ (second x) (second y))))

;; count total number of open squares on a board
(defun be-count-open-spaces (board)
  (apply #'+ (mapcar #'be-count-open-spaces-row board)))

;; count total number of open squares on a row
(defun be-count-open-spaces-row (row)
  (let ((n 0))
    (dolist (p row n)
      (if (equal p open_block) (setf n (1+ n))))))


;;; generate legal moves
;;; For simplicity, this is one DUMB way to do it (though not the dumbest)

(defun be-find-free-corners (player board)
  (let ((ss (be-start-square player board)))
    (if (equal (be-get-square ss board) open_block)
	(list ss)
      (let* ((top (pop board))
	     (middle (pop board))
	     (bottom (pop board))
	     (curr 2)
	     (ret nil))
	(while bottom
	  ;;; work goes here
	  (let* ((tptr top)
		 (mptr middle)
		 (bptr bottom)
		 (tleft (pop tptr))
		 (tmiddle (pop tptr))
		 (tright (pop tptr))
		 (mleft (pop mptr))
		 (mmiddle (pop mptr))
		 (mright (pop mptr))
		 (bleft (pop bptr))
		 (bmiddle (pop bptr))
		 (bright (pop bptr))
		 (curc 2))
	    (while tright
	      (let ((rc (be-free-corners player curr curc
					 tleft tmiddle tright
					 mleft mmiddle mright
					 bleft bmiddle bright)))
		(when rc (setf ret (append rc ret))))
	      (incf curc)
	      (setf tleft tmiddle)
	      (setf mleft mmiddle)
	      (setf bleft bmiddle)
	      (setf tmiddle tright)
	      (setf mmiddle mright)
	      (setf bmiddle bright)
	      (setf tright (pop tptr))
	      (setf mright (pop mptr))
	      (setf bright (pop bptr)))
	    )
	  (setf top middle)
	  (setf middle bottom)
	  (setf bottom (pop board))
	  (incf curr))
	ret))))

(defun be-start-square (player board)
  (if (equal player player1) 
      '(2 2)
    (let ((cols (- (be-board-width board) 1))
	  (rows (- (be-board-height board) 1)))
      (cond ((equal player player2) (list 2 cols))
	    ((equal player player3) (list rows cols))
	    ((equal player player4) (list rows 2))))))

(defun be-free-corners (player curr curc
			       tleft tmiddle tright 
			       mleft mmiddle mright
			       bleft bmiddle bright)
  (when (equal mmiddle player)
    (let ((ret nil))
      (unless (or (not (equal tleft open_block))
		  (equal mleft player)
		  (equal tmiddle player))
	(push (list (1- curr) (1- curc)) ret))
      (unless (or (not (equal tright open_block))
		  (equal mright player)
		  (equal tmiddle player))
	(push (list (1- curr) (1+ curc)) ret))
      (unless (or (not (equal bleft open_block))
		  (equal mleft player)
		  (equal bmiddle player))
	(push (list (1+ curr) (1- curc)) ret))
      (unless (or (not (equal bright open_block))
		  (equal mright player)
		  (equal bmiddle player))
	(push (list (1+ curr) (1+ curc)) ret))
      ret)))

;; Given all the spots around corners now try to put 
;; every piece there and return the legal ones!

;; generate all legal moves from the given position on the given board
(defun be-gen-moves (player pieces board)
  (let ((options (be-find-free-corners player board))
	(ret))
    (dolist (rc options)
      (let ((r (first rc))
	    (c (second rc)))
	(dolist (po pieces)
	  (let ((poi 0))
	    (dolist (piece po)
	      (let ((cols (be-board-width piece))
		    (rows (be-board-height piece)))
		(dotimes (i cols)
		  (dotimes (j rows)
		    (let ((maybe (list (- r j) (- c i) po poi)))
;;		      (format t "(be-legal? ~a ~a)~%" 
;;			      (list (nth 0 maybe) (nth 1 maybe))
;;			      (nth 3 maybe))
		      (when (be-legal? player pieces maybe board)
			(push maybe ret))))))
	      (incf poi))))))
    (remove-duplicates ret :test #'equal)))

;; We think in column, row but assignment wants row, column
;;(defun be-hack-fix (move)
;;  (list (second move) (first move) (third move) (fourth move)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Sample Boards

(defconstant be-small
  '((* * * * * * * * * * * *)
    (* - - - - - - - - - - *)
    (* - - - - - - - - - - *)
    (* - - - - - - - - - - *)
    (* - - - - - - - - - - *)
    (* - - - - - - - - - - *)
    (* - - - - - - - - - - *)
    (* - - - - - - - - - - *)
    (* - - - - - - - - - - *)
    (* - - - - - - - - - - *)
    (* - - - - - - - - - - *)
    (* * * * * * * * * * * *)))

(defconstant be-small-pieces
  '(
    (((* * * * *))
     ((*)
      (*)
      (*)
      (*)
      (*)))
    (((* * * *))
     ((*)
      (*)
      (*)
      (*)))
    (((* * *))
     ((*)
      (*)
      (*)))
    (((* *))
     ((*)
      (*)
      ))
    (((*)))
    (((* *)
      (* *)))
    (((- * -)
      (* * *)
      (- * -)))
    ))

(defconstant be-big-pieces
  '(
    (((* * * * *))
     ((*)
      (*)
      (*)
      (*)
      (*)))
    (((* * * *))
     ((*)
      (*)
      (*)
      (*)))
    (((* * *))
     ((*)
      (*)
      (*)))
    (((* *))
     ((*)
      (*)
      ))
    (((*)))
    (((* *)
      (* *)))
    (((- * -)
      (* * *)
      (- * -)))
    (((- * *)
      (- * -)
      (* * -))
     ((* * -)
      (- * -)
      (- * *))
     ((* - -)
      (* * *)
      (- - *))
     ((- - *)
      (* * *)
      (* - -)))
    (((* * * *)
      (* - - -))
     ((- - - *)
      (* * * *))
     ((* -)
      (* -)
      (* -)
      (* *))
     ((* *)
      (- *)
      (- *)
      (- *)))
    (((* * * *)
      (- - - *))
     ((* - - -)
      (* * * *))
     ((- *)
      (- *)
      (- *)
      (* *))
     ((* *)
      (* -)
      (* -)
      (* -)))
    ))

(defconstant be-big
  '((* * * * * * * * * * * * * * * * * * * * * *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* - - - - - - - - - - - - - - - - - - - - *)
    (* * * * * * * * * * * * * * * * * * * * * *)))

;;;; Code for generating random decks.  Stolen from:
;;;; Peter Hendrickson from a posting on cypherpunks.


;;;-*- Mode: Lisp; Package: COMMON-LISP-USER -*-

(defun compute-combination-number (cards)
  "Converts list of numbered cards into a unique number representing
their order."
  (cond ((> (length cards) 1)
         (+ (* (car cards)
               (factorial (1- (length cards))))
            (compute-combination-number (renumber-cards cards))))
        (t 0)))

(defun renumber-cards (cards)
  "Removes lead card from deck, decrements higher numbered cards
by one so there are no gaps."
  (let ((renumbered-cards-reversed)
        (lead-card (car cards)))
    (dolist (card (cdr cards))
      (cond ((> card lead-card)
             (push (1- card) renumbered-cards-reversed))
            (t
             (push card renumbered-cards-reversed))))
    (reverse renumbered-cards-reversed)))

(defun reconstruct-deck (combination-number deck-size)
  "Converts unique number representing order of a deck of cards
and returns a list of numbers representing the deck."
  (cond ((not (<= deck-size 1))
         (multiple-value-bind (digit remaining-combination-number)
                              (floor combination-number
                                     (factorial (1- deck-size)))
           (insert-card digit (reconstruct-deck
                               remaining-combination-number
                               (1- deck-size)))))
        (t (list 0))))

(defun insert-card (new-card card-list)
  "Inserts a card into a deck, increasing by one every card which
is of higher or equal number so there are no duplicate cards."
  (let ((new-deck-reversed))
    (push new-card new-deck-reversed)
    (dolist (card card-list)
      (cond ((>= card new-card)
             (push (1+ card) new-deck-reversed))
            (t
             (push card new-deck-reversed))))
    (reverse new-deck-reversed)))

(defun factorial (number)
  (cond ((or (= number 1) (= number 0)) 1)
        (t (* number (factorial (1- number))))))

;;; Testing routines

(defun shuffle-deck (deck-size)
  (randomize-list (build-card-list deck-size)))

(defun randomize-list (some-list)
  (do ((randomized-list nil))
      ((null some-list) randomized-list)
    (let ((item-number (random (length some-list))))
      (push (elt some-list item-number)
            randomized-list)
      (setf some-list
            (remove (elt some-list item-number) some-list)))))

(defun build-card-list (deck-size)
  "Returns a list of consecutive numbers representing a deck of
cards."
  (do ((card-list nil)
       (count 0 (1+ count)))
      ((= deck-size count) card-list)
    (push count card-list)))

(defun identicalp (list-one list-two)
  "Returns non-nil if the two lists are identical."
  (eval (cons 'and (map 'list #'equal list-one list-two))))

(defun exhaustively-test-card-combinations (deck-size)
  "Verifies that the correct deck is reconstructed from the unique
order number for every combination of a small deck of cards."
  (let ((combinations (factorial deck-size)))
    (do ((combo-number 0 (1+ combo-number)))
        ((= combinations combo-number) t)
      (cond ((not (= (compute-combination-number
                      (reconstruct-deck combo-number deck-size))
                     combo-number))
             (warn "Test failed for ~D" combo-number))))))

(defun test-one-deck (deck-size)
  "Shuffles a deck of cards and verifies that it may be reconstructed
from the unique number representing its order."
  (let* ((original-deck (shuffle-deck deck-size))
         (reconstructed-deck (reconstruct-deck
                              (compute-combination-number original-deck)
                              deck-size)))
    (cond ((not (identicalp original-deck reconstructed-deck))
           (warn "Test failed for ~A" original-deck)))))

(defun test-many-decks (trials max-deck-size)
  "Shuffles trials decks of maximum size max-deck-size and verifies
that their order may be reconstructed from the unique number we compute."
  (do ((trial-number 0 (1+ trial-number)))
      ((= trials trial-number) t)
    (test-one-deck (1+ (random max-deck-size)))))

(defun complete-combination-test ()
  "Good test of all the card combination routines."
  (format t "Performing exhaustive test.~%")
  (exhaustively-test-card-combinations 6)
  (format t "Performing random test on large decks.~%")
  (test-many-decks 10 100))

;; (Exercise Answer: (4 2 1 3 0) = 111)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Here are some testing functions!

;; Notice that the (position) call in compete-many will always return 
;; player #2 as the winner whether player #2, #3, or #4 wins because 
;; they are (equal) 
(defun be-test-me (rounds who time board pieces)
  (be-test-me-work (make-blockem-instance board pieces) 
		   rounds who time board pieces))
(defun rbe-test-me (rounds who time board pieces)
  (be-test-me-work (make-rblockem-instance board pieces) 
		   rounds who time board pieces))

(defun be-test-me-work (be rounds who time board pieces)
  (compete-many rounds be 4 time 
		who 
		#'be-random-player #'be-random-player #'be-random-player))

(defun player-xxx (turn xpos opos vpos zpos time-left board)
  (be-random-player turn xpos opos vpos zpos time-left board))

; (be-test-me 3 #'player-xxx 100000 be-small be-small-pieces)
; (be-test-me 3 #'player-xxx 10000 be-small be-small-pieces)
; (be-test-me 3 #'player-xxx 10000 be-small be-small-pieces)

; (be-test-me 1 #'player-xxx 100000 be-small be-small-pieces)
; (rbe-test-me 1 #'player-xxx 100000 be-small be-small-pieces)

; (be-test-me 1 #'player-xxx 100000 be-big be-big-pieces)
; (rbe-test-me 1 #'player-xxx 100000 be-big be-big-pieces)