Corwin Brust
2c700b7739
Shared hand row gains a region-tag: tagged hands carry a cg-regions click map (cards -> (hand . i)) and a card-size slider in the same image. cg-core adds cg-mouse-action, cg-card-click, zoom commands, cg-card-scale (folded into cg-scale), and a cg-render-apply base for scale/zoom. Seven hand games are now click-to-position (Scopa/Casino/Spite click-to-play), with [mouse-1] and +/-/0 bound. Adds cgt-hand-regions; suite 111/111.
547 lines
22 KiB
EmacsLisp
547 lines
22 KiB
EmacsLisp
;;; cg-handfoot.el --- Hand and Foot, a partnership rummy -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2026 Corwin Brust
|
|
|
|
;; Author: Corwin Brust <corwin@bru.st>
|
|
;; Maintainer: Corwin Brust <corwin@bru.st>
|
|
;; Version: 1.0.60
|
|
;; Package-Requires: ((emacs "26.1"))
|
|
;; Keywords: games
|
|
;; URL: https://code.bru.st/corwin/card-game.el
|
|
|
|
;; This program is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Hand & Foot, a Canasta cousin played in partnerships. Each player is
|
|
;; dealt two packets: a "hand" played first and a "foot" taken up once the
|
|
;; hand is gone. Partners build *books* -- three or more cards of one
|
|
;; rank, suits ignored -- on the table; a book of seven is complete (a
|
|
;; "pile"), clean if it holds no wild card and dirty if it does. Twos and
|
|
;; Jokers are wild. You go out, ending the round, once your side owns at
|
|
;; least two complete books and you can empty your foot.
|
|
;;
|
|
;; You partner the North player against East and West, all three of them
|
|
;; computer opponents. Mark cards with SPC, meld them with m, lay off onto
|
|
;; a book with l, and discard with RET.
|
|
;;
|
|
;; This is a deliberately streamlined Hand & Foot: it omits picking up the
|
|
;; discard pile, the red-three bonus, and round-by-round minimum-meld
|
|
;; requirements, keeping the books, wilds, hand/foot, and partnership
|
|
;; scoring that give the game its character. Cards use the package cons
|
|
;; (SUIT . RANK), RANK 0 (Ace) .. 12 (King), with jokers as (joker . 0).
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'eieio)
|
|
(require 'cg-core)
|
|
(require 'cg-rummy)
|
|
|
|
(defcustom cg-handfoot-target 5000
|
|
"Points a partnership needs to win Hand & Foot."
|
|
:type 'integer :group 'card-games)
|
|
|
|
(defconst cg-handfoot--names ["You" "West" "North" "East"]
|
|
"Seat labels; North is your partner.")
|
|
|
|
(defclass cg-handfoot-game (cg-rummy-game)
|
|
((vname :initform "Hand & Foot"))
|
|
"A game of Hand & Foot.")
|
|
|
|
;;;; Cards
|
|
|
|
(defun cg-hf--wild-p (card)
|
|
"Return non-nil when CARD is wild (a Joker or a Two)."
|
|
(or (cg-rummy-joker-p card) (= (cdr card) 1)))
|
|
|
|
(defun cg-hf--three-p (card)
|
|
"Return non-nil when CARD is a three (never meldable)."
|
|
(and (not (cg-rummy-joker-p card)) (= (cdr card) 2)))
|
|
|
|
(defun cg-hf-value (card)
|
|
"Return the Hand & Foot point value of CARD."
|
|
(cond ((cg-rummy-joker-p card) 50)
|
|
(t (let ((r (cdr card)))
|
|
(cond ((= r 1) 20) ; Two (wild)
|
|
((= r 0) 20) ; Ace
|
|
((= r 2) 5) ; Three
|
|
((<= r 6) 5) ; 4 5 6 7
|
|
(t 10)))))) ; 8 9 10 J Q K
|
|
|
|
(defun cg-hf--book-rank (cards)
|
|
"Return the natural rank shared by CARDS, or nil if invalid."
|
|
(let ((nats (cl-remove-if #'cg-hf--wild-p cards)))
|
|
(and nats
|
|
(let ((r (cdr (car nats))))
|
|
(and (cl-every (lambda (c) (= (cdr c) r)) nats)
|
|
(/= r 2)
|
|
r)))))
|
|
|
|
(defun cg-hf--book-valid-p (cards)
|
|
"Return non-nil when CARDS form a legal book."
|
|
(let* ((nats (cl-remove-if #'cg-hf--wild-p cards))
|
|
(wilds (cl-remove-if-not #'cg-hf--wild-p cards)))
|
|
(and (>= (length cards) 3)
|
|
(cg-hf--book-rank cards)
|
|
(>= (length nats) 2)
|
|
(<= (length wilds) 3)
|
|
(<= (length wilds) (length nats)))))
|
|
|
|
(defun cg-hf--book-complete-p (cards) (>= (length cards) 7))
|
|
(defun cg-hf--book-clean-p (cards) (not (cl-some #'cg-hf--wild-p cards)))
|
|
|
|
;;;; Setup
|
|
|
|
(defun cg-hf--team (game s) (mod s (cg-get game :nteams)))
|
|
|
|
(cl-defmethod cg-hf--deal ((game cg-handfoot-game))
|
|
"Deal a fresh round into GAME."
|
|
(let* ((n (cg-get game :nplayers))
|
|
(decks (1+ n))
|
|
(deck (cg-rummy-deck decks 2))
|
|
(hands (make-vector n nil)) (feet (make-vector n nil))
|
|
(stage (make-vector n 0)))
|
|
(dotimes (s n)
|
|
(aset hands s (cg-rummy-sort-hand (cl-loop repeat 11 collect (pop deck))))
|
|
(aset feet s (cg-rummy-sort-hand (cl-loop repeat 11 collect (pop deck)))))
|
|
(cg-put game :hands hands)
|
|
(cg-put game :feet feet)
|
|
(cg-put game :stage stage)
|
|
(cg-put game :books (make-vector (cg-get game :nteams) nil))
|
|
(cg-put game :discard (list (pop deck)))
|
|
(cg-put game :stock deck)
|
|
(cg-put game :turn 0)
|
|
(cg-put game :step 'draw)
|
|
(cg-put game :phase 'play)
|
|
(cg-put game :cursor 0)
|
|
(cg-put game :marks nil)
|
|
(cg-put game :message "Your turn: s draws two cards.")
|
|
game))
|
|
|
|
(defun cg-hf--books (game team) (aref (cg-get game :books) team))
|
|
(defun cg-hf--set-books (game team v) (aset (cg-get game :books) team v))
|
|
|
|
;;;; Engine
|
|
|
|
(defun cg-hf--draw2 (game s)
|
|
"Draw two stock cards into seat S's hand. Return nil if stock runs out."
|
|
(let ((ok t))
|
|
(dotimes (_ 2)
|
|
(let ((stock (cg-get game :stock)))
|
|
(if (null stock) (setq ok nil)
|
|
(cg-rummy--set-hand game s (cg-rummy-sort-hand
|
|
(cons (car stock) (cg-rummy--hand game s))))
|
|
(cg-put game :stock (cdr stock)))))
|
|
ok))
|
|
|
|
(defun cg-hf--meld (game s cards)
|
|
"Have seat S lay CARDS as a new book for their team. Return non-nil on win."
|
|
(when (and (cg-hf--book-valid-p cards)
|
|
(cl-subsetp cards (cg-rummy--hand game s) :test #'equal))
|
|
(let ((team (cg-hf--team game s)))
|
|
(dolist (c cards)
|
|
(cg-rummy--set-hand game s (cg-rummy--remove1 c (cg-rummy--hand game s))))
|
|
(cg-hf--set-books game team
|
|
(append (cg-hf--books game team)
|
|
(list (cg-rummy-sort-hand (copy-sequence cards)))))
|
|
t)))
|
|
|
|
(defun cg-rummy--remove1 (card list)
|
|
"Return LIST with one copy of CARD (an `equal' match) removed."
|
|
(let ((seen nil))
|
|
(cl-remove-if (lambda (c) (and (not seen) (equal c card) (setq seen t))) list)))
|
|
|
|
(defun cg-hf--layoff (game s card)
|
|
"Lay CARD off onto a team book it fits. Return non-nil on success."
|
|
(let* ((team (cg-hf--team game s)) (books (cg-hf--books game team)) (done nil))
|
|
(catch 'hit
|
|
(dolist (bk books)
|
|
(unless (cg-hf--book-complete-p bk)
|
|
(let ((cand (cons card bk)))
|
|
(when (cg-hf--book-valid-p cand)
|
|
(cg-rummy--set-hand game s (cg-rummy--remove1 card (cg-rummy--hand game s)))
|
|
(setcar (memq bk books) (cg-rummy-sort-hand cand))
|
|
(setq done t)
|
|
(throw 'hit t))))))
|
|
done))
|
|
|
|
(defun cg-hf--advance (game s)
|
|
"After a play, take up the foot or finish, then pass the turn."
|
|
(let ((stage (cg-get game :stage)))
|
|
(when (and (= (aref stage s) 0) (null (cg-rummy--hand game s)))
|
|
;; hand exhausted: pick up the foot
|
|
(aset stage s 1)
|
|
(cg-rummy--set-hand game s (aref (cg-get game :feet) s)))
|
|
(if (and (= (aref stage s) 1) (null (cg-rummy--hand game s))
|
|
(cg-hf--can-go-out-p game (cg-hf--team game s)))
|
|
(cg-hf--score-round game s)
|
|
(cg-put game :turn (mod (1+ s) (cg-get game :nplayers)))
|
|
(cg-put game :step 'draw))))
|
|
|
|
(defun cg-hf--can-go-out-p (game team)
|
|
"Return non-nil when TEAM owns at least two complete books."
|
|
(>= (cl-count-if #'cg-hf--book-complete-p (cg-hf--books game team)) 2))
|
|
|
|
(defun cg-hf--discard (game s card)
|
|
"Discard CARD from seat S and end the play portion of the turn."
|
|
(cg-rummy--set-hand game s (cg-rummy--remove1 card (cg-rummy--hand game s)))
|
|
(cg-put game :discard (cons card (cg-get game :discard)))
|
|
(cg-hf--advance game s))
|
|
|
|
(cl-defmethod cg-hf--score-round ((game cg-handfoot-game) outseat)
|
|
"Score the round (OUTSEAT went out, or nil if the stock ran dry)."
|
|
(let* ((nt (cg-get game :nteams)) (scores (cg-get game :scores)))
|
|
(dotimes (team nt)
|
|
(let ((pts 0))
|
|
(dolist (bk (cg-hf--books game team))
|
|
(dolist (c bk) (setq pts (+ pts (cg-hf-value c))))
|
|
(when (cg-hf--book-complete-p bk)
|
|
(setq pts (+ pts (if (cg-hf--book-clean-p bk) 500 300)))))
|
|
(when (and outseat (= (cg-hf--team game outseat) team))
|
|
(setq pts (+ pts 100))) ; going-out bonus
|
|
;; subtract cards left in members' hands and feet
|
|
(dotimes (s (cg-get game :nplayers))
|
|
(when (= (cg-hf--team game s) team)
|
|
(dolist (c (cg-rummy--hand game s)) (setq pts (- pts (cg-hf-value c))))
|
|
(when (= (aref (cg-get game :stage) s) 0)
|
|
(dolist (c (aref (cg-get game :feet) s))
|
|
(setq pts (- pts (cg-hf-value c)))))))
|
|
(aset scores team (+ (aref scores team) pts))))
|
|
(let ((win nil) (best most-negative-fixnum))
|
|
(dotimes (team nt)
|
|
(when (and (>= (aref scores team) cg-handfoot-target)
|
|
(> (aref scores team) best))
|
|
(setq win team best (aref scores team))))
|
|
(cg-put game :phase (if win 'game-over 'round-over))
|
|
(cg-put game :winner (or win (and outseat (cg-hf--team game outseat))))
|
|
(cg-put game :reveal t)
|
|
(cg-put game :message
|
|
(concat
|
|
(if outseat (format "%s goes out! " (aref cg-handfoot--names outseat))
|
|
"Stock exhausted. ")
|
|
(if win (format "Team %d wins the game! (n: new game)" win)
|
|
(format "Round over. Scores: %s. (n: next round)"
|
|
(cg-hf--scores-string game))))))))
|
|
|
|
(defun cg-hf--scores-string (game)
|
|
"Return a compact per-team score line for GAME."
|
|
(let ((scores (cg-get game :scores)) (parts '()))
|
|
(dotimes (team (cg-get game :nteams))
|
|
(push (format "Team %d %d" team (aref scores team)) parts))
|
|
(mapconcat #'identity (nreverse parts) " · ")))
|
|
|
|
;;;; AI
|
|
|
|
(defun cg-hf--ai-meld (game s)
|
|
"Lay down and extend books for seat S as far as is easy."
|
|
;; lay off naturals onto existing incomplete team books
|
|
(let ((again t))
|
|
(while again
|
|
(setq again nil)
|
|
(let ((card (cl-find-if
|
|
(lambda (c)
|
|
(and (not (cg-hf--wild-p c)) (not (cg-hf--three-p c))
|
|
(cl-find-if
|
|
(lambda (bk) (and (not (cg-hf--book-complete-p bk))
|
|
(equal (cg-hf--book-rank bk) (cdr c))))
|
|
(cg-hf--books game (cg-hf--team game s)))))
|
|
(cg-rummy--hand game s))))
|
|
(when card (cg-hf--layoff game s card) (setq again t)))))
|
|
;; start new books from ranks with >=3 naturals in hand
|
|
(let ((again t))
|
|
(while again
|
|
(setq again nil)
|
|
(let* ((hand (cg-rummy--hand game s))
|
|
(byrank (make-hash-table :test 'eql)) (target nil))
|
|
(dolist (c hand)
|
|
(unless (or (cg-hf--wild-p c) (cg-hf--three-p c))
|
|
(push c (gethash (cdr c) byrank))))
|
|
(maphash (lambda (_r cs) (when (and (not target) (>= (length cs) 3))
|
|
(setq target cs)))
|
|
byrank)
|
|
(when target
|
|
(cg-hf--meld game s (cl-subseq target 0 (min 7 (length target))))
|
|
(setq again t)))))
|
|
;; push a nearly-complete book to seven with a spare wild
|
|
(let ((again t))
|
|
(while again
|
|
(setq again nil)
|
|
(let ((wild (cl-find-if #'cg-hf--wild-p (cg-rummy--hand game s)))
|
|
(team (cg-hf--team game s)))
|
|
(when wild
|
|
(let ((bk (cl-find-if
|
|
(lambda (b)
|
|
(and (not (cg-hf--book-complete-p b))
|
|
(>= (length b) 5)
|
|
(> (cl-count-if-not #'cg-hf--wild-p b)
|
|
(cl-count-if #'cg-hf--wild-p b))
|
|
(< (cl-count-if #'cg-hf--wild-p b) 3)))
|
|
(cg-hf--books game team))))
|
|
(when bk
|
|
(cg-rummy--set-hand game s (cg-rummy--remove1 wild (cg-rummy--hand game s)))
|
|
(setcar (memq bk (cg-hf--books game team))
|
|
(cg-rummy-sort-hand (cons wild bk)))
|
|
(setq again t))))))))
|
|
|
|
(defun cg-hf--ai-discard-card (game s)
|
|
"Return the card seat S should discard."
|
|
(let ((hand (cg-rummy--hand game s)))
|
|
(or (cl-find-if #'cg-hf--three-p hand)
|
|
;; a high singleton, else the first card
|
|
(let ((byrank (make-hash-table :test 'eql)) (best (car hand)) (bestv -1))
|
|
(dolist (c hand) (unless (cg-hf--wild-p c)
|
|
(push c (gethash (cdr c) byrank))))
|
|
(maphash (lambda (_r cs)
|
|
(when (= (length cs) 1)
|
|
(let ((v (cg-hf-value (car cs))))
|
|
(when (> v bestv) (setq best (car cs) bestv v)))))
|
|
byrank)
|
|
best))))
|
|
|
|
(cl-defmethod cg-hf--ai-turn ((game cg-handfoot-game) s)
|
|
"Play seat S's whole turn."
|
|
(if (not (cg-hf--draw2 game s))
|
|
(cg-hf--score-round game nil)
|
|
(cg-hf--ai-meld game s)
|
|
(when (eq (cg-get game :phase) 'play)
|
|
;; if the hand emptied through melding, pick up the foot and meld again
|
|
(when (and (= (aref (cg-get game :stage) s) 0) (null (cg-rummy--hand game s)))
|
|
(aset (cg-get game :stage) s 1)
|
|
(cg-rummy--set-hand game s (aref (cg-get game :feet) s))
|
|
(cg-hf--ai-meld game s))
|
|
(when (eq (cg-get game :phase) 'play)
|
|
(if (cg-rummy--hand game s)
|
|
(cg-hf--discard game s (cg-hf--ai-discard-card game s))
|
|
(cg-hf--advance game s))))))
|
|
|
|
(defun cg-hf--run (game)
|
|
"Advance AI seats until it is your turn or the round ends."
|
|
(while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0))
|
|
(cg-hf--ai-turn game (cg-get game :turn))))
|
|
|
|
;;;; UI
|
|
|
|
(defvar-local cg-hf--game nil "The Hand & Foot game in the current buffer.")
|
|
|
|
(cl-defmethod cg-render ((game cg-handfoot-game))
|
|
"Return a propertized depiction of the Hand & Foot GAME."
|
|
(let* ((out '()) (scores (cg-get game :scores))
|
|
(hand (cg-rummy--hand game 0)) (cursor (cg-get game :cursor)))
|
|
(push (format " Hand & Foot target %d\n\n" cg-handfoot-target) out)
|
|
(dotimes (team (cg-get game :nteams))
|
|
(push (format " Team %d (score %d):\n" team (aref scores team)) out)
|
|
(let ((bks (cg-hf--books game team)))
|
|
(if bks
|
|
(dolist (bk bks)
|
|
(push (format " %s%s\n"
|
|
(mapconcat #'cg-rummy-card-string bk " ")
|
|
(cond ((cg-hf--book-complete-p bk)
|
|
(if (cg-hf--book-clean-p bk) " [clean pile]" " [dirty pile]"))
|
|
(t "")))
|
|
out))
|
|
(push " (no books yet)\n" out))))
|
|
(push "\n" out)
|
|
(dotimes (s (cg-get game :nplayers))
|
|
(unless (= s 0)
|
|
(push (format " %-6s %d in hand%s\n" (aref cg-handfoot--names s)
|
|
(length (cg-rummy--hand game s))
|
|
(if (= (aref (cg-get game :stage) s) 1) " (on foot)" ""))
|
|
out)))
|
|
(push (format "\n Discard: %s Stock: %d\n\n"
|
|
(let ((cs (cg-rummy-card-string (cg-rummy--top game))) (tp (cg-rummy--top game)))
|
|
(if (and tp (not (cg-rummy-joker-p tp)) (cg-red-suit-p (car tp)))
|
|
(propertize cs 'face 'cg-red-suit) cs))
|
|
(length (cg-get game :stock)))
|
|
out)
|
|
(push (format " Your %s:\n " (if (= (aref (cg-get game :stage) 0) 1) "foot" "hand")) out)
|
|
(push (cg-rummy--render-cards hand cursor (cg-get game :marks) nil 'hand) out)
|
|
(push (format "\n\n %s\n" (cg-get game :message)) out)
|
|
(apply #'concat (nreverse out))))
|
|
|
|
(cl-defmethod cg-render-apply ((g cg-handfoot-game) action)
|
|
"Apply a click ACTION on the hand to GAME G."
|
|
(pcase action
|
|
(`(hand . ,i) (cg-put g :cursor i))
|
|
(_ (cl-call-next-method))))
|
|
|
|
(defun cg-hf--redisplay ()
|
|
"Redraw the Hand & Foot buffer."
|
|
(let ((game cg-hf--game) (inhibit-read-only t))
|
|
(setq cg-current-game game cg-redisplay-function #'cg-hf--redisplay)
|
|
(setq-local mode-line-process
|
|
(format " [%s]" (or (cg-get game :step) (cg-get game :phase))))
|
|
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
|
|
|
|
(defun cg-hf--clamp (g)
|
|
"Keep G's cursor in range and drop stale marks."
|
|
(let ((n (length (cg-rummy--hand g 0))))
|
|
(cg-put g :cursor (if (> n 0) (min (cg-get g :cursor) (1- n)) 0))
|
|
(cg-put g :marks (cl-remove-if (lambda (i) (>= i n)) (cg-get g :marks)))))
|
|
|
|
(defun cg-hf--my-turn-p (g)
|
|
(and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0)))
|
|
|
|
(defun cg-hf-left ()
|
|
"Move the hand cursor left."
|
|
(interactive)
|
|
(let* ((g cg-hf--game) (n (length (cg-rummy--hand g 0))))
|
|
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
|
|
(cg-hf--redisplay)))
|
|
|
|
(defun cg-hf-right ()
|
|
"Move the hand cursor right."
|
|
(interactive)
|
|
(let* ((g cg-hf--game) (n (length (cg-rummy--hand g 0))))
|
|
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
|
|
(cg-hf--redisplay)))
|
|
|
|
(defun cg-hf-mark ()
|
|
"Toggle a mark on the card under the cursor."
|
|
(interactive)
|
|
(let* ((g cg-hf--game) (i (cg-get g :cursor)) (marks (cg-get g :marks)))
|
|
(cg-put g :marks (if (memq i marks) (delq i marks) (cons i marks)))
|
|
(cg-hf--redisplay)))
|
|
|
|
(defun cg-hf--marked (g)
|
|
"Return the marked cards in G's hand."
|
|
(let ((hand (cg-rummy--hand g 0)))
|
|
(mapcar (lambda (i) (nth i hand)) (sort (copy-sequence (cg-get g :marks)) #'<))))
|
|
|
|
(defun cg-hf-meld ()
|
|
"Meld the marked cards as a new book."
|
|
(interactive)
|
|
(let* ((g cg-hf--game) (cards (cg-hf--marked g)))
|
|
(cond
|
|
((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn."))
|
|
((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s)."))
|
|
((not (cg-hf--book-valid-p cards))
|
|
(cg-put g :message "Not a legal book: 3+ of a rank, 2+ natural, wilds <= naturals."))
|
|
((cg-hf--meld g 0 cards)
|
|
(cg-put g :marks nil) (cg-hf--clamp g)
|
|
(when (and (= (aref (cg-get g :stage) 0) 0) (null (cg-rummy--hand g 0)))
|
|
(aset (cg-get g :stage) 0 1)
|
|
(cg-rummy--set-hand g 0 (aref (cg-get g :feet) 0))
|
|
(cg-hf--clamp g)
|
|
(cg-put g :message "Hand cleared -- foot picked up! Keep melding or discard (RET)."))
|
|
(unless (and (= (aref (cg-get g :stage) 0) 1) (null (cg-rummy--hand g 0)))
|
|
(cg-put g :message "Booked. Meld more, lay off (l), or discard (RET).")))
|
|
(t (cg-put g :message "Could not meld those cards.")))
|
|
(cg-hf--redisplay)))
|
|
|
|
(defun cg-hf-layoff ()
|
|
"Lay the cursor card (or marked cards) off onto a team book."
|
|
(interactive)
|
|
(let* ((g cg-hf--game) (marks (cg-hf--marked g)))
|
|
(cond
|
|
((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn."))
|
|
((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s)."))
|
|
(t (let ((cards (or marks (list (nth (cg-get g :cursor) (cg-rummy--hand g 0)))))
|
|
(any nil))
|
|
(dolist (c cards) (when (and c (cg-hf--layoff g 0 c)) (setq any t)))
|
|
(cg-put g :marks nil) (cg-hf--clamp g)
|
|
(cg-put g :message (if any "Laid off." "That card fits none of your books.")))))
|
|
(cg-hf--redisplay)))
|
|
|
|
(defun cg-hf-draw ()
|
|
"Draw two cards from the stock."
|
|
(interactive)
|
|
(let ((g cg-hf--game))
|
|
(cond
|
|
((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn."))
|
|
((not (eq (cg-get g :step) 'draw)) (cg-put g :message "You already drew."))
|
|
((cg-hf--draw2 g 0)
|
|
(cg-put g :step 'play) (cg-hf--clamp g)
|
|
(cg-put g :message "Meld (m), lay off (l), then discard (RET)."))
|
|
(t (cg-hf--score-round g nil)))
|
|
(cg-hf--redisplay)))
|
|
|
|
(defun cg-hf-discard ()
|
|
"Discard the cursor card and end your turn."
|
|
(interactive)
|
|
(let* ((g cg-hf--game) (card (nth (cg-get g :cursor) (cg-rummy--hand g 0))))
|
|
(cond
|
|
((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn."))
|
|
((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s)."))
|
|
((null card) (cg-put g :message "No card selected."))
|
|
(t (cg-hf--discard g 0 card)
|
|
(cg-put g :marks nil)
|
|
(when (memq (cg-get g :phase) '(play))
|
|
(cg-put g :message "You discarded.")
|
|
(cg-hf--run g))))
|
|
(cg-hf--redisplay)))
|
|
|
|
(defun cg-hf-new ()
|
|
"Deal a fresh round, or a new game when one is over."
|
|
(interactive)
|
|
(let ((g cg-hf--game))
|
|
(when (eq (cg-get g :phase) 'game-over)
|
|
(cg-put g :scores (make-vector (cg-get g :nteams) 0)))
|
|
(cg-put g :reveal nil)
|
|
(cg-hf--deal g)
|
|
(cg-hf--run g)
|
|
(cg-hf--redisplay)))
|
|
|
|
(defun cg-hf-redraw () "Redraw the board." (interactive) (cg-hf--redisplay))
|
|
|
|
(defun cg-hf-help ()
|
|
"Describe the Hand & Foot controls."
|
|
(interactive)
|
|
(message "Arrows: choose SPC: mark m: meld l: lay off s: draw 2 RET: discard n: new"))
|
|
|
|
(defvar cg-handfoot-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map [mouse-1] #'cg-card-click)
|
|
(define-key map "+" #'cg-card-zoom-in)
|
|
(define-key map "=" #'cg-card-zoom-in)
|
|
(define-key map "-" #'cg-card-zoom-out)
|
|
(define-key map "0" #'cg-card-zoom-reset)
|
|
(define-key map (kbd "<left>") #'cg-hf-left)
|
|
(define-key map (kbd "<right>") #'cg-hf-right)
|
|
(define-key map (kbd "SPC") #'cg-hf-mark)
|
|
(define-key map "m" #'cg-hf-meld)
|
|
(define-key map "l" #'cg-hf-layoff)
|
|
(define-key map "s" #'cg-hf-draw)
|
|
(define-key map (kbd "RET") #'cg-hf-discard)
|
|
(define-key map "n" #'cg-hf-new)
|
|
(define-key map "g" #'cg-hf-redraw)
|
|
(define-key map "?" #'cg-hf-help)
|
|
map)
|
|
"Keymap for `cg-handfoot-mode'.")
|
|
|
|
(define-derived-mode cg-handfoot-mode special-mode "Hand&Foot"
|
|
"Major mode for Hand & Foot."
|
|
(setq-local truncate-lines t))
|
|
|
|
;;;###autoload
|
|
(defun cg-handfoot ()
|
|
"Play Hand & Foot, partnering North against two AI opponents."
|
|
(interactive)
|
|
(let ((buf (get-buffer-create "*Hand & Foot*")))
|
|
(with-current-buffer buf
|
|
(cg-handfoot-mode)
|
|
(setq cg-hf--game (cg-handfoot-game))
|
|
(cg-put cg-hf--game :nplayers 4)
|
|
(cg-put cg-hf--game :nteams 2)
|
|
(cg-put cg-hf--game :scores (make-vector 2 0))
|
|
(cg-hf--deal cg-hf--game)
|
|
(cg-hf--run cg-hf--game)
|
|
(cg-hf--redisplay))
|
|
(switch-to-buffer buf)))
|
|
|
|
;;;###autoload
|
|
(defalias 'cg-hand-and-foot #'cg-handfoot)
|
|
|
|
(provide 'cg-handfoot)
|
|
;;; cg-handfoot.el ends here
|