;;; -*- 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. J Q K A))

(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
  heart-cards
  club-cards 
  diamond-cards)

(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) *card-values*)
     (find-position-in-list (card-value card2) *card-values*)))	

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

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

(setq *THE-DECK* (append (suit-cards the-spades-suit)
			 (suit-cards the-hearts-suit)
			 (suit-cards the-clubs-suit)
			 (suit-cards the-diamonds-suit)))

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

(defun give-spade (card player)
  (setf (hand-spade-cards (player-hand player))
	(merge 'list (list card) (hand-spade-cards (player-hand player))
	       'card-value-greater)))

(defun give-heart (card player)
  (setf (hand-heart-cards (player-hand player))
	(merge 'list (list card) (hand-heart-cards (player-hand player))
	       'card-value-greater)))

(defun give-club (card player)
  (setf (hand-club-cards (player-hand player))
	(merge 'list (list card) (hand-club-cards (player-hand player))
	       'card-value-greater)))

(defun give-diamond (card player)
  (setf (hand-diamond-cards (player-hand player))
	(merge 'list (list card) (hand-diamond-cards (player-hand player))
	       'card-value-greater)))

(defun DEAL-HAND ()
  (clear-all-hands)
  (let ((the-deck *THE-DECK*))
    (dotimes (i (length the-deck))
      (let* ((player (nth (remainder i 4.) *the-table*))
	     (card (nth (random (- 52 i)) the-deck)))
	(selectq (card-suit card)
	  (spades (give-spade card player))
	  (hearts (give-heart card player))
	  (clubs (give-club card player))
	  (diamonds (give-diamond card player)))
	(setq the-deck (remq card the-deck))))))

(defun DISPLAY-HANDS ()
  (let ((hand (player-hand north))
	(west-hand (player-hand west))
	(east-hand (player-hand east))
	(south-hand (player-hand south)))
    (format t "~%~%~25TH: ~A~%~25TS: ~A~%~25TC: ~A~%~25TD: ~A~%"
	    (mapcar 'card-value (hand-heart-cards hand))
	    (mapcar 'card-value (hand-spade-cards hand))
	    (mapcar 'card-value (hand-club-cards hand))
	    (mapcar 'card-value (hand-diamond-cards hand)))
    (format t "~%~%S: ~A~50TS: ~A"
	    (mapcar 'card-value (hand-spade-cards west-hand))
	    (mapcar 'card-value (hand-spade-cards east-hand)))
    (format t "~%H: ~A~50TH: ~A"
	    (mapcar 'card-value (hand-heart-cards west-hand))
	    (mapcar 'card-value (hand-heart-cards east-hand)))
    (format t "~%C: ~A~50TC: ~A"
	    (mapcar 'card-value (hand-club-cards west-hand))
	    (mapcar 'card-value (hand-club-cards east-hand)))
    (format t "~%D: ~A~50TD: ~A"
	    (mapcar 'card-value (hand-diamond-cards west-hand))
	    (mapcar 'card-value (hand-diamond-cards east-hand)))
    (format t "~%~%~25TH: ~A~%~25TS: ~A~%~25TC: ~A~%~25TD: ~A~%"
	    (mapcar 'card-value (hand-heart-cards south-hand))
	    (mapcar 'card-value (hand-spade-cards south-hand))
	    (mapcar 'card-value (hand-club-cards south-hand))
	    (mapcar 'card-value (hand-diamond-cards south-hand)))))