Real work towards a DSL and classset

This commit is contained in:
Dan 2008-05-21 11:46:32 -07:00
parent b5081c7f72
commit 26eb67f494
6 changed files with 151 additions and 31 deletions

View File

@ -1,8 +1,5 @@
(in-package :board)
(defun make-2d-board (size &optional (initial nil))
(let ((array (make-array size)))
(dotimes (i size)
@ -37,43 +34,115 @@
(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)))
@ -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))

View File

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

View File

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

13
macro-utils.lisp Normal file
View File

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

View File

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

42
test-class.lisp Normal file
View File

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