;;; A scopa game
;;; Supports human vs pc
;;; Source in the public domain
;;;
;;; Dom De Felice

(defvar *game*)

(defvar *from-deck*)
(defvar *into-deck*)


(defstruct game
  (pc-player       (make-player))
  (human-player    (make-player))
  (stock           (make-deck))
  (cards           (make-empty-deck))
  (turn            (nth (random 2) '(pc human)))
  ;; Last player that collected cards in current hand.
  (last-to-collect nil))

(defun game-current-player (game)
  (if (eq (game-turn game) 'pc)
      (game-pc-player    game)
      (game-human-player game)))

(defun game-current-opponent (game)
  (if (eq (game-turn game) 'pc)
      (game-human-player game)
      (game-pc-player    game)))

(defstruct player
  "A player of scopa."
  (hand            (make-empty-deck))
  (collected-cards (make-empty-deck))
  ;; Number of scopas in current hand
  (scopas          0)
  ;; Score of current game
  (score           0))

(defstruct card
  "A card."
  suit
  rank)

(defun card-description (card)
  (format nil "[~A OF ~A]" (card-rank card) (card-suit card)))

;; weight-function used by AI to determine how
;; much it is desirable to collect this card.
(defun card-weight (card)
  (cond ((and
	  (= (card-rank card) 7)
	  (eq (card-suit card) 'DENARI))   50)
	((= (card-rank card) 7)            10)
	((eq (card-suit card) 'DENARI)      5)
	((= (card-rank card) 6)             5)
	(t                                  0)))


(defun make-empty-deck ()
  (make-array 40 :element-type 'card :fill-pointer 0))

(defun make-deck ()
  (let ((deck (make-empty-deck)))
    (loop for suit in '(COPPE BASTONI DENARI SPADE) do
	 (loop for rank from 1 to 10 do
	      (vector-push (make-card :suit suit :rank rank) deck)))
    (shuffle-vector deck)))

; Fisher-Yates algorithm to shuffle a vector.
(defun shuffle-vector (vec)
  (let ((last-index (1- (length vec))))
    ; Loop over all items but the 1st
    (loop for i from last-index downto 1 do
       (let ((random-j (random (1+ i)))) ; Random index between 0 and i *inclusive*
	 (rotatef (aref vec i) (aref vec random-j)))))
  vec)


;; Some shortcuts.
(defun deck (shortcut)
  (if (symbolp shortcut)
      (case shortcut
	(stock           (game-stock *game*))
	(table           (game-cards *game*))
	(hand            (player-hand (game-current-player *game*)))
	(opponent-hand   (player-hand (game-current-opponent *game*)))
	(human-hand      (player-hand (game-human-player *game*)))
	(pc-hand         (player-hand (game-pc-player *game*)))
	(collected       (player-collected-cards (game-current-player *game*)))
	(human-collected (player-collected-cards (game-human-player *game*)))
	(pc-collected    (player-collected-cards (game-pc-player *game*))))
      shortcut))


(defun human-turn? ()
  (eq (game-turn *game*) 'human))

(defun pc-turn? ()
  (eq (game-turn *game*) 'pc))

(defun empty-deck? (deck-reference)
  (let ((deck (deck deck-reference)))
    (zerop (length deck))))


(defmacro playing-new-game (&body body)
  `(let ((*game* (make-game)))
     ,@body))

(defmacro from-deck (deck &body body)
  `(let ((*from-deck* (deck ,deck)))
     ,@body))
(defmacro into-deck (deck &body body)
  `(let ((*into-deck* (deck ,deck)))
     ,@body))



(defun draw-card ()
    (vector-pop *from-deck*))

(defun draw-cards (n)
  (loop repeat n collecting (draw-card)))

(defun put-card (card)
  (vector-push card *into-deck*))

(defun put-cards (cards)
  (loop for card in cards doing (put-card card)))

(defun move-card (card)
  (put-card card)
  (setf *from-deck* (delete card *from-deck*)))

(defun move-cards (cards)
  (if (numberp cards)
      (put-cards (draw-cards cards))
      (progn
	(put-cards cards)
	(setq *from-deck*
	      (delete-if (lambda (card) (find card cards)) *from-deck*)))))


(defun deal-cards ()
  (from-deck 'stock
    (into-deck 'pc-hand
      (move-cards 3))
    (into-deck 'human-hand
      (move-cards 3))))




;; Returns a list with all the possible playable options
;; at the current state of the game.
;; Each option is a list whose car is the card to play
;; and whose cdr is the list of cards you would collect
;; from the table.
(defun possible-options ()
  (loop for card across (deck 'hand)
     append (or
	     ;; cons `card' before the list of collected cards.
	     (mapcar (lambda (option) (cons card option))
		     (possible-options-playing card))
	     ;; No cards collected: option contains only the card to play.
	     (list (list card)))))

;; Returns a list with all the possible options
;; by playing `card' on a table with `cards'.
;; Each option is a list of cards you could take.
(defun possible-options-playing (card)
  (let* ((options ())
	 (cards (deck 'table))
	 (same-rank-card-position (position (card-rank card) cards :key #'card-rank)))
    (if same-rank-card-position
	;; Options will be all singleton lists.
	(progn
	  (push (list (aref cards same-rank-card-position)) options)
	  (do* ((next-position (1+ same-rank-card-position) (1+ curr-position))
		(curr-position (position (card-rank card) cards :key #'card-rank :start next-position)
			       (position (card-rank card) cards :key #'card-rank :start next-position)))
	       ((null curr-position))
	    (push (list (aref cards curr-position)) options)))
	;; Options will be lists of cards
	;; that sum up to the rank of `card'.
	(setq options (cards-summing-up-to (card-rank card) cards)))
    options))

;; Returns a list with all the combinations of
;; cards in `deck' which ranks sum up to `value'.
;; Each combination is a list of cards.
(defun cards-summing-up-to (value deck &key (from 0))
  (let ((combinations ())
	(last-index (1- (length deck))))
    (loop for i from from to last-index do
	 (let* ((card (aref deck i))
		(rank (card-rank card)))
	   (if (= rank value)
	       (push (list card) combinations)
	       (if (and (< rank value) (< i last-index))
		   ;; Now we need to find cards summing up to `value' minus `rank'.
		   (let* ((new-value (- value rank))
			  (sub-combinations (cards-summing-up-to new-value deck :from (1+ i))))
		     (loop for sub-combination in sub-combinations do
			  (push (cons card sub-combination) combinations)))))))
    combinations))

(defun option-weight (option)
  (if (= (length option) 1)
      ;; Singleton option means the card will not be collected
      ;; i.e. the more the card weight, the less the option weight.
      (* -1 (card-weight (car option)))
      ;; All cards will be collected, so sum their weights.
      (loop for card in option summing (card-weight card))))

(defun option<=> (a b)
  (let ((a-weight (option-weight a))
	(b-weight (option-weight b)))
    (if (= a-weight b-weight)
	;; Weights being equal, longer sequences are preferred.
	(> (length a) (length b))
	(> a-weight b-weight))))


(defun sort-options-by-relevance (options)
  (sort options #'option<=>))

(defun make-a-decision ()
  (first (sort-options-by-relevance (possible-options))))

(defun read-user-decision ()
  (let ((choices (sort-options-by-relevance (possible-options))))
    (format t "0) Quit the game~%")
    (loop for choice in choices
          for i from 1 do
	 (format t "~A) " i)
	 (describe-option choice))
    (format t "What do you want to do?~%")
    (let ((user-choice (read)))
      (if (zerop user-choice)
	  ()
	  (nth (1- user-choice) choices)))))

(defun apply-decision (decision)
  (let ((played-card     (car decision))
	(collected-cards (cdr decision)))
    (if (null collected-cards)
	;; No cards collected.
	(from-deck 'hand
	  (into-deck 'table
	    (move-card played-card)))
	;; The player collected some cards.
	(progn
	  (setf (game-last-to-collect *game*) (game-turn *game*))
	  (into-deck 'collected
	    (from-deck 'hand
	      (move-card played-card))
	    (from-deck 'table
	      (move-cards collected-cards)))))
    (when (empty-deck? 'table) ; scopa!
      (incf (player-scopas (game-current-player *game*))))
    (next-turn!)))


(defun next-turn! ()
  (setf (game-turn *game*)
	(if (pc-turn?)
	    'human
	    'pc)))



(defun prime-points-of-card (card)
  (let ((prime-points '((7 21) (6 18) (1 16) (5 15) (4 14) (3 13) (2 12) (10 10) (9 10) (8 10))))
    (cadr (assoc (card-rank card) prime-points))))

(defun prime-points (deck)
  (let ((scores (copy-tree '((denari 0) (coppe 0) (bastoni 0) (spade 0)))))
    (loop for card across deck do
	 (let ((suit (card-suit card)))
	   (setf (cadr (assoc suit scores)) (max (cadr (assoc suit scores))
						 (prime-points-of-card card)))))
    (apply #'+ (mapcar #'cadr scores))))

(defun settebello? (card)
  (and
   (eq (card-suit card) 'DENARI)
   (= (card-rank card) 7)))

(defmacro if<=> (exp1 exp2 < = >)
  (let ((val1 (gensym))
	(val2 (gensym)))
    `(let ((,val1 ,exp1)
	   (,val2 ,exp2))
       (cond ((< ,val1 ,val2) ,<)
	     ((> ,val1 ,val2) ,>)
	     (t ,=)))))

(defun hand-scores-assignment ()
  `((more-cards ,(if<=> 20 (length (deck 'human-collected))
			'human
			nil
			'pc))
    (more-coins ,(if<=> 5 (count 'denari (deck 'human-collected) :key #'card-suit)
			'human
			nil
			'pc))
    (settebello ,(if    (find-if #'settebello? (deck 'human-collected))
			'human
			'pc))
    (prime      ,(if<=> (prime-points (deck 'pc-collected)) (prime-points (deck 'human-collected))
			'human
			nil
			'pc))))



(defun describe-card (card)
  (format t "~A" (card-description card)))

(defun describe-cards (deck)
  (format t "~{~15@A~^, ~}~%" (loop for card across deck collecting (card-description card))))


(defun describe-option (option)
  (let ((played-card     (car option))
	(collected-cards (cdr option)))
    (format t "Play ~A" (card-description played-card))
    (if collected-cards
	(format t " taking ~{~A~^, ~}~%" (mapcar #'card-description collected-cards))
	(terpri))))

(defun describe-decision (decision)
  (let ((player-name     (game-turn *game*))
	(played-card     (car decision))
	(collected-cards (cdr decision)))
    (format t "Player ~A plays ~A"
	    player-name
	    (card-description played-card))
    (if collected-cards
	(format t " taking ~{~A~^, ~}~%" (mapcar #'card-description collected-cards))
	(terpri))))

(defun describe-game ()
  (format t "~%On the table: ")
  (describe-cards (deck 'table))
  (format t "Your hand:    ")
  (describe-cards (deck 'human-hand))
  (format t "Stock: ~A card~:p.~%" (length (deck 'stock)))
  (format t "~%It's ~A turn.~%~%" (game-turn *game*)))

(defun describe-score-assignments (assignments)
  (format t "~%SCORE ASSIGNMENTS~%")
  (format t "~%Greatest number of cards: ~A~%" (cadr (assoc 'more-cards assignments)))
  (format t "Greatest number of denari cards: ~A~%" (cadr (assoc 'more-coins assignments)))
  (format t "Settebello: ~A~%" (cadr (assoc 'settebello assignments)))
  (format t "Prime: ~A~%" (cadr (assoc 'prime assignments))))

(defun update-scores (assignments)
  (let ((human (game-human-player *game*))
	(pc    (game-pc-player *game*))
	(human-hand-score (count 'human assignments :key #'cadr))
	(pc-hand-score    (count 'pc    assignments :key #'cadr)))
    (format t "HUMAN~%")
    (format t "~A + ~A + ~A scopa~:P = ~A~%"
	    (player-score human)
	    human-hand-score
	    (player-scopas human)
	    (incf (player-score human) (+ human-hand-score (player-scopas human))))
    (format t "-------~%PC~%")
    (format t "~A + ~A + ~A scopa~:P = ~A~%"
	    (player-score pc)
	    pc-hand-score
	    (player-scopas pc)
	    (incf (player-score pc) (+ pc-hand-score (player-scopas pc))))
    (setf (player-scopas human) 0
	  (player-scopas pc)    0)))


(defun collect-remaining-cards ()
  (let ((player (game-last-to-collect *game*)))
    (when player
      (format t "Player ~A collect all the remaining cards on the table.~%" player)
      (into-deck (if (eq player 'pc) 'pc-hand 'human-hand)
	(from-deck 'table
	  (loop for card across (deck 'table)
	     do (move-card card)))))))


(defun game-step ()
  (describe-game)
  (let ((decision (if (pc-turn?)
		      (make-a-decision)
		      (read-user-decision))))
    (unless decision
      (handle-end-of-game)
      (return-from game-step))
    (describe-decision decision)
    (apply-decision decision)
    (let ((end-of-the-hand (and (empty-deck? 'hand)
				(empty-deck? 'opponent-hand)))
	  (last-hand (empty-deck? 'stock)))
      (if end-of-the-hand
	  ;; Hand ended.
	  (if last-hand
	      ;; Game ended.
	      (progn
		;; Last player who collected any card takes all remaining cards.
		(collect-remaining-cards)
		(let ((assignments (hand-scores-assignment)))
		  (describe-score-assignments assignments)
		  (update-scores assignments)
		  (let ((human-score (player-score (game-human-player *game*)))
			(pc-score    (player-score (game-pc-player    *game*))))
		    (if (and (or (>= human-score 11)
				 (>= pc-score    11))
			     (not (= human-score pc-score)))
			;; The score of 11 has been reached and there is not a tie
			;; i.e. there is a winner.
			(handle-end-of-game)
			;; The score of 11 has not been reached or players are tied:
			;; game goes on.
			(play :human-score human-score :pc-score pc-score)))))
	      ;; Next hand.
	      (progn
		(setf (game-last-to-collect *game*) nil)
		(deal-cards)
		(game-step)))
	  ;; Hand still on.
	  (game-step)))))

(defun handle-end-of-game ()
  (let ((human-score (player-score (game-human-player *game*)))
	(pc-score    (player-score (game-pc-player *game*))))
    (format t "The game is over!~%The winner is ~A with a score of ~A!~%"
	    (if (> human-score pc-score) 'human 'pc) (max human-score pc-score))))


(defun play (&key (human-score 0) (pc-score 0))
  (playing-new-game
   (deal-cards) ; Deal cards to players.
   (from-deck 'stock
     (into-deck 'table
       (move-cards 4))) ; Put four cards on the table.
   (setf (player-score (game-human-player *game*)) human-score
	 (player-score (game-pc-player    *game*)) pc-score)
   ;; Enters game main loop.
   (game-step)))