1; AisleRiot - agnes.scm
2; Copyright (C) 2001, 2003 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) (ice-9 format))
18
19(define BASE-VAL 0)
20
21(define stock 0)
22(define foundation '(1 2 3 4))
23(define tableau '(5 6 7 8 9 10 11))
24
25(define (new-game)
26  (initialize-playing-area)
27  (set-ace-low)
28  (make-standard-deck)
29  (shuffle-deck)
30
31  (add-normal-slot DECK 'stock)
32  (add-blank-slot)
33  (add-blank-slot)
34
35  (add-normal-slot '() 'foundation)
36  (add-normal-slot '() 'foundation)
37  (add-normal-slot '() 'foundation)
38  (add-normal-slot '() 'foundation)
39  (add-carriage-return-slot)
40
41  (add-extended-slot '() down 'tableau)
42  (add-extended-slot '() down 'tableau)
43  (add-extended-slot '() down 'tableau)
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
49  (deal-cards 0 '(5 6 7 8 9 10 11 6 7 8 9 10 11 7 8 9 10 11 8 9 10 11
50		    9 10 11 10 11 11))
51
52  (map flip-top-card '(5 6 7 8 9 10 11))
53
54  (deal-cards-face-up 0 '(1))
55
56  (add-to-score! 1)
57  (set! BASE-VAL (get-value (get-top-card 1)))
58
59  (give-status-message)
60  (dealable-set-sensitive (dealable?))
61
62  (list 7 4))
63
64(define (give-status-message)
65  (set-statusbar-message (string-append (get-stock-no-string)
66					"   "
67					(get-base-string))))
68
69(define (get-base-string)
70  (cond ((and (> BASE-VAL 1)
71	      (< BASE-VAL 11))
72	 (format #f (_"Base Card: ~a") (number->string BASE-VAL)))
73	((= BASE-VAL 1)
74	 (_"Base Card: Ace"))
75	((= BASE-VAL 11)
76	 (_"Base Card: Jack"))
77	((= BASE-VAL 12)
78	 (_"Base Card: Queen"))
79	((= BASE-VAL 13)
80	 (_"Base Card: King"))
81	(#t "")))
82
83(define (get-stock-no-string)
84  (if (> (length (get-cards 0)) 1)
85      (string-append (_"Stock left:") " "
86		     (number->string (length (get-cards 0))))
87      (string-append (_"Stock left: 0"))))
88
89(define (check-straight-descending-list-base-low card-list)
90  (or (< (length card-list) 2)
91      (and (= (get-value (car card-list)) king)
92	   (= (get-value (cadr card-list)) ace)
93	   (not (= BASE-VAL ace))
94	   (check-straight-descending-list-base-low (cdr card-list)))
95      (and (= (get-value (car card-list)) (- (get-value (cadr card-list)) 1))
96	   (not (= BASE-VAL (get-value (cadr card-list))))
97	   (check-straight-descending-list-base-low (cdr card-list)))))
98
99(define (button-pressed slot-id card-list)
100  (and (not (empty-slot? slot-id))
101       (is-visible? (car (reverse card-list)))
102       (check-same-color-list card-list)
103       (check-straight-descending-list-base-low card-list)))
104
105(define (droppable? start-slot card-list end-slot)
106  (cond ((= start-slot end-slot)
107	 #f)
108	((and (> end-slot 0)
109	      (< end-slot 5))
110	 (and (= (length card-list) 1)
111	      (or (and (empty-slot? end-slot)
112		       (= (get-value (car card-list))
113			  BASE-VAL))
114		  (and (not (empty-slot? end-slot))
115		       (= (get-suit (car card-list))
116			  (get-suit (get-top-card end-slot)))
117		       (or (= (get-value (car card-list))
118			      (+ 1 (get-value (get-top-card end-slot))))
119			   (and (= (get-value (car card-list)) ace)
120				(= (get-value (get-top-card end-slot)) king)))))))
121	((> end-slot 4)
122	 (and (not (empty-slot? end-slot))
123	      (eq? (is-red? (car card-list))
124		   (is-red? (get-top-card end-slot)))
125	      (or (= (get-value (car (reverse card-list)))
126		     (- (get-value (get-top-card end-slot)) 1))
127		  (and (= (get-value (car (reverse card-list))) king)
128		       (= (get-value (get-top-card end-slot)) ace)))))
129	(#t #f)))
130
131(define (button-released start-slot card-list end-slot)
132  (and (droppable? start-slot card-list end-slot)
133       (move-n-cards! start-slot end-slot card-list)
134       (or (> start-slot 4)
135           (add-to-score! -1))
136       (or (> end-slot 4)
137           (add-to-score! 1))
138       (or (empty-slot? start-slot)
139	   (make-visible-top-card start-slot))))
140
141(define (check-slot-and-deal slot)
142  (if (and (not (empty-slot? 0))
143	   (< slot 12))
144      (and (deal-cards-face-up 0 (list slot))
145	   (check-slot-and-deal (+ 1 slot)))))
146
147(define (do-deal-next-cards)
148  (and (dealable?)
149       (check-slot-and-deal 5)))
150
151(define (button-clicked slot-id)
152  (and (= slot-id 0)
153       (do-deal-next-cards)))
154
155(define (dealable?)
156  (not (empty-slot? 0)))
157
158(define (check-dc slot f-slot just-checking?)
159  (cond ((= f-slot 5)
160	 #f)
161	((and (not (empty-slot? f-slot))
162	      (= (get-suit (get-top-card slot))
163		 (get-suit (get-top-card f-slot)))
164	      (or (= (get-value (get-top-card slot))
165		     (+ 1 (get-value (get-top-card f-slot))))
166		  (and (= (get-value (get-top-card slot)) ace)
167		       (= (get-value (get-top-card f-slot)) king)))
168	      (or (and just-checking?
169		       f-slot)
170		  (and (deal-cards slot (list f-slot))
171		       (add-to-score! 1)
172		       (or (empty-slot? slot)
173			   (make-visible-top-card slot))))))
174	(#t
175	 (check-dc slot (+ 1 f-slot) just-checking?))))
176
177(define (autoplay-foundations)
178  (define (autoplay-foundations-tail)
179    (if (or-map button-double-clicked '(5 6 7 8 9 10 11))
180        (delayed-call autoplay-foundations-tail)
181        #t))
182  (if (or-map button-double-clicked '(5 6 7 8 9 10 11))
183      (autoplay-foundations-tail)
184      #f))
185
186(define (button-double-clicked slot-id)
187  (cond ((or (and (empty-slot? slot-id)
188                  (> slot-id 4))
189	     (= slot-id 0))
190	 #f)
191	((< slot-id 5)
192	 (autoplay-foundations))
193	((= (get-value (get-top-card slot-id)) BASE-VAL)
194	 (and (or (and (empty-slot? 1)
195		       (deal-cards slot-id '(1)))
196		  (and (empty-slot? 2)
197		       (deal-cards slot-id '(2)))
198		  (and (empty-slot? 3)
199		       (deal-cards slot-id '(3)))
200		  (deal-cards slot-id '(4)))
201	      (add-to-score! 1)
202	      (or (empty-slot? slot-id)
203		  (make-visible-top-card slot-id))))
204	(#t
205	 (check-dc slot-id 1 #f))))
206
207(define (game-continuable)
208  (give-status-message)
209  (dealable-set-sensitive (dealable?))
210  (not (game-won)))
211
212(define (game-won)
213  (and (= 13 (length (get-cards 1)))
214       (= 13 (length (get-cards 2)))
215       (= 13 (length (get-cards 3)))
216       (= 13 (length (get-cards 4)))))
217
218(define (check-to-foundation? slot)
219  (cond ((= slot 12)
220	 #f)
221	((and (not (empty-slot? slot))
222	      (= (get-value (get-top-card slot))
223		 BASE-VAL))
224	 (hint-move slot 1 (find-empty-slot foundation)))
225	((and (not (empty-slot? slot))
226	      (check-dc slot 1 #t))
227	 (hint-move slot 1 (check-dc slot 1 #t)))
228	(#t (check-to-foundation? (+ 1 slot)))))
229
230(define (check-a-tableau card slot)
231  (and (not (empty-slot? slot))
232       (eq? (is-red? card) (is-red? (get-top-card slot)))
233       (not (= (get-value (get-top-card slot)) BASE-VAL))
234       (or (and (= (get-value card) king)
235		(= (get-value (get-top-card slot)) ace))
236	   (= (+ (get-value card) 1)
237	      (get-value (get-top-card slot))))))
238
239(define (strip card-list)
240  (cond ((< (length card-list) 2)
241	 (car card-list))
242	((or (not (is-visible? (car (reverse card-list))))
243;	     (eq? (is-red? (car (reverse card-list)))
244;		  (is-black? (car card-list)))
245	     (not (check-same-color-list card-list))
246	     (not (check-straight-descending-list-base-low card-list)))
247	 (strip (reverse (cdr (reverse card-list)))))
248	(#t (car (reverse card-list)))))
249
250(define (check-to-tableau? slot1 slot2)
251  (cond ((= slot1 12)
252	 #f)
253	((or (= slot2 12)
254	     (empty-slot? slot1))
255	 (check-to-tableau? (+ 1 slot1) 5))
256	((and (not (= slot1 slot2))
257	      (check-a-tableau (strip (get-cards slot1)) slot2))
258	 (hint-move slot1 (find-card slot1 (strip (get-cards slot1))) slot2))
259	(#t (check-to-tableau? slot1 (+ 1 slot2)))))
260
261
262(define (check-deal?)
263  (and (dealable?)
264       (list 0 (_"Deal more cards"))))
265
266(define (get-hint)
267  (or (check-to-foundation? 5)
268      (check-to-tableau? 5 6)
269      (check-deal?)
270      (list 0 (_"Try rearranging the cards"))))
271
272(define (get-options)
273  #f)
274
275(define (apply-options options)
276  #f)
277
278(define (timeout)
279  #f)
280
281(set-features droppable-feature dealable-feature)
282
283(set-lambda new-game button-pressed button-released button-clicked
284button-double-clicked game-continuable game-won get-hint get-options
285apply-options timeout droppable? dealable?)
286