From b5f322a3f97abbe00943933f7d3e615f05e39255 Mon Sep 17 00:00:00 2001 From: Dan Date: Tue, 24 Jun 2008 10:45:26 -0700 Subject: [PATCH] shape liberty main working all done and passing reworked --- board.lisp | 68 +++++++------------- gobot.lisp | 23 ++++--- gtp.lisp | 3 +- liberty-shape.lisp | 150 +++++++++++++++++++++++++++++++++++++++------ macro-utils.lisp | 25 +++++--- packages.lisp | 10 ++- shape.lisp | 4 +- 7 files changed, 196 insertions(+), 87 deletions(-) diff --git a/board.lisp b/board.lisp index d6a2375..c164bf6 100644 --- a/board.lisp +++ b/board.lisp @@ -57,9 +57,8 @@ (defun get-2d-stone (board coord) (if (not (listp coord)) - (progn - (format t "MASSIVE ERROR!~%trying to access coord:~a on board" coord)) - (aref (aref board (first coord)) (second coord)))) + (format t "MASSIVE ERROR!~%trying to access coord:~a on board" coord)) + (aref (aref board (first coord)) (second coord))) (defun set-2d-stone (board coord val) (setf (aref (aref board (first coord)) (second coord)) val)) @@ -89,6 +88,9 @@ (defmethod get-stone ((board basic-board) coords) (get-2d-stone (board board) coords)) +(defmacro get-player (board coords) + `(get-stone ,board ,coords)) + ;(defgeneric (setf stone) (val coords @@ -148,7 +150,7 @@ (rank-top-count :initarg rank-top-count :initform 0 - :accessor rank-top-count))) + :accessor rank-top-count))) (defmacro copy-slots (slots dst src) `(progn ,@(loop for slot in slots collect `(setf (,slot ,dst) (,slot ,src))))) @@ -168,8 +170,10 @@ (cons (car list) (insert (cdr list) comp var)))) -(defmethod set-stone :after ((board ranked-board) coords val) -; (format t "~a ~a~%" coords val) +(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) (incf (rank-count board)) (if (or (eql (rank-highest board) nil) (>= val (rank-highest board))) (progn @@ -186,6 +190,10 @@ (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)) + @@ -234,7 +242,10 @@ (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)))))))) + (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)))))) (defgeneric score (board player) @@ -248,9 +259,10 @@ ) (defmethod select-move ((board ranked-board)) - (if (eql (rank-top-count board) 0) - '(-1 (-1 -1)) - (car (nthcdr (random (rank-top-count board)) (rank-top-list board))))) + ;(if (eql (rank-top-count board) 0) + ;'(-1 (-1 -1)) + (pdebug "select-move ~%") + (car (nthcdr (random (rank-top-count board)) (rank-top-list board)))) @@ -261,6 +273,7 @@ `(make-instance ,class :boardsize (boardsize ,board) :board-def-type ,def-type)) (defmethod genmove ((board basic-board) player &key (depth 1)) + (pdebug "genmove ~a~%" depth) ; (format t "genmove depth ~a player ~a~%" depth player) (if (= depth 0) `( ,(score board (invert-player player)) nil) @@ -298,38 +311,3 @@ (set-stone score-board coord (first (score newboard player)))))) (board-to-analyze (board score-board))))) - - -;(defun make-move (board player) -; (select-move (score board player))) - -;(defun score (board player) -; (let ((score-board (make-board (length board) 0))) -; (dolist (slist *score-functions*) -; (merge-score-board score-board (funcall (first slist) board player) (second slist))) -; score-board)) - -;(defun merge-score-board (score-board scores weight) -; (dotimes (x (length score-board)) -; (dotimes (y (length score-board)) -; (set-stone score-board `(,x ,y) (+ (get-stone score-board `(,x ,y)) (* weight (get-stone scores `(,x ,y)))))))) - - -;(defun select-move (board) -; (let ((highest (get-stone board '(0 0))) -; (coords (make-array 10 :fill-pointer 0 :adjustable t))) -; (do ((x 0 (1+ x))) -; ((>= x (length board)) (aref coords (random (length coords)))) -; (do ((y 0 (1+ y))) -; ((>= y (length board))) -; (let ((score (get-stone board `(,x ,y)))) -; (if (> score highest) -; (progn -; (setf highest score) -; (setf coords (make-array 10 :fill-pointer 0 :adjustable t )) -; (vector-push-extend `(,x ,y) coords)) -; (if (= score highest) -; (if (= (random 2) 1) -; (vector-push-extend `(,x ,y) coords))))))))) - - diff --git a/gobot.lisp b/gobot.lisp index 9610510..73f2264 100644 --- a/gobot.lisp +++ b/gobot.lisp @@ -60,14 +60,20 @@ (if (or (eql *passed* t) (eql *last-player* player)) "pass" (let* ((move (genmove *board* player)) - (board-score (first move)) - (coord (coord-to-str (second move)))) +; (board-score (first move)) + (coord (second move))) ;(format t "score: ~a for player ~a ~%" board-score player) - (if (< board-score 0) - "pass" - (progn - (do-play player coord) - coord))))) + (if (listp coord) ; string= coord "pass")) + (let ((coord-str (coord-to-str coord))) + (do-play player coord-str) + coord-str) + coord)))) + + ;(if (< board-score 0) + ; "pass" + ; (progn + ; (do-play player coord) + ; coord))))) (defun analyze-score () @@ -81,3 +87,6 @@ (defun analyze-shape-liberties () (liberty-shape-to-analyze *board*)) + +(defun analyze-shape-stone-liberties () + (liberty-shape-stone-to-analyze *board*)) diff --git a/gtp.lisp b/gtp.lisp index d7539fa..a6569c0 100644 --- a/gtp.lisp +++ b/gtp.lisp @@ -48,7 +48,7 @@ (defparameter *supported_commands* '("name" "version" "protocol_version" "komi" "boardsize" "clear_board" "play" "genmove" "cputime" "quit" "game_score" "list_commands" "known_command" "gogui-analyze_commands" )) -(defparameter *analyze_commands* '("gfx/Liberties/liberties" "gfx/Shapes/shapes" "gfx/Shape-Liberties/shape-liberties")) +(defparameter *analyze_commands* '("gfx/Liberties/liberties" "gfx/Shapes/shapes" "gfx/Shape-Liberties/shape-liberties" "gfx/Shape-Stone-Liberties/shape-stone-liberties")) @@ -90,6 +90,7 @@ (liberties (string-trim #(#\newline) (analyze-liberty))) (shapes (string-trim #(#\newline) (analyze-shapes))) (shape-liberties (string-trim #(#\newline) (analyze-shape-liberties))) + (shape-stone-liberties (string-trim #(#\newline) (analyze-shape-stone-liberties))) ;(scores (string-trim #(#\newline)(analyze-score))) (quit (setf *quit?* t) "") (otherwise (concatenate 'string "? unknown command: " (string-downcase (first commands))))))) diff --git a/liberty-shape.lisp b/liberty-shape.lisp index 5464444..0d4bccc 100644 --- a/liberty-shape.lisp +++ b/liberty-shape.lisp @@ -1,11 +1,24 @@ (in-package :liberty-shape-board) (defclass liberty-shape-board (liberty-board shape-board) - ((shapes-liberties + ( + ; stores lists (shape-liberties shape-libertirs-score) + (shapes-liberties :initform nil :accessor shapes-liberties) - ; stores lists (shape-liberties shape-libertirs-score - + ; stores lists of free stones adjacent to shape + (shapes-free-points + :initform nil + :accessor shapes-free-points) + (shapes-free-scores + :initform nil + :accessor shapes-free-scores) + (black-shape-stone-liberties + :initform 0 + :accessor black-shape-stone-liberties) + (white-shape-stone-liberties + :initform 0 + :accessor white-shape-stone-liberties) (black-shape-liberties :initform 0 :accessor black-shape-liberties) @@ -16,11 +29,21 @@ (defmethod initialize-instance :after ((board liberty-shape-board) &key from-board) (if (eql from-board nil) (progn - (setf (shapes-liberties board) (make-array 1 :fill-pointer 0 :adjustable t))) + (setf (shapes-liberties board) (make-array 1 :fill-pointer 0 :adjustable t)) + (setf (shapes-free-points board) (make-array 1 :fill-pointer 0 :adjustable t)) + (setf (shapes-free-scores board) (make-array 1 :fill-pointer 0 :adjustable t))) + (progn (setf (shapes-liberties board) (copy-array (shapes-liberties from-board))) - (copy-slots (white-shape-liberties black-shape-liberties) board from-board)))) + (setf (shapes-free-points board) (copy-2d-array (shapes-free-points from-board))) + (setf (shapes-free-scores board) (copy-array (shapes-free-scores from-board))) + (copy-slots (white-shape-liberties black-shape-liberties black-shape-stone-liberties white-shape-stone-liberties) board from-board)))) +(defmacro inc-player-shape-stone-liberty (board player delta) + `(if (eql ,player #\B) + (incf (black-shape-stone-liberties ,board) ,delta) + (incf (white-shape-stone-liberties ,board) ,delta))) + (defmacro inc-player-shape-liberty (board player delta) `(if (eql ,player #\B) (incf (black-shape-liberties ,board) ,delta) @@ -28,7 +51,7 @@ (defmethod convert-shape :before ((board liberty-shape-board) shape-id to-id) (let ((player (get-stone board (aref (aref (shapes-points board) shape-id) 0)))) - (inc-player-shape-liberty board player (- (second (aref (shapes-liberties board) shape-id)))) + (inc-player-shape-stone-liberty board player (- (second (aref (shapes-liberties board) shape-id)))) (setf (aref (shapes-liberties board) shape-id) '(0 0)))) @@ -38,37 +61,126 @@ (sid (shape-id board coords)) (shape-liberties-score (aref (shapes-liberties board) sid)) (old-score (second shape-liberties-score))) -; (format t "sid @ ~a = ~a~%" sid coords) - (inc-player-shape-liberty board player (- old-score)) + ; (pdebug "calculate-shape-liberties for sid:~a score:~a~%" sid shape-liberties-score) + (inc-player-shape-stone-liberty board player (- old-score)) +; (pdebug "loop add liberties~%") (loop for index from 0 to (1- (length (aref (shapes-points board) sid))) do +; (pdebug "adding on ~a~%" index) (incf liberties (liberty board (aref (aref (shapes-points board) sid) index)))) - (let ((score (* liberties (size-of-shape board sid)))) + (let ((score (* liberties (shape-size board sid)))) +; (pdebug "sets shape-liberties for ~a (~a ~a)~%" sid liberties score) (setf (aref (shapes-liberties board) sid) `(,liberties ,score)) - (inc-player-shape-liberty board player score)))) + (inc-player-shape-stone-liberty board player score)))) +(defmacro coords-eql (a b) + `(and (eql (first ,a) (first ,b)) (eql (second ,a) (second ,b)))) + + +(defun add-free-point (board coord sid player) + ;(pdebug "1st (dec) inc score ~a by ~a " (if (eql player #\B) (black-shape-liberties board) (white-shape-liberties board)) (- (aref (shapes-free-scores board) sid))) + (inc-player-shape-liberty board player (- (aref (shapes-free-scores board) sid))) + ;(pdebug " = ~a~%" (if (eql player #\B) (black-shape-liberties board) (white-shape-liberties board))) + (let* ((found nil) + (free-points (aref (shapes-free-points board) sid))) + (loop for i from 0 to (1- (length free-points)) do + (if (coords-eql coord (aref free-points i)) + (progn + (setf found t) + (return)))) + (if (eql found nil) + (progn + (vector-push-extend coord free-points))) +; (inc-player-shape-liberty board player 1))) + (let ((newscore (* (shape-size board sid) (length free-points)))) + ; (format t "newscore ~a*~a = ~a~%" (shape-size board sid) (length free-points) newscore) +; (pdebug "2nd inc score ~a by ~a " (if (eql player #\B) (black-shape-liberties board) (white-shape-liberties board)) newscore) + (setf (aref (shapes-free-scores board) sid) newscore) + ; (format t "set shape-free-scores~%") + (inc-player-shape-liberty board player newscore)))) + ; (pdebug " = ~a~%" (if (eql player #\B) (black-shape-liberties board) (white-shape-liberties board)))))) + +(defun add-free-points-around (board nexus player) + (let ((sid (shape-id board nexus))) + (do-over-adjacent (coords-var board nexus) + (if (eql (get-stone board coords-var) nil) + (add-free-point board coords-var sid player))))) + +(defun remove-free-point (board coord sid player) + (let ((free-points (aref (shapes-free-points board) sid))) + (if (> (length free-points) 0) + (let ((tmp (aref free-points (1- (length free-points))))) + ; (pdebug "dec inc-player-shape-liberty~%") + + ;(pdebug "search for point~%") + (loop for i from 0 to (1- (length free-points)) do + ; (pdebug "search ~a" i) + (if (coords-eql coord (aref free-points i)) + (progn + ; (pdebug "found on ~a @ ~a" i (aref free-points i)) + (setf (aref free-points i) tmp) + ; (pdebug "do vector pop~%") + (vector-pop free-points) + ; (pdebug "inc-player-shape-liberty~%") + (inc-player-shape-liberty board player (- (aref (shapes-free-scores board) sid))) + (inc-player-shape-liberty board player (* (length free-points) (shape-size board sid))) + ; (pdebug "set shapes-free-scores new score for ~a~%" sid) + (setf (aref (shapes-free-scores board) sid) (* (length free-points) (shape-size board sid))) + (return)))))))) + (defmethod set-stone :after ((board liberty-shape-board) coords val) (while (not (eql (length (shapes-liberties board)) (next-shape-id board))) - (vector-push-extend '(0 0) (shapes-liberties board))) ; new shape + (vector-push-extend '(0 0) (shapes-liberties board)) ; new shape + (vector-push-extend 0 (shapes-free-scores board)) + (vector-push-extend (make-array 1 :fill-pointer 0 :adjustable t) (shapes-free-points board))) (calculate-shape-liberties board coords val) + ; (pdebug "about to add-free-points~%") + (add-free-points-around board coords val) ;adjust neighebors + ; (pdebug "about to adjust neighbors~%") (let ((sid (shape-id board coords))) (do-over-adjacent (coords-var board coords) - (let ((adj-sid (shape-id board coords-var))) - (if (not (or (eql adj-sid sid) (eql adj-sid nil))) - (calculate-shape-liberties board coords-var (get-stone board coords-var))))))) + (let ((adj-sid (shape-id board coords-var)) + (adj-player (get-player board coords-var))) + (if (not (eql adj-sid nil)) + (progn + ; (pdebug "adjusting: from coord:~a removing free: ~a and sid:~a player ~a~%" coords coords-var adj-sid adj-player) + (remove-free-point board coords adj-sid adj-player) + ; (pdebug "remove-free-point done~%") + (if (not(eql adj-sid sid)) + (calculate-shape-liberties board coords-var (get-stone board coords-var))))))))) -(defun liberty-shape-to-analyze (board) +(defun liberty-shape-stone-to-analyze (board) (let ((lsb (make-2d-board (boardsize board) 0))) (do-over-board (coords board) (if (not (eql nil (shape-id board coords))) (set-2d-stone lsb coords (second (aref (shapes-liberties board) (shape-id board coords)))))) (concatenate 'string (board-to-analyze lsb) - '(#\newline) " TEXT blakc shape liberties: " (write-to-string (black-shape-liberties board)) - " white shape liberties: " (write-to-string (white-shape-liberties board))))) + '(#\newline) " TEXT black shape stone liberties: " (write-to-string (black-shape-stone-liberties board)) + " white shape stone liberties: " (write-to-string (white-shape-stone-liberties board))))) + +(defun shape-liberties-score (board sid) + (* (shape-size board sid) (length (aref (shapes-free-points board) sid)))) + +(defun liberty-shape-to-analyze (board) + (let ((lsb (make-2d-board (boardsize board) 0))) + (do-over-board (coords board) + (if (not (eql nil (shape-id board coords))) + (set-2d-stone lsb coords (shape-liberties-score board (shape-id board coords))))) + (concatenate 'string (board-to-analyze lsb) + '(#\newline) " TEXT black shape liberties: " (write-to-string (black-shape-liberties board)) + " white shape liberties: " (write-to-string (white-shape-liberties board))))) + + + +;(defmethod score + ((board liberty-shape-board) player) +; (if (eql player #\B) +; (- (black-shape-liberties board) (white-shape-liberties board)) +; (- (white-shape-liberties board) (black-shape-liberties board)))) + (defmethod score + ((board liberty-shape-board) player) (if (eql player #\B) - (- (black-shape-liberties board) (white-shape-liberties board)) - (- (white-shape-liberties board) (black-shape-liberties board)))) \ No newline at end of file + (- (black-shape-stone-liberties board) (white-shape-stone-liberties board)) + (- (white-shape-stone-liberties board) (black-shape-stone-liberties board)))) \ No newline at end of file diff --git a/macro-utils.lisp b/macro-utils.lisp index 180dbbf..d49f31a 100644 --- a/macro-utils.lisp +++ b/macro-utils.lisp @@ -1,16 +1,19 @@ (in-package macro-utils) -(defun test-while (n) - (let ((i 0)) - (while (< i n) - (format t "~a~%" i) - (incf i)))) +;(defun test-while (n) +; (let ((i 0)) +; (while (< i n) +; (format t "~a~%" i) +; (incf i)))) -(defun test-until (n) - (let ((i 0)) - (until (= i n) - (format t "~a~%" i) - (incf i)))) +;(defun test-until (n) +; (let ((i 0)) +; (until (= i n) +; (format t "~a~%" i) +; (incf i)))) + +(defmacro pdebug (&body body) + `(format *error-output* ,@body)) (defmacro while (test-case &body body) `(do () @@ -26,6 +29,8 @@ `(let ,(loop for n in names collect `(,n (gensym))) ,@body)) + + (defmacro once-only ((&rest names) &body body) (let ((gensyms (loop for n in names collect (gensym)))) `(let (,@(loop for g in gensyms collect `(,g (gensym)))) diff --git a/packages.lisp b/packages.lisp index 779ac34..91c934e 100644 --- a/packages.lisp +++ b/packages.lisp @@ -9,7 +9,8 @@ (:export :with-gensyms :once-only :while - :until)) + :until + :pdebug)) (defpackage netpipe (:use :common-lisp) @@ -29,6 +30,7 @@ :ranked-board :get-stone :set-stone + :get-player :coord-to-str :str-to-coord :genmove @@ -70,7 +72,7 @@ :shape-sizes :next-shape-id :convert-shape - :size-of-shape)) + :shape-size)) (defpackage liberty-shape-board (:use :common-lisp @@ -79,7 +81,8 @@ :liberty-board :shape-board) (:export :liberty-shape-board - :liberty-shape-to-analyze)) + :liberty-shape-to-analyze + :liberty-shape-stone-to-analyze)) (defpackage go-bot @@ -104,6 +107,7 @@ :analyze-liberty :analyze-shapes :analyze-shape-liberties + :analyze-shape-stone-liberties )) (defpackage gtp-handler diff --git a/shape.lisp b/shape.lisp index fa53287..2538705 100644 --- a/shape.lisp +++ b/shape.lisp @@ -41,7 +41,7 @@ (vector-push-extend coords (aref (shapes-points board) shape-id)) (incf (aref (shape-sizes board) shape-id))) -(defmacro size-of-shape (board shape-id) +(defmacro shape-size (board shape-id) `(aref (shape-sizes ,board) ,shape-id)) (defgeneric convert-shape (board shape-id to-id)) @@ -58,7 +58,7 @@ (defmethod join-shapes ((board shape-board) nexus shapes-list) (let ((biggest-shape (first shapes-list))) (loop for shape-id in shapes-list do - (if (> (size-of-shape board shape-id) (size-of-shape board biggest-shape)) + (if (> (shape-size board shape-id) (shape-size board biggest-shape)) (setf biggest-shape shape-id))) (loop for shape-id in shapes-list do