shape liberty main working all done and passing reworked

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))
-	(format t "MASSIVE ERROR!~%trying to access coord:~a on board" coord))
+  (aref (aref board (first coord)) (second 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
 
@@ -168,8 +170,10 @@
       (cons (car list) (insert (cdr list) comp var))))
 
 
-(defmethod set-stone :after ((board ranked-board) coords val)
+(defgeneric insert-into-ranked-list (board coords val))
-;  (format t "~a ~a~%" 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)
+  ;(if (eql (rank-top-count board) 0)
-      '(-1 (-1 -1))
+      ;'(-1 (-1 -1))
-      (car (nthcdr (random (rank-top-count board)) (rank-top-list board)))))
+  (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)))))))))
-      
-

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))
+;	     (board-score (first move))
-	     (coord (coord-to-str (second move))))
+	     (coord (second move)))
 	;(format t "score: ~a for player ~a ~%" board-score player)
-	(if (< board-score 0)
+	(if (listp coord)  ; string= coord "pass"))
-	    "pass"
+	    (let ((coord-str (coord-to-str coord)))
-	    (progn
+	      (do-play player coord-str)
-	      (do-play player coord)
+	      coord-str)
-	      coord)))))
+	    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*))

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)))))))

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,10 +29,20 @@
 (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)
@@ -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)
+ ;   (pdebug "calculate-shape-liberties for sid:~a score:~a~%" sid shape-liberties-score)
-    (inc-player-shape-liberty board player (- old-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)))
+      (let ((adj-sid (shape-id board coords-var))
-	(if (not (or (eql adj-sid sid) (eql adj-sid nil)))
+	    (adj-player (get-player board coords-var)))
-	    (calculate-shape-liberties board coords-var (get-stone 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)) 
+	       '(#\newline) " TEXT black shape stone liberties: " (write-to-string (black-shape-stone-liberties board)) 
-	       " white shape liberties: " (write-to-string (white-shape-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))
+      (- (black-shape-stone-liberties board) (white-shape-stone-liberties board))
-      (- (white-shape-liberties board) (black-shape-liberties board))))
+      (- (white-shape-stone-liberties board) (black-shape-stone-liberties board))))

macro-utils.lisp

@@ -1,16 +1,19 @@
 (in-package macro-utils)
 
-(defun test-while (n)
+;(defun test-while (n)
-  (let ((i 0))
+;  (let ((i 0))
-    (while (< i n)
+;    (while (< i n)
-      (format t "~a~%" i)
+;      (format t "~a~%" i)
-      (incf i))))
+;      (incf i))))
 
-(defun test-until (n)
+;(defun test-until (n)
-  (let ((i 0))
+;  (let ((i 0))
-    (until (= i n)
+;    (until (= i n)
-      (format t "~a~%" i)
+;      (format t "~a~%" i)
-      (incf 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))))

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

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