thumb-and-pouch.scm 7.99 KB
Newer Older
Rosanna Yuen's avatar
Rosanna Yuen committed
1
; AisleRiot - thumb_and_pouch.scm
2
; Copyright (C) 1999, 2003 Rosanna Yuen <rwsy@mit.edu>
Rosanna Yuen's avatar
Rosanna Yuen committed
3
;
4
; This program is free software: you can redistribute it and/or modify
Rosanna Yuen's avatar
Rosanna Yuen committed
5
; it under the terms of the GNU General Public License as published by
6 7
; the Free Software Foundation, either version 3 of the License, or
; (at your option) any later version.
Rosanna Yuen's avatar
Rosanna Yuen committed
8 9 10 11 12 13 14
;
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU General Public License for more details.
;
; You should have received a copy of the GNU General Public License
15
; along with this program.  If not, see <http://www.gnu.org/licenses/>.
Rosanna Yuen's avatar
Rosanna Yuen committed
16

17 18
(use-modules (aisleriot interface) (aisleriot api))

Rosanna Yuen's avatar
Rosanna Yuen committed
19 20 21 22 23 24 25 26 27 28
(define tableau '(6 7 8 9 10 11 12))
(define foundation '(2 3 4 5))

(define (new-game)
  (initialize-playing-area)
  (set-ace-low)

  (make-standard-deck)
  (shuffle-deck)
  
29
  (add-normal-slot DECK 'stock)
Rosanna Yuen's avatar
Rosanna Yuen committed
30

31
  (add-normal-slot '() 'waste)
Rosanna Yuen's avatar
Rosanna Yuen committed
32 33

  (add-blank-slot)
34 35 36 37
  (add-normal-slot '() 'foundation)
  (add-normal-slot '() 'foundation)
  (add-normal-slot '() 'foundation)
  (add-normal-slot '() 'foundation)
Rosanna Yuen's avatar
Rosanna Yuen committed
38
  (add-carriage-return-slot)
39 40 41 42 43 44 45
  (add-extended-slot '() down 'tableau)
  (add-extended-slot '() down 'tableau)
  (add-extended-slot '() down 'tableau)
  (add-extended-slot '() down 'tableau)
  (add-extended-slot '() down 'tableau)
  (add-extended-slot '() down 'tableau)
  (add-extended-slot '() down 'tableau)
Rosanna Yuen's avatar
Rosanna Yuen committed
46

47
  (deal-cards 0 '(6 7 8 9 10 11 12 7 8 9 10 11 12 8 9 10 11 12 9 10 11 12 10 11 12 11 12 12))
Rosanna Yuen's avatar
Rosanna Yuen committed
48 49 50 51 52 53 54 55

  (map flip-top-card tableau)

  (give-status-message)

  (list 7 3))

(define (give-status-message)
56 57 58
  (set-statusbar-message (string-append (get-stock-no-string)
					"   "
					(get-redeals-string))))
Rosanna Yuen's avatar
Rosanna Yuen committed
59 60

(define (get-stock-no-string)
61
  (string-append (_"Stock left:") " " 
Rosanna Yuen's avatar
Rosanna Yuen committed
62 63
		 (number->string (length (get-cards 0)))))

64
(define (get-redeals-string)
65
  (string-append (_"Redeals left:") " "
66 67
		 (number->string (- 2 FLIP-COUNTER))))

Rosanna Yuen's avatar
Rosanna Yuen committed
68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
(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)))))

(define (complete-transaction start-slot card-list end-slot)
  (move-n-cards! start-slot end-slot card-list)
  (if (member start-slot foundation)
      (add-to-score! -1))
  (if (member end-slot foundation)
      (add-to-score! 1))
  (if (and (not (empty-slot? start-slot)) 
	   (member start-slot tableau))
      (make-visible-top-card start-slot))
  #t)

85
(define (droppable? start-slot card-list end-slot)
Rosanna Yuen's avatar
Rosanna Yuen committed
86 87 88 89 90 91 92 93 94 95 96 97 98 99 100
  (and (not (= start-slot end-slot))
       (or (and (member end-slot tableau)
		(or (empty-slot? end-slot)
		    (and (not (eq? (get-suit (get-top-card end-slot))
				   (get-suit (car (reverse card-list)))))
			 (= (get-value (get-top-card end-slot))
			    (+ 1 (get-value (car (reverse card-list))))))))
	   (and (member end-slot foundation)
		(= 1 (length card-list))
		(or (and (empty-slot? end-slot)
			 (= ace (get-value (car card-list))))
		    (and (not (empty-slot? end-slot))
			 (eq? (get-suit (get-top-card end-slot))
			      (get-suit (car card-list)))
			 (= (get-value (get-top-card end-slot))
101 102 103 104
			    (- (get-value (car card-list)) 1))))))))

(define (button-released start-slot card-list end-slot)
  (and (droppable? start-slot card-list end-slot)
Rosanna Yuen's avatar
Rosanna Yuen committed
105 106 107 108
       (complete-transaction start-slot card-list end-slot)))

(define (button-clicked slot-id)
  (and (= slot-id 0)
109
       (flip-stock 0 1 2)
Rosanna Yuen's avatar
Rosanna Yuen committed
110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138
       (give-status-message)))

(define (button-double-clicked slot-id)
  (and (or (member slot-id tableau)
	   (= slot-id 1))
       (not (empty-slot? slot-id))
       (let* ((card (get-top-card slot-id))
	      (suit (get-suit card))
	      (value (get-value card)))
	 (let ((end-slot 
		(cond ((if (empty-slot? 2)
			   (= ace value)
			   (= suit (get-suit (get-top-card 2)))) 2)
		      ((if (empty-slot? 3)
			   (= ace value)
			   (= suit (get-suit (get-top-card 3)))) 3)
		      ((if (empty-slot? 4)
			   (= ace value)
			   (= suit (get-suit (get-top-card 4)))) 4)
		      ((if (empty-slot? 5)
			   (= ace value)
			   (= suit (get-suit (get-top-card 5)))) 5)
		      (#t #f))))
	   (and end-slot
		(or (= ace value)
		    (= (get-value (get-top-card end-slot)) (- value 1)))
		(remove-card slot-id)
		(complete-transaction slot-id (list card) end-slot))))))

139 140 141 142 143
(define (do-deal-next-cards)
  (flip-stock 0 1 2)
  (give-status-message))

(define (dealable?)
144
  (flippable? 0 1 2))
145

Rosanna Yuen's avatar
Rosanna Yuen committed
146
(define (game-continuable)
147
  (get-hint))
Rosanna Yuen's avatar
Rosanna Yuen committed
148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164

(define (game-won)
  (and (= 13 (length (get-cards 2)))
       (= 13 (length (get-cards 3)))
       (= 13 (length (get-cards 4)))
       (= 13 (length (get-cards 5)))))

(define (empty-exist? slot-id)
  (cond ((= slot-id 13)
	 #f)
	((empty-slot? slot-id)
	 #t)
	(#t
	 (empty-exist? (+ 1 slot-id)))))

(define (check-waste-to-empty)
  (and (not (empty-slot? 1))
165
       (hint-move 1 1 (find-empty-slot tableau))))
Rosanna Yuen's avatar
Rosanna Yuen committed
166

167
(define (stripped-len card-list acc)
Rosanna Yuen's avatar
Rosanna Yuen committed
168
  (if (not (is-visible? (cadr card-list)))
169 170
      acc
      (stripped-len (cdr card-list) (+ 1 acc))))
Rosanna Yuen's avatar
Rosanna Yuen committed
171 172 173 174 175 176

(define (check-tableau-to-empty slot-id)
  (cond ((= slot-id 13)
	 #f)
	((and (not (empty-slot? slot-id))
	      (not (is-visible? (car (reverse (get-cards slot-id))))))
177
	 (hint-move slot-id (stripped-len (get-cards slot-id) 1) (find-empty-slot tableau)))
Rosanna Yuen's avatar
Rosanna Yuen committed
178 179 180 181 182 183 184 185 186 187
	(#t (check-tableau-to-empty (+ 1 slot-id)))))


(define (check-empty?)
  (and (empty-exist? 6)
       (or (check-tableau-to-empty 6)
	   (check-waste-to-empty))))

(define (check-a-foundation slot-id card f-slot)
  (cond ((or (> f-slot 5)
Rosanna Yuen's avatar
Rosanna Yuen committed
188 189
	     (or (< slot-id 0)
		 (empty-slot? slot-id)))
Rosanna Yuen's avatar
Rosanna Yuen committed
190 191 192 193 194
	 #f)
	((and (empty-slot? f-slot)
	      (= (get-value card) ace))
	 (if (< slot-id 0)
	     #t
195
	     (hint-move slot-id 1 f-slot)))
Rosanna Yuen's avatar
Rosanna Yuen committed
196 197 198 199 200 201 202
	((and (not (empty-slot? f-slot))
	      (eq? (get-suit (get-top-card f-slot))
		   (get-suit card))
	      (= (get-value card)
		 (+ 1 (get-value (get-top-card f-slot)))))
	 (if (< slot-id 0)
	     #t
203
	     (hint-move slot-id 1 f-slot)))
Rosanna Yuen's avatar
Rosanna Yuen committed
204 205 206 207 208 209 210 211 212 213 214 215
	(#t
	 (check-a-foundation slot-id card (+ 1 f-slot)))))

(define (check-to-foundations slot-id)
  (cond ((> slot-id 12)
	 #f)
	((= slot-id 2)
	 (check-to-foundations 6))
	(#t
	 (or (check-a-foundation slot-id (get-top-card slot-id) 2)
	     (check-to-foundations (+ 1 slot-id))))))

216
(define (check-a-tslot from-slot to-slot num-cards card card-list)
Rosanna Yuen's avatar
Rosanna Yuen committed
217 218 219 220 221 222 223 224 225 226
  (and (not (or (= (length card-list) 0)
		(not (is-visible? (car card-list)))
		(>= (get-value (car card-list)) (get-value card))))
       (or (and (= (get-value card)
		   (+ 1 (get-value (car card-list))))
		(not (eq? (get-suit card)
			  (get-suit (car card-list))))
		(or (= (length card-list) 1)
		    (not (is-visible? (cadr card-list)))
		    (check-a-foundation -1 (cadr card-list) 2))
227 228
		(hint-move from-slot num-cards to-slot))
	   (check-a-tslot from-slot to-slot (+ 1 num-cards) card (cdr card-list)))))
Rosanna Yuen's avatar
Rosanna Yuen committed
229 230 231 232 233 234 235 236 237

(define (check-tslot to-slot from-slot)
  (cond ((> from-slot 12)
	 #f)
	((= from-slot 2)
	 (check-tslot to-slot 6))
	((empty-slot? to-slot)
	 (check-tslot to-slot (+ 1 from-slot)))
	(#t 
Rosanna Yuen's avatar
Rosanna Yuen committed
238 239
	 (or (and (= from-slot 1)
		  (not (empty-slot? 1))
240 241
		  (check-a-tslot from-slot to-slot 1
		                 (get-top-card to-slot)
Rosanna Yuen's avatar
Rosanna Yuen committed
242
				 (list (get-top-card from-slot))))
243 244
	     (check-a-tslot from-slot to-slot 1
	                    (get-top-card to-slot)
Rosanna Yuen's avatar
Rosanna Yuen committed
245 246 247 248 249 250 251 252 253 254 255 256
			    (get-cards from-slot))
	     (check-tslot to-slot (+ 1 from-slot))))))

(define (check-to-tableau slot-id)
  (and (not (> slot-id 12))
       (or (check-tslot slot-id 1)
	   (check-to-tableau (+ 1 slot-id)))))

(define (get-hint)
  (or (check-to-foundations 1)
      (check-to-tableau 6)
      (check-empty?)
257 258 259 260 261
      (or (and (not (empty-slot? 0))
               (list 0 (_"Deal another round")))
          (and (not (empty-slot? 1))
               (< FLIP-COUNTER 2)
               (list 0 (_"Move waste back to stock"))))))
Rosanna Yuen's avatar
Rosanna Yuen committed
262 263 264 265 266 267 268 269 270 271

(define (get-options) 
  #f)

(define (apply-options options) 
  #f)

(define (timeout) 
  #f)

272
(set-features droppable-feature dealable-feature)
273

Rosanna Yuen's avatar
Rosanna Yuen committed
274 275
(set-lambda new-game button-pressed button-released button-clicked
button-double-clicked game-continuable game-won get-hint get-options
276
apply-options timeout droppable? dealable?)