;;; -*- Mode:LISP; Readtable:CL; Base:10 -*-

(defstruct CARD
  "A thing with a suit and a (pip) value"	
  suit
  value)

(defstruct SUIT
  "A collection of cards with an identifying symbol (one of
spades, hearts, clubs, or diamonds."
  symbol
  cards)

(setq *CARD-VALUES* '(2 3 4 5 6 7 8 9 10 JACK QUEEN KING ACE))


(defstruct (SPADE-CARD (:include card
				 (suit 'spades))				 
		       (:conc-name spade-)))

(defstruct (HEART-CARD (:include card
				 (suit 'hearts))
		       (:conc-name heart-)))

(defstruct (CLUB-CARD (:include card
				(suit 'clubs))
			(:conc-name club-)))

(defstruct (DIAMOND-CARD (:include card
				   (suit 'diamonds))
			(:conc-name diamond-)))

(setq THE-SPADES-SUIT 
  (make-suit :symbol 'spades
	     :cards (mapcar #'(lambda (value) (make-spade-card :value value))
			    *CARD-VALUES*)))

(setq THE-HEARTS-SUIT
  (make-suit :symbol 'hearts
	     :cards (mapcar #'(lambda (value) (make-heart-card :value value))
			    *CARD-VALUES*)))

(setq THE-CLUBS-SUIT
  (make-suit :symbol 'clubs
	     :cards (mapcar #'(lambda (value)  (make-club-card :value value))
			    *CARD-VALUES*)))

(setq THE-DIAMONDS-SUIT
  (make-suit :symbol 'diamonds
	     :cards (mapcar #'(lambda (value)  (make-diamond-card :value value))
			    *CARD-VALUES*)))

(defstruct HAND
  "At most thirteen cards, divided up into suits."
  (spade-cards 'void)
  (heart-cards 'void)
  (club-cards 'void)
  (diamond-cards 'void))

(defstruct PLAYER
  "A side of the table and its hand (its cards)"
  name
  hand)

(setq NORTH (make-player :name 'north :hand (make-hand)))
(setq SOUTH (make-player :name 'south :hand (make-hand)))
(setq EAST (make-player :name 'east :hand (make-hand)))
(setq WEST (make-player :name 'west :hand (make-hand)))

(setq *THE-TABLE* (list NORTH EAST SOUTH WEST))

(defun CARD-VALUE-LESS (card1 card2)
  (< (find-position-in-list (card-value card1) *each-suit*)
     (find-position-in-list (card-value card2) *each-suit*)))

(defun CARD-VALUE-GREATER (card1 card2)
  (> (find-position-in-list (card-value card1) *each-suit*)
     (find-position-in-list (card-value card2) *each-suit*)))

(setq *ALL-SUITS* '(SPADES DIAMONDS HEARTS CLUBS))

(defun CLEAR-ALL-HANDS ()
  (mapcar #'(lambda (player) (setf (player-hand player) (make-hand))) *the-table*))

(defun DEAL (card player)
  (let* ((suit (card-suit card)))
    (selectq suit
	     (spades (hand-spade-cards (player-hand player)))
	     (hearts (hand-heart-cards (player-hand player)))
	     (clubs (hand-club-cards (player-hand player)))
	     (diamonds (hand-diamond-cards (player-hand player))))
	  (if (eq cards-in-suit 'void)
	      (list card)
	    (merge 'list (list card) cards-in-suit 'card-value-less)))
    (format t "~%Player ~A gets a ~A card..." player suit)))

(defun DEAL-HAND ()
  (clear-all-hands)
  (let ((all-cards (append (suit-cards the-spades-suit)
			   (suit-cards the-hearts-suit)
			   (suit-cards the-clubs-suit)
			   (suit-cards the-diamonds-suit))))
    (dotimes (i (print (length all-cards)))
      (let* ((player (nth (remainder i 4.) *the-table*))
	     (card (nth (random (- 52 i)) all-cards)))
	(deal card player)
	(setq all-cards (remq card all-cards))))))