diff --git a/NEWS b/NEWS index db88f2d..a7d6325 100644 --- a/NEWS +++ b/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~) -- diff --git a/cg-trick.el b/cg-trick.el index 54ecbde..dae410b 100644 --- a/cg-trick.el +++ b/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 diff --git a/test/card-games-tests.el b/test/card-games-tests.el index 142b7d8..9de16bf 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -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))))