corwin/card-game.el
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Cut 1.0.90 pretest: 500 mouse UX, version bump, NEWS, docs

Browse source 
Full-SVG 500 made mouse-operable for newcomers: kitty Discard button and
five-card cap, on-table phase banner, ? Help/Rules overlay with the bid
legend, legal-play dimming, card-size slider, and a layout pass that
moves the Help and size controls into the log panel so nothing overlaps.
Bump all files to 1.0.90, add NEWS, a README testing quick-start, and
make the shared engine files checkdoc-clean.
This commit is contained in:
Corwin Brust 2026-06-26 18:48:31 -05:00
parent 5ff6d8afed
commit 5da3144c0a
28 changed files with 360 additions and 112 deletions
Download patch file Download diff file Expand all files Collapse all files

279
cg-bid-ui.el
View file

@ -4,7 +4,7 @@
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.60
;; Version: 1.0.90
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el
@ -173,6 +173,11 @@ the left, and a scrollable message log on the right."
South hand, re-fitting on window changes. Only used when `cg-bid-svg-ui'."
:type 'boolean :group 'cg-svg)
(defcustom cg-bid-card-scale 1.0
"Card-size multiplier for the South hand in the full-SVG 500 UI.
Driven by the on-screen card-size slider and the +/-/0 keys."
:type 'number :group 'cg-svg)
(defun cg-bid--header-text (game)
"Return the header lines (scores, contract, tricks) for GAME."
@ -345,24 +350,28 @@ Folds the controls into the single action-button row (see
('gameover " [Game over — n]")
(_ "")))
(defun cg-bid--phase-text (game)
"Return a short prompt describing what to do now in GAME."
(pcase (cg-get game :phase)
('auction (if (= (cg-get game :bidder) 0)
"Your turn to bid — click a bid, or Pass."
(format "Waiting for %s to bid..."
(aref cg-bid-seat-names (cg-get game :bidder)))))
('kitty (if (cg-bid--human-p (cg-get game :contractor))
"Click 5 cards to discard, then Discard."
(format "%s is exchanging the kitty..."
(aref cg-bid-seat-names (cg-get game :contractor)))))
('play (if (= (cg-get game :turn) 0)
"Your turn — click a card to play."
(format "Waiting for %s to play..."
(aref cg-bid-seat-names (cg-get game :turn)))))
('done (or (cg-get game :hand-result) (cg-get game :message)))
('gameover (or (cg-get game :message) "Game over — click New game."))
(_ (cg-get game :message))))
(defun cg-bid--announce (game)
"Echo a prompt or status describing what to do now in GAME."
(message "%s"
(pcase (cg-get game :phase)
('auction (if (= (cg-get game :bidder) 0)
"Your turn to bid — press b to bid (e.g. 7H) or p to pass."
(format "Waiting for %s to bid..."
(aref cg-bid-seat-names (cg-get game :bidder)))))
('kitty (if (cg-bid--human-p (cg-get game :contractor))
"You won the bid — mark five cards (RET) then press x to discard."
(format "%s is exchanging the kitty..."
(aref cg-bid-seat-names (cg-get game :contractor)))))
('play (if (= (cg-get game :turn) 0)
"Your turn — pick a card (arrows + RET, or click a card)."
(format "Waiting for %s to play..."
(aref cg-bid-seat-names (cg-get game :turn)))))
('done (or (cg-get game :hand-result) (cg-get game :message)))
(_ (cg-get game :message)))))
(message "%s" (cg-bid--phase-text game)))
(defun cg-bid--button (label cmd help)
"Insert a clickable button LABEL running CMD with tooltip HELP."
@ -468,12 +477,19 @@ The treatment is chosen by `cg-bid--treatment' and dispatched with
('kitty
(when (cg-bid--human-p (cg-get game :contractor))
(let ((marks (cg-get game :marks)))
(cg-put game :marks (if (member card marks)
(remove card marks)
(cons card marks)))
(cg-put game :message
(format "%d of 5 marked for discard."
(length (cg-get game :marks))))
(cond
((member card marks)
(cg-put game :marks (remove card marks))
(cg-put game :message
(format "%d of 5 marked for discard." (length (cg-get game :marks)))))
((>= (length marks) 5)
(cg-put game :message
"Five already marked — click a marked card to unmark first."))
(t (cg-put game :marks (cons card marks))
(cg-put game :message
(let ((np (length (cg-get game :marks))))
(if (= np 5) "5 of 5 marked — press Discard."
(format "%d of 5 marked for discard." np))))))
(cg-bid--redisplay))))
('play
(if (/= (cg-get game :turn) 0)
@ -584,15 +600,28 @@ progress must be played out (unlike the solitaire games)."
"Show brief help."
(interactive)
(message "%s" (concat "500: win the auction, exchange the kitty, take your bid "
"in tricks. Trump order: Joker, right bower, left bower, "
"A K Q 10 9 8 7 6 5 4. b=bid p=pass, arrows+RET to play.")))
"in tricks. Click the ? Help button (SVG UI) for the rules.")))
(defun cg-bid-zoom-in ()
"Enlarge the cards." (interactive) (text-scale-increase 1) (cg-bid--redisplay))
"Enlarge the cards."
(interactive)
(if (and cg-bid-svg-ui (display-graphic-p))
(progn (setq cg-bid-card-scale (min 2.2 (+ (or cg-bid-card-scale 1.0) 0.2)))
(cg-bid--redisplay))
(text-scale-increase 1) (cg-bid--redisplay)))
(defun cg-bid-zoom-out ()
"Shrink the cards." (interactive) (text-scale-decrease 1) (cg-bid--redisplay))
"Shrink the cards."
(interactive)
(if (and cg-bid-svg-ui (display-graphic-p))
(progn (setq cg-bid-card-scale (max 0.6 (- (or cg-bid-card-scale 1.0) 0.2)))
(cg-bid--redisplay))
(text-scale-decrease 1) (cg-bid--redisplay)))
(defun cg-bid-zoom-reset ()
"Reset the card size." (interactive) (text-scale-set 0) (cg-bid--redisplay))
"Reset the card size."
(interactive)
(if (and cg-bid-svg-ui (display-graphic-p))
(progn (setq cg-bid-card-scale 1.0) (cg-bid--redisplay))
(text-scale-set 0) (cg-bid--redisplay)))
(defun cg-bid-redraw ()
"Redraw the table (e.g. after a theme or frame change)."
@ -636,6 +665,7 @@ progress must be played out (unlike the solitaire games)."
(define-derived-mode cg-bid-mode special-mode "500"
"Major mode for playing 500 (Bid)."
(setq-local truncate-lines t)
(setq-local cursor-type cg-cursor-type)
(add-hook 'window-configuration-change-hook #'cg-bid--fit nil t)
(when (eq cg-keys 'classic)
(use-local-map (cg-bid--classic-keymap))))
@ -672,8 +702,10 @@ fast as the window widens, so the hand compresses (cards overlap) as the
table enlarges. Capped at 42% of canvas height; width is capped later,
per-deal, so the hand always fits the table."
(let* ((wf (- w cg-bid--ui-w)) (hf (- h cg-bid--ui-h))
(sh (max 76 (min (round (* h 0.42))
(round (+ 92 (* hf 0.20) (* wf 0.40))))))
(base (max 76 (min (round (* h 0.42))
(round (+ 92 (* hf 0.20) (* wf 0.40))))))
(sh (max 50 (min (round (* h 0.60))
(round (* base (or cg-bid-card-scale 1.0))))))
(sw (round (* sh 0.70))))
(cons sw sh)))
@ -765,13 +797,21 @@ Return (:hand (X0 STEP Y N SH))."
(cursor (cg-get game :cursor)) (marks (cg-get game :marks)) (i 0))
(svg-rectangle svg tx (- y 6) tw (+ sh 14) :rx 10
:fill "#ffffff" :fill-opacity 0.05)
(let ((cg-svg-card-width sw) (cg-svg-card-height sh))
(let ((cg-svg-card-width sw) (cg-svg-card-height sh)
(legal (and (eq (cg-get game :phase) 'play) (= (cg-get game :turn) 0)
(cg-bid-legal-cards
(cg-bid--hand game 0) (cg-get game :led)
(and (cg-get game :contract)
(cg-bid-trump (cg-get game :contract)))))))
(dolist (card hand)
(let* ((spec (cg-bid--spec card)) (marked (and (member card marks) t))
(illegal (and legal (not (member card legal))))
(hl (or (and (eq (cg-get game :phase) 'play) (= i cursor)) marked))
(cxc (+ x0 (* i step)))
(cy (if marked (- y (round (* sh 0.17))) y)))
(cg-svg-card svg (+ x0 (* i step)) cy
:rank (car spec) :suit (cdr spec) :highlight hl))
(cg-svg-card svg cxc cy :rank (car spec) :suit (cdr spec) :highlight hl)
(when illegal
(svg-rectangle svg cxc cy sw sh :rx 6 :fill "#0a1a0c" :fill-opacity 0.55)))
(setq i (1+ i))))
(list :hand (list x0 step y n sh)))))
@ -882,7 +922,10 @@ panel content grows with the window."
(let* ((gx px0) (gy y)
(g (funcall F 5))
(cw (max 24 (/ (- lpw px0 (funcall F 12) (* 4 g)) 5)))
(ch (funcall F 26))
;; full height when the panel is tall; shrink to fit on short windows
(ch (min (funcall F 26)
(max (funcall F 10)
(- (/ (- (- h (funcall F 14)) gy) 6) g))))
(legal (cg-bid--legal-bids game)) (bids nil))
(dolist (b cg-bid-schedule)
(when (memq b legal)
@ -903,13 +946,29 @@ panel content grows with the window."
(+ (nth 1 pr) (round (* ch 0.66)))
(funcall F 12) "#ffffff" t)
(setq regions (plist-put regions :pass pr)))))
;; kitty: a Discard button for the human contractor (mouse-only path)
(when (and (eq (cg-get game :phase) 'kitty)
(cg-bid--human-p (cg-get game :contractor)))
(setq y (+ y (funcall F 18)))
(cg-bid--ui-label svg "Kitty" px0 y (funcall F 10))
(setq y (+ y (funcall F 14)))
(let* ((nmk (length (cg-get game :marks))) (ready (= nmk 5))
(bx px0) (by y) (bw (- lpw px0 (funcall F 12))) (bh (funcall F 30)))
(svg-rectangle svg bx by bw bh :rx 6
:fill (if ready "#2e7d32" "#14401f")
:fill-opacity (if ready 1.0 0.6)
:stroke "#0a3a1a" :stroke-width 1)
(cg-svg--text svg (format "Discard %d / 5" nmk)
(+ bx (/ bw 2)) (+ by (round (* bh 0.64)))
(funcall F 13) (if ready "#ffffff" "#9fd0a8") t)
(setq regions (plist-put regions :discard (list bx by bw bh)))))
regions))
(defun cg-bid--draw-log (svg game x w h fs ccy)
"Draw the full-height right log panel (emblem + scrolling story); return regions.
FS scales the emblem and fonts; CCY aligns the divider with the compass."
(let* ((F (lambda (n) (round (* n fs))))
(y 6) (bottom (- h 6))
(y 6) (bottom (- h 6 (funcall F 64))) ; reserve a control strip
(logtop (+ ccy (funcall F 44) (funcall F 12))) ; align with left divider
(lh (funcall F 16))
(list-top (+ logtop (funcall F 24)))
@ -918,7 +977,7 @@ FS scales the emblem and fonts; CCY aligns the divider with the compass."
(scroll (or (cg-get game :log-scroll) 0))
(vis (max 1 (/ (- bottom list-top) lh)))
(maxch (max 12 (round (/ (- w (funcall F 22)) (* 0.62 (funcall F 11)))))))
(svg-rectangle svg x y w (- bottom y) :rx 10 :fill "#0d4a22" :fill-opacity 0.9
(svg-rectangle svg x y w (- (- h 6) y) :rx 10 :fill "#0d4a22" :fill-opacity 0.9
:stroke "#0a3a1a" :stroke-width 1)
;; emblem in the open top area, divider aligned with the left compass divider
(cg-bid--draw-logo svg (+ x (/ w 2)) ccy fs)
@ -949,7 +1008,86 @@ FS scales the emblem and fonts; CCY aligns the divider with the compass."
(if top? "#f4faf4" "#cfe3cf") top?)
(setq yy (+ yy (if top? (funcall F 22) lh))))
(setq ents (cdr ents) k (1+ k))))
(list :scroll-up up :scroll-down dn :log-region (list x y w (- bottom y))))))
;; global controls (Help, card size) in the reserved bottom strip
(cg-bid--ui-divider svg (+ x (funcall F 10)) (- (+ x w) (funcall F 10))
(+ bottom (funcall F 4)))
(let* ((cz (+ bottom (funcall F 12)))
(hx (+ x (funcall F 12))) (hw (- w (funcall F 24))) (hh (funcall F 24))
(sy (+ cz hh (funcall F 14)))
(lx (+ x (funcall F 36))) (rx2 (- (+ x w) (funcall F 14)))
(stops cg-svg-slider-stops)
(segw (/ (float (- rx2 lx)) (max 1 (1- (length stops)))))
(srs nil) (k 0))
(svg-rectangle svg hx cz hw hh :rx (funcall F 6)
:fill "#14401f" :stroke "#2e7d32" :stroke-width 1)
(cg-svg--text svg "? Help / Rules" (+ hx (/ hw 2)) (+ cz (round (* hh 0.66)))
(funcall F 12) "#cfe3cf" t)
(cg-bid--ui-label svg "Size" (+ x (funcall F 12)) (+ sy (funcall F 4)) (funcall F 9))
(svg-line svg lx sy rx2 sy :stroke "#1b6b35" :stroke-width 2)
(dolist (v stops)
(let* ((cxk (round (+ lx (* k segw))))
(near (< (abs (- v (or cg-bid-card-scale 1.0))) 0.08)))
(svg-circle svg cxk sy (if near 7 4)
:fill (if near "#f1c40f" "#eaffea")
:stroke "#0a3a1a" :stroke-width 1)
(push (cons (list (- cxk (round (/ segw 2))) (- sy 10)
(max 12 (round segw)) 20) (cons 'scale v)) srs))
(setq k (1+ k)))
(list :scroll-up up :scroll-down dn :log-region (list x y w (- bottom y))
:help (list hx cz hw hh) :sizer (nreverse srs))))))
(defun cg-bid--draw-banner (svg game tx tw ty fs)
"Draw the phase-prompt banner across the top of the table."
(let* ((txt (cg-bid--phase-text game))
(by (+ ty (round (* 6 fs)))) (bh (round (* 30 fs)))
(bw (min (- tw (round (* 90 fs)))
(max (round (* 240 fs)) (* (length txt) (round (* 8 fs))))))
(bx (+ tx (/ (- tw bw) 2))))
(svg-rectangle svg bx by bw bh :rx (round (* 15 fs))
:fill "#0d2c17" :fill-opacity 0.88 :stroke "#2e7d32" :stroke-width 1)
(cg-svg--text svg txt (+ bx (/ bw 2)) (+ by (round (* bh 0.66)))
(round (* 14 fs)) "#f4faf4" t)))
(defun cg-bid--draw-help-overlay (svg _game tx ty tw th fs)
"Draw the rules/legend overlay over the table; return its regions."
(let* ((F (lambda (n) (round (* n fs))))
(m (funcall F 26))
(ox (+ tx m)) (oy (+ ty m)) (ow (- tw (* 2 m))) (oh (- th (* 2 m)))
(lx (+ ox (funcall F 22))) (y (+ oy (funcall F 36)))
(lines '("How to play 500"
""
"You (South) + North are partners vs West + East."
"1. AUCTION — bid how many tricks your side will take,"
" or Pass. Click a bid in the left panel; high bid wins."
"2. KITTY — the winner takes 5 hidden cards, then clicks"
" 5 to throw away (the Discard button turns green at 5)."
"3. PLAY — take turns clicking a card; follow the led suit."
" Take at least as many tricks as you bid to score."
""
"Bids: 7♠ = take 7 tricks, spades trump. NT = no-trump."
" NL / ON / GN = misère bids (try to take none)."
"Trump rank: Joker, right & left bowers, A K Q 10 9 ... 4."))
(regions nil))
(svg-rectangle svg ox oy ow oh :rx (funcall F 14)
:fill "#08200f" :fill-opacity 0.97 :stroke "#2e7d32" :stroke-width 2)
(dolist (ln lines)
(let ((title (string-prefix-p "How to" ln)))
(cg-bid--text-left svg ln lx y (if title (funcall F 18) (funcall F 13))
(if title "#f1c40f" "#eaffea") title))
(setq y (+ y (funcall F 22))))
(let* ((by (- (+ oy oh) (funcall F 44)))
(bw (funcall F 130)) (bh (funcall F 30)) (g (funcall F 14)) (bx lx))
(cl-flet ((btn (label key fill)
(svg-rectangle svg bx by bw bh :rx (funcall F 6) :fill fill
:stroke "#0a3a1a" :stroke-width 1)
(cg-svg--text svg label (+ bx (/ bw 2)) (+ by (round (* bh 0.64)))
(funcall F 13) "#ffffff" t)
(setq regions (plist-put regions key (list bx by bw bh)))
(setq bx (+ bx bw g))))
(btn "Close" :help-close "#2e7d32")
(btn "Classic view" :help-classic "#34495e")
(btn "Quit" :help-quit "#7f3b3b")))
regions))
(defun cg-bid--ui-svg (game &optional w h)
"Return (SVG . REGIONS) for the full-buffer SVG-UI of GAME (W by H).
@ -991,19 +1129,21 @@ table cards, PSCALE the side-panel widths."
(setq regions (append regions
(cg-bid--draw-south-region svg game tx tw (+ ty th)
(car ss) (cdr ss)))))
(let* ((hy (nth 2 (plist-get regions :hand)))
(bw (round (* 120 fs))) (bh (round (* 26 fs)))
(bx (- cx (/ bw 2))) (by (- hy bh (round (* 8 fs))))
(active (memq (cg-get game :phase) '(done gameover))))
(svg-rectangle svg bx by bw bh :rx 6
:fill (if active "#2e7d32" "#14401f")
:fill-opacity (if active 1.0 0.55)
:stroke "#0a3a1a" :stroke-width 1)
(cg-svg--text svg "Next hand" (+ bx (/ bw 2)) (+ by (round (* bh 0.66)))
(round (* 14 fs)) (if active "#ffffff" "#7fa888") active)
(when active (setq regions (plist-put regions :next (list bx by bw bh)))))
(when (memq (cg-get game :phase) '(done gameover))
(let* ((hy (nth 2 (plist-get regions :hand)))
(bw (round (* 120 fs))) (bh (round (* 26 fs)))
(bx (- cx (/ bw 2))) (by (- hy bh (round (* 8 fs)))))
(svg-rectangle svg bx by bw bh :rx 6 :fill "#2e7d32"
:stroke "#0a3a1a" :stroke-width 1)
(cg-svg--text svg "Next hand" (+ bx (/ bw 2)) (+ by (round (* bh 0.66)))
(round (* 14 fs)) "#ffffff" t)
(setq regions (plist-put regions :next (list bx by bw bh)))))
(setq regions (append regions (cg-bid--draw-left-panel svg game H lpw fs ccy)))
(setq regions (append regions (cg-bid--draw-log svg game rp-x rp-w H fs ccy)))
(cg-bid--draw-banner svg game tx tw ty fs)
(when (cg-get game :help-open)
(setq regions (append regions
(cg-bid--draw-help-overlay svg game tx ty tw th fs))))
(cons svg regions)))
(defun cg-bid--insert-svg-ui (game)
@ -1017,7 +1157,8 @@ When `cg-bid-svg-fill', size the canvas to fill the window."
(when fill (setq cg-bid--last-size (cons (window-body-width win t)
(window-body-height win t))))
(setq cg-bid--regions (cdr sr))
(insert-image (cg-svg-image (car sr) (if fill 1.0 (cg-scale))))))
(insert-image (cg-svg-image (car sr) (if fill 1.0 (cg-scale))))
(put-text-property (point-min) (point-max) 'pointer 'hand)))
(defun cg-bid--fit (&rest _)
"Re-render the SVG-UI to fit the window after a configuration change."
@ -1074,22 +1215,40 @@ Elsewhere, fall back to normal buffer scrolling."
(<= py (+ y sh 8)) (>= px x0))
(let ((i (if (<= step 0) 0 (/ (- px x0) step)))) (when (< i n) i))))))
(defun cg-bid--sizer-hit (px py rg)
"If PX,PY lands on a card-size slider stop in RG, apply it; return non-nil."
(let ((hit (cl-some (lambda (e) (and (cg-bid--in-rect px py (car e)) (cdr e)))
(plist-get rg :sizer))))
(when (and (consp hit) (eq (car hit) 'scale))
(setq cg-bid-card-scale (cdr hit))
(cg-bid--refresh)
t)))
(defun cg-bid--svg-ui-click (start)
"Dispatch a click at posn START within the SVG-UI."
(let* ((xy (posn-object-x-y start)) (s (cg-scale))
(px (round (/ (car xy) s))) (py (round (/ (cdr xy) s)))
(game cg-bid--game) (rg cg-bid--regions) bid)
(cond
((cg-bid--in-rect px py (plist-get rg :scroll-up)) (cg-bid-log-up))
((cg-bid--in-rect px py (plist-get rg :scroll-down)) (cg-bid-log-down))
((cg-bid--in-rect px py (plist-get rg :next)) (cg-bid-new))
((and (cg-bid--in-rect px py (plist-get rg :pass))
(eq (cg-get game :phase) 'auction) (= (cg-get game :bidder) 0))
(cg-bid--auction-act game 0 nil) (cg-bid--refresh))
((setq bid (cg-bid--region-bid px py rg))
(cg-bid--auction-act game 0 bid) (cg-bid--refresh))
(t (let ((i (cg-bid--region-hand px py (plist-get rg :hand))))
(when i (cg-put game :cursor i) (cg-bid-select)))))))
(if (cg-get game :help-open)
(cond
((cg-bid--in-rect px py (plist-get rg :help-classic)) (cg-bid-toggle-svg-ui))
((cg-bid--in-rect px py (plist-get rg :help-quit)) (quit-window))
(t (cg-put game :help-open nil) (cg-bid--redisplay)))
(cond
((cg-bid--in-rect px py (plist-get rg :help))
(cg-put game :help-open t) (cg-bid--redisplay))
((cg-bid--in-rect px py (plist-get rg :scroll-up)) (cg-bid-log-up))
((cg-bid--in-rect px py (plist-get rg :scroll-down)) (cg-bid-log-down))
((cg-bid--in-rect px py (plist-get rg :next)) (cg-bid-new))
((cg-bid--in-rect px py (plist-get rg :discard)) (cg-bid-discard-marked))
((cg-bid--sizer-hit px py rg))
((and (cg-bid--in-rect px py (plist-get rg :pass))
(eq (cg-get game :phase) 'auction) (= (cg-get game :bidder) 0))
(cg-bid--auction-act game 0 nil) (cg-bid--refresh))
((setq bid (cg-bid--region-bid px py rg))
(cg-bid--auction-act game 0 bid) (cg-bid--refresh))
(t (let ((i (cg-bid--region-hand px py (plist-get rg :hand))))
(when i (cg-put game :cursor i) (cg-bid-select))))))))
(defun cg-bid-toggle-svg-ui ()
"Toggle the full-buffer SVG UI for 500."