Real work towards a DSL and classset

board.lisp

@@ -1,8 +1,5 @@
 (in-package :board)
 
-
-
-
 (defun make-2d-board (size &optional (initial nil))
   (let ((array (make-array size)))
     (dotimes (i size)
@@ -37,46 +34,118 @@
 
 
 
-(defun get-stone (board coord)
+(defun get-2d-stone (board coord)
   (aref (aref board (first coord)) (second coord)))
 
-(defun set-stone (board coord val)
+(defun set-2d-stone (board coord val)
   (setf (aref (aref board (first coord)) (second coord)) val))
 
-  
+
 
 (defclass  basic-board ()
   ((boardsize
-    :initarg boardsize
-   ; :initform *boardsize*
+    :initarg :boardsize
+    :initform 19
     :accessor boardsize)
    (board-def-type
-    :initarg board-def-type
+    :initarg :board-def-type
     :initform nil
     :accessor board-def-type)
    (board
-    :accessor board)))
+    :accessor board
+    :initform nil)))
 
-(defmethod initialize-instance :after ((board basic-board) &key (from-board 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))
+
+
+;(defgeneric (setf stone) (val coords
+
+(defmethod initialize-instance :after ((board basic-board) &key from-board)
   (if (eql from-board nil)
-      (setf (board-def-type board) (make-2d-board (boardsize board) (board-def-type board)))
+      (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))
 	(setf (board board) (copy-2d-board (board from-board))))))
 
 
-(defgeneric prune (board)
-  ()
+
+(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))))
+
+
+
+
+(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"))
+
+
+(defmethod prune ((board basic-board) prune-board)
+  (prune-placed-stones board prune-board))
+
+
+(def-over-board prune-placed-stones (coord board prune-board)
+  (if (not (eql (get-stone board coord) nil))
+	(set-stone prune-board coord nil)))
+
+;(defun prune-placed-stones (board prune-board)
+;  (do-over-board (coord board)
+;    (if (not (eql (get-stone board coord) nil))
+;	(set-stone prune-board coord nil))))
+
+;(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))))
+
+
+
+
+
+; generate a same sized board with a def type
+(defmacro gen-board (board def-type)
+  `(make-instance 'basic-board :boardsize (boardsize ,board) :board-def-type ,def-type))
 
 (defmethod genmove ((board basic-board) player)
-  (prune board player)
-  ;(focus board player)
-  (minmax board player)
-  (select-move board player))
+  (let ((prune-board (gen-board board t))
+	(focus-board (gen-board board nil))
+	(score-board (gen-board board nil)))
+    
+    (prune board prune-board)))
+    (focus board prune-board focus-board player)
+;    (score board focus-board score-board player)
+;    (select-move score-board)))
   
 
 
+
+
+
 ;(defun make-move (board player)
 ;  (select-move (score board player)))
 
@@ -110,13 +179,3 @@
 ;		      (vector-push-extend `(,x ,y) coords)))))))))
       
 
-;(defun score-unused (board player)
-;  (let ((scores (make-board (length board) 0)))
-;    (dotimes (x (length board))
-;      (dotimes (y (length board))
-;	;body
-;	(if (eql (get-stone board `(,x ,y)) nil)
-;	    (set-stone scores `(,x ,y) 1))
-;	;end
-;	))
-;    scores))

env.lisp

@@ -12,6 +12,7 @@
 (defparameter *src-root* "/home/dan/src/my/gobot/")
 
 (load (compile-file (concatenate 'string *src-root* "packages.lisp")))
+(load (compile-file (concatenate 'string *src-root* "macro-utils.lisp")))
 (load (compile-file (concatenate 'string *src-root* "netpipe.lisp")))
 (load (compile-file (concatenate 'string *src-root* "board.lisp")))
 (load (compile-file (concatenate 'string *src-root* "gobot.lisp")))

fink.lisp

@@ -2,9 +2,8 @@
 
 (defparameter *src-root* "/home/dan/src/my/gobot/")
 
-asdas asd asd ad  asd 
-
 (load (concatenate 'string *src-root* "packages.fasl"))
+(load (concatenate 'string *src-root* "macro-utils.fasl"))
 (load (concatenate 'string *src-root* "netpipe.fasl"))
 (load (concatenate 'string *src-root* "board.fasl"))
 (load (concatenate 'string *src-root* "gobot.fasl"))

macro-utils.lisp

@@ -0,0 +1,13 @@
+(in-package macro-utils)
+
+(defmacro with-gensyms ((&rest names) &body body)
+  `(let ,(loop for n in names collect `(,n (gensym)))
+    ,@body))
+
+(defmacro only-once ((&rest names) &body body)
+  (let ((gensyms (loop for n in names collect (gensym))))
+    `(let (,@(loop for g in gensyms collect `(,g (gensym))))
+       `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
+	  ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
+		,@body)))))
+	

packages.lisp

@@ -4,6 +4,11 @@
 ;(asdf:oos 'asdf:load-op :cl-ppcre)
 (require :sb-bsd-sockets)
 
+(defpackage macro-utils
+  (:use :common-lisp)
+  (:export :with-gensyms
+	   :once-only))
+
 (defpackage netpipe
   (:use :common-lisp)
   (:export :tcp-connect
@@ -19,7 +24,8 @@
 	   :gtp-net-client))
 
 (defpackage board
-  (:use :common-lisp)
+  (:use :common-lisp
+	:macro-utils)
   (:export :basic-board
 	   :get-stone
 	   :set-stone

test-class.lisp

@@ -0,0 +1,42 @@
+(defclass class_a ()
+  ((a
+   :initarg a
+   :initform (make-array 10 :initial-element 0)
+   :accessor a)))
+
+(defclass class_b (class_a)
+  ((b 
+   :initform (make-array 10 :initial-element 0)
+   :initarg b
+   :accessor b)))
+
+(defgeneric dothing (class data)
+  (:method-combination progn :most-specific-last))
+  
+
+(defmethod dothing progn ((class class_a) data)
+  (loop for i from 0 to 9 do (setf (aref (a class) i) (+ (aref (a class) i) data))))
+
+(defmethod dothing progn ((class class_b) data)
+  (loop for i from 0 to 9 do (setf (aref (b class) i) (+ (aref (b class) i) (aref (a class) i) data))))
+
+(defgeneric doother4 (class data)
+  );(:method-combination progn :most-specific-last))
+
+(defmethod doother4  ((class class_a) data)
+  (format t "class_a~%")
+  (loop for i from 0 to 4 do (setf (aref data i) "a"))
+  data)
+
+
+(defmethod doother4 :after ((class class_b) data)
+  (format t "class_b~%")
+  (loop for i from 0 to 2 do (setf (aref data i) "b"))
+  data)
+
+(defmethod (setf a) (new-number (class class_a))
+  (setf (aref (a class) 0) new-number))
+
+
+;(defmethod (setf a) (new-number index (class class_a))
+;  (setf (aref (a class) index) new-number))