;;; 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 with ~A packs, ~A suits, ~A stacks, ~A hidden rows>"
	  (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)))))