#!/usr/local/kalypso
;
; fish
;
; the card game
;

(defun pick-card ()
  (let (ret)
    (cond (deck
    	   (setq ret (car deck))
    	   (setq deck (cdr deck))
    	   ret
	   )
	  (t nil)
	  )
    )
  )

(defun deal (number-hands cards/hand)
  (let (n m (hands (new-vector number-hands)))
    (setq n 0)
    (while (< n cards/hand)
	   (setq m 0)
	   (while (< m number-hands)
		  (store hands m (cons (pick-card) (fetch hands m)))
		  (++ m)
		  )
	   (++ n)
	   )
    hands
    )
  )


;
; a person is a hand and a group of sets-of-four
;

(defun set-person-hand (person hand) (store person 0 hand))
(defun get-person-hand (person) (fetch person 0))
(defun set-person-sets (person sets) (store person 1 sets))
(defun get-person-sets (person) (fetch person 1))
(defun set-person-has (person has) (store person 2 has))
(defun get-person-has (person) (fetch person 2))
(defun set-person-hasnt (person hasnt) (store person 3 hasnt))
(defun get-person-hasnt (person) (fetch person 3))

(defun new-person (hand sets)
  (let ((person (new-vector 4)))
    (set-person-hand person hand)
    (set-person-sets person sets)
    (set-person-has person nil)
    (set-person-hasnt person nil)
    person
    )
  )

(defun init ()
  (setq deck (shuffle standard-deck))
  (let ((hands (deal 2 start-hand-size)))
    (setq human (new-person (fetch hands 0) nil))
    (setq computer (new-person (fetch hands 1) nil))
    )
  )

(defun find-rank (cards rank)
  (cond (cards
	 (cond ((= rank (caar cards))
		cards
		)
	       (t (find-rank (cdr cards) rank))
	       )
	 )
	(t nil)
	)
  )

(defun count-rank (cards rank)
  (cond (cards
	 (setq cards (find-rank cards rank))
	 (cond (cards
		(1+ (count-rank (cdr cards) rank))
		)
	       (t 0)
	       )
	 )
	(t 0)
	)
  )

(defun check-sets (person rank)
  (let ((cards (get-person-hand person)) (card))
    (cond ((= (count-rank cards rank) 4)
	   (while (setq card (assoc-rank cards rank))
		  (setq cards (remove-card cards card))
		  )
	   (set-person-hand person cards)
	   (set-person-sets person (cons rank (get-person-sets person)))
	   rank
	   )
	  (t nil)
	  )
    )
  )
    
(defun add-history (ranks rank)
  (cons rank
  	(cond ((member? rank ranks)
	       (delete rank ranks)
	       )
	      (t ranks)
	      )
	)
  )

(defun delete-history (ranks rank)
  (delete rank ranks)
  )

(defun clip-to-length (len items)
  (cond ((and items (>= len 0))
	 (cons (car items) (clip-to-length (1- len) (cdr items)))
	 )
	(t nil)
	)
  )

;
; history
;  retain information about who asked for which cards
;

(defun history (person opponent rank)
  (set-person-has person (add-history (get-person-has person) rank))
  (set-person-hasnt person (delete-history (get-person-hasnt person) rank))
  (set-person-has opponent (delete-history (get-person-has opponent) rank))
  (set-person-hasnt opponent
		    (clip-to-length 5
				    (add-history (get-person-hasnt opponent)
						 rank
						 )
				    )
		    )
  )

(defun play (person opponent rank person-name opponent-name print-draw)
  (cond ((assoc-rank (get-person-hand person) rank)
	 (history person opponent rank)
  	 (let (new-card new-cards add-rank)
    	   (cond ((assoc-rank (get-person-hand opponent) rank)
	   	  (while (setq new-card (assoc-rank (get-person-hand opponent) rank))
		  	 (setq new-cards (cons new-card new-cards))
		  	 (set-person-hand opponent
				   	  (remove-card (get-person-hand opponent)
						       new-card
						       )
				   	  )
		  	 )
	   	  (add-message (spatom person-name " got "
				   (length new-cards) " "
				   )
			   )
	   	  (add-message (sprint-card-rank (car new-cards)))
	   	  (cond ((> (length new-cards) 1)
		  	 (add-message "s")
		  	 )
		 	)
	   	  (message ".")
	   	  (set-person-hand person (conc new-cards
					 	(get-person-hand person)
					 	)
			    	   )
	   	  (cond ((setq add-rank (check-sets person rank))
		  	 (add-message (spatom person-name " made a set of "))
		  	 (add-message (sprint-rank add-rank))
		  	 (message "s.")
		  	 )
		 	)
		  (message (spatom person-name " get to guess again."))
	   	  t
	   	  )
	  	 (t
	   	  (message (spatom opponent-name " say \"Go Fish\".\n"))
	   	  (setq new-card (pick-card))
	   	  (cond (new-card
		  	 (cond (print-draw
		  	 	(add-message (spatom person-name
						     " picked the "
						     )
					     )
		  	 	(add-message (sprint-card new-card))
		  	 	(message ".")
			 	)
			       )
	   	  	 (set-person-hand person (cons new-card
						       (get-person-hand person)
						       )
				   	  )
		  	 (cond ((= (car new-card) rank)
			 	(message (spatom person-name " got it!\n"))
	   		 	(cond ((setq add-rank (check-sets person (car new-card)))
		  		       (add-message (spatom person-name
							    " made a set of "
							    )
						    )
		  		       (add-message (sprint-rank add-rank))
		  		       (message "s.")
		  		       )
		 	       	      )
		  		(message (spatom person-name
						 " get to guess again.\n"
						 )
					 )
			 	t
			 	)
			       (t
	   		 	(cond ((setq add-rank (check-sets person (car new-card)))
		  		       (add-message (spatom person-name
							    " made a set of "
							    )
						    )
		  		       (add-message (sprint-rank add-rank))
		  		       (message "s.")
		  		       )
		 	       	      )
			 	nil)
			       )
		  	 )
		 	(t
		  	 (message "End of the deck.")
	   	  	 nil
		  	 )
		 	)
	   	  )
	  	 )
    	   )
	 )
	(t
	 (add-message (spatom person-name " don't have any "))
	 (add-message (sprint-rank rank))
	 (message "s.  Try again.")
	 t
	 )
  	)
  )

(defun find-has (ranks cards)
  (cond (cards
	 (cond ((member? (caar cards) ranks)
		(caar cards)
		)
	       (t (find-has ranks (cdr cards)))
	       )
	 )
	(t nil)
	)
  )

(defun find-hasnt (ranks cards)
  (cond (cards
	 (cond ((member? (caar cards) ranks)
		(find-hasnt ranks (cdr cards))
		)
	       (t
		(cons (caar cards)
		      (find-hasnt ranks (cdr cards))
		      )
		)
	       )
	 )
	(t nil)
	)
  )

(defun pick-random (items)
  (nth (random (length items)) items)
  )

(defun think (person opponent opponent-has-picked)
  (let (rank ranks)
    (cond ((setq rank (find-has (get-person-has opponent)
			      	(get-person-hand person)
			      	)
	       	 )
;	   (patom "I know you have " rank "\n")
	   rank
	   )
	  (t
	   ;
	   ; 75% chance of using the hasnt information
	   ; in choosing a move.  This is make it possible
	   ; to choose a random card even if it is thought to
	   ; not be in the opponents hand.  the opponent may
	   ; have just drawn it, after all.
	   ;
	   (cond ((and (< (random 100) 75)
	    	       (setq ranks (find-hasnt (get-person-hasnt opponent)
				  	       (get-person-hand person)
				  	       )
			     )
		       )
;	   	  (patom "I know you dont not have " ranks "\n")
	   	  (pick-random ranks)
	   	  )
	  	 (t
;	   	  (patom "I can't decide\n")
	   	  (setq ranks (find-hasnt picked-this-time
		  			  (get-person-hand person)
					  )
			)
		  (cond (ranks
		  	 (pick-random ranks)
			 )
			(t
			 (car (pick-random (get-person-hand person)))
			 )
			)
	   	  )
	  	 )
	   )
	  )
    )
  )

(defun computer-turn (person opponent)
  (let (rank picked-this-time)
    (while t
  	   (cond ((check-empty person "My" "I" nil)
		  (return nil)
		  )
		 )
	   (update-display)
	   (setq rank (think person opponent picked-this-time))
    	   (add-message "I ask you for ")
	   (add-message (sprint-rank rank))
	   (message "s.")
    	   (cond ((play person opponent rank "I" "You" nil)
		  )
		 (t (return t))
		 )
	   (setq picked-this-time (cons rank picked-this-time))
	   )
    )
  )

(defun human-turn (person opponent)
  (let (pick)
    (while t
  	   (cond ((check-empty person "Your" "you" t)
		  (return nil)
		  )
		 )
	   (update-display)
	   (add-message "Your turn -> ")
	   (refresh)
	   (setq pick (read-response))
	   (cond ((and (nil? pick) error-number)
		  (message "Good bye.")
	   	  (return nil)
		  )
		 )
	   (cond ((and (symbol? pick)
		       (string? (get-name pick))
		       )
		  (cond ((> (strlen (get-name pick)) 1)
			 (setq pick (symbol (scons (scar (get-name pick)) nil)
					    system-dictionary
					    )
			       )
			 )
			)
		  (cond ((and (<= ~a (scar (get-name pick)))
		       	      (<= (scar (get-name pick)) ~z)
		       	      )
		  	 (setq pick (symbol (scons (+ (- ~A ~a)
					       	      (scar (get-name pick))
					       	      )
					    	   nil
					    	   )
				     	    system-dictionary
				     	    )
			       )
			 )
			)
		  )
		 )
		  
	   (message (sprint-rank pick))
	   (cond ((play person opponent pick "You" "I" t)
		  )
		 (t (return t))
		 )
	   )
    )
  )

(defun check-empty (person pronoun1 pronoun2 print-card?)
  (cond ((get-person-hand person)
	 nil
	 )
	(t
	 (let ((new-card (pick-card)))
	   (cond (new-card
		  (add-message (spatom pronoun1 " hand is empty; " pronoun2))
		  (cond (print-card?
		   	 (add-message " draw the ")
		   	 (add-message (sprint-card new-card))
			 )
			(t
			 (add-message " draw a card")
			 )
			)
		  (message ".")
		  (set-person-hand person (cons new-card nil))
		  nil
		  )
		 (t t)
		 )
	   )
	 )
	)
  )

(defun end-game ()
  (message "The game is over.")
  (message (spatom "I have " (length (get-person-sets computer)) " sets."))
  (message (spatom "You have " (length (get-person-sets human)) " sets."))
  (cond ((< (length (get-person-sets human))
	    (length (get-person-sets computer))
	    )
	 (message "I win.")
	 t
	 )
	((> (length (get-person-sets human))
	    (length (get-person-sets computer))
	    )
	 (message "You win.")
	 nil
	 )
	(t
	 (message "We tie.")
	 nil
	 )
	)
  )

(defun fish ()
  (init)
  (start-display)
  (let (player)
    (while t
	   (cond ((not deck)
		  (return nil)
		  )
		 )
	   (cond ((human-turn human computer)
	   	  )
		 (t
		  (return nil)
		  )
		 )
	   (cond ((not deck)
		  (return nil)
		  )
		 )
	   (cond ((computer-turn computer human)
		  )
		 (t
		  (return nil)
		  )
		 )
	   )
    (end-game)
    (end-display)
    )
  )

;
; user interface portion
;

(setq person-hand-position '(0 2))
(setq person-sets-position '(28 2))
(setq computer-hand-position '(40 2))
(setq computer-sets-position '(68 2))
(setq deck-position '(38 15))
(setq min-message 20)
(setq current-message min-message)
(setq max-message 23)
(setq message-x 0)

(defun start-display ()
  (initscr)
  (noecho)
  (crmode)
  (setq max-message (- (getLINES) 1))
  )

(defun end-display ()
  (endwin)
  )

(defun update-display ()
  (let ((human-width) (computer-width))
    (clear-lines 0 (- min-message 1))
    (setq human-width (draw-hand (sort (get-person-hand human) bigger-card)
	     		       	 (car person-hand-position)
	     		       	 (cadr person-hand-position)
	     		       	 min-message
	     		       	 )
	  )
    (setq computer-width (draw-blank-hand (get-person-hand computer)
		   			  (car computer-hand-position)
		   			  (cadr computer-hand-position)
		   			  min-message
		   			  "Fish"
		   			  )
	  )
    (draw-blank-card (car deck-position)
		     (cadr deck-position)
		     (sprint (length deck))
		     )
    (cond ((get-person-sets human)
	   (draw-hand (get-person-sets human)
		      (+ human-width 3)
		      (cadr person-sets-position)
		      min-message
		      )
	   )
	  )
    (cond ((get-person-sets computer)
	   (draw-hand (get-person-sets computer)
		      (+ computer-width 3)
		      (cadr computer-sets-position)
		      min-message
		      )
	   )
	  )
    )
  )

(defun clear-lines (from to)
  (while (<= from to)
	 (move from 0)
	 (clrtoeol)
	 (++ from)
	 )
  )

(defun next-message-line (num)
  (cond ((>= (+ num 1) max-message)
	 min-message
	 )
	(t (+ num 1))
	)
  )

(defun message (string)
  (move (next-message-line current-message) 0)
  (clrtoeol)
  (move-add-str current-message message-x string)
  (setq current-message (next-message-line current-message))
  (refresh)
  (setq message-x 0)
  )

(defun add-message (string)
  (move (next-message-line current-message) 0)
  (clrtoeol)
  (move-add-str current-message message-x string)
  (setq message-x (+ message-x (strlen string)))
  )

(defun get-line ()
  (let ((result nil) (c) (x))
    (move current-message message-x)
    (setq x message-x)
    (while t
	   (refresh)
	   (setq c (getch))
  	   (cond ((= c ~\n)
	 	  (return nil)
	 	  )
		 ((= c ~\r)
	 	  (return nil)
	 	  )
		 ((= c ~\004)
		  (setq result (scons c result))
	 	  (return nil)
	 	  )
		 ((= c ~\010)
		  (cond (result
		  	 (setq result (scdr result))
			 (-- x)
			 (move current-message x)
			 (clrtoeol)
			 )
			)
		  )
		 ((= c ~\025)
		  (setq result nil)
		  (setq x message-x)
		  (move current-message x)
		  (clrtoeol)
		  )
		 (t
		  (setq result (scons c result))
		  (addch c)
		  (++ x)
		  )
		 )
	   )
    (move current-message message-x)
    (sreverse result)
    )
  )
	     
(defun read-response ()
  (let ((line))
    (setq line (get-line))
    (cond ((and line (= (scar line) ~\004))
	   (setq error-number 1)
	   nil
	   )	
    	  (t
    	   (sread line)
	   )
	  )
    )
  )

; a library of simple functions dealing with "cards".  a deck
; of cards is just an arbitrary list of cards.  a card is
; a two element list of the form (rank suit).
; Bart 1/87


; suit and rank ordering
(setq !rank-list '(A 2 3 4 5 6 7 8 9 10 J Q K))
(setq !suit-list '(C D H S))

; generate a standard deck of playing cards.  this will
; probably be called only once, and the result saved,
; as (shuffle) generates a completely new deck anyway
(defun gen-deck ()
	(let ((ranks !rank-list) (suits) (deck '()))
	  (while ranks
		 (setq suits !suit-list)
		 (while suits
			(setq deck (cons (list (car ranks) (car suits)) deck))
			(setq suits (cdr suits))
			)
		 (setq ranks (cdr ranks))
		 )
	  deck)
	)

; shuffle the deck
; put some randomly chosen card at the front,
; then shuffle the rest of the deck
(defun shuffle (deck)
	(and
		deck
		(let ((choice (add1 (random (length deck)))))
		  (cons (nthelem choice deck) (shuffle 
	 		       (append (cut-deck deck (- 1 choice))
	 			       (cut-deck deck choice))))
		)
	)
)

; return a portion of the deck
; if position is negative, return all the cards above and including it
; if position is positive, return all the cards below it
(defun cut-deck (deck position)
	(cond
		((negative? position)
			(reverse (nthcdr (add (length deck) position) 
			 (reverse deck))))
		((positive? position)
			(nthcdr position deck))
	)
)

; compare two cards.  return true if they are ordered (larger) (smaller).
; note that this code refers to the globals !rank-list and !suit-list,
; so one can easily order the deck as needed (e.g. make the ace high)
(defun bigger-card (c1 c2)
	(cond
		( (gt? 
			(length (member? (car c2) !rank-list)) 
			(length (member? (car c1) !rank-list)))
		't)
		( (and 
			(equal? (car c1) (car c2)) 
			(gt? 
				(length (member? (cadr c2) !suit-list)) 
				(length (member? (cadr c1) !suit-list))))
		't)
	)
)

;
; find a card by rank
;

(defun assoc-rank (deck rank)
  (cond (deck
	 (cond ((= rank (caar deck))
	 	(car deck)
	 	)
	       (t (assoc-rank (cdr deck) rank))
	       )
	 )
	(t nil)
	)
  )

;
; find a card by suit
;

(defun assoc-suit (deck suit)
  (cond (deck
	 (cond ((= suit (cadar deck))
	 	(car deck)
	 	)
	       (t (assoc-suit (cdr deck) suit))
	       )
	 )
	(t nil)
	)
  )

;
; remove a card from a deck
;

(defun remove-card (deck card)
  (cond (deck
	 (cond ((= card (car deck))
		(remove-card (cdr deck) card)
		)
	       (t
		(cons (car deck)
		      (remove-card (cdr deck) card)
		      )
		)
	       )
	 )
	(t nil)
	)
  )

(defun sprint-rank (rank)
  (cond ((= 'K rank)
	 "King"
	 )
	((= 'Q rank)
	 "Queen"
	 )
	((= 'J rank)
	 "Jack"
	 )
	((= 'A rank)
	 "Ace"
	 )
	(t
	 (spatom rank)
	 )
	)
  )

(defun sprint-card-rank (card)
  (sprint-rank (car card))
  )

(defun sprint-suit (suit)
  (cond ((= 'S suit)
	 "Spades"
	 )
	((= 'H suit)
	 "Hearts"
	 )
	((= 'D suit)
	 "Diamonds"
	 )
	((= 'C suit)
	 "Clubs"
	 )
	)
  )

(defun sprint-card-suit (card)
  (sprint-suit (cadr card))
  )

(defun sprint-card (card)
  (strcat (sprint-card-rank card) " of " (sprint-card-suit card))
  )

(defun sprint-ranks (ranks)
  (cond (ranks
	 (strcat (sprint-rank (car ranks))
	 	 (cond ((cdr ranks)
	       		(strcat ", " (sprint-ranks (cdr ranks)))
			)
		       (t "")
		       )
		 )
	 )
	(t "")
	)
  )

(defun sprint-card-ranks (cards)
  (cond (cards
	 (strcat (sprint-card-rank (car cards))
	 	 (cond ((cdr cards)
	       		(strcat ", " (sprint-card-ranks (cdr cards)))
			)
	       	       (t "")
	       	       )
	 	 )
	 )
	(t "")
	)
  )

(defun sprint-cards (cards)
  (cond (cards
	 (strcat (sprint-card (car cards))
	 	 (cond ((cdr cards)
	       		(strcat ", " (sprint-cards (cdr cards)))
			)
	       	       (t "")
	       	       )
	 	 )
	 )
	(t "")
	)
  )

;
; drawcard.l
;
; curses interface for cards
;

(setq card-width 7)
(setq card-height 5)

(setq card-outline '(
	"+-----+"
	"|     |"
	"|     |"
	"|     |"
	"+-----+"
	)
	)
			     

(defun move-add-ch (y x c)
  (move y x)
  (addch c)
  )

(defun move-add-str (y x s)
  (move y x)
  (addstr s)
  )

(defun draw-outline (x y)
  (let ((stuff card-outline))
    (while stuff
	   (move-add-str y x (car stuff))
	   (setq stuff (cdr stuff))
	   (++ y)
	   )
    )
  )

(defun draw-card (card x y)
  (draw-outline x y)
  (let ((label (spatom card)))
    (move-add-str (+ y 1) (+ x 1) label)
    (move-add-str (+ y (- card-height 2))
		  (+ x (- card-width (+ (strlen label) 1)))
		  label
		  )
    )
  )

(defun draw-blank-card (x y label)
  (draw-outline x y)
  (move-add-str (+ y (/ card-height 2))
		(+ x (/ (- card-width (strlen label)) 2))
		label
		)
  )

(defun draw-hand-internal (hand x y)
  (cond (hand
  	 (cond ((>= (+ y card-height) max-y)
	 	(draw-hand hand (+ start-x card-width 2) start-y max-y)
	 	)
	       (t
	 	(draw-card (car hand) x y)
	 	(draw-hand-internal (cdr hand) (+ x 1) (+ y 2))
		)
	       )
	 )
	)
  )

(setq right-most 0)

(defun draw-hand (hand start-x start-y max-y)
  (setq right-most start-x)
  (draw-hand-internal hand start-x start-y)
  (+ right-most card-width)
  )

(defun draw-blank-hand-internal (hand x y label)
  (cond (hand
  	 (cond ((>= (+ y card-height) max-y)
	 	(draw-blank-hand hand (+ start-x card-width 2) start-y max-y label)
	 	)
	       (t
	 	(draw-blank-card x y label)
	 	(draw-blank-hand-internal (cdr hand) (+ x 1) (+ y 2) label)
		)
	       )
	 )
	)
  )

(defun draw-blank-hand (hand start-x start-y max-y label)
  (setq right-most start-x)
  (draw-blank-hand-internal hand start-x start-y label)
  (+ right-most card-width)
  )

(setq standard-deck (gen-deck))
(setq start-hand-size 6)

(set-random (time))
(fish)
