diff --git a/NEWS b/NEWS index c2f0156..b3d9adf 100644 --- a/NEWS +++ b/NEWS @@ -46,6 +46,10 @@ the mouse as well as the keyboard. - The same board now covers Hand & Foot (each team's books, and your hand or foot) and the fishing games Scopa and Casino (the loose table cards and the deck). + - SVG boards for Crazy Eights (the discard, the suit in play, and the + stock), Spite & Malice (the four centre piles, your goal and discard + piles), and Old Maid (the opponents and your hand; click one of the + next player's face-down cards to draw it). ** Rummy-family rules completed - Rummy 500: take a card from anywhere in the discard pile (key ~T~) -- diff --git a/cg-eights.el b/cg-eights.el index b78a9d8..d6a8a06 100644 --- a/cg-eights.el +++ b/cg-eights.el @@ -213,8 +213,65 @@ Return the drawn card, or nil when none is available." "Return the cg-svg display spec (RANK-STRING . SUIT) for CARD." (cons (aref cg-eights-ranks (cdr card)) (car card))) +(defun cg-eights--board-svg (game) + "Return an SVG board for the Crazy Eights GAME." + (let* ((w cg-svg-card-width) (h cg-svg-card-height) (gap cg-svg-card-gap) (pad 16) + (hand (cg-eights--hand game 0)) (n (length hand)) + (cursor (cg-get game :cursor)) + (top (cg-eights--top game)) (suit (cg-get game :suit)) + (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)) + (np (cg-get game :nplayers)) (nstock (length (cg-get game :stock))) + (y-title 6) (y-info 26) + (y-mid (+ y-info (* (1- np) 16) 14)) + (y-hand (+ y-mid h 42)) + (height (+ y-hand h 30)) + (width (max (+ fanw (* 2 pad)) 560)) + (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"))))) + (txt "Crazy Eights" pad (+ y-title 12) 13 t) + (let ((yy (+ y-info 4))) + (dotimes (s np) + (unless (= s 0) + (txt (format "Player %d: %d cards (score %d)" s + (length (cg-eights--hand game s)) (aref (cg-get game :scores) s)) + pad yy 12) + (setq yy (+ yy 16))))) + (cg-svg-card svg pad y-mid :down (> nstock 0) :gap (= nstock 0)) + (txt (format "Stock %d" nstock) pad (+ y-mid h 13) 11) + (let ((dx (+ pad w gap 28)) (sp (cg-eights--spec top))) + (cg-svg-card svg dx y-mid :rank (car sp) :suit (cdr sp)) + (txt "Discard" dx (+ y-mid h 13) 11) + (let ((sx (+ dx w gap 34)) + (col (if (cg-red-suit-p suit) "#c0392b" "#2c3e50"))) + (txt "Suit in play" sx (- y-mid 4) 11) + (svg-text svg (cg-suit-glyph suit) :x (+ sx 12) :y (+ y-mid 46) + :font-size 44 :fill col :font-family cg-svg-font-family))) + (txt "Your hand" pad (- y-hand 6) 11) + (let ((x (max pad (- (/ width 2) (/ fanw 2)))) (i 0)) + (dolist (c hand) + (let ((sp (cg-eights--spec c)) (curp (= i cursor)) + (hintp (cg-eights--legal-p game 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-eights-game)) - "Return a propertized string depicting GAME for a text display." + "Return a depiction of GAME: an SVG board if graphical, else text." + (if (and cg-eights-svg-cards (display-graphic-p)) + (cg-eights--board-svg game) + (cg-eights--render-text game))) + +(defun cg-eights--render-text (game) + "Return a plain-text depiction of GAME." (let* ((out (list)) (top (cg-eights--top game)) (hand (cg-eights--hand game 0)) (cursor (cg-get game :cursor))) (push (format " Crazy Eights\n\n") out) diff --git a/cg-match.el b/cg-match.el index 3e67917..338f8a6 100644 --- a/cg-match.el +++ b/cg-match.el @@ -452,8 +452,69 @@ instead of hunting for one overlapped card in a big hand." (defvar-local cg-om--game nil "The Old Maid game in the current buffer.") +(defun cg-om--svg (game) + "Return an SVG board for the Old Maid GAME." + (let* ((w cg-svg-card-width) (h cg-svg-card-height) (gap cg-svg-card-gap) (pad 16) + (hand (cg-om--hand game 0)) (n (length hand)) + (target (cg-om--target game 0)) (pick (or (cg-get game :pick) 0)) + (yourp (and target (eq (cg-get game :phase) 'play) (= (cg-get game :turn) 0))) + (np (cg-get game :nplayers)) + (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)) + (bstep 20) + (tn (and target (length (cg-om--hand game target)))) + (y-title 6) (y-info 26) + (y-target (+ y-info (* (1- np) 16) 18)) + (y-hand (+ y-target h 42)) + (targetw (if (and yourp tn (> tn 0)) (+ (* (1- tn) bstep) w) 0)) + (height (+ y-hand h 30)) + (width (max (+ fanw (* 2 pad)) (+ targetw (* 2 pad)) 560)) + (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"))))) + (txt "Old Maid" pad (+ y-title 12) 13 t) + (let ((yy (+ y-info 4))) + (dotimes (s np) + (unless (= s 0) + (txt (format "Player %d: %d cards%s" s (length (cg-om--hand game s)) + (if (eql s target) " <- draw from here" "")) + pad yy 12) + (setq yy (+ yy 16))))) + (when (and yourp tn (> tn 0)) + (txt (format "Pick a card from Player %d:" target) pad (- y-target 6) 11) + (let ((x pad)) + (dotimes (i tn) + (cg-svg-card svg x y-target :down t :highlight (= i pick)) + (push (cons (list x y-target (if (= i (1- tn)) w bstep) h) (cons 'pick i)) + regions) + (setq x (+ x bstep))))) + (txt "Your hand" pad (- y-hand 6) 11) + (let ((x (max pad (- (/ width 2) (/ fanw 2))))) + (dolist (c hand) + (let ((sp (cg-rummy--card-spec c))) + (cg-svg-card svg x y-hand :rank (car sp) :suit (cdr sp))) + (setq x (+ x step)))) + (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-apply ((g cg-old-maid-game) action) + "Apply a click ACTION: pick that card from the target and draw it." + (pcase action + (`(pick . ,i) (cg-put g :pick i) (cg-om-draw)) + (_ (cl-call-next-method)))) + (cl-defmethod cg-render ((game cg-old-maid-game)) - "Return a propertized depiction of the Old Maid GAME." + "Return a depiction of the Old Maid GAME: SVG board if graphical, else text." + (if (and cg-rummy-svg-cards (display-graphic-p)) + (cg-om--svg game) + (cg-om--render-text game))) + +(defun cg-om--render-text (game) + "Return a plain-text depiction of the Old Maid GAME." (let* ((out '()) (target (cg-om--target game 0))) (push " Old Maid\n\n" out) (dotimes (s (cg-get game :nplayers)) @@ -472,6 +533,7 @@ instead of hunting for one overlapped card in a big hand." (defun cg-om--redisplay () (let ((game cg-om--game) (inhibit-read-only t)) + (setq cg-current-game game cg-redisplay-function #'cg-om--redisplay) (setq-local mode-line-process (format " [%s]" (cg-get game :phase))) (erase-buffer) (insert (cg-render game)) (goto-char (point-min)))) @@ -510,6 +572,11 @@ instead of hunting for one overlapped card in a big hand." (defvar cg-old-maid-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 "") #'cg-om-left) (define-key map (kbd "") #'cg-om-right) (define-key map (kbd "RET") #'cg-om-draw) diff --git a/cg-spite.el b/cg-spite.el index 2ff7ee2..2e3f841 100644 --- a/cg-spite.el +++ b/cg-spite.el @@ -273,8 +273,74 @@ (push (format "%d:%s" (1+ d) (if top (cg-rummy-card-string top) "--")) parts))) (mapconcat #'identity (nreverse parts) " "))) +(defun cg-spite--board-svg (game) + "Return an SVG board for the Spite & Malice GAME." + (let* ((w cg-svg-card-width) (h cg-svg-card-height) (gap cg-svg-card-gap) (pad 16) + (hand (cg-spite--hand game 0)) (n (length hand)) + (cursor (cg-get game :cursor)) (center (cg-get game :center)) + (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)) + (colstep (+ w 14)) + (y-title 6) (y-opp 26) + (y-center (+ y-opp 16)) + (y-sm (+ y-center h 16)) + (y-ylabel (+ y-sm 12)) + (y-yours (+ y-ylabel 6)) + (y-hand (+ y-yours h 42)) + (height (+ y-hand h 30)) + (width (max (+ fanw (* 2 pad)) (+ (* 5 colstep) (* 2 pad)) 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")))) + (pilecard (spec x y) + (if spec (cg-svg-card svg x y :rank (car spec) :suit (cdr spec)) + (cg-svg-card svg x y :gap t)))) + (txt (format "Spite & Malice (goal %d)" cg-spite-goal-size) pad (+ y-title 12) 13 t) + (txt (format "Computer: goal %d left hand %d discards %s" + (length (cg-spite--goal game 1)) (length (cg-spite--hand game 1)) + (cg-spite--disc-string game 1)) + pad (+ y-opp 4) 12) + (txt "Centre (build A..Q; King is wild)" pad (- y-center 4) 11) + (dotimes (i 4) + (let* ((x (+ pad (* i colstep))) (pp (aref center i)) + (spec (and pp (cons (aref cg-rummy-ranks (car pp)) (car (cadr pp)))))) + (pilecard spec x y-center))) + (txt (format "Stock %d Muck %d" + (length (cg-get game :stock)) (length (cg-get game :muck))) + pad y-sm 11) + (let* ((gtop (car (cg-spite--goal game 0))) + (gspec (and gtop (cg-rummy--card-spec gtop)))) + (txt (format "Your goal (%d left)" (length (cg-spite--goal game 0))) + pad y-ylabel 11) + (txt "Discards" (+ pad colstep) y-ylabel 11) + (pilecard gspec pad y-yours) + (dotimes (d 4) + (let* ((x (+ pad colstep (* d colstep))) + (dtop (car (aref (cg-spite--disc game 0) d))) + (dspec (and dtop (cg-rummy--card-spec dtop)))) + (pilecard dspec x y-yours)))) + (txt "Your 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))) + (cg-svg-card svg x y-hand :rank (car sp) :suit (cdr sp) :highlight curp) + (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-spite-game)) - "Return a propertized depiction of the Spite & Malice GAME." + "Return a depiction of the GAME: an SVG board if graphical, else text." + (if (and cg-rummy-svg-cards (display-graphic-p)) + (cg-spite--board-svg game) + (cg-spite--render-text game))) + +(defun cg-spite--render-text (game) + "Return a plain-text depiction of the Spite & Malice GAME." (let* ((out '()) (cursor (cg-get game :cursor))) (push " Spite & Malice\n\n" out) (push (format " Computer goal: %d left hand: %d discards: %s\n\n" diff --git a/test/card-games-tests.el b/test/card-games-tests.el index e0a9165..2dc0354 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -894,6 +894,31 @@ (should (rassoc '(hand . 0) (get-text-property 0 'cg-regions (cg-fish--svg g)))))) +(ert-deftest cgt-eights-svg-smoke () + (let ((g (cg-eights-game))) + (cg-put g :nplayers 3) (cg-put g :scores (make-vector 3 0)) + (cg-eights--deal g) (cg-put g :cursor 0) (cg-put g :message "x") + (should (stringp (cg-eights--render-text g))) + (let ((regs (get-text-property 0 'cg-regions (cg-eights--board-svg g)))) + (should (rassoc '(hand . 0) regs)) + (should (cl-every (lambda (r) (= 4 (length (car r)))) regs))))) + +(ert-deftest cgt-spite-svg-smoke () + (let ((g (cg-spite-game))) + (cg-put g :nplayers 2) (cg-put g :scores (make-vector 2 0)) + (cg-spite--deal g) (cg-put g :cursor 0) (cg-put g :message "x") + (aset (cg-get g :center) 0 (cons 3 (list '(1 . 3)))) + (should (stringp (cg-spite--render-text g))) + (should (rassoc '(hand . 0) + (get-text-property 0 'cg-regions (cg-spite--board-svg g)))))) + +(ert-deftest cgt-om-svg-smoke () + (let ((g (cg-old-maid-game))) + (cg-om--deal g) + (cg-put g :phase 'play) (cg-put g :turn 0) (cg-put g :message "x") + (should (stringp (cg-om--render-text g))) + (should (stringp (cg-om--svg g))))) + (ert-deftest cgt-pat-golf-deal () (let ((g (cg-pat--deal (cg-golf-game)))) (should (= 35 (length (cg-get g :cards))))