[Welcome to Sensei's Library!]

StartingPoints
ReferenceSection
About


Referenced by
MetaDiscussion
TheCodeSoFar

 

Gorobei - The Current Code
   

[(Is there someplace to send comments on the code? I looked for an email address without success. So I'll just stuff my comment in here and hope that someone more knowledgeable can send it where it belongs.)

The LESSP operation

 (defmethod lessp ((p1 Point) (p2 Point))
   (or (< (row p1) (row p2)) (< (col p1) (col p2))))

doesn't "consistently represent a total order" on points (as required by the ANSI specification for SORT). Consider point1=c1 and point2=a3. Then (LESSP point1 point2) and (LESSP point2 point1) are both true! So if you try to use LESSP as the ordering predicate for the ANSI CL SORT function, you'll probably get some bogus result.

There are several ways to make LESSP better behaved, so that when (LESSP a b) you never have (LESSP b a) also. One way is to define a unique one-dimensional index e.g.

  (defun point-index (point)
    (+ (row p1) (* (col p1) board-edge)))

and then define LESSP as

  (defmethod lessp ((p1 point) (p2 point))
     (< (point-index p1) (point-index p2)))

-- Bill Newman (another Lisp Go programmer:-) 2002-03-25]

Gorobei: Ouch! You are quite right - that accounts for some quirky profiling results I was seeing. I wish I could claim that horrible function was due to my just learning LISP, but it is obviously just a stupidity.

I purposely didn't add my email address because I felt that comments such as yours are better contributed to the page... I'd like to show my errors (of design, understanding, and implementation,) as much as any successes I happen to have.


This is the up-to-date version of my Go playing program (it currently can only solve simple Life and Death problems.) You can use SL's page info & history feature (at the bottom of the page) to see the code as it was at the time I wrote something on one of my "The code so far" pages.

Here is a board indicative of the current code's level of play:

[Diagram]
Diag.: Black to save the marked stones.


[Diagram]
Diag.: 1-43: Solution


The following code is largely uncommented: see TheCodeSoFar and its decendants for why it is the way it is:


  ==> go.lsp <==
  (in-package "CL-USER")
  (load "utils.lsp" )
  (load "point.lsp" )
  (load "board.lsp" )
  (load "stone.lsp" )
  (load "game-board.lsp" )
  (load "worm.lsp" )
  (load "worm-info.lsp" )
  (load "game.lsp" )
  (load "goal.lsp" )
  (load "problem.lsp" )
  (load "tickable.lsp" )
  (load "analyzer.lsp" )
  (load "go-utils.lsp" )
  (load "sgf.lsp" )
  (defvar *Print-Verbose* nil)
  (defmethod solve ((problem Problem))
    (let ((analyzer (Make-Analyzer problem)))
      (generate-candidate-moves analyzer)
      analyzer))
  (defun reg-test (problem-set)
    (let ((results (mapcar #'solve problem-set)))
      (with-open-file (os "/home/mmn/out.sgf" :direction :output)
  		  (format os "(;~%")
  		  (format os "FF[4]~%")
  		  (format os "SZ[~A]~%" (size (board (game-board (game (car results))))))
  		  (mapc (lambda (analyzer)
  			  (print-sgf analyzer os))
  			results)
  		  (format os ")~%"))))
  (defun reg-test-1 ()
    (reg-test *ps1*))
  ==> utils.lsp <==
  (defun s-uniq (list)
    (sort (remove-duplicates list) #'lessp))
  (defun string-to-integer (string)
    (with-input-from-string (s string) (read s)))
  (defun first-n (n list)
    (if (or (zerop n) (null list))
        ()
      (cons (car list) (first-n (1- n) (cdr list)))))
  (defun collapse (list f)
    (let ((result ()))
      (mapc (lambda (pair)
  	    (let ((accum (assoc (car pair) result)))
  	      (if accum
  		  (rplacd accum (funcall f (cdr accum) (cdr pair)))
  		(push pair result))))
  	  list)
      result))
  (defun as-char (n)
    (aref "abcdefghijklmnopqrstuvwxyz" n))
  ==> point.lsp <==
  (defclass Point ()
    ((row :documentation "row"
  	:reader row
  	:initarg :row)
     (col :documentation "column"
  	:reader col
  	:initarg :col)
     (index :documentation "location on the board"
    	  :reader index
    	  :initarg :index)
     (adjacent :documentation "the 2, 3, or 4 points that I touch."
    	     :accessor adjacent )))
  (defmethod lessp ((p1 Point) (p2 Point))
    (or (< (row p1) (row p2))
        (and (= (row p1) (row p2))
  	   (< (col p1) (col p2)))))
  (defmethod name ((p Point))
    (format nil "~S.~S" (row p) (col p)))
  (defmethod print-object ((point Point) s)
    (format s "<~A>" (name point)))
  (defmethod sgf ((point point))
    (format nil "~A~A"
  	  (as-char (col point))
  	  (as-char (row point))))
  ==> board.lsp <==
  (defclass Board ()
    ((size :documentation "size of board: 9, 13, or 19, usually"
    	 :reader Size
    	 :initarg :Size)
     (points :documentation "a 1-d array of the points on this board"
    	   :reader Points
    	   :initarg :Points)))
  (defun make-Board (sz)
    (let ((b (make-instance 'Board :Size sz :Points (make-array (* sz sz)))))
      (loop for r from 0 to (1- sz) do
    	  (loop for c from 0 to (1- sz) do
    		(let ((index (+ (* r sz) c)))
    		  (setf (aref (Points b) index)
    			(make-instance 'Point :row r :col c :index index)))))
      (loop for p across (Points b) do (setf (adjacent p) (adjacency-list b p)))
      b))
  (defmethod valid ((b Board) r c)
    (let ((Size (Size b)))
      (and (>= r 0) (>= c 0) (< r Size) (< c Size))))
  (defmethod b-at ((b Board) r c)
    (aref (Points b) (+ (* r (Size b)) c)))
  (defmethod at ((b Board) l)
    (aref (Points b) (+ (* (car l) (Size b)) (cadr l))))
  (defmethod adjacency-list ((b Board) (p Point))
    (let ((r (row p))
    	(c (col p)))
      (mapcan (lambda (row col) (if (valid b row col) (list (b-at b row col))))
    	    (list (1+ r) (1- r) r      r     )
    	    (list c      c      (1+ c) (1- c)))))
  (defmethod grid ((b Board))
    (make-array (* (size b) (size b)) :initial-element +Empty+ ))
  ==> stone.lsp <==
  (defclass Stone ()
    ((PChar :reader PChar :initarg :PChar )
     (MChar :reader MChar :initarg :MChar )
     (Name  :reader Name  :initarg :Name  )))
  (defparameter +Black+ (make-instance 'Stone :PChar #\X :MChar #\# :Name "Black" ))
  (defparameter +White+ (make-instance 'Stone :PChar #\O :MChar #\@ :Name "White" ))
  (defparameter +Empty+ (make-instance 'Stone :PChar #\. :MChar #\S :Name "Empty" ))
  (defmethod other ((s Stone))
    (if (eq s +White+) +Black+ +White+))
  (defmethod not-empty? ((s Stone))
    (or (eq s +White+) (eq s +Black+)))
  ==> game-board.lsp <==
  (defclass Game-Board ()
    ((Board :reader Board :initarg :Board)
     (Stones :reader Stones :initarg :Stones)))
  ;; This happens if we try to get the liberties of a dead snake!
  ;; Fair enough, I guess - it's got no liberties if it died.
  (defmethod liberties ((s Stone) (p Game-Board))
    ())
  (defun new-Game-Board (sz)
    (let ((b (make-Board sz)))
      (make-instance 'Game-Board
    		   :Board b
    		   :Stones (grid b))))
  (defmethod copy ((p Game-Board))
    (make-instance 'Game-Board
     		 :Board (Board p)
     		 :Stones (copy-seq (Stones p))))
  (defmethod at ((b Game-Board) (p Point))
    (aref (Stones b) (index p)))
  (defmethod at ((b Game-Board) l)
    (aref (Stones b) (index (b-at (Board b) (car l) (cadr l)))))
  ;;; Game-Boards can be used for much more than Stones!
  ;;;(defmethod (setf at) ((s Stone) (b Game-Board) (p Point))
  (defmethod (setf at) (s (b Game-Board) (p Point))
    (setf (aref (Stones b) (index p)) s))
  (defmethod empty? ((b Game-Board) (p Point))
    (eq (at b p) +Empty+))
  (defmethod stone? ((b Game-Board) (p Point))
    (or (eq (at b p) +White+)
        (eq (at b p) +Black+)))
  (defmethod liberties ((b Game-Board) (p Point))
    (s-uniq (mapcan (lambda (pnt)
    		    (if (empty? b pnt) (list pnt)))
    		  (adjacent p))))
  (defmethod point ((b Game-Board) l)
    (b-at (Board b) (car l) (cadr l)))
  (defmethod add ((b Game-Board) (s Stone) (p Point))
    (let* ((nb (copy b)))
      (setf (at nb p) s)
      nb))
  (defmethod add-stones ((b Game-Board) (s Stone) l)
    (if (null l)
        b
      (add (add-stones b s (cdr l)) s (point b (car l)))))
  (defun make-Game-Board (sz black white)
    (add-stones (add-stones (new-Game-Board sz) +White+ white)
     	      +Black+ black))
  (defmethod printb ((b Game-Board))
    (let ((sz (Size (Board b))))
      (loop for r from 0 to (1- sz) do
     	  (loop for c from 0 to (1- sz) do
     		(format t "~C " (PChar (at b (b-at (Board b) r c))))
     		finally (format t "~%" )))))
  (defmethod print-object ((b Game-Board) s)
    (let ((sz (Size (Board b))))
      (format s "$$  ")
      (loop for i from 1 to sz do
   	  (format s "--"))
      (format s "~%")
      (loop for r from 0 to (1- sz) do
    	  (format s "$$ |" )
     	  (loop for c from 0 to (1- sz) do
     		(format s "~C " (PChar (at b (b-at (Board b) r c))))
     		finally (format s "|~%" )))
      (format s "$$  ")
      (loop for i from 1 to sz do
   	  (format s "--"))
      (format s "~%")
      ))
  ==> worm.lsp <==
  #|
  Worm - a group of connected points
  |#
  (defclass Worm ()
    ((Color  :reader Color :initarg :Color)
     (Size   :accessor Size :initarg :Size)
     (Points :accessor Points :initarg :Points)))
  (defmethod print-object ((worm worm) s)
    (format s "Worm-~A:~A " (Name (Color worm)) (Size worm)))
  (defmethod printb ((s Worm))
    (format t "Worm: ~A" (Name (Color s)))
    (mapcar #'printb (Points s))
    (format t "~%" ))
  (defmethod PChar ((worm Worm))
    (if (eq (Color worm) +White+) #\o #\b))
  (defmethod lessp ((worm1 Worm) (worm2 Worm))
    (lessp (car (Points worm1)) (car (Points worm2))))
  (defmethod take-string ((b Game-Board) (p Point) (s Stone) (worm Worm))
    (setf (at b p) worm)
    (cons p (mapcan (lambda (pa)
     		    (if (eq (at b pa) s)
     			(take-string b pa s worm)))
     		  (adjacent p))))
  (defmethod Make-Worm (points (stone Stone))
    (make-instance 'Worm :Color stone :Points points))
  (defmethod Take-Worm ((game-board Game-Board) (point Point) (stone Stone))
    (let* ((worm (make-instance 'Worm :Color stone))
   	 (points (take-string game-board point stone worm)))
      (setf (Points worm) (s-uniq points))
      (setf (Size worm) (length (Points worm)))
      worm))
  (defmethod adjacencies ((worm Worm))
    (s-uniq (apply #'append (mapcar #'adjacent (Points worm)))))
  (defmethod liberties ((worm Worm) (game-board Game-Board))
    (remove-if-not (lambda (point) (empty? game-board point))
  		 (adjacencies worm)))
  ==> worm-info.lsp <==
  #|
  Worm - a group of worms, etc, and a mapping from a board point to a specific worm in the group.
  |#
  (defclass Worm-Info ()
    ((Worms :reader Worms :initarg :Worms)
     (SMap :reader SMap :initarg :SMap)))
  (defmethod Make-Worm-Info ((game-board Game-Board))
    (let ((board-copy (copy game-board))
  	(worms ()))
      (loop for point across (points (board game-board))
  	  do (if (or (stone? board-copy point) (empty? board-copy point))
  		 (push (Take-Worm board-copy point (at board-copy point))
  		       worms)))
      (make-instance 'Worm-Info :Worms worms :SMap board-copy)))
  (defmethod of-color ((worm-info Worm-Info) (stone Stone))
    (remove-if-not (lambda (worm) (eq (Color worm) stone))
  		 (Worms worm-info)))
  (defmethod print-object ((worm-info worm-info) s)
    (mapcar (lambda (worm) (princ worm s))
  	  (worms worm-info)))
  (defmethod snakes ((worm-info worm-info))
    (remove-if (lambda (worm) (eq (color worm) +Empty+))
  	     (worms worm-info)))
  ==> game.lsp <==
  (defclass Game ()
    ((Game-Board :documentation "The current Game-Board."
    	:accessor Game-Board
    	:initarg :Game-Board)
     (Current-Player :documentation "The player that will place the next stone or pass"
    		   :accessor Current-Player
    		   :initarg :Current-Player)
     (Worm-Info :documentation "The connected strings on this board"
    	      :accessor Worm-Info
    	      :initarg :Worm-Info)
     (Last-Move :accessor Last-Move :initarg :Last-Move)
     (Previous :accessor Previous :initarg :Previous)))
  (defclass Pass ())
  (defmethod name ((p Pass))
    (format nil "Pass"))
  (defparameter +Pass+ (make-instance 'Pass))
  (defmethod Make-Game ((p Game-Board) (s Stone))
    (make-instance 'Game
    		 :Game-Board p
    		 :Current-Player s
    		 :Last-Move ()
    		 :Previous ()
    		 :Worm-Info (Make-Worm-Info p)))
  (defun New-Game (sz)
    (Make-Game (new-Game-Board sz) +Black+))
  (defmethod point ((g Game) l)
    (b-at (Game-Board g) (car l) (cadr l)))
  (defmethod done? ((g Game))
    (and (eq (Last-Move g) +Pass+)
         (Previous g)
         (eq (Last-Move (Previous g)) +Pass+ )))
  (defmethod SMap ((g Game))
    (Smap (Worm-Info g)))
  (defmethod adjacent-snakes ((g Game) (p Point))
    (s-uniq (mapcan (lambda (p)
    		    (let ((sn (at (SMap g) p)))
    		      (if (not (eq sn +Empty+)) (list sn))))
    		  (adjacent p))))
  (defmethod move ((g Game) (p Pass))
    (make-instance 'Game
    		 :Game-Board (copy (Game-Board g))
    		 :Current-Player (Other (Current-Player g))
    		 :Last-Move p
    		 :Previous g
    		 :Last-Move p
    		 :Worm-Info (Worm-Info g)))
  (defmethod move ((g Game) (p Point))
    (if (and (empty? (Game-Board g) p)
    	   1) ; FIX - (not (eq (Ko-Point g) p)))
        (let* ((snakes (adjacent-snakes g p))
    	     (kills (mapcan (lambda (sn)
    			      (if (and (eq (Color sn) (Other (Current-Player g)))
    				       (= 1 (length (liberties sn (Game-Board g)))))
    				  (list sn)))
    			    snakes))
    	     (safe-friends (mapcan (lambda (sn)
    				     (if (and (eq (Color sn) (Current-Player g))
    					      (> (length (liberties sn (Game-Board g))) 1))
    					 (list sn)))
    				   snakes))
    	     (p-liberties (liberties (Game-Board g) p)))
    	(if (or p-liberties kills safe-friends)
    	    (let* ((dead-stones (apply #'append (mapcar #'Points kills)))
   		   (new-pos (add (Game-Board g) (Current-Player g) p)))
    	      (mapc (lambda (p) (setf (at new-pos p) +Empty+)) dead-stones)
  	      ;(format t "Move ~A kills ~A~%" (name p) (mapcar #'name dead-stones))
    	      (make-instance 'Game
    			     :Game-Board new-pos
    			     :Current-Player (Other (Current-Player g))
    			     :Previous g
    			     :Last-Move p
    			     :Worm-Info (Make-Worm-Info new-pos)))
    	  ))))
  (defmethod play ((g Game) l)
    (move g (Point (Game-Board g) l)))
  (defmethod print-object ((game Game) s)
    (format s "$$~A~A to play.~%"
  	  (if (eq (Current-Player game) +Black+) "B" "W" )
  	  (Name (Current-Player game)))
    (princ (Game-Board game) s))
  ==> goal.lsp <==
  (defclass Goal ()
    ((Action :reader Action :initarg :Action)
     (Player :accessor Player :initarg :Player)
     (Focus  :reader Focus  :initarg :Focus :initform ())
     (Answer :reader Answer :initarg :Answer :initform ())
     (Kill-Count :reader Kill-Count :initarg :Kill-Count :initform ())))
  (defun make-goal (a p game)
    (if (listp a)
        (case (car a)
   	    ((Kill)  (make-instance 'Goal :Action 'KillN :Player p :Kill-Count (cadr a)))
    	    ((SaveP) (make-instance 'Goal :Action 'SaveP :Player p :Answer (list (cadr a)) :Focus (cddr a)))
    	    ((KillG) (make-instance 'Goal :Action 'KillG :Player p :Focus (cdr a)))
    	    ((SaveG) (make-instance 'Goal :Action 'SaveG :Player p :Focus (cdr a))))
      (let ((focus (if (eq a 'Kill)
  		     (mapcar (lambda (s) (car (points s)))
  			     (of-color (worm-info game) (other p)))
  		   (if (eq a 'Save)
  		       (mapcar (lambda (s) (car (points s)))
  			       (of-color (worm-info game) p))
  		     ()))))
        (make-instance 'Goal :Action a :Player p :Answer () :Focus focus))))
  (defmethod print-object ((g Goal) s)
    (case (Action g)
   	((Kill)       (format s "~A to kill." (name (Player g))))
   	((KillG)      (format s "~A to kill ~A." (name (Player g)) (focus g)))
    	((SaveG)      (format s "~A to save ~A." (name (Player g)) (focus g)))
    	((Live Save)  (format s "~A to live." (name (Player g))))
    	((KillN)      (format s "~A to kill ~A stones." (name (Player g)) (Kill-Count g)))
    	(otherwise    (format s "~A **Unknown goal: ~S**" (name (Player g)) (Action g)))))
  (defmethod solved? ((gl Goal) (g Game))
    (cond
    	((not (Previous g)) ())
    	((eq (Action gl) 'KillG)
    	 (eq (at (Game-Board g) (Focus gl)) +Empty+))
    	((eq (Action gl) 'SaveG)
    	 (not (eq (at (Game-Board g) (Focus gl)) +Empty+)))
    	((eq (Action gl) 'Kill)
  	 (some (lambda (p)
  		 (eq (at (Game-Board g) p) +Empty+))
  	       (focus gl)))
    	((eq (Action gl) 'Save)
  	 (not (some (lambda (p)
  		      (eq (at (Game-Board g) p) +Empty+))
  		    (focus gl))))
    	((eq (Action gl) 'SaveP) nil)
    	(t nil)))
  (defmethod resolved-save? ((gl Goal) (g Game) (p Point))
    (eq (at (Game-Board g) p) +Empty+))
  (defmethod resolved-save-escaped? ((gl Goal) (g Game) (p Point))
    (< 4 (length (liberties
  		(at (smap (worm-info g)) p)
  		(game-board g)))))
  (defmethod resolved? ((gl Goal) (g Game))
    (cond
    	((not (Previous g)) ())
  	((done? g) t)
    	((eq (Action gl) 'KillG)
    	 (eq (at (Game-Board g) (Focus gl)) +Empty+))
    	((eq (Action gl) 'SaveG)
  	 (or
  	  (resolved-save? gl g (at (board (Game-Board g)) (Focus gl)))
  	  (resolved-save-escaped? gl g (at (board (Game-Board g)) (Focus gl)))))
    	((eq (Action gl) 'Kill)
  	 (some (lambda (p)
  		 (eq (at (Game-Board g) p) +Empty+))
  	       (focus gl)))
    	((eq (Action gl) 'Save)
  	 (or
  	  (some (lambda (p)
  		  (resolved-save? gl g p))
  		(focus gl))
  	  (every (lambda (p)
  		   (resolved-save-escaped? gl g p))
  		 (focus gl))))
    	(t nil)))
  ==> problem.lsp <==
  (defclass Problem ()
    ((Game :reader Game :initarg :Game)
     (Goal :reader Goal :initarg :Goal)
     (Answer :reader Answer :initarg :Answer)
     (Name :reader Name :initarg :Name)))
  (defun make-problem (toplay goal name sz ans black white)
    (let ((game (make-game (make-Game-Board sz black white) toplay)))
      (make-instance 'Problem
  		   :Game game
  		   :Name name
  		   :Answer ans
  		   :Goal (make-goal goal toplay game))))
  (defun make-problem-set (controls sgf-file-name)
    (let ((sgf (read-sgf sgf-file-name)))
      (mapcar (lambda (control)
  	      (let* ((name (car control))
  		     (toplay (if (eq (cadr control) 'Black) +Black+ +White+ ))
  		     (goal (caddr control))
  		     (answer (cadddr control))
  		     (node (find-node sgf name))
  		     (black (all-black-stones node))
  		     (white (all-white-stones node))
  		     (size (size sgf)))
  		(make-problem toplay goal name size answer black white)))
  	    controls)))
  (defmethod focus ((problem problem))
    (let* ((game (game problem))
  	 (action (action (goal problem))))
      (case Action
  	  ((KillG SaveG) (at (SMap game)
  			     (point (Game-Board game) (Focus (Goal problem)))))
  	  ((Kill Save) (let* ((color (if (eq Action 'Save)
  					 (current-player game)
  				       (other (current-player game))))
  			      (snakes (of-color (worm-info game) color)))
  			 (make-worm (apply #'append (mapcar #'points snakes)) color)))
  	   (otherwise ()))))
  (defmethod print-object ((problem problem) s)
    (format s "$$ ~A: ~A~%" (name problem) (goal problem)))
  (defmethod solution ((p Problem))
    (let* ((sol (solve p))
    	 (answer (Answer (Goal p)))
    	 (solved (and Answer (eq (car Answer) sol))))
      (if answer
    	(if (or *Print-Verbose* (not solved))
    	    (printsl (Game p) (format nil "~A: ~A - ~A" (name p) sol (if solved  "Correct" "Incorrect" )))
    	  (format t "~A: ~A - ~A~%" (name p) sol (if solved  "Correct" "Incorrect" )))
        (if sol
    	  (let ((g (move (game p) sol)))
    	    (setf solved (solved? (Goal p) g))
    	    (if (or *Print-Verbose* (not solved))
    		(printsl g (format nil "~A: Solved with ~A- ~A"
  				   (name p) (prints sol) (if solved "Correct" "Incorrect" )))
    	      (format t "~A: Solved with ~A- ~A~%" (name p) (prints sol) (if solved "Correct" "Incorrect" ))))
    	(progn
    	  (setf solved ())
    	  (printsl (Game p) (format nil "Can't solve ~A" (name p))))))
      solved))
  ==> tickable.lsp <==
  #|
   A Tickable is something that can use CPU time.
   when it has been given a full tick, it will do something (typically generate a new board.)
   Tickables can get fractional ticks.
  |#
  (defclass Tickable ()
    ((energy :accessor energy :initform 0)
     (stats  :documentation "statistics about this tickable"
  	   :accessor stats :initarg :stats :initform ())))
  (defmethod add-tick1 ((a Tickable) (p Tickable) amt)
    (incf (tick-count (stats a)) amt)
    (setf (energy a) (+ (energy a) amt))
    (when (>= (energy a) 1)
      (decf (energy a))
      (add-tick a p)))
  (defclass Stats ()
    ((tick-count
      :documentation "how many ticks I have been given"
      :accessor tick-count
      :initform 0)))
  ==> analyzer.lsp <==
  (defclass Analyzer (Tickable)
    ((problem    :documentation "the problem being solved"  :accessor problem      :initarg :problem)
     (game       :documentation "the current game state"    :accessor game         :initarg :game)
     (goal       :documentation "the goal of this analyzer" :accessor goal         :initarg :goal)
     (Maximize   :accessor Maximize  :initarg :Maximize :initform t)
     (children   :documentation "the tree of games after this game state"
  	       :accessor children :initarg :children :initform ())
     (candidate-moves :accessor candidate-moves :initform ())
     (name       :accessor name :initarg :name :initform "Root" )))
  (defmethod make-analyzer ((p Problem))
    (make-instance 'Analyzer
  		 :Problem p
  		 :Game (Game p)
  		 :maximize t
  		 :children ()
  		 :stats (make-instance 'Stats)
  		 :goal (goal p)))
  (defmethod name ((a Analyzer))
    (if (last-move (game a))
        (format nil "Analyzer(~A)" (name (last-move (game a))))
      "Analyzer(Root)"))
  (defmethod make-child ((a Analyzer) c) ;; c is a Point or a Pass
    (let* ((ng (Move (game a) c)))
      (if ng
  	(let ((na (make-instance 'Analyzer
  				 :problem (problem a)
  				 :game ng
  				 :children ()
  				 :maximize (not (maximize a))
  				 :name (format nil "~A-~A" (name a) (name c))
  				 :stats (make-instance 'stats)
  				 :goal (Goal a))))
  	  (setf (score na) (static-eval na a))
  	  na))))
  (defmethod add-child ((a Analyzer) (c Analyzer))
    (push c (children a)))
  (defmethod focus ((analyzer Analyzer))
    (focus (problem analyzer)))
  (defmethod level0-candidates ((a Analyzer))
    (liberties (focus a) (game-board (game a))))
  (defmethod level1-candidates ((a Analyzer))
    (let ((l0 (level0-candidates a)))
      (remove-if (lambda (point) (member point l0))
  	       (s-uniq (mapcan (lambda (p)
  				 (liberties (game-board (game a)) p))
  			       l0)))))
  (defun urgency (liberties-length)
    (case liberties-length
  	((1) 50)
  	((2) 10)
  	((3)  3)
  	(otherwise 1)))
  (defmethod get-candidate-moves-0 ((analyzer analyzer))
    (let ((worm-info (worm-info (game analyzer)))
  	(game-board (game-board (game analyzer))))
      (let ((candidates (mapcan (lambda (worm)
  				(let ((liberties (liberties worm game-board)))
  				  (mapcar (lambda (point)
  					    (cons point (urgency (length liberties))))
  					  liberties)))
  			      (snakes worm-info))))
        (collapse candidates #'+))))
  (defun sort-candidates (list)
    (sort list (lambda (a b)
  	       (> (cdr a) (cdr b)))))
  (defmethod generate-candidate-moves ((analyzer analyzer))
    (setf (candidate-moves analyzer)
  	(first-n 4 (sort-candidates (get-candidate-moves-0 analyzer)))))
  (defmethod print-sgf ((analyzer analyzer) os)
    (format os "(;~%")
    (mapc (lambda (worm)
  	  (format os (if (eq (color worm) +White+) "AW" "AB" ))
  	  (mapc (lambda (point)
  		  (format os "[~A]" (sgf point)))
  		(points worm))
  	  (format os "~%"))
  	(snakes (worm-info (game analyzer))))
    (format os "L")
    (mapc (lambda (pair)
  	  (format os "[~A]" (sgf (car pair))))
  	(candidate-moves analyzer))
    (format os "~%")
    (format os "C[")
    (loop for pair in (candidate-moves analyzer)
  	with y = 0
  	do (format os "~A: ~A~%" (as-char y) (cdr pair))
  	do (incf y))
    (format os "]~%")
    (format os "N[~A]~%" (name (problem analyzer)))
    (format os ")~%"))
  (defmethod print-object ((analyzer Analyzer) s)
    (let* ((last-move (or (last-move (game analyzer)) +Pass+))
  	 (solution (at (board (Game-Board (game analyzer))) (answer (problem a)))))
      (if (eq last-move solution)
  	(format s "~A Right: ~A, move is ~A~%"
  		(name (problem analyzer))
  		(goal analyzer)
  		(name last-move))
        (progn
  	(format s "~%" )
  	(princ (problem a) s)
  	(format s "Wrong: ~A wanted ~A~%" (name last-move) (name solution))
  	(format s "~%~%" )))))
  ==> go-utils.lsp <==
  (defmethod mark-snake ((game-board game-board) (worm worm) s)
    (let ((pos (copy Game-Board)))
      (mapcar (lambda (point)
  	      (setf (at pos point) s))
  	    (points worm))
      pos))
  (defmethod mark-points ((analyzer Analyzer) l)
    (let ((game-board (game-board (game analyzer)))
  	(stone (make-instance 'Stone :PChar #\a)))
      (mark-snake game-board
  		(take-worm game-board l stone)
  		stone)))
  ==> sgf.lsp <==
  ;;;
  ;;;  A really crappy sgf file reader
  ;;;
  (defclass sgf-node ()
    ((nodes :accessor nodes :initform () :initarg :nodes)
     (properties :accessor properties :initform () :initarg :properties)))
  (defmethod read-args ((is stream))
    (when (char= (peek-char t is) #\[ )
      (peek-char #\[ is)
      (read-char is)
      (do ((str ())
  	 (c (read-char is) (read-char is)))
  	((char= c #\] )
  	 (cons (coerce (reverse str) 'string) (read-args is)))
  	(push c str))))
  (defmethod read-property ((is stream))
    (do ((tok)
         (c (peek-char nil is) (peek-char nil is nil 'eof)))
        ((not (and (characterp c) (upper-case-p c)))
         (cons (coerce (reverse tok) 'string)
  	     (read-args is)))
        (push (read-char is) tok)))
  (defmethod read-sgf-node ((is stream))
    (let ((nodes ())
  	(properties ()))
      (do ((c (peek-char t is) (peek-char t is)))
  	(nil)
  	(cond
  	 ((char= c #\( ) (push (read-sgf is) nodes))
  	 ((upper-case-p c) (push (read-property is) properties))
  	 ((char= c #\) )
  	  (progn
  	    (read-char is)
  	    (return (make-instance 'sgf-node :nodes (reverse nodes) :properties (reverse properties)))))
  	 (t (read-char is))))))
  (defmethod read-sgf ((is stream))
    (do ((c (read-char is) (read-char is)))
        (nil)
        (when (and (char= c #\( )
  		 (char= (peek-char t is) #\; ))
  	(peek-char #\; is)
  	(read-char is)
  	(return (read-sgf-node is)))))
  (defmethod read-sgf ((filename string))
    (let ((path (merge-pathnames filename)))
      (with-open-file (is path :direction :input)
  		    (read-sgf is))))
  (defmethod get-property-lists ((sgf sgf-node) name)
    (remove-if-not (lambda (property)
  		   (equal (car property) name))
  		 (properties sgf)))
  (defmethod get-property ((sgf sgf-node) name)
    (cadar (get-property-lists sgf name)))
  (defmethod find-node ((sgf sgf-node) name )
    (find-if (lambda (node)
  	     (equal (get-property node "N") name))
  	   (nodes sgf)))
  (defun to-points (list)
    (mapcar (lambda (s)
  	    (reverse (mapcar (lambda (c) (- (char-int c) 97 ))
  			     (coerce s 'list ))))
  	  list))
  (defmethod size ((sgf sgf-node))
    (string-to-integer (get-property sgf "SZ")))
  (defmethod all-white-stones ((sgf sgf-node))
    (apply #'append (mapcar (lambda (property)
  			    (to-points (cdr property)))
  			  (get-property-lists sgf "AW"))))
  (defmethod all-black-stones ((sgf sgf-node))
    (apply #'append (mapcar (lambda (property)
  			    (to-points (cdr property)))
  			  (get-property-lists sgf "AB"))))


This is a copy of the living page "Gorobei - The Current Code" at Sensei's Library.
(C) the Authors, published under the OpenContent License V1.0.