[gnome-games] aisleriot: only allow moving builds of cards in Klondike-based games

[Vincent Povirk <vpovirk src gnome org>]

commit 0a175ed6f4ff8ad6d120b17d4744248e90f92867
Author: Vincent Povirk <madewokherd gmail com>
Date:   Sun Jun 14 20:26:36 2009 -0500

    aisleriot: only allow moving builds of cards in Klondike-based games
    
    bug #355381

 aisleriot/help/C/athena.xml    |    4 ++--
 aisleriot/help/C/aunt_mary.xml |    4 ++--
 aisleriot/help/C/saratoga.xml  |    4 ++--
 aisleriot/rules/klondike.scm   |   28 ++++++++++++++++++++++------
 4 files changed, 28 insertions(+), 12 deletions(-)
---
diff --git a/aisleriot/help/C/athena.xml b/aisleriot/help/C/athena.xml
index c42bbad..2566359 100644
--- a/aisleriot/help/C/athena.xml
+++ b/aisleriot/help/C/athena.xml
@@ -59,7 +59,7 @@
 	    Essentially Athena is the same as Klondike only the opening 
 	    layout is different.  
 	    <!-- TODO FIXME link to Klondike Help page -->
-	    Tableau can be built down in alternating colors.  Groups of
+	    Tableau can be built down in alternating colors.  Builds of
 	    cards can be moved.  Empty piles can only be filled by Kings
 	    or group of cards starting with a King.
 	  </entry>
@@ -75,7 +75,7 @@
   </sect2>
   <sect2><title>Rules</title>
   <para>
-    Cards in the Tableau are built down by alternating color.  Groups of
+    Cards in the Tableau are built down by alternating color.  Builds of
     cards can be moved.  An empty pile in the Tableau can be filled with
     a King or a group of cards with a King on the bottom.
   </para>
diff --git a/aisleriot/help/C/aunt_mary.xml b/aisleriot/help/C/aunt_mary.xml
index 29d3606..4af3a30 100644
--- a/aisleriot/help/C/aunt_mary.xml
+++ b/aisleriot/help/C/aunt_mary.xml
@@ -52,7 +52,7 @@
 	    piles.  Place three cards face up and the rest face down and so on.  
 	    Repeat gradually revealing more cards each time until there are 
             six rows with six cards.  
-	    Tableau can be built down in alternating colors.  Groups of
+	    Tableau can be built down in alternating colors.  Builds of
 	    cards can be moved.  Empty piles can only be filled by Kings
 	    or group of cards starting with a King.
 	  </entry>
@@ -72,7 +72,7 @@
         <sect2><title>Rules</title>
 
   <para>
-    Cards in the Tableau are built down by alternating color.  Groups of
+    Cards in the Tableau are built down by alternating color.  Builds of
     cards can be moved.  An empty pile in the Tableau can be filled with
     a King or a group of cards with a King on the bottom.
   </para>
diff --git a/aisleriot/help/C/saratoga.xml b/aisleriot/help/C/saratoga.xml
index 1661ce9..9e4e034 100644
--- a/aisleriot/help/C/saratoga.xml
+++ b/aisleriot/help/C/saratoga.xml
@@ -64,7 +64,7 @@
 	    reduces the element of risk and makes Saratoga slightly easier 
 	    than Klondike.  
 	    <!-- TODO FIXME link to Klondike Help page -->
-	    Tableau can be built down in alternating colors.  Groups of
+	    Tableau can be built down in alternating colors.  Builds of
 	    cards can be moved.  Empty piles can only be filled by Kings
 	    or group of cards starting with a King.
 	  </entry>
@@ -84,7 +84,7 @@
         <sect2><title>Rules</title>
 
   <para>
-    Cards in the Tableau are built down by alternating color.  Groups of
+    Cards in the Tableau are built down by alternating color.  Builds of
     cards can be moved.  An empty pile in the Tableau can be filled with
     a King or a group of cards with a King on the bottom.
   </para>
diff --git a/aisleriot/rules/klondike.scm b/aisleriot/rules/klondike.scm
index 5e1c1d9..b074bc3 100644
--- a/aisleriot/rules/klondike.scm
+++ b/aisleriot/rules/klondike.scm
@@ -86,11 +86,19 @@
   (string-append (_"Stock left:") " " 
 		 (number->string (length (get-cards 0)))))
 
+(define (is-tableau-build? card-list)
+  (and (is-visible? (car card-list))
+       (or (null? (cdr card-list))
+           (and (not (color-eq? (car card-list) (cadr card-list)))
+                (= (get-value (cadr card-list))
+                   (+ 1 (get-value (car card-list))))
+                (is-tableau-build? (cdr card-list))))))
+
 (define (button-pressed slot-id card-list)
   (and (or (> slot-id 1)
 	   (and (= slot-id 1)
 		(= (length card-list) 1)))
-       (is-visible? (car (reverse card-list)))))
+       (is-tableau-build? card-list)))
 
 (define (complete-transaction start-slot card-list end-slot)
   (move-n-cards! start-slot end-slot card-list)
@@ -201,18 +209,26 @@
 		(not (= (get-color (get-top-card slot-id2)) color))
 		(list 1 (get-name card) (get-name (get-top-card slot-id2)))))))
 
-(define (check-visible card)
-  (and (is-visible? card) card))
+(define (get-top-build card-list acc)
+  (if (or (null? card-list)
+          (not (is-visible? (car card-list))))
+      acc
+      (if (or (null? acc)
+              (and (not (color-eq? (car card-list) (car acc)))
+                   (= (get-value (car card-list))
+                      (+ 1 (get-value (car acc))))))
+          (get-top-build (cdr card-list) (cons (car card-list) acc))
+          acc)))
 
 (define (shiftable-iter slot-id)
   (and (not (empty-slot? slot-id))
-       (let ((card-list (reverse (get-cards slot-id))))
-	 (set! card (or-map check-visible card-list))
+       (begin
+	 (set! card (car (get-top-build (get-cards slot-id) '())))
 	 (set! color (get-color card))	
 	 (set! value (get-value card))
 	 (set! slot-id1 slot-id)
 	 (and (not (and (= value king)
-			(eq? card (car card-list))))
+			(equal? card (car (reverse (get-cards slot-id))))))
 	      (or-map shiftable? tableau)))))
 
 (define (addable? slot-id)