106 lines
4.0 KiB
Common Lisp
106 lines
4.0 KiB
Common Lisp
(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)))
|
|
|
|
(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 1 :fill-pointer 0 :adjustable t))
|
|
(setf (shapes-points board) (make-array 1 :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)))
|
|
(setf (shapes-points board) (copy-2d-array (shapes-points from-board)))
|
|
(copy-slots (next-shape-id) board from-board))))
|
|
|
|
(defmacro shape-id (board coords)
|
|
`(get-2d-stone (shape-board ,board) ,coords))
|
|
|
|
(defun add-shape (board coords)
|
|
(set-2d-stone (shape-board board) coords (next-shape-id board))
|
|
(vector-push-extend 1 (shape-sizes board))
|
|
(vector-push-extend (make-array 1 :fill-pointer 0 :adjustable t) (shapes-points board))
|
|
(vector-push-extend coords (aref (shapes-points board) (next-shape-id board)))
|
|
(incf (next-shape-id board)))
|
|
|
|
(defun add-to-shape (board coords shape-id)
|
|
(set-2d-stone (shape-board board) coords shape-id)
|
|
(vector-push-extend coords (aref (shapes-points board) shape-id))
|
|
(incf (aref (shape-sizes board) shape-id)))
|
|
|
|
(defmacro shape-size (board shape-id)
|
|
`(aref (shape-sizes ,board) ,shape-id))
|
|
|
|
(defgeneric convert-shape (board shape-id to-id))
|
|
|
|
(defmethod convert-shape ((board shape-board) shape-id to-id)
|
|
; (format t "convert-shape ~a to ~a~%" shape-id to-id)
|
|
(loop for index from 0 to (1- (length (aref (shapes-points board) shape-id))) do
|
|
(add-to-shape board (aref (aref (shapes-points board) shape-id) index ) to-id))
|
|
(setf (aref (shapes-points board) shape-id) (make-array 1 :fill-pointer 0 :adjustable t))
|
|
(setf (aref (shape-sizes board) shape-id) 0))
|
|
|
|
(defgeneric join-shapes (board nexus shapes-list))
|
|
|
|
(defmethod join-shapes ((board shape-board) nexus shapes-list)
|
|
(let ((biggest-shape (first shapes-list)))
|
|
(loop for shape-id in shapes-list do
|
|
(if (> (shape-size board shape-id) (shape-size board biggest-shape))
|
|
(setf biggest-shape shape-id)))
|
|
|
|
(loop for shape-id in shapes-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 (eql val (get-stone 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 alist))
|
|
(join-shapes board coords alist)))))
|
|
|
|
;(defun shape-to-analyze ())
|
|
|
|
(defmethod remove-stone :after ((board shape-board) coords)
|
|
(pdebug "shape-board:remove-stone ~a~%" coords)
|
|
(set-2d-stone (shape-board board) coords nil))
|
|
|
|
(defgeneric remove-shape (board sid))
|
|
|
|
(defmethod remove-shape ((board shape-board) sid)
|
|
(pdebug "shape-board:remove-shape ~a~%" sid)
|
|
(let ((stones (aref (shapes-points board) sid)))
|
|
(loop for index from 0 to (1- (length stones)) do
|
|
(progn (pdebug "removing stone ~a~%" (aref stones index))
|
|
(remove-stone board (aref stones index)))))
|
|
(pdebug "shape-sizes to 0~%")
|
|
(setf (aref (shape-sizes board) sid) 0)
|
|
(pdebug "shape-points to nil~%")
|
|
(setf (aref (shapes-points board) sid) (make-array 1 :fill-pointer 0 :adjustable t))
|
|
(pdebug "remove-shape done~%"))
|
|
|
|
|
|
|
|
(defun shapes-to-analyze (board)
|
|
(concatenate 'string (board-to-analyze (shape-board board))
|
|
'(#\newline) " TEXT next-shape-id: " (write-to-string (next-shape-id board)) " length(shapes-points): " (write-to-string (length (shapes-points board)))))
|
|
|