1; AisleRiot - lady_jane.scm
2; Copyright (C) 1999, 2003 Rosanna Yuen <rwsy@mit.edu>
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 BASE-VAL 0)
20
21(define stock 0)
22(define waste 1)
23(define foundation '(2 3 4 5))
24(define tableau '(6 7 8 9 10 11 12))
25(define reserve '(13 14 15 16 17 18 19))
26
27(define (new-game)
28  (initialize-playing-area)
29  (set-ace-low)
30  (make-standard-deck)
31  (shuffle-deck)
32
33  (add-normal-slot DECK 'stock)
34  (add-normal-slot '() 'waste)
35
36  (add-blank-slot)
37
38  (add-normal-slot '() 'foundation)
39  (add-normal-slot '() 'foundation)
40  (add-normal-slot '() 'foundation)
41  (add-normal-slot '() 'foundation)
42
43  (add-carriage-return-slot)
44
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  (set! HORIZPOS 0)
54  (set! VERTPOS 0)
55
56  (set! VERTPOS (+ VERTPOS 0.5))
57  (set! HORIZPOS (+ HORIZPOS 7))
58  (add-normal-slot '() 'reserve)
59  (add-carriage-return-slot)
60  (set! HORIZPOS (+ HORIZPOS 7))
61  (add-normal-slot '() 'reserve)
62  (add-carriage-return-slot)
63  (set! HORIZPOS (+ HORIZPOS 7))
64  (add-normal-slot '() 'reserve)
65  (add-carriage-return-slot)
66  (set! HORIZPOS (+ HORIZPOS 7))
67
68
69  (set! HORIZPOS 0)
70  (set! VERTPOS 0)
71
72  (set! HORIZPOS (+ HORIZPOS 7))
73  (add-blank-slot)
74  (add-normal-slot '() 'reserve)
75  (add-carriage-return-slot)
76  (set! HORIZPOS (+ HORIZPOS 7))
77  (add-blank-slot)
78  (add-normal-slot '() 'reserve)
79  (add-carriage-return-slot)
80  (set! HORIZPOS (+ HORIZPOS 7))
81  (add-blank-slot)
82  (add-normal-slot '() 'reserve)
83  (add-carriage-return-slot)
84  (set! HORIZPOS (+ HORIZPOS 7))
85  (add-blank-slot)
86  (add-normal-slot '() 'reserve)
87
88  (deal-cards 0 '(7 8 9 10 11 12 8 9 10 11 12 9 10 11 12 10 11 12
89		    11 12 12))
90  (deal-cards-face-up 0 '(6 7 8 9 10 11 12 13 14 15 16 17 18 19 2))
91
92  (add-to-score! 1)
93
94  (set! BASE-VAL (get-value (get-top-card 2)))
95
96  (give-status-message)
97
98  (list 9 4)
99)
100
101(define (give-status-message)
102  (set-statusbar-message (string-append (get-stock-no-string)
103					"   "
104					(get-base-string))))
105
106(define (get-base-string)
107  (cond ((and (> BASE-VAL 1)
108	      (< BASE-VAL 11))
109	 (string-append (_"Base Card:") " " (number->string BASE-VAL)))
110	((= BASE-VAL 1)
111	 (_"Base Card: Ace"))
112	((= BASE-VAL 11)
113	 (_"Base Card: Jack"))
114	((= BASE-VAL 12)
115	 (_"Base Card: Queen"))
116	((= BASE-VAL 13)
117	 (_"Base Card: King"))
118	(#t "")))
119
120(define (get-stock-no-string)
121  (if (> (length (get-cards 0)) 1)
122      (string-append (_"Stock left:") " "
123		     (number->string (length (get-cards 0))))
124      (string-append (_"Stock left: 0"))))
125
126(define (button-pressed slot-id card-list)
127  (and (not (empty-slot? slot-id))
128       (is-visible? (car (reverse card-list)))))
129
130(define (to-foundation? card end-slot)
131  (if (empty-slot? end-slot)
132      (= (get-value card) BASE-VAL)
133      (and (eq? (get-suit card)
134		(get-suit (get-top-card end-slot)))
135	   (or (= (+ 1 (get-value (get-top-card end-slot)))
136		  (get-value card))
137	       (and (= (get-value (get-top-card end-slot)) king)
138		    (= (get-value card) ace))))))
139
140(define (to-tableau? card end-slot)
141  (if (empty-slot? end-slot)
142      (or (= (get-value card) (- BASE-VAL 1))
143	  (and (= BASE-VAL ace)
144	       (= (get-value card) king)))
145      (and (not (eq? (is-red? card)
146		     (is-red? (get-top-card end-slot))))
147	   (not (= (get-value (get-top-card end-slot)) BASE-VAL))
148	   (or (= (get-value (get-top-card end-slot))
149		  (+ 1 (get-value card)))
150	       (and (= (get-value (get-top-card end-slot)) ace)
151		    (= (get-value card) king))))))
152
153(define (droppable? start-slot card-list end-slot)
154  (if (not (= start-slot end-slot))
155      (cond ((and (> end-slot 1)
156		  (< end-slot 6))
157	     (and (= (length card-list) 1)
158		  (to-foundation? (car card-list) end-slot)))
159	    ((and (> end-slot 5)
160		  (< end-slot 13))
161	     (and (to-tableau? (car (reverse card-list)) end-slot)))
162	    (#t #f))
163      #f))
164
165(define (button-released start-slot card-list end-slot)
166  (if (droppable? start-slot card-list end-slot)
167      (cond ((and (> end-slot 1)
168		  (< end-slot 6))
169	     (and (or (and (> start-slot 5)
170			   (< start-slot 13)
171			   (not (empty-slot? start-slot))
172			   (make-visible-top-card start-slot))
173		      (and (> start-slot 1)
174			   (< start-slot 6)
175			   (add-to-score! -1))
176		      #t)
177		  (add-to-score! 1)
178		  (move-n-cards! start-slot end-slot card-list)))
179	    ((and (> end-slot 5)
180		  (< end-slot 13))
181	     (and (or (and (> start-slot 1)
182			   (< start-slot 6)
183			   (add-to-score! -1))
184		      (and (> start-slot 5)
185			   (< start-slot 13)
186			   (not (empty-slot? start-slot))
187			   (make-visible-top-card start-slot))
188		      #t)
189		  (move-n-cards! start-slot end-slot card-list)))
190	    (#t #f))
191      #f))
192
193(define (button-clicked slot-id)
194  (if (= slot-id 0)
195      (cond ((> (length (get-cards slot-id)) 7)
196	     (and (deal-cards-face-up 0 '(13 14 15 16 17 18 19))
197		  (give-status-message)))
198	    ((> (length (get-cards slot-id)) 1)
199	     (and (deal-cards-face-up 0 '(1))
200		  (make-visible-top-card 0)
201		  (give-status-message)))
202	    (#t #f))
203      #f))
204
205(define (move-to-foundations? card slot-id)
206  (cond ((> slot-id 5)
207	 #f)
208	((to-foundation? card slot-id)
209	 (add-card! slot-id card))
210	(#t
211	 (move-to-foundations? card (+ 1 slot-id)))))
212
213(define (button-double-clicked slot-id)
214  (if (or (empty-slot? slot-id)
215	  (and (> slot-id 2)
216	       (< slot-id 6))
217	  (not (is-visible? (get-top-card slot-id))))
218      #f
219      (and (move-to-foundations? (get-top-card slot-id) 2)
220	   (remove-card slot-id)
221	   (add-to-score! 1)
222	   (or (empty-slot? slot-id)
223	       (> slot-id 12)
224	       (< slot-id 2)
225	       (make-visible-top-card slot-id)))))
226
227(define (game-continuable)
228  (and (not (game-won))
229       (get-hint)))
230
231(define (game-won)
232  (and (= (length (get-cards 2)) 13)
233       (= (length (get-cards 3)) 13)
234       (= (length (get-cards 4)) 13)
235       (= (length (get-cards 5)) 13)))
236
237(define (dealable?)
238  (and (> (length (get-cards 0)) 1)
239       (list 0 (_"Deal another round"))))
240
241(define (check-a-foundation slot1 slot2)
242  (and (< slot2 6)
243       (if (to-foundation? (get-top-card slot1) slot2)
244           (hint-move slot1 1 slot2)
245           (check-a-foundation slot1 (+ 1 slot2)))))
246
247(define (check-to-foundations slot-id)
248  (cond ((> slot-id 19)
249	 #f)
250	((= slot-id 2)
251	 (check-to-foundations 6))
252	((or (empty-slot? slot-id)
253	     (not (is-visible? (get-top-card slot-id))))
254	 (check-to-foundations (+ 1 slot-id)))
255	(#t
256	 (or (check-a-foundation slot-id 2)
257	     (check-to-foundations (+ 1 slot-id))))))
258
259(define (check-a-foundation2 card slot2)
260  (if (< slot2 6)
261      (or (to-foundation? card slot2)
262	  (check-a-foundation2 card (+ 1 slot2)))
263      #f))
264
265(define (stripped card-list card)
266  (if (<= (length card-list) 1)
267      '()
268      (if (eq? card (car card-list))
269	  (cdr card-list)
270	  (if (= (length card-list) 2)
271	      '()
272	      (stripped (cdr card-list) card)))))
273
274(define (check-a-tableau-with-pile card slot1 card-list slot2 imbedded?)
275  (cond ((or (= (length card-list) 0)
276	     (not (is-visible? (car card-list))))
277	 #f)
278	((and (not (eq? (is-red? (car card-list))
279			(is-red? card)))
280	      (or (= (+ 1 (get-value (car card-list)))
281		     (get-value card))
282		  (and (= (get-value (car card-list))
283			  king)
284		       (= (get-value card)
285			  ace))))
286	 (if (or  (= (length card-list) 1)
287		  (eq? (is-red? (car card-list))
288		       (is-red? (cadr card-list)))
289		  imbedded?
290		  (not (and (is-visible? (cadr card-list))
291			    (or (= (+ 1 (get-value (car card-list)))
292				   (get-value (cadr card-list)))
293				(and (= (get-value (car card-list))
294					king)
295				     (= (get-value (cadr card-list))
296					ace)))))
297		  (check-a-foundation2 (cadr card-list) 2)
298		  (check-a-tableau-with-pile (get-top-card slot2)
299					     slot1
300					     (cdr card-list)
301					     slot2
302					     #t)
303		  (check-a-tableau-with-pile (cadr card-list)
304					     slot2
305					     (get-cards slot1)
306					     slot1
307					     #t)
308		  (check-a-tableau-with-pile (cadr card-list)
309					     slot2
310					     (stripped (get-cards slot2)
311						       (car card-list))
312					     slot2
313					     #t))
314	     (if imbedded?
315	         #t
316	         (hint-move slot2 (- (+ 1 (length (get-cards slot2))) (length card-list)) slot1))
317	     (and (not imbedded?)
318		  (check-a-tableau-with-pile card
319					     slot1
320					     (cdr card-list)
321					     slot2
322					     imbedded?))))
323	(imbedded? #f)
324	(#t (check-a-tableau-with-pile card slot1 (cdr card-list) slot2 imbedded?))))
325
326(define (check-a-tableau r-slot t-slot)
327  (if (and (eq? (is-red? (get-top-card r-slot))
328		(is-black? (get-top-card t-slot)))
329	   (or (= (+ 1 (get-value (get-top-card r-slot)))
330		  (get-value (get-top-card t-slot)))
331	       (and (= (get-value (get-top-card r-slot))
332		       king)
333		    (= (get-value (get-top-card t-slot))
334		       ace))))
335      (hint-move r-slot 1 t-slot)
336      #f))
337
338(define (check-to-tableau? slot1 slot2)
339  (cond ((= slot1 20)
340	 #f)
341	((= slot1 2)
342	 (check-to-tableau? 6 7))
343	((or (= slot2 13)
344	     (empty-slot? slot1)
345	     (not (is-visible? (get-top-card slot1))))
346	 (check-to-tableau? (+ 1 slot1) 6))
347	((and (not (= slot1 slot2))
348	      (> slot1 5)
349	      (< slot1 13)
350	      (check-a-tableau-with-pile (get-top-card slot1)
351					 slot1
352					 (get-cards slot2)
353					 slot2
354					 #f))
355	 (check-a-tableau-with-pile (get-top-card slot1)
356				    slot1
357				    (get-cards slot2)
358				    slot2
359				    #f))
360	((and (not (= slot1 slot2))
361	      (not (empty-slot? slot2))
362	      (or (> slot1 12)
363		  (< slot1 2))
364	      (check-a-tableau slot1 slot2))
365	 (check-a-tableau slot1 slot2))
366	(#t (check-to-tableau? slot1 (+ 1 slot2)))))
367
368(define (get-top-visible-card card-list)
369  (if (not (is-visible? (cadr card-list)))
370      (car card-list)
371      (get-top-visible-card (cdr card-list))))
372
373(define (visible-card-count card-list acc)
374  (if (not (is-visible? (cadr card-list)))
375      acc
376      (visible-card-count (cdr card-list) (+ 1 acc))))
377
378(define (find-high-value slot)
379  (cond ((= slot 20)
380	 #f)
381	((= slot 2)
382	 (find-high-value 6))
383	((and (not (empty-slot? slot))
384	      (is-visible? (get-top-card slot))
385	      (< slot 13)
386	      (> slot 5)
387	      (not (is-visible? (car (reverse (get-cards slot)))))
388	      (or (= (get-value (get-top-visible-card (get-cards slot)))
389		     (- BASE-VAL 1))
390		  (and (= (get-value (get-top-visible-card (get-cards slot)))
391			  king)
392		       (= BASE-VAL ace))))
393	 (hint-move slot (visible-card-count (get-cards slot) 1) (find-empty-slot tableau)))
394	((and (not (empty-slot? slot))
395	      (or (> slot 12)
396		  (< slot 2))
397              (is-visible? (get-top-card slot))
398	      (or (= (get-value (get-top-card slot))
399		     (- BASE-VAL 1))
400		  (and (= (get-value (get-top-card slot))
401			  king)
402		       (= BASE-VAL ace))))
403	 (hint-move slot 1 (find-empty-slot tableau)))
404	(#t (find-high-value (+ 1 slot)))))
405
406(define (empty-tableau?)
407  (if (or (empty-slot? 6)
408	  (empty-slot? 7)
409	  (empty-slot? 8)
410	  (empty-slot? 9)
411	  (empty-slot? 10)
412	  (empty-slot? 11)
413	  (empty-slot? 12))
414      (find-high-value 0)
415      #f))
416
417(define (get-hint)
418  (or (check-to-foundations 0)
419      (check-to-tableau? 0 6)
420      (empty-tableau?)
421      (dealable?)
422      (list 0 (_"Try rearranging the cards"))))
423
424(define (get-options)
425  #f)
426
427(define (apply-options options)
428  #f)
429
430(define (timeout)
431  #f)
432
433(set-features droppable-feature)
434
435(set-lambda new-game button-pressed button-released button-clicked
436button-double-clicked game-continuable game-won get-hint get-options
437apply-options timeout droppable?)
438