othello.lisp

(defconstant +empty+ #b00)
(defconstant +black+ #b01)
(defconstant +white+ #b10)

(defun bref (board row col)
  (let* ((start (* 2 (+ (* 8 row) col)))
	 (bit-1 (aref board start))
	 (bit-2 (aref board (1+ start))))
    (logior bit-1 (ash bit-2 1))
    ))

(defun set-bref (board row col val)
  (let ((start (* 2 (+ (* 8 row) col))))
    (setf (aref board start) (ash (logand val #b10) -1))
    (setf (aref board (1+ start)) (logand val #b01))
    val))

(defsetf bref set-bref)

(defun make-board ()
  (let ((board (make-sequence '(simple-bit-vector) 128 :initial-element +empty+)))
    (setf (bref board 3 3) +black+)
    (setf (bref board 3 4) +white+)
    (setf (bref board 4 3) +white+)
    (setf (bref board 4 4) +black+)
    board
    ))

(declaim (inline copy-board pos end-pos oponent))

(defun copy-board (board)
  (copy-seq board))

(defun print-board (board)
  (terpri)
  (write-line "          A B C D E F G H")
  (dotimes (j 8)
    (write-string "        ")
    (write (1+ j))
    (write-char #\SPACE)
    (dotimes (i 8)
      (case (bref board j i)
	(#.+empty+ (write-char #\.))
	(#.+black+ (write-char #\X))
	(#.+white+ (write-char #\O)))
      (write-char #\SPACE))
    (terpri))
  (terpri))

(defun pos (move) (first move))

(defun end-pos (move) (rest move))

(defun opponent (side)
  (if (= side +black+)
      +white+
    +black+))

(defun pos->string (pos)
  (assert (and (listp pos) (= (length pos) 2)
	       (numberp (first pos)) (numberp (second pos))
	       (>= (first pos) 0) (<= (first pos) 7)
	       (>= (second pos) 0) (<= (second pos) 7))
	  (pos))
  (let ((letter (code-char (+ (first pos) (char-int #\A))))
	(digit (code-char (+ (second pos) (char-int #\1))))
	(string (make-string 2)))
    (setf (aref string 0) letter)
    (setf (aref string 1) digit)
    string))

(defun string->pos (string)
  (assert (and (stringp string) (= (length string) 2)
	       (char>= (char string 0) #\A) (char<= (char string 0) #\H)
	       (char>= (char string 1) #\1) (char<= (char string 1) #\8))
	  (string))
  (let ((x (- (char-int (char string 0)) (char-int #\A)))
	(y (- (char-int (char string 1)) (char-int #\1))))
    (list x y)))

(defun input-move ()
  (format t "~&Move ? ")
  (loop
   (let ((move
	  (progn
	    (clear-input)
	    (string-upcase (string-trim " " (read-line))))))
     (cond
      ((string= move "QUIT")
       (return move))
      ((string= move "LIST")
       (return move))
      ((string= move "PASS")
       (return move))
      ((not (= (length move) 2))
       (progn
	 (format t "~&Entry has the wrong length!~%")
	 (format t "Reenter ? ")
	 (force-output)))
      (t (progn
	   (let ((letter (char move 0))
		 (digit (char move 1)))
	     (if (or (char< letter #\A) (char> letter #\H)
		     (char< digit #\1) (char> digit #\8))
		 (progn
		   (format t "~&Invalid syntax (expected A-H 1-8 as in A1)~%")
		   (format t "Reenter ? ")
		   (force-output))
	       (return-from input-move move))
	     )))
      ))))

(defun flip (board move side)
  "function: flip
         in: board - nb. modified
             move  - move and end-pos. See find-moves return type for details
             side - +black+ or +white+
    returns: board - pieces flipped
             Destructive on board"
  (let ((pos-1 (pos move)) (end-pos (end-pos move)))
    (dolist (pos-2 end-pos)
      (let* ((x-1 (first pos-1)) (y-1 (second pos-1))
	     (x-2 (first pos-2)) (y-2 (second pos-2))
	     (step-x (signum (- x-2 x-1)))
	     (step-y (signum (- y-2 y-1)))
	     (x x-1) (y y-1)
	     (x-start (if (>= step-x 0) x-2 x-1))
	     (x-end (if (>= step-x 0) x-1 x-2))
	     (y-start (if (>= step-y 0) y-2 y-1))
	     (y-end (if (>= step-y 0) y-1 y-2)))
	(loop until (or (> x x-start) (< x x-end) (> y y-start) (< y y-end)) do
	      (setf (bref board y x) (opponent side))
	      (incf x step-x)
	      (incf y step-y)))))
  board)

(defun find-line (board x-start y-start step-x step-y side)
  (let ((x x-start) (y y-start))
    (incf x step-x)
    (incf y step-y)
    (when (and (>= x 0) (<= x 7) (>= y 0) (<= y 7)
	       (= (bref board y x) (opponent side)))
      (incf x step-x)
      (incf y step-y)
      (loop until (or (< x 0) (> x 7) (< y 0) (> y 7)) do
	    (when (= (bref board y x) +empty+)
	      (return-from find-line nil))
	    (when (= (bref board y x) side)
	      (return-from find-line (list x y)))
	    (incf x step-x)
	    (incf y step-y)
	    ))
    nil))

(defun find-move (board x y side)
  (let ((temp nil))
    (macrolet ((set-tp-cons (var element)
			    `(progn
			       (setf temp ,element)
			       (when temp (setf ,var (cons temp ,var))))))
      (let ((end-pos nil))
	(set-tp-cons end-pos (find-line board x y  1  0 side))
	(set-tp-cons end-pos (find-line board x y -1  0 side))
	(set-tp-cons end-pos (find-line board x y  0  1 side))
	(set-tp-cons end-pos (find-line board x y  0 -1 side))
	(set-tp-cons end-pos (find-line board x y  1  1 side))
	(set-tp-cons end-pos (find-line board x y -1  1 side))
	(set-tp-cons end-pos (find-line board x y  1 -1 side))
	(set-tp-cons end-pos (find-line board x y -1 -1 side))
	end-pos))))

(defun find-moves (board side)
  "function: find-move
         in: board - see make-board
             side  - either X or O
    returns: ((legal-move end-pos) ...)
             legal-move is a position 
             end-pos is a list of end position's to flip along
             position is a tuple of integers (list 0-7 0-7)"
  (let ((moves nil))
    (dotimes (j 8)
      (dotimes (i 8)
	(when (= (bref board j i) +empty+)
	  (let ((pos (list i j))
		(end-pos (find-move board i j side)))
	    (when end-pos
	      (setf moves (cons (cons pos end-pos) moves)))
	    ))))
    (reverse moves)))

(defun print-moves (moves)
  "function: print-moves
         in: list of moves. See find-moves return type for details
    returns: comma seperated moves
         ex: \"A1, B2, C5\""
  (if moves
      (format t "~&Legal move~P ~:[is~;are~] ~A~%"
	      (length moves) (> (length moves) 1)
	      (reduce (lambda (e1 e2) (concatenate 'string e1 ", " e2))
		      (mapcar (lambda (e) (pos->string (pos e))) moves)))
    (format t "~&No moves. You must pass!~%")
    ))

(defun random-move-strategy (board side)
  "Select a legal disc at random"
  (let ((moves (find-moves board side)))
    (when moves
      (nth (random (length moves)) moves))))

(defun count-flipped (move)
  (let ((pos-1 (pos move)) (end-pos (end-pos move))
        (count 0))
    (dolist (pos-2 end-pos)
      (let* ((x-1 (first pos-1)) (y-1 (second pos-1))
             (x-2 (first pos-2)) (y-2 (second pos-2))
             (delta-x (- x-2 x-1)) (delta-y (- y-2 y-1))
             (line-count (1- (floor (sqrt (+ (* delta-x delta-x) (* delta-y delta-y)))))))
        (incf count line-count)))
    count))

(defun maximum-disc-strategy (board side)
  "Select from the moves that turn the largest number of pieces"
  (let ((moves (find-moves board side))
        (biggest-number 0)
        (best-moves nil))
    (dolist (move moves)
      (let ((number (count-flipped move)))
        (cond ((= number biggest-number)
               (setf best-moves (cons move best-moves)))
              ((> number biggest-number)
               (setf biggest-number number)
               (setf best-moves (cons move nil))))
        ))
    (if best-moves
        (nth (random (length best-moves)) best-moves)
      nil)
    ))

(defparameter +weights+
  #2A((120 -20 20  5  5 20 -20 120)
      (-20 -40 -5 -5 -5 -5 -40 -20)
      ( 20  -5 15  3  3 15  -5  20)
      (  5  -5  3  3  3  3  -5   5)
      (  5  -5  3  3  3  3  -5   5)
      ( 20  -5 15  3  3 15  -5  20)
      (-20 -40 -5 -5 -5 -5 -40 -20)
      (120 -20 20  5  5 20 -20 120)))

(defparameter +corner-nabours+
  '(((0 0) (0 1) (1 0) (1 1))
    ((0 7) (0 6) (1 7) (6 1))
    ((7 0) (6 0) (7 1) (1 6))
    ((7 7) (6 7) (7 6) (6 6))))

(defun stable-disc-positional-strategy (board move side)
  (let ((pos (pos move)))
    (aref (second pos) (first pos) +weights+)))

;;; order moves
;;; trasposition table (hash-table) for different moves leading to same position
;;; remember played moves
;;; no global variables (server will play multiple games in multible theads)

(defconstant +top-value+ most-positive-fixnum)
(defconstant +bottom-value+ most-negative-fixnum)
(defconstant +ply-depth+ 1)

(defun alpha-beta-search (board side alpha beta ply fn)
  (let ((moves (find-moves board side)))
    (if (not moves)
	(dolist (move moves)
	  (if (= ply +ply-depth+)
	      (fn move board)
	    (alpha-beta-search board (opponent side) beta alpha (1+ ply) fn))))))

(defun stable-disc-positional-strategy (board side)
  (let ((transposition-table (make-transposition-table)))
    (multiple-value-bind (val best-move)
	(alpha-beta-search board side +bottom-value+ +top-value+ +ply-depth+
			   #'stable-disk-positional-evaluator))))

(defun maximum-mobility-stategy (board side)
  (random-move-strategy board side))

(defun computer-move (board level side)
  (cond ((eq level 'clueless) (random-move-strategy board side))
	((eq level 'beginner) (maximum-disc-strategy board side))
	((eq level 'novice) (stable-disc-positional-strategy board side))
	((eq level 'expert) (maximum-mobility-stategy board side))
	(t (error "Not a legal level!"))))

(defun count-pieces (board)
  (let ((user 0) (computer 0))
    (dotimes (j 8)
      (dotimes (i 8)
	(case (bref board i j)
	  (#.+black+ (incf user))
	  (#.+white+ (incf computer)))))
    (values user computer)))

(defun game-finished (board)
  (let ((computer (find-moves board +white+))
	(user (find-moves board +black+)))
    (and (eq computer nil) (eq user nil))))

(defun move->positions (move moves)
  "Return move + end positions used in flip. nil if it is not a legal move"
  (find-if (lambda (e) (equal move (pos e))) moves))

(defun level-p (level)
  (find-if (lambda (e) (eq level e)) '(clueless beginner novice expert)))

(defun side-p (side)
  (member side (list +black+ +white+)))

(defun othello (&key (level 'beginner) (side +black+))
  (unless (level-p level)
    (format t "Not a legal level! (clueless beginner novice expert)~%")
    (return-from othello))
  (unless (side-p side)
    (format t "Not a legal side! (black white)~%")
    (return-from othello))
  (setf *random-state* (make-random-state t))
  (let ((board (make-board))
	(computer 0) (user 0))
    (format t "~&Othello~%2003 John Thingstad~%")
    (print-board board)
    (loop
     (block main
       (let ((response (input-move)))
	 (cond ((string= response "QUIT")
		(return-from othello nil))
	       ((string= response "LIST")
		(print-moves (find-moves board side))
		(return-from main))
	       (t
		(if (string= response "PASS")
		    (progn
		      (let ((moves (find-moves board side)))
			(when moves
			  (format t "~&You are not allowd to pass when you have legal moves!")
			  (return-from main))))
		  (progn
		    (let ((your-move (move->positions
				      (string->pos response)
				      (find-moves board side))))
		      (when (not your-move)
			(format t "~&~A is not a legal move!~%"  response)
			(return-from main))
		      (setf board (flip board your-move side)))))
		(let ((my-move (computer-move board level (opponent side))))
		  (if my-move
		      (progn
			(format t "~&I chose ~A.~%" (pos->string (first my-move)))
			(setf board (flip board my-move (opponent side))))
		    (format t "~&I have to pass.~%")))
		(print-board board)
		(multiple-value-setq (user computer) (count-pieces  board))
		(format t "~&White(O) - ~D, Black(X) - ~D~2%" computer user)
		))))
       
     (when (game-finished board)
       (cond
	((< user computer) (format t "~&I won!~%"))
	((> user computer) (format t "~&You won!~%"))
	(t (format t "~&It's a draw!~%")))
       (return-from othello nil)))
    ))