Trick games: full SVG table (opponents, trick, fanned hand)
* cg-trick.el (cg-trick--svg, cg-trick--draw-backs): draw the whole table as one SVG -- three opponents, the trick in a diamond, the South hand fanned with cursor, legal-play hints, and pass marks; hand cards carry (hand . INDEX) click regions. (cg-trick--render-text): the text fallback. (cg-render): dispatch SVG on a graphical display, else text. Add a footer legend; refresh the help. Covers Hearts, Spades, Whist, Oh Hell, and the Euchre/Pitch/Briscola subclasses. * test/card-games-tests.el: add cgt-trick-svg-smoke, cgt-trick-svg-bidding. * NEWS: note the trick-taking SVG table.
This commit is contained in:
parent
5060835731
commit
400e5830be
3 changed files with 161 additions and 36 deletions
10
NEWS
10
NEWS
|
|
@ -21,7 +21,10 @@ the mouse as well as the keyboard.
|
|||
"stop" rule that ends your turn if you skip a foundation play
|
||||
(toggle with ~cg-crapette-stops~), and sequenced house-to-house
|
||||
moves limited by the number of empty houses -- with ~[~ and ~]~ to
|
||||
choose how many cards of a run to drop onto an empty house.
|
||||
choose how many cards of a run to drop onto an empty house. On a
|
||||
graphical display it draws an SVG board (houses shown as stacks) that
|
||||
you can click to pick up and drop, with ~+~ / ~-~ / ~0~ to zoom;
|
||||
set ~cg-crapette-svg-cards~ to nil for the plain-text board.
|
||||
- Pegging: Cribbage. Capturing: Scopa, Casino. Spite & Malice.
|
||||
(These join Gaps/Montana, Hell's Half-Acre, and 500 from 1.0.60.)
|
||||
|
||||
|
|
@ -31,6 +34,11 @@ the mouse as well as the keyboard.
|
|||
- Mouse support everywhere: click cards to select or play, click board
|
||||
slots and buttons, and use an on-screen card-size slider plus the
|
||||
~+~ / ~-~ / ~0~ zoom keys.
|
||||
- Full SVG table for the trick-taking games (Hearts, Spades, Whist,
|
||||
Oh Hell, Euchre, Pitch, Briscola): the three opponents, the trick in
|
||||
the middle, and your fanned hand, with the legal cards you may play
|
||||
ringed. Click a card to play it. Set ~cg-trick-svg-cards~ to nil
|
||||
for the plain-text board.
|
||||
|
||||
** Rummy-family rules completed
|
||||
- Rummy 500: take a card from anywhere in the discard pile (key ~T~) --
|
||||
|
|
|
|||
153
cg-trick.el
153
cg-trick.el
|
|
@ -545,8 +545,100 @@
|
|||
(max 0 (- cg-svg-card-width 24)) 0)
|
||||
:region-tag region-tag))
|
||||
|
||||
(cl-defmethod cg-render ((game cg-trick-game))
|
||||
"Return a propertized string depicting GAME for a text display."
|
||||
(defun cg-trick--draw-backs (svg x y n)
|
||||
"Draw up to three overlapped face-down 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-trick--svg (game)
|
||||
"Return a propertized full-table SVG depiction of trick GAME.
|
||||
The South hand carries clickable (hand . INDEX) regions."
|
||||
(let* ((w cg-svg-card-width) (h cg-svg-card-height) (gap cg-svg-card-gap)
|
||||
(pad 16)
|
||||
(hand (cg-trick--sort (cg-trick--hand game 0)))
|
||||
(n (length hand))
|
||||
(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))
|
||||
(width (max (+ fanw (* 2 pad)) 720))
|
||||
(cx (/ width 2))
|
||||
(scores (cg-get game :scores))
|
||||
(trick (cg-get game :trick))
|
||||
(turn (cg-get game :turn))
|
||||
(phase (cg-get game :phase))
|
||||
(marks (cg-get game :marks))
|
||||
(cursor (cg-get game :cursor))
|
||||
(bids (cg-get game :bids))
|
||||
(tks (cg-get game :tricks))
|
||||
(y-title 6) (y-north 26)
|
||||
(y-tn (+ y-north h 22))
|
||||
(cy (+ y-tn (round (* h 0.55))))
|
||||
(y-ts (+ cy (round (* h 0.15))))
|
||||
(y-south (+ y-ts h 34))
|
||||
(height (+ y-south h 30))
|
||||
(svg (svg-create width height))
|
||||
(lc (cg-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels
|
||||
((txt (str x y &optional sz bold anchor)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family cg-svg-font-family
|
||||
(append (and bold '(:font-weight "bold"))
|
||||
(and anchor (list :text-anchor anchor)))))
|
||||
(seat (s x y)
|
||||
(cg-trick--draw-backs svg x (+ y 6) (length (cg-trick--hand game s)))
|
||||
(txt (format "%s%s%s%s" (aref cg-trick-seat-names s)
|
||||
(if (and bids (aref bids s)) (format " bid %d" (aref bids s)) "")
|
||||
(if (and tks (> (aref tks s) 0)) (format " won %d" (aref tks s)) "")
|
||||
(if (= turn s) " <-" ""))
|
||||
x y 11))
|
||||
(trick-card (s x y)
|
||||
(let ((play (assq s trick)))
|
||||
(when play
|
||||
(let ((sp (cg-trick--spec (cdr play))))
|
||||
(cg-svg-card svg x y :rank (car sp) :suit (cdr sp)))))))
|
||||
(txt (format "%s -- %s" (oref game vname)
|
||||
(pcase phase
|
||||
('pass "pass three cards") ('bid "bidding")
|
||||
('play (if (= turn 0) "your turn" "opponents playing"))
|
||||
(_ "play")))
|
||||
pad (+ y-title 12) 13 t)
|
||||
(when scores
|
||||
(txt (format "S %d W %d N %d E %d"
|
||||
(aref scores 0) (aref scores 1) (aref scores 2) (aref scores 3))
|
||||
(- width pad) (+ y-title 12) 12 nil "end"))
|
||||
(seat 2 (- cx 40) y-north)
|
||||
(seat 1 pad cy)
|
||||
(seat 3 (- width pad 100) cy)
|
||||
(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 (- cy (* h 0.25))))
|
||||
(trick-card 3 (+ cx (round (* w 0.4))) (round (- cy (* h 0.25))))
|
||||
(txt (format "Your hand (South)%s"
|
||||
(if (eq phase 'pass) (format " -- marked %d/3" (length marks)) ""))
|
||||
pad (- y-south 6) 11)
|
||||
(let ((x (- cx (/ fanw 2))) (i 0)
|
||||
(legalp (and (eq phase 'play) (= turn 0))))
|
||||
(dolist (c hand)
|
||||
(let ((sp (cg-trick--spec c))
|
||||
(curp (= i cursor))
|
||||
(markp (member c marks))
|
||||
(hintp (and legalp (cg-trick--legal-p game 0 c))))
|
||||
(cg-svg-card svg x y-south :rank (car sp) :suit (cdr sp)
|
||||
:highlight curp :hint hintp)
|
||||
(when markp
|
||||
(svg-rectangle svg (- x 3) (- y-south 3) (+ w 6) (+ h 6)
|
||||
:rx 8 :fill "none" :stroke "#4a90d9" :stroke-width 3))
|
||||
(push (cons (list x y-south (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))))
|
||||
|
||||
(defun cg-trick--render-text (game)
|
||||
"Return a plain-text depiction of trick GAME."
|
||||
(let* ((out (list))
|
||||
(scores (cg-get game :scores))
|
||||
(marks (cg-get game :marks))
|
||||
|
|
@ -557,45 +649,36 @@
|
|||
(push (format " Scores: South %d West %d North %d East %d\n\n"
|
||||
(aref scores 0) (aref scores 1) (aref scores 2) (aref scores 3))
|
||||
out))
|
||||
(dolist (s '(2 1 3)) ; North, West, East
|
||||
(dolist (s '(2 1 3))
|
||||
(push (cg-trick--seat-line game s) out))
|
||||
;; current trick
|
||||
(push "\n Trick: " out)
|
||||
(cond
|
||||
((null (cg-get game :trick)) (push "(empty)" out))
|
||||
((and cg-trick-svg-cards (display-graphic-p))
|
||||
(push (concat (mapconcat (lambda (p) (aref cg-trick-seat-names (car p)))
|
||||
(reverse (cg-get game :trick)) " ") " ")
|
||||
out)
|
||||
(push (cg-trick--svg-row (mapcar #'cdr (reverse (cg-get game :trick)))) out))
|
||||
(t (dolist (play (reverse (cg-get game :trick)))
|
||||
(push (format "%s:%s " (aref cg-trick-seat-names (car play))
|
||||
(let ((cs (cg-trick-card-string (cdr play))))
|
||||
(if (cg-trick-red-p (cdr play))
|
||||
(propertize cs 'face 'cg-red-suit) cs)))
|
||||
out))))
|
||||
(if (null (cg-get game :trick))
|
||||
(push "(empty)" out)
|
||||
(dolist (play (reverse (cg-get game :trick)))
|
||||
(push (format "%s:%s " (aref cg-trick-seat-names (car play))
|
||||
(let ((cs (cg-trick-card-string (cdr play))))
|
||||
(if (cg-trick-red-p (cdr play))
|
||||
(propertize cs 'face 'cg-red-suit) cs)))
|
||||
out)))
|
||||
(push "\n\n Your hand (South):\n " out)
|
||||
(if (and cg-trick-svg-cards (display-graphic-p))
|
||||
(let ((mi '()) (hi '()) (i 0)
|
||||
(legalp (and (eq (cg-get game :phase) 'play) (= (cg-get game :turn) 0))))
|
||||
(dolist (c hand)
|
||||
(when (member c marks) (push i mi))
|
||||
(when (and legalp (cg-trick--legal-p game 0 c)) (push i hi))
|
||||
(setq i (1+ i)))
|
||||
(push (cg-trick--svg-row hand :cursor cursor :marks mi :hints hi
|
||||
:region-tag 'hand) out))
|
||||
(let ((i 0))
|
||||
(dolist (c hand)
|
||||
(let* ((cs (cg-trick-card-string c))
|
||||
(faces nil))
|
||||
(when (cg-trick-red-p c) (push 'cg-red-suit faces))
|
||||
(when (member c marks) (push 'cg-hint faces))
|
||||
(when (= i cursor) (push 'cg-cursor faces))
|
||||
(push (propertize (format "%4s" cs) 'face (or faces 'default)) out))
|
||||
(setq i (1+ i)))))
|
||||
(let ((i 0))
|
||||
(dolist (c hand)
|
||||
(let ((cs (cg-trick-card-string c)) (faces nil))
|
||||
(when (cg-trick-red-p c) (push 'cg-red-suit faces))
|
||||
(when (member c marks) (push 'cg-hint faces))
|
||||
(when (= i cursor) (push 'cg-cursor faces))
|
||||
(push (propertize (format "%4s" cs) 'face (or faces 'default)) out))
|
||||
(setq i (1+ i))))
|
||||
(push (format "\n\n %s\n" (cg-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod cg-render ((game cg-trick-game))
|
||||
"Return a depiction of GAME: a full SVG table on a graphical display,
|
||||
else a plain-text board."
|
||||
(if (and cg-trick-svg-cards (display-graphic-p))
|
||||
(cg-trick--svg game)
|
||||
(cg-trick--render-text game)))
|
||||
|
||||
(cl-defmethod cg-render-apply ((g cg-trick-game) action)
|
||||
"Apply a click ACTION on the hand: select that card and play it."
|
||||
(pcase action
|
||||
|
|
|
|||
|
|
@ -821,6 +821,40 @@
|
|||
(should (= 2 (length (cg-crap--house g 0))))
|
||||
(should (= 1 (length (cg-crap--house g 1))))))
|
||||
|
||||
(ert-deftest cgt-crap-svg-smoke ()
|
||||
(let ((g (cg-crap--deal (cg-crapette-game))))
|
||||
(aset (cg-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6))) ; a run to draw
|
||||
(aset (cg-get g :reserve) 0 (list '(3 . 0))) ; a forced foundation
|
||||
(cg-put g :sel '(house . 0)) (cg-put g :sel-n 2) (cg-put g :cursor 3)
|
||||
(let ((res (cg-crap--svg g)))
|
||||
(should (stringp (car res)))
|
||||
(should (get-text-property 0 'display (car res)))
|
||||
(should (get-text-property 0 'cg-regions (car res)))
|
||||
;; every clickable region is a (RECT . SPOT) with a 4-number RECT
|
||||
(should (cl-every (lambda (r) (= 4 (length (car r)))) (cdr res)))
|
||||
(should (rassoc '(house . 0) (cdr res))))))
|
||||
|
||||
(ert-deftest cgt-trick-svg-smoke ()
|
||||
(let ((g (cg-hearts-game)))
|
||||
(cg-trick--deal g)
|
||||
(cg-put g :cursor 0) (cg-put g :phase 'play) (cg-put g :turn 0) (cg-put g :message "x")
|
||||
(cg-put g :trick (list (cons 1 (car (cg-trick--hand g 1))))) ; West has led
|
||||
(should (stringp (cg-trick--render-text g)))
|
||||
(let ((s (cg-trick--svg g)))
|
||||
(should (stringp s))
|
||||
(should (get-text-property 0 'display s))
|
||||
(let ((regs (get-text-property 0 'cg-regions s)))
|
||||
(should regs)
|
||||
(should (rassoc '(hand . 0) regs))
|
||||
(should (cl-every (lambda (r) (= 4 (length (car r)))) regs))))))
|
||||
|
||||
(ert-deftest cgt-trick-svg-bidding ()
|
||||
(let ((g (cg-spades-game)))
|
||||
(cg-trick--deal g)
|
||||
(cg-put g :cursor 2) (cg-put g :phase 'bid) (cg-put g :turn 0) (cg-put g :message "bid")
|
||||
(cg-put g :bids (vector 3 nil 4 nil)) (cg-put g :scores (vector 100 50 100 50))
|
||||
(should (stringp (cg-trick--svg g)))))
|
||||
|
||||
(ert-deftest cgt-pat-golf-deal ()
|
||||
(let ((g (cg-pat--deal (cg-golf-game))))
|
||||
(should (= 35 (length (cg-get g :cards))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue