1; AisleRiot - labyrinth.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(def-save-var first-row #f)
20
21(define (new-game)
22  (initialize-playing-area)
23  (set-ace-low)
24  (set! DECK (make-deck-list-ace-low 2 2 club))
25  (shuffle-deck)
26
27  (add-normal-slot DECK 'stock)
28  (add-blank-slot)
29  (add-normal-slot '() 'foundation)
30  (add-normal-slot '() 'foundation)
31  (add-normal-slot '() 'foundation)
32  (add-normal-slot '() 'foundation)
33  (add-carriage-return-slot)
34
35  (add-normal-slot '() 'tableau)
36  (add-normal-slot '() 'tableau)
37  (add-normal-slot '() 'tableau)
38  (add-normal-slot '() 'tableau)
39  (add-normal-slot '() 'tableau)
40  (add-normal-slot '() 'tableau)
41  (add-normal-slot '() 'tableau)
42  (add-normal-slot '() 'tableau)
43
44  (add-carriage-return-slot)
45
46  (set! VERTPOS (- VERTPOS (/ 2 3)))
47
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  (add-extended-slot '() down 'tableau)
53  (add-extended-slot '() down 'tableau)
54  (add-extended-slot '() down 'tableau)
55  (add-extended-slot '() down 'tableau)
56
57
58  (add-card! 1 (make-visible (make-card ace club)))
59  (add-card! 2 (make-visible (make-card ace diamond)))
60  (add-card! 3 (make-visible (make-card ace heart)))
61  (add-card! 4 (make-visible (make-card ace spade)))
62
63  (deal-cards-face-up 0 '(5 6 7 8 9 10 11 12))
64  (set! first-row #t)
65
66  (give-status-message)
67
68  (list 8 4))
69
70(define (give-status-message)
71  (set-statusbar-message (get-stock-no-string)))
72
73(define (get-stock-no-string)
74  (string-append (_"Stock left:") " "
75		 (number->string (length (get-cards 0)))))
76
77(define (button-pressed slot-id card-list)
78  (and (not (empty-slot? slot-id))
79       (> slot-id 4)
80       (= (length card-list) 1)))
81
82(define (droppable? start-slot card-list end-slot)
83  (and (< end-slot 5)
84       (> end-slot 0)
85       (= (get-suit (get-top-card end-slot))
86	  (get-suit (car card-list)))
87       (= (+ 1 (get-value (get-top-card end-slot)))
88	  (get-value (car card-list)))))
89
90(define (button-released start-slot card-list end-slot)
91  (and (droppable? start-slot card-list end-slot)
92       (move-n-cards! start-slot end-slot card-list)
93       (or (and (not first-row)
94		(or (> start-slot 12)
95		    (empty-slot? (+ start-slot 8))
96		    (and (set-cards! start-slot
97				     (list (car (reverse (get-cards (+ start-slot 8))))))
98			 (set-cards! (+ start-slot 8)
99				     (reverse (cdr (reverse (get-cards (+ start-slot 8)))))))))
100	   (empty-slot? 0)
101	   (deal-cards-face-up 0 (list start-slot)))
102       (add-to-score! 1)))
103
104(define (check-slot-and-deal slot)
105  (cond ((or (empty-slot? 0)
106             (= slot 21))
107	 #t)
108	((empty-slot? (- slot 8))
109	 (and (deal-cards-face-up 0 (list (- slot 8)))
110	      (check-slot-and-deal (+ 1 slot))))
111	(#t (and (deal-cards-face-up 0 (list slot))
112		 (check-slot-and-deal (+ 1 slot))))))
113
114(define (button-clicked slot-id)
115  (and (= slot-id 0)
116       (not (empty-slot? 0))
117       (set! first-row #f)
118       (check-slot-and-deal 13)))
119
120(define (button-double-clicked slot-id)
121  (and (> slot-id 4)
122       (not (empty-slot? slot-id))
123       (or (and (= (get-suit (get-top-card slot-id)) club)
124		(= (get-value (get-top-card slot-id))
125		   (+ 1 (get-value (get-top-card 1))))
126		(deal-cards slot-id '(1))
127		(add-to-score! 1))
128	   (and (= (get-suit (get-top-card slot-id)) diamond)
129		(= (get-value (get-top-card slot-id))
130		   (+ 1 (get-value (get-top-card 2))))
131		(deal-cards slot-id '(2))
132		(add-to-score! 1))
133	   (and (= (get-suit (get-top-card slot-id)) heart)
134		(= (get-value (get-top-card slot-id))
135		   (+ 1 (get-value (get-top-card 3))))
136		(deal-cards slot-id '(3))
137		(add-to-score! 1))
138	   (and (= (get-suit (get-top-card slot-id)) spade)
139		(= (get-value (get-top-card slot-id))
140		   (+ 1 (get-value (get-top-card 4))))
141		(deal-cards slot-id '(4))
142		(add-to-score! 1)))
143       (or (and first-row
144		(not (empty-slot? 0))
145		(deal-cards-face-up 0 (list slot-id)))
146	   (> slot-id 12)
147	   (empty-slot? (+ 8 slot-id))
148	   (and (set-cards! slot-id
149			    (list (car (reverse (get-cards (+ slot-id 8))))))
150		(set-cards! (+ slot-id 8)
151			    (reverse (cdr (reverse (get-cards (+ slot-id 8))))))))))
152
153(define (game-continuable)
154  (give-status-message)
155  (and (not (game-won))
156       (get-hint)))
157
158(define (game-won)
159  (and (= (length (get-cards 1)) 13)
160       (= (length (get-cards 2)) 13)
161       (= (length (get-cards 3)) 13)
162       (= (length (get-cards 4)) 13)))
163
164(define (check-slot slot)
165  (cond ((= slot 21)
166	 #f)
167	((empty-slot? slot)
168	 (check-slot (+ 1 slot)))
169	((and (= (get-suit (get-top-card slot)) club)
170	      (= (get-value (get-top-card slot))
171		 (+ 1 (get-value (get-top-card 1)))))
172	 (hint-move slot 1 1))
173	((and (= (get-suit (get-top-card slot)) diamond)
174	      (= (get-value (get-top-card slot))
175		 (+ 1 (get-value (get-top-card 2)))))
176	 (hint-move slot 1 2))
177	((and (= (get-suit (get-top-card slot)) heart)
178	      (= (get-value (get-top-card slot))
179		 (+ 1 (get-value (get-top-card 3)))))
180	 (hint-move slot 1 3))
181	((and (= (get-suit (get-top-card slot)) spade)
182	      (= (get-value (get-top-card slot))
183		 (+ 1 (get-value (get-top-card 4)))))
184	 (hint-move slot 1 4))
185	(#t (check-slot (+ 1 slot)))))
186
187(define (dealable?)
188  (and (not (empty-slot? 0))
189       (list 0 (_"Deal more cards"))))
190
191(define (get-hint)
192  (or (check-slot 5)
193      (dealable?)))
194
195(define (get-options)
196  #f)
197
198(define (apply-options options)
199  #f)
200
201(define (timeout)
202  #f)
203
204(set-features droppable-feature)
205
206(set-lambda new-game button-pressed button-released button-clicked
207button-double-clicked game-continuable game-won get-hint get-options
208apply-options timeout droppable?)
209
210