1; AisleRiot - gypsy.scm
2; Copyright (C) 2001 Rosanna Yuen <zana@webwynk.net>
3;
4; This program is free software: you can redistribute it and/or modify
5; it under the terms of the GNU General Public License as published by
6; the Free Software Foundation, either version 3 of the License, or
7; (at your option) any later version.
8;
9; This program is distributed in the hope that it will be useful,
10; but WITHOUT ANY WARRANTY; without even the implied warranty of
11; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12; GNU General Public License for more details.
13;
14; 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/>.
16
17(use-modules (aisleriot interface) (aisleriot api))
18
19(define foundation '(1 2 3 4 5 6 7 8))
20
21(define (new-game)
22  (initialize-playing-area)
23  (set-ace-low)
24  (make-standard-double-deck)
25  (shuffle-deck)
26
27  (add-normal-slot DECK 'stock)
28
29  (add-blank-slot)
30
31  (add-normal-slot '() 'foundation)
32  (add-normal-slot '() 'foundation)
33  (add-normal-slot '() 'foundation)
34  (add-normal-slot '() 'foundation)
35  (add-normal-slot '() 'foundation)
36  (add-normal-slot '() 'foundation)
37  (add-normal-slot '() 'foundation)
38  (add-normal-slot '() 'foundation)
39
40  (add-carriage-return-slot)
41
42  (add-blank-slot)
43
44  (add-extended-slot '() down 'tableau)
45  (add-extended-slot '() down 'tableau)
46  (add-extended-slot '() down 'tableau)
47  (add-extended-slot '() down 'tableau)
48  (add-extended-slot '() down 'tableau)
49  (add-extended-slot '() down 'tableau)
50  (add-extended-slot '() down 'tableau)
51  (add-extended-slot '() down 'tableau)
52
53  (deal-cards 0 '(9 10 11 12 13 14 15 16 9 10 11 12 13 14 15 16))
54  (deal-cards-face-up 0 '(9 10 11 12 13 14 15 16))
55
56  (give-status-message)
57
58
59  (list 10 5))
60
61(define (give-status-message)
62  (set-statusbar-message (get-stock-no-string)))
63
64(define (get-stock-no-string)
65  (string-append (_"Stock left:") " "
66		 (number->string (length (get-cards 0)))))
67
68(define (button-pressed slot-id card-list)
69  (and (not (empty-slot? slot-id))
70       (> slot-id 0)
71       (not (eq? '() card-list))
72       (is-visible? (car (reverse card-list)))
73       (check-alternating-color-list card-list)
74       (check-straight-descending-list card-list)))
75
76(define (check-visibility slot)
77  (or (empty-slot? slot)
78      (is-visible? (get-top-card slot))
79      (make-visible-top-card slot)))
80
81(define (foundation-score slot-id prev-total)
82  (define (current-total)
83    (+ prev-total
84       (* (length (get-cards slot-id)) 5)
85       (if (= (length (get-cards slot-id)) 13)
86           60
87           0)))
88  (if (= slot-id 8)
89      (current-total)
90      (foundation-score (+ slot-id 1) (current-total))))
91
92(define (tableau-score slot-id prev-total)
93  (define (cards-score cards prev-total)
94    (if (< (length cards) 2)
95        prev-total
96        (if (and (is-visible? (car cards))
97                 (is-visible? (cadr cards))
98                 (not (= (get-color (car cards))
99                         (get-color (cadr cards))))
100                 (= (get-value (car cards))
101                    (- (get-value (cadr cards)) 1)))
102            (cards-score (cdr cards) (+ prev-total 2))
103            (cards-score (cdr cards) prev-total))))
104  (define (current-total)
105    (cards-score (get-cards slot-id) prev-total))
106  (if (= slot-id 16)
107      (current-total)
108      (tableau-score (+ slot-id 1) (current-total))))
109
110(define (recalculate-score)
111  (set-score! (+ (foundation-score 1 0)
112                 (tableau-score 9 0))))
113
114(define (droppable? start-slot card-list end-slot)
115  (cond ((= end-slot start-slot)
116	 #f)
117	((and (> end-slot 0)
118	      (< end-slot 9))
119	 (if (= (length card-list) 1)
120	     (cond ((empty-slot? end-slot)
121		    (= (get-value (car card-list)) ace))
122		   (#t
123		    (and (= (get-suit (get-top-card end-slot))
124			    (get-suit (car card-list)))
125			 (= (get-value (car card-list))
126			    (+ 1 (get-value (get-top-card end-slot)))))))
127	     #f))
128	((and (> end-slot 8)
129	      (empty-slot? end-slot))
130	 #t)
131	(#t (and (> end-slot 8)
132		 (eq? (is-red? (get-top-card end-slot))
133		      (is-black? (car (reverse card-list))))
134		 (= (get-value (get-top-card end-slot))
135		    (+ 1 (get-value (car (reverse card-list)))))))))
136
137(define (button-released start-slot card-list end-slot)
138  (and (droppable? start-slot card-list end-slot)
139       (move-n-cards! start-slot end-slot card-list)
140       (recalculate-score)
141       (check-visibility start-slot)))
142
143(define (button-clicked slot-id)
144  (and (= slot-id 0)
145       (not (empty-slot? slot-id))
146       (deal-cards-face-up 0 '(9 10 11 12 13 14 15 16))
147       (recalculate-score)))
148
149(define (find-empty-foundation a-slot f-slot)
150  (cond ((> f-slot 8)
151	 #f)
152	((empty-slot? f-slot)
153	 (deal-cards a-slot (list f-slot)))
154	(#t (find-empty-foundation a-slot (+ 1 f-slot)))))
155
156(define (find-foundation a-slot f-slot)
157  (cond ((> f-slot 8)
158	 #f)
159	((and (not (empty-slot? f-slot))
160	      (= (get-suit (get-top-card a-slot))
161		 (get-suit (get-top-card f-slot)))
162	      (= (get-value (get-top-card a-slot))
163		 (+ 1 (get-value (get-top-card f-slot)))))
164	 (deal-cards a-slot (list f-slot)))
165	(#t (find-foundation a-slot (+ 1 f-slot)))))
166
167(define (autoplay-foundations)
168  (define (autoplay-foundations-tail)
169    (if (or-map button-double-clicked '(9 10 11 12 13 14 15 16))
170        (delayed-call autoplay-foundations-tail)
171        #t))
172  (if (or-map button-double-clicked '(9 10 11 12 13 14 15 16))
173      (autoplay-foundations-tail)
174      #f))
175
176(define (button-double-clicked slot-id)
177  (cond ((> slot-id 8)
178         (and (not (empty-slot? slot-id))
179              (or (and (= (get-value (get-top-card slot-id))
180		          ace)
181		       (find-empty-foundation slot-id 1)
182		       (check-visibility slot-id)
183		       (recalculate-score))
184	          (and (find-foundation slot-id 1)
185		       (check-visibility slot-id)
186		       (recalculate-score)))))
187	((> slot-id 0)
188	 (autoplay-foundations))
189	(else #f)))
190
191
192(define (game-continuable)
193  (give-status-message)
194  (and (not (game-won))
195       (get-hint)))
196
197(define (game-won)
198  (and (= (length (get-cards 1)) 13)
199       (= (length (get-cards 2)) 13)
200       (= (length (get-cards 3)) 13)
201       (= (length (get-cards 4)) 13)
202       (= (length (get-cards 5)) 13)
203       (= (length (get-cards 6)) 13)
204       (= (length (get-cards 7)) 13)
205       (= (length (get-cards 8)) 13)))
206
207(define (check-for-empty)
208  (if (or (empty-slot? 9)
209	   (empty-slot? 10)
210	   (empty-slot? 11)
211	   (empty-slot? 12)
212	   (empty-slot? 13)
213	   (empty-slot? 14)
214	   (empty-slot? 15)
215	   (empty-slot? 16))
216      (list 0 (_"Move a card or build of cards on to the empty slot"))
217      #f))
218
219
220(define (check-a-foundation card slot-id)
221  (cond ((= slot-id 9)
222	 #f)
223	((and (not (empty-slot? slot-id))
224	      (eq? (get-suit card)
225		   (get-suit (get-top-card slot-id)))
226	      (= (get-value card)
227		 (+ 1 (get-value (get-top-card slot-id)))))
228	 slot-id)
229	(#t (check-a-foundation card (+ 1 slot-id)))))
230
231(define (check-to-foundations? slot-id)
232  (cond ((= slot-id 17)
233	 #f)
234	((empty-slot? slot-id)
235	 (check-to-foundations? (+ 1 slot-id)))
236	((= (get-value (get-top-card slot-id)) ace)
237	 (hint-move slot-id 1 (find-empty-slot foundation)))
238	((check-a-foundation (get-top-card slot-id) 1)
239	 (hint-move slot-id 1 (check-a-foundation (get-top-card slot-id) 1)))
240	(#t (check-to-foundations? (+ 1 slot-id)))))
241
242(define (stripped card-list card)
243  (if (<= (length card-list) 1)
244      '()
245      (if (eq? card (car card-list))
246	  (cdr card-list)
247	  (if (= (length card-list) 2)
248	      '()
249	      (stripped (cdr card-list) card)))))
250
251(define (check-a-tableau card slot1 card-list slot2 imbedded?)
252  (cond ((or (= (length card-list) 0)
253	     (not (is-visible? (car card-list))))
254	 #f)
255	((and (not (eq? (is-red? (car card-list))
256			(is-red? card)))
257	      (= (+ 1 (get-value (car card-list)))
258		 (get-value card)))
259	 (if (or (= (length card-list) 1)
260		  (eq? (is-red? (car card-list))
261		       (is-red? (cadr card-list)))
262		  imbedded?
263		  (not (= (+ 1 (get-value (car card-list)))
264			  (get-value (cadr card-list))))
265		  (check-a-foundation (cadr card-list) 1)
266		  (and (check-alternating-color-list (list (car card-list) (cadr card-list)))
267		       (check-straight-descending-list (list (car card-list) (cadr card-list)))
268		       (check-a-tableau (get-top-card slot2)
269					slot1
270					(cdr card-list)
271					slot2
272					#t))
273		  (and (> (length (get-cards slot1)) 1)
274		       (check-alternating-color-list (list (get-top-card slot1)
275							   (cadr (get-cards slot1))))
276		       (check-straight-descending-list (list (get-top-card slot1)
277							     (cadr (get-cards slot1))))
278		       (check-a-tableau (cadr card-list)
279					slot2
280					(get-cards slot1)
281					slot1
282					#t)))
283	     (hint-move slot2 (+ 1 (- (length (get-cards slot2)) (length card-list))) slot1)
284	     (and (not imbedded?)
285		  (> (length card-list) 1)
286		  (check-alternating-color-list (list (car card-list)
287						      (cadr card-list)))
288		  (check-straight-descending-list (list (car card-list)
289						      (cadr card-list)))
290		  (check-a-tableau card
291				   slot1
292				   (cdr card-list)
293				   slot2
294				   imbedded?))))
295	(imbedded? #f)
296	(#t (and (> (length card-list) 1)
297		 (check-alternating-color-list (list (car card-list)
298						     (cadr card-list)))
299		 (check-straight-descending-list (list (car card-list)
300						       (cadr card-list)))
301		 (check-a-tableau card slot1 (cdr card-list) slot2 imbedded?)))))
302
303(define (check-to-tableau? slot1 slot2)
304  (cond ((= slot1 17)
305	 #f)
306	((or (= slot2 17)
307	     (empty-slot? slot1))
308	 (check-to-tableau? (+ 1 slot1) 9))
309	((and (not (= slot1 slot2))
310	      (check-a-tableau (get-top-card slot1)
311			       slot1
312			       (get-cards slot2)
313			       slot2
314			       #f))
315	 (check-a-tableau (get-top-card slot1)
316			  slot1
317			  (get-cards slot2)
318			  slot2
319			  #f))
320	(#t (check-to-tableau? slot1 (+ 1 slot2)))))
321
322(define (check-from-foundation? slot1 slot2)
323  (cond ((= slot1 9)
324	 #f)
325	((or (= slot2 17)
326	     (empty-slot? slot1))
327	 (check-from-foundation? (+ 1 slot1) 9))
328	(#t (or (and (not (empty-slot? slot2))
329		     (check-a-tableau (get-top-card slot2)
330				      slot2
331				      (get-cards slot1)
332				      slot1
333				      #f))
334		(check-from-foundation? slot1 (+ 1 slot2))))))
335
336
337(define (check-for-deal)
338  (if (not (empty-slot? 0))
339      (list 0 (_"Deal another hand"))
340      #f))
341
342(define (get-hint)
343  (or (check-to-foundations? 9)
344      (check-to-tableau? 9 10)
345      (check-for-empty)
346      (check-for-deal)
347      (check-from-foundation? 1 9)))
348
349(define (get-options)
350  #f)
351
352(define (apply-options options)
353  #f)
354
355(define (timeout)
356  #f)
357
358(set-features droppable-feature)
359
360(set-lambda new-game button-pressed button-released button-clicked
361button-double-clicked game-continuable game-won get-hint get-options
362apply-options timeout droppable?)
363