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

Cribbage and Bridge: full SVG boards (completes full-SVG package)

Browse source 
* cg-cribbage.el (cg-crib--svg, cg-crib--render-text): board with a peg-track,
the starter, the pegging count/cards, the crib, and the hand.
board with the rubber/contract, four seats with the dummy exposed, the trick,
and the interactive hand.
* test/card-games-tests.el: add cgt-crib-svg-smoke, cgt-bridge-svg-smoke.
* NEWS: note the boards; every game now has a full SVG board.
This commit is contained in:
Corwin Brust 2026-07-01 05:13:46 -05:00
parent 32fb9f0c6d
commit fdccde0634
4 changed files with 216 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

5
NEWS
View file

@ -50,6 +50,11 @@ the mouse as well as the keyboard.
stock), Spite & Malice (the four centre piles, your goal and discard stock), Spite & Malice (the four centre piles, your goal and discard
piles), and Old Maid (the opponents and your hand; click one of the piles), and Old Maid (the opponents and your hand; click one of the
next player's face-down cards to draw it). next player's face-down cards to draw it).
- SVG boards for Cribbage (a peg-track for each player, the starter, the
pegging count and cards, and the crib at the show) and Bridge (the
rubber and contract, all four seats with the dummy exposed, the trick
in the middle, and the hand you are playing). With these every game
in the collection now has a full graphical board.
** Rummy-family rules completed ** Rummy-family rules completed
- Rummy 500: take a card from anywhere in the discard pile (key ~T~) -- - Rummy 500: take a card from anywhere in the discard pile (key ~T~) --

102
cg-bridge.el
View file

@ -498,8 +498,108 @@ vulnerability, and TRICKS the declarer side's trick count. Keys:
(max 0 (- cg-svg-card-width 26)) 0) (max 0 (- cg-svg-card-width 26)) 0)
:region-tag region-tag)) :region-tag region-tag))
(defun cg-bridge--draw-backs (svg x y n)
"Draw up to three overlapped backs at X, Y for a hand of N cards."
(let ((k (min (max n 0) 3)) (xx x))
(dotimes (_ k) (cg-svg-card svg xx y :down t) (setq xx (+ xx 16)))))
(defun cg-bridge--svg (game)
"Return an SVG board for the Bridge GAME (four seats, dummy exposed)."
(let* ((w cg-svg-card-width) (h cg-svg-card-height) (gap cg-svg-card-gap) (pad 16)
(phase (cg-get game :phase)) (cursor (cg-get game :cursor))
(turn (cg-get game :turn)) (dummy (cg-get game :dummy))
(exposed (cg-get game :exposed)) (trick (cg-get game :trick))
(act (if (and (eq phase 'play) (memq turn (cg-bridge--controls game))) turn 0))
(ahand (cg-bridge--sort (cg-bridge--hand game act)))
(n (length ahand))
(overlap (cond ((> n 11) (- w 26)) ((> n 8) 20) (t 0)))
(step (max 14 (- (+ w gap) overlap)))
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
(width (max (+ fanw (* 2 pad)) 760))
(cx (/ width 2))
(y-title 6) (y-info 24) (y-north 62)
(y-tn (+ y-north h 20))
(cyc (+ y-tn (round (* h 0.5))))
(y-ts (+ cyc (round (* h 0.15))))
(y-hand (+ y-ts h 42))
(height (+ y-hand h 30))
(svg (svg-create width height))
(lc (cg-color 'shadow :foreground "gray50"))
(regions '()))
(cl-labels
((txt (str x y &optional sz bold)
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
:font-family cg-svg-font-family (and bold '(:font-weight "bold"))))
(seat (s x y)
(if (and exposed (eql s dummy) (/= s act))
(let ((cs (cg-bridge--sort (cg-bridge--hand game s))) (xx x))
(dolist (c cs)
(let ((sp (cg-bridge--spec c)))
(cg-svg-card svg xx y :rank (car sp) :suit (cdr sp)))
(setq xx (+ xx 15))))
(cg-bridge--draw-backs svg x (+ y 6) (length (cg-bridge--hand game s))))
(txt (format "%s%s%s" (aref cg-bridge-seat-names s)
(if (eql s dummy) " (dummy)" "")
(if (= turn s) " <-" ""))
x y 11))
(trick-card (s x y)
(let ((play (assq s trick)))
(when play
(let ((sp (cg-bridge--spec (cdr play))))
(cg-svg-card svg x y :rank (car sp) :suit (cdr sp)))))))
(txt "Bridge" pad (+ y-title 12) 13 t)
(txt (format "Games N-S %d E-W %d Below %d/%d Above %d/%d"
(aref (cg-get game :games) 0) (aref (cg-get game :games) 1)
(aref (cg-get game :below) 0) (aref (cg-get game :below) 1)
(aref (cg-get game :above) 0) (aref (cg-get game :above) 1))
pad (+ y-info 8) 11)
(pcase phase
('auction
(txt (format "Auction: %s" (cg-bridge--auction-string game)) pad (+ y-info 24) 11)
(txt (format "Your bid: %d %s (arrows compose, RET bids)"
(cg-get game :bid-level)
(aref cg-bridge-strains (cg-get game :bid-strain)))
pad (+ y-info 40) 11))
((or 'play 'scored 'passed-out)
(txt (format "Contract: %s by %s Declarer tricks: %d"
(cg-bridge--contract-string game)
(if (cg-get game :declarer)
(aref cg-bridge-seat-names (cg-get game :declarer)) "--")
(cg-get game :tricks))
pad (+ y-info 24) 11)))
(seat 2 (- cx 40) y-north)
(seat 1 pad cyc)
(seat 3 (- width pad 110) cyc)
(when (eq phase 'play)
(trick-card 2 (- cx (/ w 2)) y-tn)
(trick-card 0 (- cx (/ w 2)) y-ts)
(trick-card 1 (- cx w (round (* w 0.4))) (round (- cyc (* h 0.25))))
(trick-card 3 (+ cx (round (* w 0.4))) (round (- cyc (* h 0.25)))))
(txt (format "%s%s" (aref cg-bridge-seat-names act)
(cond ((eq phase 'auction) " (you)")
((= act 0) " (you)")
(t " (dummy -- you play)")))
pad (- y-hand 6) 11)
(let ((x (max pad (- (/ width 2) (/ fanw 2)))) (i 0)
(legalp (and (eq phase 'play) (= turn act))))
(dolist (c ahand)
(let ((sp (cg-bridge--spec c)) (curp (= i cursor))
(hintp (and legalp (cg-bridge--legal-play-p game act c))))
(cg-svg-card svg x y-hand :rank (car sp) :suit (cdr sp)
:highlight curp :hint hintp)
(push (cons (list x y-hand (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
(setq x (+ x step) i (1+ i))))
(txt (or (cg-get game :message) "") pad (- height 8) 12))
(propertize "*" 'display (cg-svg-image svg (cg-scale)) 'cg-regions (nreverse regions))))
(cl-defmethod cg-render ((game cg-bridge-game)) (cl-defmethod cg-render ((game cg-bridge-game))
"Return a propertized depiction of the Bridge GAME." "Return a depiction of the Bridge GAME: SVG board if graphical, else text."
(if (and cg-bridge-svg-cards (display-graphic-p))
(cg-bridge--svg game)
(cg-bridge--render-text game)))
(defun cg-bridge--render-text (game)
"Return a plain-text depiction of the Bridge GAME."
(let* ((out '()) (phase (cg-get game :phase)) (cursor (cg-get game :cursor))) (let* ((out '()) (phase (cg-get game :phase)) (cursor (cg-get game :cursor)))
(push " Bridge\n" out) (push " Bridge\n" out)
(push (format " Rubber: You/North games %d East/West games %d%s\n" (push (format " Rubber: You/North games %d East/West games %d%s\n"

77
cg-cribbage.el
View file

@ -297,8 +297,83 @@ TOTAL is the running count after the play."
(defvar-local cg-crib--game nil "The Cribbage game in the current buffer.") (defvar-local cg-crib--game nil "The Cribbage game in the current buffer.")
(defun cg-crib--svg (game)
"Return an SVG board for the Cribbage GAME (with a peg-track)."
(let* ((w cg-svg-card-width) (h cg-svg-card-height) (gap cg-svg-card-gap) (pad 16)
(phase (cg-get game :phase)) (scores (cg-get game :scores))
(hand (if (eq phase 'play) (cg-crib--play game 0) (cg-crib--hand game 0)))
(n (length hand)) (cursor (cg-get game :cursor)) (marks (cg-get game :marks))
(overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0)))
(step (max 14 (- (+ w gap) overlap)))
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
(target cg-cribbage-target) (barw 220) (peg-h 14) (peg-gap 8)
(y-title 6) (y-peg 26)
(y-mid (+ y-peg (* 2 (+ peg-h peg-gap)) 18))
(y-hand (+ y-mid h 44))
(height (+ y-hand h 30))
(width (max (+ fanw (* 2 pad)) (+ pad 90 barw 120) 620))
(svg (svg-create width height))
(lc (cg-color 'shadow :foreground "gray50"))
(regions '()))
(cl-labels ((txt (str x y &optional sz bold)
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
:font-family cg-svg-font-family (and bold '(:font-weight "bold"))))
(peg (label sc y)
(txt label pad (+ y 11) 12)
(let ((bx (+ pad 90)))
(svg-rectangle svg bx y barw peg-h :rx 4 :fill "none"
:stroke lc :stroke-width 1)
(svg-rectangle svg bx y
(round (* barw (/ (float (min sc target)) target)))
peg-h :rx 4 :fill "#3aa15a")
(txt (format "%d" sc) (+ bx barw 8) (+ y 11) 12)))
(crow (cards x y)
(let ((xx x))
(dolist (c cards)
(let ((sp (cg-rummy--card-spec c)))
(cg-svg-card svg xx y :rank (car sp) :suit (cdr sp)))
(setq xx (+ xx (round (* w 0.5))))))))
(txt (format "Cribbage (to %d)" target) pad (+ y-title 12) 13 t)
(peg "You" (aref scores 0) y-peg)
(peg "Computer" (aref scores 1) (+ y-peg peg-h peg-gap))
(txt (format "%s deals" (cg-crib--who (cg-get game :dealer)))
(+ pad 90 barw 60) (+ y-peg 11) 11)
(let ((mx pad))
(when (cg-get game :starter)
(let ((sp (cg-rummy--card-spec (cg-get game :starter))))
(cg-svg-card svg mx y-mid :rank (car sp) :suit (cdr sp))
(txt "Starter" mx (+ y-mid h 13) 11)
(setq mx (+ mx w gap 24))))
(cond
((eq phase 'play)
(txt (format "Count: %d" (cg-get game :total)) mx (- y-mid 4) 12)
(crow (reverse (cg-get game :seq)) mx y-mid))
((memq phase '(show game-over))
(when (cg-get game :crib)
(txt (format "Crib (%s)" (cg-crib--who (cg-get game :dealer))) mx (- y-mid 4) 11)
(crow (cg-get game :crib) mx y-mid)))))
(txt (format "Your %s" (if (eq phase 'play) "cards" "hand")) pad (- y-hand 6) 11)
(let ((x (max pad (- (/ width 2) (/ fanw 2)))) (i 0))
(dolist (c hand)
(let ((sp (cg-rummy--card-spec c)) (curp (= i cursor))
(markp (and marks (memq i marks))))
(cg-svg-card svg x y-hand :rank (car sp) :suit (cdr sp) :highlight curp)
(when markp
(svg-rectangle svg (- x 3) (- y-hand 3) (+ w 6) (+ h 6)
:rx 8 :fill "none" :stroke "#4a90d9" :stroke-width 3))
(push (cons (list x y-hand (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
(setq x (+ x step) i (1+ i))))
(txt (or (cg-get game :message) "") pad (- height 8) 12))
(propertize "*" 'display (cg-svg-image svg (cg-scale)) 'cg-regions (nreverse regions))))
(cl-defmethod cg-render ((game cg-cribbage-game)) (cl-defmethod cg-render ((game cg-cribbage-game))
"Return a propertized depiction of the Cribbage GAME." "Return a depiction of the Cribbage GAME: SVG board if graphical, else text."
(if (and cg-rummy-svg-cards (display-graphic-p))
(cg-crib--svg game)
(cg-crib--render-text game)))
(defun cg-crib--render-text (game)
"Return a plain-text depiction of the Cribbage GAME."
(let* ((out '()) (scores (cg-get game :scores)) (phase (cg-get game :phase)) (let* ((out '()) (scores (cg-get game :scores)) (phase (cg-get game :phase))
(cursor (cg-get game :cursor))) (cursor (cg-get game :cursor)))
(push (format " Cribbage to %d\n\n" cg-cribbage-target) out) (push (format " Cribbage to %d\n\n" cg-cribbage-target) out)

34
test/card-games-tests.el
View file

@ -919,6 +919,40 @@
(should (stringp (cg-om--render-text g))) (should (stringp (cg-om--render-text g)))
(should (stringp (cg-om--svg g))))) (should (stringp (cg-om--svg g)))))
(ert-deftest cgt-crib-svg-smoke ()
(let ((g (cg-cribbage-game)))
(cg-put g :scores (make-vector 2 0))
(cg-crib--deal g)
(cg-put g :cursor 0) (cg-put g :message "x")
(should (stringp (cg-crib--render-text g)))
(let ((regs (get-text-property 0 'cg-regions (cg-crib--svg g))))
(should (rassoc '(hand . 0) regs))
(should (cl-every (lambda (r) (= 4 (length (car r)))) regs))))
(let ((g (cg-cribbage-game)))
(cg-put g :scores (vector 60 90))
(cg-crib--deal g)
(cg-put g :phase 'play) (cg-put g :starter '(2 . 4)) (cg-put g :total 15)
(cg-put g :play (vector (cg-crib--hand g 0) (cg-crib--hand g 1)))
(cg-put g :seq (list '(0 . 6) '(3 . 8))) (cg-put g :message "x")
(should (stringp (cg-crib--svg g)))))
(ert-deftest cgt-bridge-svg-smoke ()
(let ((g (cg-bridge-game)))
(cg-bridge--deal g)
(cg-put g :cursor 0) (cg-put g :turn 0) (cg-put g :bid-level 1) (cg-put g :bid-strain 0)
(cg-put g :message "x")
(should (stringp (cg-bridge--render-text g)))
(should (rassoc '(hand . 0)
(get-text-property 0 'cg-regions (cg-bridge--svg g)))))
(let ((g (cg-bridge-game)))
(cg-bridge--deal g)
(cg-put g :phase 'play) (cg-put g :turn 0) (cg-put g :cursor 0)
(cg-put g :declarer 0) (cg-put g :dummy 2) (cg-put g :exposed t) (cg-put g :tricks 0)
(cg-put g :contract '(3 . 3)) (cg-put g :doubled nil)
(cg-put g :trick (list (cons 1 (car (cg-bridge--hand g 1)))))
(cg-put g :message "x")
(should (stringp (cg-bridge--svg g)))))
(ert-deftest cgt-pat-golf-deal () (ert-deftest cgt-pat-golf-deal ()
(let ((g (cg-pat--deal (cg-golf-game)))) (let ((g (cg-pat--deal (cg-golf-game))))
(should (= 35 (length (cg-get g :cards)))) (should (= 35 (length (cg-get g :cards))))