1
; AisleRiot - streets_and_alleys.scm
2
; Copyright (C) 2001 Rosanna Yuen <zana@webwynk.net>
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.
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.
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/>.
17
(use-modules (aisleriot interface) (aisleriot api))
20
(initialize-playing-area)
24
(add-extended-slot '() right)
28
(add-normal-slot DECK)
29
(set! HORIZPOS (+ HORIZPOS 0.5))
30
(add-extended-slot '() right)
31
(add-carriage-return-slot)
32
(add-extended-slot '() right)
37
(set! HORIZPOS (+ HORIZPOS 0.5))
38
(add-extended-slot '() right)
39
(add-carriage-return-slot)
40
(add-extended-slot '() right)
45
(set! HORIZPOS (+ HORIZPOS 0.5))
46
(add-extended-slot '() right)
47
(add-carriage-return-slot)
48
(add-extended-slot '() right)
53
(set! HORIZPOS (+ HORIZPOS 0.5))
54
(add-extended-slot '() right)
55
(deal-cards-face-up 1 '(0 2 3 5 6 8 9 11 0 2 3 5 6 8 9 11
56
0 2 3 5 6 8 9 11 0 2 3 5 6 8 9 11
57
0 2 3 5 6 8 9 11 0 2 3 5 6 8 9 11 0 3 6 9))
62
(define (button-pressed slot-id card-list)
63
(= (length card-list) 1))
65
(define (droppable? start-slot card-list end-slot)
66
(cond ((= start-slot end-slot)
68
((member end-slot '(1 4 7 10))
69
(cond ((empty-slot? end-slot)
70
(= (get-value (car card-list)) 1))
72
(and (= (get-suit (get-top-card end-slot))
73
(get-suit (car card-list)))
74
(= (+ 1 (get-value (get-top-card end-slot)))
75
(get-value (car card-list)))))))
76
((empty-slot? end-slot)
78
((= (get-value (get-top-card end-slot))
79
(+ 1 (get-value (car card-list))))
83
(define (button-released start-slot card-list end-slot)
84
(and (droppable? start-slot card-list end-slot)
85
(move-n-cards! start-slot end-slot card-list)
86
(or (not (member start-slot '(1 4 7 10)))
88
(or (not (member end-slot '(1 4 7 10)))
91
(define (button-clicked slot-id)
94
(define (button-double-clicked slot-id)
95
(if (and (not (empty-slot? slot-id))
96
(is-visible? (get-top-card slot-id))
97
(not (or (= slot-id 1)
101
(cond ((= (get-value (get-top-card slot-id)) ace)
102
(and (or (and (empty-slot? 1)
103
(deal-cards slot-id '(1)))
105
(deal-cards slot-id '(4)))
107
(deal-cards slot-id '(7)))
108
(deal-cards slot-id '(10)))
110
((and (not (null? (get-top-card 1)))
111
(= (get-suit (get-top-card slot-id))
112
(get-suit (get-top-card 1)))
113
(= (get-value (get-top-card slot-id))
114
(+ 1 (get-value (get-top-card 1)))))
115
(deal-cards slot-id '(1))
117
((and (not (null? (get-top-card 4)))
118
(= (get-suit (get-top-card slot-id))
119
(get-suit (get-top-card 4)))
120
(= (get-value (get-top-card slot-id))
121
(+ 1 (get-value (get-top-card 4)))))
122
(deal-cards slot-id '(4))
124
((and (not (null? (get-top-card 7)))
125
(= (get-suit (get-top-card slot-id))
126
(get-suit (get-top-card 7)))
127
(= (get-value (get-top-card slot-id))
128
(+ 1 (get-value (get-top-card 7)))))
129
(deal-cards slot-id '(7))
131
((and (not (null? (get-top-card 10)))
132
(= (get-suit (get-top-card slot-id))
133
(get-suit (get-top-card 10)))
134
(= (get-value (get-top-card slot-id))
135
(+ 1 (get-value (get-top-card 10)))))
136
(deal-cards slot-id '(10))
141
(define (game-continuable)
145
(and (= (length (get-cards 1)) 13)
146
(= (length (get-cards 4)) 13)
147
(= (length (get-cards 7)) 13)
148
(= (length (get-cards 10)) 13)))
150
(define (check-a-foundation slot1 slot2)
151
(cond ((or (= slot1 1)
157
(and (= (get-value (get-top-card slot1)) ace)
158
(list 2 (get-name (get-top-card slot1)) (_"an empty foundation"))))
159
((and (= (get-suit (get-top-card slot1))
160
(get-suit (get-top-card slot2)))
161
(= (get-value (get-top-card slot1))
162
(+ 1 (get-value (get-top-card slot2)))))
164
(get-name (get-top-card slot1))
165
(get-name (get-top-card slot2))))
168
(define (check-to-foundation slot-id)
169
(if (not (empty-slot? slot-id))
170
(or (check-a-foundation slot-id 1)
171
(check-a-foundation slot-id 4)
172
(check-a-foundation slot-id 7)
173
(check-a-foundation slot-id 10)
175
(check-to-foundation (+ 1 slot-id))))
177
(check-to-foundation (+ 1 slot-id))
181
(or (check-to-foundation 0)
182
(list 0 (_"Try rearranging the cards"))))
184
(define (get-options)
187
(define (apply-options options)
193
(set-features droppable-feature)
195
(set-lambda new-game button-pressed button-released button-clicked
196
button-double-clicked game-continuable game-won get-hint get-options
197
apply-options timeout droppable?)