Crapette: choose how many cards of a run to drop onto an empty house

* cg-crapette.el (cg-crap--house-move): honour an optional WANT count on
an empty-house destination.  (cg-crap--do-move): thread it through.
(cg-crap--hold-adjust, cg-crap-hold-less, cg-crap-hold-more): [ and ] set
the held count.  (cg-crap--holding-line): show the run with the held
cards marked.  (cg-crap-act): default the held count to the run length.
Bind [ and ]; update the legend and help.
* test/card-games-tests.el: add cgt-crap-sequence-partial, cgt-crap-partial-space.
* NEWS: note choosing the group size.

NEWS

@@ -20,7 +20,8 @@ the mouse as well as the keyboard.
     foundations, shared houses, loading cards onto your opponent, the
     "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.
+    moves limited by the number of empty houses -- with ~[~ and ~]~ to
+    choose how many cards of a run to drop onto an empty house.
   - Pegging: Cribbage.   Capturing: Scopa, Casino.   Spite & Malice.
   (These join Gaps/Montana, Hell's Half-Acre, and 500 from 1.0.60.)
 

cg-crapette.el

@@ -213,10 +213,13 @@ F onto an empty house (the destination itself cannot serve as a relay)."
   (let ((free (cg-crap--free-houses game)))
     (if (cg-crap--house game dest-i) (1+ free) free)))
 
-(defun cg-crap--house-move (game i j)
+(defun cg-crap--house-move (game i j &optional want)
   "Move a legal sequence from house I onto house J in GAME.
-Return non-nil on success, the symbol `space' when the sequence is legal
+WANT, when given, is how many of the top cards to move onto an EMPTY
-but there are too few empty houses, and nil when nothing fits."
+house (default the whole run); it is ignored for a non-empty house, where
+the landing rank fixes the count.  Return non-nil on success, the symbol
+`space' when the sequence is legal but there are too few empty houses,
+and nil when nothing fits."
   (if (= i j)
       nil
     (let* ((run (cg-crap--house-run game i))
@@ -227,7 +230,7 @@ but there are too few empty houses, and nil when nothing fits."
            (n nil))
       (when (> rlen 0)
         (if (null dsttop)
-            (setq n (min rlen (max cap 0)))           ; empty house: as many as fit
+            (setq n (min (or want rlen) rlen))        ; empty house: the chosen count
           (cl-loop for k from 0 below rlen            ; RUN is bottom-to-top
                    for card = (nth k run)
                    when (cg-crap--builds-down-p dsttop card)
@@ -338,14 +341,14 @@ Return non-nil when the move was legal and performed."
       (cg-put game :moves (1+ (cg-get game :moves)))
       t)))
 
-(defun cg-crap--do-move (game from to p)
+(defun cg-crap--do-move (game from to p &optional want)
   "Perform player P's move from FROM to TO in GAME.
 A house-to-house move may carry a legal sequence of cards (see
-`cg-crap--house-move'); every other move carries a single card.  Returns
+`cg-crap--house-move', to which WANT is passed); every other move carries
-the same values as those functions (non-nil on success, `space' when a
+a single card.  Returns the same values as those functions (non-nil on
-sequence is too long for the empty houses)."
+success, `space' when a sequence is too long for the empty houses)."
   (if (and (eq (car from) 'house) (eq (car to) 'house))
-      (cg-crap--house-move game (cdr from) (cdr to))
+      (cg-crap--house-move game (cdr from) (cdr to) want)
     (cg-crap--move game from to p)))
 
 
@@ -503,7 +506,31 @@ is guaranteed to end."
                (length (cg-crap--hand g 0)) (length (cg-crap--reserve g 0))
                (length (cg-crap--waste g 0)))
        (cell '(res . 0) "R:") (cell '(was . 0) "W:") "\n\n"
-       (format "  %s\n" (cg-get g :message))))))
+       (format "  %s\n" (cg-get g :message))
+       (cg-crap--holding-line g)))))
+
+(defun cg-crap--holding-line (g)
+  "Return a line showing the picked-up house run, marking the held top cards.
+Empty when nothing (or a single card) is held from a house."
+  (let ((sel (cg-get g :sel)))
+    (if (not (and sel (eq (car sel) 'house)))
+        ""
+      (let* ((run (cg-crap--house-run g (cdr sel)))
+             (m (length run))
+             (held (min (or (cg-get g :sel-n) m) m))
+             (i 0) (parts nil))
+        (if (< m 2)
+            ""
+          (dolist (c run)
+            (let ((on (>= i (- m held))))
+              (push (propertize (concat (cg-crap--card-string c) " ")
+                                'face (cond (on 'cg-hint)
+                                            ((cg-crap--red-p c) 'cg-red-suit)
+                                            (t 'shadow)))
+                    parts))
+            (setq i (1+ i)))
+          (concat "  Holding: " (apply #'concat (nreverse parts))
+                  (format "(moving top %d of %d)\n" held m)))))))
 
 (cl-defmethod cg-render ((game cg-crapette-game))
   "Return a text depiction of GAME."
@@ -521,7 +548,7 @@ is guaranteed to end."
     (erase-buffer)
     (insert (cg-crap--render g))
     (cg-insert-legend
-     "arrows move · RET pick up/drop (runs move house→house) · f foundation · SPC turn a card · e end · u undo · n new · q menu")
+     "arrows move · RET pick up/drop · [ ] group size · f foundation · SPC turn a card · e end · u undo · n new · q menu")
     (goto-char (point-min))))
 
 
@@ -554,20 +581,21 @@ is guaranteed to end."
     (when (cg-crap--your-turn-p g)
       (if sel
           (unless (and (not (eq (car spot) 'found)) (cg-crap--stop g))
-            (let ((res (cg-crap--do-move g sel spot 0)))
+            (let ((res (cg-crap--do-move g sel spot 0 (cg-get g :sel-n))))
               (cond
                ((eq res 'space)
-                (cg-crap--msg g "Not enough empty houses to move that whole sequence."))
+                (cg-crap--msg g "Not enough empty houses to move that many cards."))
-               (res (cg-put g :sel nil) (cg-crap--after-human-move g))
+               (res (cg-put g :sel nil) (cg-put g :sel-n nil) (cg-crap--after-human-move g))
                (t (cg-crap--msg g "That card can't go there.")))))
         (if (and (cg-crap--source-p spot 0) (cg-crap--spot-top g spot))
             (let* ((top (cg-crap--spot-top g spot))
                    (run (and (eq (car spot) 'house) (cg-crap--house-run g (cdr spot))))
                    (n (length run)))
               (cg-put g :sel spot)
+              (cg-put g :sel-n (max 1 n))
               (cg-crap--msg g
                             (if (> n 1)
-                                (format "Picked up a run of %d (%s on top) -- drop it on a house."
+                                (format "Picked up a run of %d (%s on top) -- [ / ] to change how many, drop on a house."
                                         n (cg-crap--card-string top))
                               (format "Picked up %s -- choose where to drop it."
                                       (cg-crap--card-string top)))))
@@ -588,6 +616,27 @@ is guaranteed to end."
           (cg-crap--msg g "No foundation accepts that card."))))
     (cg-crap--redisplay)))
 
+(defun cg-crap--hold-adjust (d)
+  "Change how many cards of a picked-up house run you hold, by D."
+  (let* ((g cg-crap--game) (sel (cg-get g :sel)))
+    (when (cg-crap--your-turn-p g)
+      (if (and sel (eq (car sel) 'house))
+          (let* ((m (length (cg-crap--house-run g (cdr sel))))
+                 (new (max 1 (min m (+ (or (cg-get g :sel-n) m) d)))))
+            (cg-put g :sel-n new)
+            (cg-crap--msg g (format "Holding the top %d of %d -- drop on an empty house."
+                                    new m)))
+        (cg-crap--msg g "Pick up a house run first, then [ and ] set how many to move.")))
+    (cg-crap--redisplay)))
+
+(defun cg-crap-hold-less ()
+  "Hold one fewer card of the picked-up run."
+  (interactive) (cg-crap--hold-adjust -1))
+
+(defun cg-crap-hold-more ()
+  "Hold one more card of the picked-up run."
+  (interactive) (cg-crap--hold-adjust 1))
+
 (defun cg-crap-draw ()
   "Turn the top card of your hand onto your waste.
 If it fits nowhere your turn ends."
@@ -647,7 +696,7 @@ If it fits nowhere your turn ends."
   "Describe the controls."
   (interactive)
   (message
-   "Arrows: move  RET: pick up/drop (runs move house->house)  f: to foundation  SPC: turn a card  e: end turn  u: undo  n: new  q: menu"))
+   "Arrows: move  RET: pick up/drop  [ ]: how many cards of a run  f: to foundation  SPC: turn a card  e: end  u: undo  n: new  q: menu"))
 
 (defvar cg-crapette-mode-map
   (let ((map (make-sparse-keymap)))
@@ -658,6 +707,8 @@ If it fits nowhere your turn ends."
     (define-key map (kbd "RET") #'cg-crap-act)
     (define-key map (kbd "SPC") #'cg-crap-draw)
     (define-key map "f" #'cg-crap-found)
+    (define-key map "[" #'cg-crap-hold-less)
+    (define-key map "]" #'cg-crap-hold-more)
     (define-key map "d" #'cg-crap-draw)
     (define-key map "e" #'cg-crap-end)
     (define-key map "u" #'cg-crap-undo)

test/card-games-tests.el

@@ -800,6 +800,27 @@
       (should (cg-crap--stop g))
       (should (string-match-p "STOP" (cg-get g :message))))))
 
+(ert-deftest cgt-crap-sequence-partial ()
+  (let ((g (cg-crap--deal (cg-crapette-game))))
+    (aset (cg-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6)))  ; 9D 8S 7H
+    (aset (cg-get g :houses) 1 nil)                                ; empty destination
+    (dotimes (i 6) (aset (cg-get g :houses) (+ 2 i) nil))          ; plenty of space
+    (should (eq t (cg-crap--house-move g 0 1 2)))                  ; move only the top 2
+    (should (equal '(2 . 8) (cg-crap--top (cg-crap--house g 0))))  ; 9D stays behind
+    (should (= 2 (length (cg-crap--house g 1))))
+    (should (equal '(0 . 7) (car (cg-crap--house g 1))))          ; 8S is the moved bottom
+    (should (equal '(3 . 6) (cg-crap--top (cg-crap--house g 1)))))) ; 7H the top
+
+(ert-deftest cgt-crap-partial-space ()
+  (let ((g (cg-crap--deal (cg-crapette-game))))
+    (aset (cg-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6)))  ; run of 3
+    (aset (cg-get g :houses) 1 nil)                                ; the only empty house
+    (dotimes (i 6) (aset (cg-get g :houses) (+ 2 i) (list '(0 . 0))))
+    (should (eq 'space (cg-crap--house-move g 0 1 3)))             ; 3 needs more space
+    (should (eq t (cg-crap--house-move g 0 1 1)))                  ; but 1 fits
+    (should (= 2 (length (cg-crap--house g 0))))
+    (should (= 1 (length (cg-crap--house g 1))))))
+
 (ert-deftest cgt-pat-golf-deal ()
   (let ((g (cg-pat--deal (cg-golf-game))))
     (should (= 35 (length (cg-get g :cards))))