From 26eb67f4945b17d8a64978db2ac698afa98b06cf Mon Sep 17 00:00:00 2001 From: Dan Date: Wed, 21 May 2008 11:46:32 -0700 Subject: [PATCH] Real work towards a DSL and classset --- board.lisp | 115 +++++++++++++++++++++++++++++++++++------------ env.lisp | 1 + fink.lisp | 3 +- macro-utils.lisp | 13 ++++++ packages.lisp | 8 +++- test-class.lisp | 42 +++++++++++++++++ 6 files changed, 151 insertions(+), 31 deletions(-) create mode 100644 macro-utils.lisp create mode 100644 test-class.lisp diff --git a/board.lisp b/board.lisp index 614a3a0..ee49b4c 100644 --- a/board.lisp +++ b/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)) \ No newline at end of file diff --git a/env.lisp b/env.lisp index a94387a..ba4a42c 100644 --- a/env.lisp +++ b/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"))) diff --git a/fink.lisp b/fink.lisp index 00f9f58..48449ca 100644 --- a/fink.lisp +++ b/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")) diff --git a/macro-utils.lisp b/macro-utils.lisp new file mode 100644 index 0000000..7506889 --- /dev/null +++ b/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))))) + \ No newline at end of file diff --git a/packages.lisp b/packages.lisp index 9df7630..2296fa6 100644 --- a/packages.lisp +++ b/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 diff --git a/test-class.lisp b/test-class.lisp new file mode 100644 index 0000000..f9fb055 --- /dev/null +++ b/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)) \ No newline at end of file