;;; Code for the Spider Solitaire domain
;;; The underlying structure of a spider game is a deterministic
;;; partially observable problem.
;;; Each problem instance is defined by the initial shuffling of the cards.
;;; Given the actual card state, the outcome of any action (including
;;; dealing a new row) is determined.
(defstruct (spider-problem (:include poproblem) (:constructor create-spider-problem))
"Class of spider solitaire problems."
num-packs ; number of packs of cards (52 each)
num-suits ; number of suits - 1, 2, or 4
num-stacks ; number of stacks
num-hidden-rows ; number of complete rows of hidden cards (may need an extra partial row)
)
(defun make-spider-problem (&key (num-packs 2) (num-suits 4) (num-stacks 10) (num-hidden-rows 4))
"Returns a randomly generated spider solitaire instance."
(create-spider-problem
:num-packs num-packs :num-suits num-suits :num-stacks num-stacks :num-hidden-rows num-hidden-rows
:initial-state (deal (shuffle (make-spider-cards num-packs num-suits))
num-packs num-stacks num-hidden-rows)))
(defmethod print-object ((problem spider-problem) stream)
"Print out the parameters of a particular spider solitaire instance."
(format stream ""
(spider-problem-num-packs problem)
(spider-problem-num-suits problem)
(spider-problem-num-stacks problem)
(spider-problem-num-hidden-rows problem)))
;;;; Spider state
;;; State consists of the "stacks" and the "reserve" of as-yet-undealt cards.
;;; Each stack is a list of cards, possibly empty. The visible cards are
;;; always at the front and the hidden cards at the end. For example,
;;; a stack with the jack and ten of hearts (in order) and three hidden cards
;;; looks like (10H JH ??? ??? ???).
;;; State also includes the list of completed suits (each a list of 13 cards).
(defstruct spider-state
"The actual state of a spider solitaire game. Agent perceives a subset."
stacks ; Vector of stacks, each a list of cards
reserve ; Single list of cards
all-hidden-cards ; Combines reserve with hidden cards in stacks; used only in percept
(completed nil) ; List of completed suits
)
(defmethod copy-state ((state spider-state))
"Return a copy of the spider solitaire state sharing no structure."
(make-spider-state
:stacks (map 'vector #'(lambda (stack) (copy-list stack)) (spider-state-stacks state))
:reserve (copy-list (spider-state-reserve state))
:all-hidden-cards (copy-list (spider-state-all-hidden-cards state))
:completed (copy-list (spider-state-completed state))))
(defmethod print-object ((state spider-state) stream)
"Print out the spider state as it would be seen by a player.
Stacks are shown in decreasing order left-to-right."
(let ((stacks (spider-state-stacks state)))
(loop for i from 0 to (1- (array-dimension stacks 0)) do
(format stream "~%~2@A " i)
(loop for card in (reverse (aref (spider-state-stacks state) i)) do
(format stream " ") (print-object card stream)))
(format stream "~%~%Reserve: ")
(format stream (dots (length (spider-state-reserve state))))
(format stream "~%Completed: ")
(loop for suit in (spider-state-completed state) do (print-object (last1 suit) stream))))
;;;; Spider cards
(defstruct card
"A card has a suit and number, and may be hidden."
suit ; One of S, H, D, C
number ; One of 1 - 13 (AKQJ names generated for output only)
(hidden? t) ; True iff card is hidden on table
)
(defmethod print-object ((card card) stream)
"Print a card in human-readable form; hidden cards are written as ???."
(if (card-hidden? card) (format stream "???")
(format stream "~2@A~A" (card-number-display (card-number card)) (card-suit card))))
(defun card-number-display (n)
(case n (1 'A) (13 'K) (12 'Q) (11 'J) (t n)))
(defun card-unknown? (card)
"Return true iff card is *unknown*, i.e., a hidden card in the
percept supplied to an agent."
(null (card-suit card)))
(defun make-suit (s)
"Return a list of cards in a single suit."
(loop for i from 1 to 13 collect (make-card :suit s :number i)))
(defun make-spider-cards (num-packs num-suits &aux (cards nil))
"Return the complete list of 52*num-packs cards for num-suits distinct suits."
(cond ((= num-suits 1)
(loop for i from 1 to (* 4 num-packs) do
(setf cards (append (make-suit 'H) cards))))
((= num-suits 2)
(loop for i from 1 to (* 2 num-packs) do
(setf cards (append (make-suit 'H) (make-suit 'S) cards))))
((= num-suits 4)
(loop for i from 1 to (* 1 num-packs) do
(setf cards (append (make-suit 'S) (make-suit 'H) (make-suit 'D) (make-suit 'C) cards)))))
cards)
(defun hide (card)
"Return a copy of card with its hidden bit set."
(let ((new (copy-card card)))
(setf (card-hidden? new) t)
new))
(defun unhide (card)
"Return a copy of card with its hidden bit unset."
(let ((new (copy-card card)))
(setf (card-hidden? new) nil)
new))
(defun deal (cards num-packs num-stacks num-hidden-rows)
"Given the (shuffled) cards for the game, set up the initial state."
;; There are 52*num-packs cards. The number of complete hidden rows
;; is given; the number of cards in the partial hidden row, if any,
;; is (remainder 52*num-packs num-stacks).
(let ((stacks (make-array num-stacks :initial-element nil)))
(loop for i from 1 to num-stacks do
(loop for row from 1 to num-hidden-rows do
(push (hide (pop cards)) (aref stacks (1- i)))))
(loop for i from 1 to (rem (* 52 num-packs) num-stacks) do
(push (hide (pop cards)) (aref stacks (1- i))))
(loop for i from 1 to num-stacks do
(push (unhide (pop cards)) (aref stacks (1- i))))
(make-spider-state :stacks stacks :reserve cards)))
(defun count-same-suit-sequence (cards &optional (previous-number nil) (previous-suit nil) (n 0))
"Return length of maximal ascending same-suit sequence,
starting at front. E.g., ((2 H) (3 H) (4 S)) gives 2."
(if (or (null cards)
(card-hidden? (first cards))
(and previous-suit (not (eql (card-suit (first cards)) previous-suit)))
(and previous-number (not (eql (card-number (first cards)) (1+ previous-number)))))
n
(count-same-suit-sequence (rest cards) (card-number (first cards)) (card-suit (first cards)) (1+ n))))
;;;; Spider actions
;;; An action can be 'new-row, in which case 1 card from
;;; the reserve is added to each stack. Otherwise, an action
;;; moves a continuous descending sequence of k same-suit cards
;;; from one stack to another. If the destination stack is not empty,
;;; the head of the subsequence moved must be one less
;;; then the top card (which can be of any suit) of the destination.
;;; For example, with these two stacks:
;;; 1: ??? ??? JH 10H
;;; 2: ??? 3C 9S 8S
;;; we can move the 9S and 8S onto the 10H:
;;; 1: ??? ??? JH 10H 9S 8S
;;; 2: ??? 3C
;;; To eliminate pointless moves we make some modifications to
;;; the standard rules:
;;; 1) never move part of a sequence onto another sequence of the same suit
;;; unless the destination sequence starts with a higher card;
;;; 2) never move an entire stack fron one space to another;
;;; 3) never move *part* of a same-suit sequence onto an empty space.
;;; 4) new-row is allowed even if there are empty spaces.
(defstruct spider-move
k ; number of cards to move
from ; origin stack
to ; destination stack
)
(defmethod actions ((problem spider-problem) state &aux (moves nil))
"Return a list of actions legal in state."
(let ((stacks (spider-state-stacks state)))
(loop for to from 0 to (1- (array-dimension stacks 0)) do
(let ((to-stack (aref stacks to)))
(loop for from from 0 to (1- (array-dimension stacks 0)) do
(unless (or (= from to) (null (aref stacks from)))
(let* ((from-stack (aref stacks from))
(kmax (count-same-suit-sequence from-stack)))
(if to-stack
(let ((from-top (card-number (first from-stack)))
(from-suit (card-suit (first from-stack)))
(to-top (card-number (first to-stack)))
(to-suit (card-suit (first to-stack)))
(to-kmax (count-same-suit-sequence to-stack)))
(when (and (> to-top from-top) (>= (+ from-top kmax) to-top)
(or (not (eq from-suit to-suit))
(> (+ to-top to-kmax) (+ from-top kmax))))
(push (make-spider-move
:k (- to-top from-top) :from from :to to) moves)))
(unless (= kmax (length from-stack)) ; never move a whole stack to another empty space!
(push (make-spider-move :k kmax :from from :to to) moves))))))))
(when (and (spider-state-reserve state)
; removed (notany #'null stacks) for now
)
(push 'new-row moves))
moves))
(defmethod result ((problem spider-problem) move state &aux (cards nil))
"Return the new state resulting from move."
(if (equalp :stop move) (return-from result state))
(let* ((new (copy-state state))
(stacks (spider-state-stacks new)))
(cond ((eq move 'new-row)
(loop for i from 0 to (1- (array-dimension stacks 0)) do
(push (unhide (pop (spider-state-reserve new))) (aref stacks i))
(collect-if-complete i new)
(flip-if-exposed i new)))
(t (let ((k (spider-move-k move)) (from (spider-move-from move)) (to (spider-move-to move)))
(loop for i from 1 to k do
(push (pop (aref stacks from)) cards))
(loop for card in cards do
(push card (aref stacks to)))
(collect-if-complete to new)
(flip-if-exposed from new)
(flip-if-exposed to new))))
new))
(defun collect-if-complete (i state &aux (suit nil) (stacks (spider-state-stacks state)))
(when (= 13 (count-same-suit-sequence (aref stacks i)))
(setf suit nil)
(loop for j from 1 to 13 do
(push (pop (aref stacks i)) suit))
(push nil (spider-state-completed state))
(loop for card in suit do
(push card (first (spider-state-completed state))))))
(defun flip-if-exposed (i state &aux (stacks (spider-state-stacks state)))
(when (and (aref stacks i)
(card-hidden? (first (aref stacks i))))
(setf (first (aref stacks i)) (unhide (first (aref stacks i))))))
(defmethod step-cost ((problem spider-problem) state1 action state2)
"Return the cost of moving from state1 to state2 by action.
1 point per step, -100 (i.e., +100 reward) for completing a suit,
-200 for finishing."
(if (equalp action :stop) (return-from step-cost 0))
(+ 1
(* -100 (- (length (spider-state-completed state2))
(length (spider-state-completed state1))))
(if (= (length (spider-state-completed state2))
(* 4 (spider-problem-num-packs problem)))
-200 0)))
(defmethod goal-test ((problem spider-problem) state)
"Return true iff game is over or no legal moves remain."
(or
(= (length (spider-state-completed state)) (* 4 (spider-problem-num-packs problem)))
(null (actions problem state))))
;;;; Spider percept
(defmethod get-percept ((problem spider-problem) state)
"Return a copy of state with all hidden cards wiped, i.e., suit and number
information is removed."
(make-spider-state
:stacks (map 'vector #'(lambda (stack) (mapcar #'wipe-if-hidden stack)) (spider-state-stacks state))
:reserve (mapcar #'wipe-if-hidden (spider-state-reserve state))
:all-hidden-cards (let ((cards nil))
(map nil #'(lambda (stack)
(setf cards (append (stack-hidden-cards stack) cards)))
(spider-state-stacks state))
(shuffle (append cards (spider-state-reserve state))))
:completed (spider-state-completed state)))
(defun wipe-if-hidden (card)
"If card is hidden, return a copy with suit and number removed."
(if (card-hidden? card)
(make-card :hidden? t :number nil :suit nil)
card))
(defun stack-hidden-cards (stack)
(cond ((null stack) nil)
((card-hidden? (first stack)) stack)
(t (stack-hidden-cards (rest stack)))))