1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283 |
- ;;;; checker-position.lisp
- (in-package #:gamao-impl)
- #|
- CHECKER-POSITION
- A persistent data structure representing the checker position. API:
- type checker-position
- make-checker-position => checker-position
- update-checker-position checker-position location player checkers => checker-position
- checker-position-checkers-at checker-position location player => checkers, owner
- |#
- (defstruct (checker-position (:constructor %make-checker-position (&optional (n 0)))
- (:conc-name %checker-position-))
- "A persistent representation of a checker position. The points are identified by numbers 1, 2, ..., 24; :BAR represents the bar and :OFF represents borne off checkers.
- Creation: MAKE-CHECKER-POSITION
- Updating: UPDATE-CHECKER-POSITION
- Querying: CHECKER-POSITION-CHECKERS-AT
- Rerooting for efficiency: COMMIT-CHECKER-POSITION
- "
- n)
- ;; TODO specify initial position (?)
- (defun make-checker-position ()
- "Return a fresh CHECKER-POSITION having zero checkers everywhere."
- (%make-checker-position 0))
- (defun %checker-position-point-checker-byte (point)
- (byte 4 (1+ (* 5 (1- point)))))
- (defun %checker-position-сolour-checker-byte (point)
- (* 5 (1- point)))
- (defun %checker-position-encode-location (location player)
- (case location
- (:off (case player
- (:black (byte 4 128))
- (:white (byte 4 132))))
- (:bar (case player
- (:black (byte 4 120))
- (:white (byte 4 124))))
- (otherwise (%checker-position-point-checker-byte location))))
- (defun %checker-position-decode-player-on-point (point checker-position)
- (if (logbitp (%checker-position-сolour-checker-byte point) (%checker-position-n checker-position))
- :black
- :white))
- (defun checker-position-checkers-at (checker-position location player)
- "Return the number of checkers at LOCATION of CHECKER-POSITION and their owner.
- LOCATION: :BAR, :OFF, or a point represented by an integer between 1 and 24
- PLAYER: :BLACK, :WHITE or NIL
- If LOCATION is :BAR or :OFF, PLAYER must be non-null.
- If LOCATION is a point, and PLAYER is not null, return the number of checkers of specified player on the point.
- If LOCATION is a point, and PLAYER is null, return the number of checkers of any player on the point.
- If PLAYER is not null, it is returned as the second value. Otherwise, it is the player occupying the point or NIL if no one occupies it."
- (let ((decoded-checkers (ldb (%checker-position-encode-location location player) (%checker-position-n checker-position))))
- (cond ((zerop decoded-checkers) (values 0 player))
- ((member location '(:off :bar)) (values decoded-checkers player))
- (t (if (or (null player) (eq player (%checker-position-decode-player-on-point location checker-position)))
- (values decoded-checkers (%checker-position-decode-player-on-point location checker-position))
- (values 0 player))))))
- (defun update-checker-position (checker-position location player checkers)
- "Return a new checker position differing from CHECKER-POSITION in that PLAYER has CHECKERS checkers on LOCATION."
- (let ((encoded-checkers-value (dpb checkers (%checker-position-encode-location location player) (%checker-position-n checker-position))))
- (%make-checker-position (case location
- ((or :bar :off) encoded-checkers-value)
- (otherwise (ecase player
- (:black (dpb 1 (byte 1 (%checker-position-сolour-checker-byte location)) encoded-checkers-value))
- (:white (dpb 0 (byte 1 (%checker-position-сolour-checker-byte location)) encoded-checkers-value))))))))
- ;; Does not perform any checks! The caller must ensure that it's OK to actually move the checker.
- (defun checker-position-move-checker (checker-position player from to)
- (let* ((checkers-at-start (checker-position-checkers-at checker-position from player))
- (checkers-at-finish (checker-position-checkers-at checker-position to player))
- (checker-removed (update-checker-position checker-position from player (1- checkers-at-start)))
- (checker-put (update-checker-position checker-removed to player (1+ checkers-at-finish))))
- checker-put))
|