fink/board.lisp

330 lines
10 KiB
Common Lisp
Raw Normal View History

(in-package :board)
(defmacro do-with-copy-of-array ((itr-name copy-name array) &body body)
`(let ((,copy-name (make-array (length ,array) :fill-pointer (fill-pointer ,array) :adjustable t)))
(dotimes (,itr-name (length ,array))
,@body)
,copy-name))
(defun copy-array (array)
(do-with-copy-of-array (i copy array)
(setf (aref copy i) (aref array i))))
(defun copy-2d-array (array)
(do-with-copy-of-array (i copy array)
(setf (aref copy i)
(if (eql (aref array i) nil)
nil
(copy-array (aref array i))))))
(defun make-2d-board (size &optional (initial nil))
(let ((array (make-array size)))
(dotimes (i size)
(setf (aref array i) (make-array size :initial-element initial)))
array))
(defun copy-2d-board (board)
(let ((copy (make-array (length board))))
(dotimes (i (length board))
(setf (aref copy i) (copy-seq (aref board i))))
copy))
(defun filter-i-number (number)
(if (> number 8)
(1- number)
number))
(defun str-to-coord (str)
`(,(abs (- (parse-integer (subseq str 1)) 19)) ,(filter-i-number (- (char-code (char (string-upcase str) 0)) 65))))
; `( ,(filter-i-number (- (char-code (char (string-upcase str) 0)) 65)) ,(- (parse-integer (subseq str 1)) 1)))
(defun filter-i-char (number)
(if (>= number 8)
(1+ number)
number))
(defun coord-to-str (coord)
(concatenate 'string (string (code-char (+ 65 (filter-i-char (second coord)))))
(write-to-string (+ (- (first coord)) 19))))
; (concatenate 'string (string (code-char (+ 65 (filter-i-char (first coord)))))
; (write-to-string (+ (second coord) 1))))
2008-05-21 18:46:32 +00:00
(defun get-2d-stone (board coord)
2008-06-21 06:03:06 +00:00
(if (not (listp coord))
(format t "MASSIVE ERROR! trying to access coord:~a on board~%" coord))
(aref (aref board (first coord)) (second coord)))
2008-05-21 18:46:32 +00:00
(defun set-2d-stone (board coord val)
(setf (aref (aref board (first coord)) (second coord)) val))
(defmacro coords-eql (a b)
`(and (eql (first ,a) (first ,b)) (eql (second ,a) (second ,b))))
2008-05-21 18:46:32 +00:00
2008-05-19 04:00:04 +00:00
(defclass basic-board ()
((boardsize
2008-05-21 18:46:32 +00:00
:initarg :boardsize
:initform 19
:accessor boardsize)
(board-def-type
2008-05-21 18:46:32 +00:00
:initarg :board-def-type
:initform nil
:accessor board-def-type)
(board
2008-05-21 18:46:32 +00:00
:accessor board
:initform nil)))
(defgeneric set-stone (board coords val))
(defgeneric get-stone (board coords))
(defmethod set-stone ((board basic-board) coords val)
(set-2d-stone (board board) coords val))
(defmethod get-stone ((board basic-board) coords)
(get-2d-stone (board board) coords))
(defmacro get-player (board coords)
`(get-stone ,board ,coords))
(defgeneric remove-stone (board coords))
; (:method-combination progn :most-specific-last))
(defmethod remove-stone ((board basic-board) coords)
(pdebug "basic-board:remove stone ~a~%" coords)
(set-2d-stone (board board) coords nil))
2008-05-21 18:46:32 +00:00
;(defgeneric (setf stone) (val coords
(defmethod initialize-instance :after ((board basic-board) &key from-board)
; (format t "init basic-board~%")
(if (eql from-board nil)
2008-05-21 18:46:32 +00:00
(setf (board board) (make-2d-board (boardsize board) (board-def-type board)))
(progn
(setf (boardsize board) (boardsize from-board))
(setf (board-def-type board) (board-def-type from-board))
2008-05-19 04:00:04 +00:00
(setf (board board) (copy-2d-board (board from-board))))))
2008-05-21 18:46:32 +00:00
(defmacro do-over-board ((coord board) &body body)
`(dotimes (x (boardsize ,board))
(dotimes (y (boardsize ,board))
(let ((,coord `(,x ,y)))
(progn ,@body)))))
(defmacro def-over-board (name (coord board &rest vars) &rest body)
`(defun ,name (,board ,@vars)
(do-over-board (,coord ,board)
(progn ,@body))))
2008-06-18 00:46:32 +00:00
(defmacro do-over-adjacent ((coords-var board coords) &body body)
`(let* ((x (first ,coords))
(y (second ,coords))
(up (1- x))
(down (1+ x))
(left (1- y))
(right (1+ y)))
(if (>= up 0) (let ((,coords-var `(,up ,y))) ,@body))
(if (>= left 0) (let ((,coords-var `(,x ,left))) ,@body))
(if (< down (boardsize ,board)) (let ((,coords-var `(,down ,y))) ,@body))
(if (< right (boardsize ,board)) (let ((,coords-var `(,x ,right))) ,@body))))
2008-05-21 18:46:32 +00:00
2008-05-26 19:13:18 +00:00
(defclass ranked-board (basic-board)
((rank-list
:initarg rank-list
:initform nil
:accessor rank-list)
(rank-top-list
:initarg rank-top-list
:initform nil
:accessor rank-top-list)
(rank-highest
:initarg rank-highest
:initform nil
:accessor rank-highest)
(rank-count
:initarg rank-count
:initform 0
:accessor rank-count)
(rank-top-count
:initarg rank-top-count
:initform 0
:accessor rank-top-count)))
2008-05-26 19:13:18 +00:00
(defmacro copy-slots (slots dst src)
`(progn ,@(loop for slot in slots collect `(setf (,slot ,dst) (,slot ,src)))))
2008-05-27 00:46:43 +00:00
(defmethod initialize-instance :after ((board ranked-board) &key from-board)
(if (not (eql from-board nil))
(progn
(copy-slots (rank-highest rank-count rank-top-count) board from-board)
(setf (rank-list board) (copy-seq (rank-list from-board)))
(setf (rank-top-list board) (copy-seq (rank-top-list from-board))))))
2008-05-27 00:46:43 +00:00
2008-05-26 19:13:18 +00:00
(defun insert (list comp var)
(if (funcall comp (car list) var)
(cons var list)
(cons (car list) (insert (cdr list) comp var))))
(defgeneric insert-into-ranked-list (board coords val))
; so i can call it with "pass" as a coords and not have to "set-stone"
(defmethod insert-into-ranked-list ((board ranked-board) coords val)
2008-05-26 19:13:18 +00:00
(incf (rank-count board))
(if (or (eql (rank-highest board) nil) (>= val (rank-highest board)))
(progn
(setf (rank-list board) (cons `(,val ,coords) (rank-list board)))
(if (or (eql (rank-highest board) nil) (> val (rank-highest board)))
(progn
(setf (rank-highest board) val)
(setf (rank-top-count board) 1)
(setf (rank-top-list board) `((,val ,coords))))
(progn
(incf (rank-top-count board))
(setf (rank-top-list board) (cons `(,val ,coords) (rank-top-list board))))))
(if (= (rank-count board) 1)
(setf (rank-list board) `((,val ,coords)))
(setf (rank-list board) (insert (rank-list board) #'(lambda (a b) (>= (first a) (first b))) `(,val ,coords))))))
(defmethod set-stone :after ((board ranked-board) coords val)
; (format t "~a ~a~%" coords val)
(insert-into-ranked-list board coords val))
2008-05-26 19:13:18 +00:00
2008-05-21 18:46:32 +00:00
(defgeneric prune (board prune-board)
(:documentation "board is the board we are working from, prune-board is an initially all t's board and each no go place is set to nil"))
2008-05-26 19:13:18 +00:00
(def-over-board prune-placed-stones (coord board prune-board)
(if (not (eql (get-stone board coord) nil))
(set-stone prune-board coord nil)))
2008-05-21 18:46:32 +00:00
(defmethod prune ((board basic-board) prune-board)
(prune-placed-stones board prune-board))
;(defgeneric prune :after ((board liberty-board) prune-board)
; (prunce-suicide board prunce-board))
(defgeneric focus (board prune-board focus-board player)
(:documentation "prunce-board: t or nil, focus board: ranked board with scores"))
(defmethod focus ((board basic-board) prune-board focus-board player)
(do-over-board (coord prune-board)
(if (not (eql (get-stone prune-board coord) nil))
(set-stone focus-board coord 1))))
2008-05-26 19:13:18 +00:00
(defgeneric search-space (board focus-board score-board player depth)
)
(defmacro invert-player (player)
2008-05-29 10:32:39 +00:00
`(if (eql ,player #\W)
#\B
#\W))
2008-05-26 19:13:18 +00:00
; multiplex the search here
(defmethod search-space ((board basic-board) focus-board score-board player depth)
; (rank-count board) / basic-proc-unit
(do-over-board (coord board)
(if (not (eql (get-stone focus-board coord) nil))
(let ((newboard (make-instance (class-of board) :from-board board)))
(set-stone newboard coord player)
(set-stone score-board coord (first (genmove newboard (invert-player player):depth (1- depth)))))))
; test pass
(let ((newboard (make-instance (class-of board) :from-board board)))
(insert-into-ranked-list score-board "pass" (first (genmove newboard (invert-player player):depth (1- depth))))))
2008-05-26 19:13:18 +00:00
(defgeneric score (board player)
(:method-combination + :most-specific-last))
2008-05-21 18:46:32 +00:00
(defmethod score + ((board basic-board) player)
2008-05-26 19:13:18 +00:00
1)
2008-05-21 18:46:32 +00:00
(defgeneric select-move (board)
)
2008-05-21 18:46:32 +00:00
2008-05-26 19:13:18 +00:00
(defmethod select-move ((board ranked-board))
;(if (eql (rank-top-count board) 0)
;'(-1 (-1 -1))
2008-06-26 06:03:09 +00:00
; (pdebug "select-move ~%")
(car (nthcdr (random (rank-top-count board)) (rank-top-list board))))
2008-05-19 04:00:04 +00:00
2008-05-21 18:46:32 +00:00
2008-05-26 19:13:18 +00:00
(defgeneric genmove (board player &key))
2008-05-21 18:46:32 +00:00
2008-05-26 19:13:18 +00:00
; generate a same sized board with a def type
(defmacro gen-board (board def-type &optional (class ''basic-board))
`(make-instance ,class :boardsize (boardsize ,board) :board-def-type ,def-type))
(defmethod genmove ((board basic-board) player &key (depth 1))
2008-06-26 06:03:09 +00:00
; (pdebug "genmove ~a~%" depth)
2008-05-29 10:32:39 +00:00
; (format t "genmove depth ~a player ~a~%" depth player)
2008-05-26 19:13:18 +00:00
(if (= depth 0)
`( ,(score board (invert-player player)) nil)
2008-05-26 19:13:18 +00:00
(let ((score-board (make-instance 'ranked-board :boardsize (boardsize board) :board-def-type nil)) ;(gen-board board 0 'ranked-board))
(prune-board (gen-board board t))
(focus-board (gen-board board nil)))
(progn
(prune board prune-board)
(focus board prune-board focus-board player)
(search-space board focus-board score-board player depth)
(select-move score-board)))))
(defun board-to-analyze (board)
(let ((resp "LABEL "))
(dotimes (x (length board))
;(format t "x:~a~%" x)
(dotimes (y (length board))
;(format t "y:~a~%" y)
(let ((coord `(,x ,y)))
(setf resp (concatenate 'string resp (coord-to-str coord) " "
(if (eql (get-2d-stone board coord) nil)
"0 "
(write-to-string (get-2d-stone board coord))) " ")))
(concatenate 'string resp '(#\newline))))
resp))
(defun analyze-board-score (board player)
(let ((score-board (make-instance 'basic-board :boardsize (boardsize board) :board-def-type nil)))
(progn
(do-over-board (coord board)
(if (eql (get-stone board coord) nil)
(let ((newboard (make-instance (class-of board) :from-board board)))
(set-stone newboard coord player)
(set-stone score-board coord (first (score newboard player))))))
(board-to-analyze (board score-board)))))
(defun stones-to-analyze (board)
(concatenate 'string (board-to-analyze (board board))
'(#\newline)))