[aisleriot] camelot: Use hint-move instead of get-name.

From: Vincent Povirk <vpovirk src gnome org>
To: commits-list gnome org
Cc:
Subject: [aisleriot] camelot: Use hint-move instead of get-name.
Date: Sun, 20 Nov 2011 04:05:55 +0000 (UTC)
commit 1dfe6fa16eb6472619c7aa511ca76012c608a895
Author: Vincent Povirk <madewokherd gmail com>
Date:   Sat Nov 19 20:01:04 2011 -0600

    camelot: Use hint-move instead of get-name.
    
    For bug 551859.

 games/camelot.scm |  109 +++++++++++++++++++++--------------------------------
 games/sol.scm     |   28 ++++++++++++--
 2 files changed, 67 insertions(+), 70 deletions(-)
---
diff --git a/games/camelot.scm b/games/camelot.scm
index 3c168b0..ffab392 100644
--- a/games/camelot.scm
+++ b/games/camelot.scm
@@ -26,40 +26,40 @@
   (add-blank-slot)
   (add-blank-slot)
   (set! HORIZPOS (+ HORIZPOS 0.5))
-  (add-normal-slot '())           ; Slot 0
-  (add-normal-slot '())           ; Slot 1
-  (add-normal-slot '())           ; Slot 2
-  (add-normal-slot '())           ; Slot 3
+  (add-normal-slot '() 'corner)           ; Slot 0
+  (add-normal-slot '() 'top)              ; Slot 1
+  (add-normal-slot '() 'top)              ; Slot 2
+  (add-normal-slot '() 'corner)           ; Slot 3
   (add-carriage-return-slot)
   (add-blank-slot)
   (add-blank-slot)
   (set! HORIZPOS (+ HORIZPOS 0.5))
-  (add-normal-slot '())           ; Slot 4
-  (add-normal-slot '())           ; Slot 5
-  (add-normal-slot '())           ; Slot 6
-  (add-normal-slot '())           ; Slot 7
+  (add-normal-slot '() 'left)     ; Slot 4
+  (add-normal-slot '() 'tableau)  ; Slot 5
+  (add-normal-slot '() 'tableau)  ; Slot 6
+  (add-normal-slot '() 'right)    ; Slot 7
   (add-carriage-return-slot)
   (add-blank-slot)
   (add-blank-slot)
   (set! HORIZPOS (+ HORIZPOS 0.5))
-  (add-normal-slot '())           ; Slot 8
-  (add-normal-slot '())           ; Slot 9
-  (add-normal-slot '())           ; Slot 10
-  (add-normal-slot '())           ; Slot 11
+  (add-normal-slot '() 'left)     ; Slot 8
+  (add-normal-slot '() 'tableau)  ; Slot 9
+  (add-normal-slot '() 'tableau)  ; Slot 10
+  (add-normal-slot '() 'right)    ; Slot 11
   (add-carriage-return-slot)
   (add-blank-slot)
   (add-blank-slot)
   (set! HORIZPOS (+ HORIZPOS 0.5))
-  (add-normal-slot '())           ; Slot 12
-  (add-normal-slot '())           ; Slot 13
-  (add-normal-slot '())           ; Slot 14
-  (add-normal-slot '())           ; Slot 15
+  (add-normal-slot '() 'corner)   ; Slot 12
+  (add-normal-slot '() 'bottom)   ; Slot 13
+  (add-normal-slot '() 'bottom)   ; Slot 14
+  (add-normal-slot '() 'corner)   ; Slot 15
 
   (set! HORIZPOS 0)
   (set! VERTPOS 0)
 
-  (add-normal-slot DECK)          ; Slot 16
-  (add-normal-slot '())           ; Slot 17
+  (add-normal-slot DECK 'stock)   ; Slot 16
+  (add-normal-slot '() 'waste)    ; Slot 17
   (set! add-stage #t)
   (set! fill-count 0)
 
@@ -162,54 +162,32 @@
        (empty-slot? 9)
        (empty-slot? 10)))
 
-(define (list-cards slot)
-  (if (= slot 16) 
-      '() 
-      (append (if (and (not (empty-slot? slot))
-		       (< (get-value (get-top-card slot)) 11)) 
-		  (get-cards slot) 
-		  '()) 
-	      (list-cards (+ 1 slot)))))
-
-(define (find-card-val-in-list? cards value)
-  (and (not (null? cards))
-       (if (= value (get-value (car cards))) 
-	   (car cards)
-	   (find-card-val-in-list? (cdr cards) value))))
-
-(define (find-match cards)
-  (and (not (null? cards))
-       (if (= 10 (get-value (car cards))) 
-	   (list 2 (get-name (car cards)) (_"itself")) ; yuk..
-	   (let ((match (find-card-val-in-list? 
-			 (cdr cards)
-			 (- 10 (get-value (car cards))))))
-	     (if match
-		 (list 1 (get-name (car cards)) (get-name match))
-		 (find-match (cdr cards)))))))
+(define (hint-remove-ten suit)
+  (cond ((eq? suit club) (_"Remove the ten of clubs."))
+        ((eq? suit diamond) (_"Remove the ten of diamonds."))
+        ((eq? suit heart) (_"Remove the ten of hearts."))
+        ((eq? suit spade) (_"Remove the ten of spades."))))
+
+(define (find-match slot1 slot2)
+  (cond ((= slot2 16) (find-match (+ 1 slot1) 0))
+        ((= slot1 16) #f)
+        ((or (empty-slot? slot2) (> (get-value (get-top-card slot2)) 10)) (find-match slot1 (+ 1 slot2)))
+        ((or (empty-slot? slot1) (> (get-value (get-top-card slot1)) 10)) (find-match (+ 1 slot1) 0))
+        ((= 10 (get-value (get-top-card slot2))) (list 0 (hint-remove-ten (get-suit (get-top-card slot2)))))
+        ((= slot1 slot2) (find-match slot1 (+ 1 slot2)))
+        ((= 10 (+ (get-value (get-top-card slot1)) (get-value (get-top-card slot2))))
+         (hint-move slot1 1 slot2))
+        (#t (find-match slot1 (+ 1 slot2)))))
 
 (define (placeable? card)
   (cond ((= (get-value card) king)
-	 (and (or (empty-slot? 0)
-		  (empty-slot? 3)
-		  (empty-slot? 12)
-		  (empty-slot? 15))
-	      (_"an empty corner slot")))
-	 ((= (get-value card) queen)
-	  (or (and (or (empty-slot? 1)
-		       (empty-slot? 2))
-		   (_"an empty top slot"))
-	      (and (or (empty-slot? 13)
-		       (empty-slot? 14))
-		   (_"an empty bottom slot"))))
+	 (find-empty-slot '(0 3 12 15)))
+	((= (get-value card) queen)
+	 (find-empty-slot '(1 2 13 14)))
 	((= (get-value card) jack)
-	  (or (and (or (empty-slot? 4)
-		       (empty-slot? 8))
-		   (_"an empty left slot"))
-	      (and (or (empty-slot? 7)
-		       (empty-slot? 11))
-		   (_"an empty right slot"))))
-	(#t (_"an empty slot"))))
+	 (find-empty-slot '(4 8 7 11)))
+	(#t
+	 (find-empty-slot '(5 6 9 10 0 1 2 3 4 7 8 11 12 13 14 15)))))
 
 (define (game-over)
   (give-status-message)
@@ -217,16 +195,15 @@
 	  (and (empty-slot? 16) (empty-slot? 17)))
       (begin 
 	(set! add-stage #f)
-	(find-match (list-cards 0)))
+	(find-match 0 0))
       (or (empty-slot? 17)
 	  (placeable? (get-top-card 17)))))
 
 (define (get-hint)
   (or (if add-stage
 	  (and (not (empty-slot? 17))
-	       (list 2 (get-name (get-top-card 17))
-		     (placeable? (get-top-card 17))))
-	  (find-match (list-cards 0)))
+	       (hint-move 17 1 (placeable? (get-top-card 17))))
+	  (find-match 0 0))
       (list 0 (_"Deal a new card from the deck"))))
 
 (define (get-options) #f)
diff --git a/games/sol.scm b/games/sol.scm
index a1f1742..e49d84a 100644
--- a/games/sol.scm
+++ b/games/sol.scm
@@ -70,7 +70,12 @@
   (set! HISTORY '())
   (set! FOUNDATION-SLOTS '())
   (set! TABLEAU-SLOTS '())
-  (set! EDGE-SLOTS '()))
+  (set! EDGE-SLOTS '())
+  (set! CORNER-SLOTS '())
+  (set! TOP-SLOTS '())
+  (set! BOTTOM-SLOTS '())
+  (set! LEFT-SLOTS '())
+  (set! RIGHT-SLOTS '()))
 
 ; Use this instead of define for variables which determine the state of
 ; the game. i.e. anything that isn't a constant. This is so undo/redo
@@ -297,9 +302,9 @@
           (any-slot-empty? (cdr slots)))))
 
 (define (find-empty-slot slots)
-  (if (empty-slot? (car slots))
-      (car slots)
-      (find-empty-slot (cdr slots))))
+  (cond ((null? slots) #f)
+        ((empty-slot? (car slots)) (car slots))
+        (#t (find-empty-slot (cdr slots)))))
 
 (define (find-card-helper card cards n)
   (if (null? cards)
@@ -456,6 +461,11 @@
       (cond ((member to-slot FOUNDATION-SLOTS) (if (= (length FOUNDATION-SLOTS) 1) (_"Move ~a onto the foundation.") (_"Move ~a onto an empty foundation slot.")))
             ((member to-slot TABLEAU-SLOTS) (if (= (length TABLEAU-SLOTS) 1) (_"Move ~a onto the tableau.") (_"Move ~a onto an empty tableau slot.")))
             ((member to-slot EDGE-SLOTS) (_"Move ~a onto an empty edge slot."))
+            ((member to-slot CORNER-SLOTS) (_"Move ~a onto an empty corner slot."))
+            ((member to-slot TOP-SLOTS) (_"Move ~a onto an empty top slot."))
+            ((member to-slot BOTTOM-SLOTS) (_"Move ~a onto an empty bottom slot."))
+            ((member to-slot LEFT-SLOTS) (_"Move ~a onto an empty left slot."))
+            ((member to-slot RIGHT-SLOTS) (_"Move ~a onto an empty right slot."))
             (else (_"Move ~a onto an empty slot.")))
       (let* ((card (get-top-card to-slot)) (value (get-value card)) (suit (get-suit card)))
              (cond ((is-joker? card)
@@ -586,6 +596,11 @@
   (case (cadddr slot)
     ((tableau) (set! TABLEAU-SLOTS (cons SLOTS TABLEAU-SLOTS)))
     ((edge) (set! EDGE-SLOTS (cons SLOTS EDGE-SLOTS)))
+    ((corner) (set! CORNER-SLOTS (cons SLOTS CORNER-SLOTS)))
+    ((top) (set! TOP-SLOTS (cons SLOTS TOP-SLOTS)))
+    ((bottom) (set! BOTTOM-SLOTS (cons SLOTS BOTTOM-SLOTS)))
+    ((left) (set! LEFT-SLOTS (cons SLOTS LEFT-SLOTS)))
+    ((right) (set! RIGHT-SLOTS (cons SLOTS RIGHT-SLOTS)))
     ((foundation) (set! FOUNDATION-SLOTS (cons SLOTS FOUNDATION-SLOTS))))
   (set! SLOTS (+ 1 SLOTS))
   (cons (- SLOTS 1) (cdr slot)))
@@ -626,6 +641,11 @@
 (define FOUNDATION-SLOTS '())
 (define TABLEAU-SLOTS '())
 (define EDGE-SLOTS '())
+(define CORNER-SLOTS '())
+(define TOP-SLOTS '())
+(define BOTTOM-SLOTS '())
+(define LEFT-SLOTS '())
+(define RIGHT-SLOTS '())
 
 ; called from C:
 (define (start-game)
[Date Prev][Date Next] [Thread Prev][Thread Next] [Thread Index] [Date Index] [Author Index]