begginings of shape support

This commit is contained in:
Dan 2008-06-17 17:46:32 -07:00
parent 7f02d755e1
commit d0cc434248
4 changed files with 81 additions and 18 deletions

View File

@ -12,9 +12,6 @@
(setf (aref copy i) (copy-seq (aref board i))))
copy))
(defun filter-i-number (number)
(if (> number 8)
(1- number)
@ -96,6 +93,17 @@
(do-over-board (,coord ,board)
(progn ,@body))))
(defmacro do-over-adjacent ((coords-var board coords) &body body)
`(let* ((x (first ,coords))
(y (second ,coords))
(up (1- x))
(down (1+ x))
(left (1- y))
(right (1+ y)))
(if (>= up 0) (let ((,coords-var `(,up ,y))) ,@body))
(if (>= left 0) (let ((,coords-var `(,x ,left))) ,@body))
(if (< down (boardsize ,board)) (let ((,coords-var `(,down ,y))) ,@body))
(if (< right (boardsize ,board)) (let ((,coords-var `(,x ,right))) ,@body))))
(defclass ranked-board (basic-board)

View File

@ -21,7 +21,6 @@
(let ((coords `( (0 0) (,max 0) (0 ,max) (,max ,max))))
(loop for coord in coords do (set-2d-stone (liberty-board board) coord stone))))
(defmethod initialize-instance :after ((board liberty-board) &key from-board)
; (format t "init liberty-board~%")
(if (eql from-board nil)
@ -49,17 +48,6 @@
(set-2d-stone (liberty-board ,board) ,coords (1- (get-2d-stone (liberty-board ,board) ,coords)))
(inc-liberties ,board ,coords -1)))
(defmacro do-over-adjacent ((coords-var board coords) &body body)
`(let* ((x (first ,coords))
(y (second ,coords))
(up (1- x))
(down (1+ x))
(left (1- y))
(right (1+ y)))
(if (>= up 0) (let ((,coords-var `(,up ,y))) ,@body))
(if (>= left 0) (let ((,coords-var `(,x ,left))) ,@body))
(if (< down (boardsize ,board)) (let ((,coords-var `(,down ,y))) ,@body))
(if (< right (boardsize ,board)) (let ((,coords-var `(,x ,right))) ,@body))))
(defmethod set-stone :after ((board liberty-board) coords val)
(inc-liberties board coords (get-2d-stone (liberty-board board) coords))

View File

@ -42,7 +42,9 @@
:score
:copy-slots
:analyze-board-score
:board-to-analyze))
:board-to-analyze
; :do-over-2d-adjacent
:do-over-adjacent))
(defpackage liberty-board
(:use :common-lisp

View File

@ -1,7 +1,72 @@
(in-package :shape-board)
(defclass shape-board (basic-board)
(
))
((shape-board
:initform nil
:accessor shape-board)
(shape-sizes
:initform nil
:accessor shape-sizes)
(shapes-points
:initform nil
:accessor shapes-points)
(next-shape-id
:initform 0
:accessor next-shape-id)))
(defun copy-array (array &optional)
(let ((copy (make-array (1+ (length array)) :adjustable t)))
(dotimes (i (length array))
(setf (aref copy i) (aref array i)))))
(defmethod initialize-instance :after ((board shape-board) &key from-board)
(if (eql from-board nil)
(progn
(setf (shape-board board) (make-2d-board (boardsize board) nil))
(setf (shape-sizes board) (make-array 2 :fill-pointer 0 :adjustable t))
(progn
(setf (shape-board board) (copy-2d-board (shape-board from-board)))
(setf (shape-sizes board) (copy-array (shape-sizes from-board)))
(copy-slots (next-shape-id) board from-board)))))
(defmethod add-shape ((board shape-board) coords)
(set-2d-stone (shape-board board) coords (next-shape-id board))
(vector-push-extend 1 (shape-sizes board))
(incf (next-shape-id board)))
(defmethod add-to-shape ((board shape-board) coords shape-id)
(set-2d-stone (shape-board board) coords shape-id)
(incf (aref (shape-sizes board) shape-id)))
(defmacro size-of-shape ((board shape-board) shape-id)
(aref (shape-sizes board) shape-id))
(defmethod join-shapes ((board shape-board) nexus shapes-list)
(let ((biggest-shape (first (shapes-list))))
(loop for shape-id in shape-list do
(if (> (size-of-shape board shape-id) (size-of-shape board biggest-shape))
(setf biggest-shape shape-id)))
(loop for shape-id in shape-list do
(if (not (= shape-id biggest-shape))
(convert-shape board shape-id biggest-shape)))
(add-to-shape board nexus biggest-shape)))
(defmethod set-stone :after ((board shape-board) coords val)
(let ((alist nil))
(do-over-adjacent (coords-var board coords)
(if (not (eql nil (get-2d-stone (shape-board board) coords-var)))
(push (get-2d-stone (shape-board board) coords-var) alist))
(if (eql alist nil)
(add-shape board coords)
(if (eql (cdr alist) nil) ; one item
(add-to-shape board coords (car (first alist)))
(join-shapes board coords alist))))
;(defun shape-to-analyze ())