← Back to branch summary

~ubuntu-branches/debian/jessie/aisleriot/jessie

« back to all changes in this revision

Viewing changes to games/eagle_wing.scm

  • Committer: Package Import Robot
  • Author(s): Jordi Mallach, Jeremy Bicha, Jordi Mallach
  • Date: 2012-04-22 12:49:26 UTC
  • mfrom: (1.1.1)
  • Revision ID: package-import@ubuntu.com-20120422124926-gmr0thwstl91jt1n
Tags: 1:3.4.1-1
[ Jeremy Bicha ]
* New upstream release
* debian/control.in: (Build)-depend on guile-2.0
* debian/*.install: Cards files are now stored as zipped .svg's
* debian/patches/99_format-security.patch: Dropped, applied upstream

[ Jordi Mallach ]
* New upstream release.
* Update copyright to final version of the machine-readable 1.0 spec.
* Bump Standards Version to 3.9.3.

Show diffs side-by-side

added added

removed removed

Lines of Context:
games/eagle_wing.scm
1
 
; AisleRiot - eagle_wing.scm
2
 
; Copyright (C) 1998, 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
 
(define BASE-VAL 0)
18
 
 
19
 
(define (new-game)
20
 
  (initialize-playing-area)
21
 
  (set-ace-low)
22
 
  (make-standard-deck)
23
 
  (shuffle-deck)
24
 
 
25
 
  (add-normal-slot DECK)
26
 
  (add-normal-slot '())                 ;waste
27
 
 
28
 
  (add-blank-slot)
29
 
  (add-normal-slot '())
30
 
  (add-normal-slot '())
31
 
  (add-normal-slot '())
32
 
  (add-normal-slot '())
33
 
 
34
 
  (add-carriage-return-slot)
35
 
  (set! VERTPOS (+ VERTPOS 0.2))
36
 
  (add-extended-slot '() down)          ;tableau (slot 6)
37
 
  (set! VERTPOS (- VERTPOS 0.1))
38
 
  (add-extended-slot '() down)          ;tableau (slot 7)
39
 
  (set! VERTPOS (- VERTPOS 0.1))
40
 
  (add-extended-slot '() down)          ;tableau (slot 8)
41
 
  (set! VERTPOS (+ VERTPOS 0.1))
42
 
  (add-extended-slot '() down)          ;tableau (slot 9)
43
 
  (set! VERTPOS (+ VERTPOS 0.25))
44
 
  (add-normal-slot '())                 ;reserve (slot 10)
45
 
  (set! VERTPOS (- VERTPOS 0.25))
46
 
  (add-extended-slot '() down)          ;tableau (slot 11)
47
 
  (set! VERTPOS (- VERTPOS 0.1))
48
 
  (add-extended-slot '() down)          ;tableau (slot 12)
49
 
  (set! VERTPOS (+ VERTPOS 0.1))
50
 
  (add-extended-slot '() down)          ;tableau (slot 13)
51
 
  (set! VERTPOS (+ VERTPOS 0.1))
52
 
  (add-extended-slot '() down)          ;tableau (slot 14)
53
 
 
54
 
  (deal-cards-face-up 0 '(10))
55
 
  (deal-cards 0 '(10 10 10 10 10 10 10 10 10 10 10 10 6 7 8 9 11 12 13 14 2))
56
 
 
57
 
  (flip-top-card 2)
58
 
  (flip-top-card 6)
59
 
  (flip-top-card 7)
60
 
  (flip-top-card 8)
61
 
  (flip-top-card 9)
62
 
  (flip-top-card 11)
63
 
  (flip-top-card 12)
64
 
  (flip-top-card 13)
65
 
  (flip-top-card 14)
66
 
 
67
 
  (add-to-score! 1)
68
 
  (set! BASE-VAL (get-value (get-top-card 2)))
69
 
 
70
 
  (give-status-message)
71
 
 
72
 
  (list 9 3))
73
 
 
74
 
(define (give-status-message)
75
 
  (set-statusbar-message (string-append (get-stock-no-string)
76
 
                                        "   "
77
 
                                        (get-reserve-no-string)
78
 
                                        "   "
79
 
                                        (get-base-string)
80
 
                                        "   "
81
 
                                        (get-redeals-string))))
82
 
 
83
 
(define (get-stock-no-string)
84
 
  (string-append (_"Stock left:") " "
85
 
                 (number->string (length (get-cards 0)))))
86
 
 
87
 
(define (get-reserve-no-string)
88
 
  (string-append (_"Reserve left:") " "
89
 
                 (number->string (length (get-cards 10)))))
90
 
 
91
 
(define (get-base-string)
92
 
  (cond ((and (> BASE-VAL 1)
93
 
              (< BASE-VAL 11))
94
 
         (string-append (_"Base Card: ") (number->string BASE-VAL)))
95
 
        ((= BASE-VAL 1)
96
 
         (_"Base Card: Ace"))
97
 
        ((= BASE-VAL 11)
98
 
         (_"Base Card: Jack"))
99
 
        ((= BASE-VAL 12)
100
 
         (_"Base Card: Queen"))
101
 
        ((= BASE-VAL 13)
102
 
         (_"Base Card: King"))
103
 
        (#t "")))
104
 
 
105
 
(define (get-redeals-string)
106
 
  (string-append (_"Redeals left:") " "
107
 
                 (number->string (- 2 FLIP-COUNTER))))
108
 
 
109
 
(define (button-pressed slot-id card-list)
110
 
  (and card-list
111
 
       (not (member slot-id '(2 3 4 5)))
112
 
       (is-visible? (car card-list))))
113
 
 
114
 
(define (fill-tableau-slot slot)
115
 
  (and (> slot 5)
116
 
       (not (= slot 10))
117
 
       (empty-slot? slot)
118
 
       (not (empty-slot? 10))
119
 
       (deal-cards-face-up 10 (cons slot '())))
120
 
  #t)
121
 
 
122
 
(define (complete-transaction start-slot card-list end-slot)
123
 
  (if (member end-slot '(2 3 4 5))
124
 
      (add-to-score! (length card-list)))
125
 
  (move-n-cards! start-slot end-slot card-list)
126
 
  (fill-tableau-slot start-slot))
127
 
 
128
 
(define (droppable? start-slot card-list end-slot)
129
 
  (and (not (= start-slot end-slot))
130
 
       (or (and (member end-slot '(2 3 4 5))
131
 
                (if (empty-slot? end-slot)
132
 
                    (= (get-value (car card-list)) BASE-VAL)
133
 
                    (and (eq? (get-suit (car card-list))
134
 
                              (get-suit (get-top-card end-slot)))
135
 
                         (or (= (get-value (car card-list))
136
 
                                (+ (get-value (get-top-card end-slot)) 1))
137
 
                             (and (= (get-value (car card-list)) ace)
138
 
                                  (= (get-value (get-top-card end-slot)) 
139
 
                                     king))))))
140
 
           (and (member end-slot '(6 7 8 9 11 12 13 14))
141
 
                (= (length card-list) 1)
142
 
                (or (empty-slot? end-slot)
143
 
                    (and (< (length (get-cards end-slot)) 3)
144
 
                         (eq? (get-suit (car card-list))
145
 
                              (get-suit (get-top-card end-slot)))
146
 
                         (or (= (get-value (car card-list))
147
 
                                (- (get-value (get-top-card end-slot)) 1))
148
 
                             (and (= (get-value (car card-list)) king)
149
 
                                  (= (get-value (get-top-card end-slot)) 
150
 
                                     ace)))))))))
151
 
 
152
 
(define (button-released start-slot card-list end-slot)
153
 
  (and (droppable? start-slot card-list end-slot)
154
 
       (complete-transaction start-slot (reverse card-list) end-slot)))
155
 
 
156
 
(define (dealable?)
157
 
  (flippable? 0 1 2))
158
 
 
159
 
(define (do-deal-next-cards)
160
 
  (flip-stock 0 1 2))
161
 
 
162
 
(define (button-clicked slot-id)
163
 
  (if (= slot-id 0)
164
 
      (do-deal-next-cards)
165
 
      #f))
166
 
 
167
 
(define (button-double-clicked slot)
168
 
  (if (and (not (empty-slot? slot))
169
 
           (is-visible? (get-top-card slot))
170
 
           (or (= slot 1)
171
 
               (and (> slot 5)
172
 
                    (< slot 10))
173
 
               (and (> slot 10))))
174
 
      (cond ((and (= BASE-VAL (get-value (get-top-card slot))))
175
 
             (cond ((empty-slot? 2)
176
 
                    (deal-cards slot '(2)))
177
 
                   ((empty-slot? 3)
178
 
                    (deal-cards slot '(3)))
179
 
                   ((empty-slot? 4)
180
 
                    (deal-cards slot '(4)))
181
 
                   (#t
182
 
                    (deal-cards slot '(5))))
183
 
             (add-to-score! 1)
184
 
             (fill-tableau-slot slot))
185
 
            ((and (not (empty-slot? 2))
186
 
                  (= (get-suit (get-top-card slot))
187
 
                     (get-suit (get-top-card 2))))
188
 
             (if (or (and (= (get-value (get-top-card slot)) ace)
189
 
                          (= (get-value (get-top-card 2)) king))
190
 
                     (= (get-value (get-top-card slot))
191
 
                        (+ 1 (get-value (get-top-card 2)))))
192
 
                 (begin
193
 
                   (deal-cards slot '(2))
194
 
                   (add-to-score! 1)
195
 
                   (fill-tableau-slot slot))
196
 
                 #f))
197
 
            ((and (not (empty-slot? 3))
198
 
                  (= (get-suit (get-top-card slot))
199
 
                     (get-suit (get-top-card 3))))
200
 
             (if (or (and (= (get-value (get-top-card slot)) ace)
201
 
                          (= (get-value (get-top-card 3)) king))
202
 
                     (= (get-value (get-top-card slot))
203
 
                        (+ 1 (get-value (get-top-card 3)))))
204
 
                 (begin
205
 
                   (deal-cards slot '(3))
206
 
                   (add-to-score! 1)
207
 
                   (fill-tableau-slot slot))
208
 
                 #f))
209
 
            ((and (not (empty-slot? 4))
210
 
                  (= (get-suit (get-top-card slot))
211
 
                     (get-suit (get-top-card 4))))
212
 
             (if (or (and (= (get-value (get-top-card slot)) ace)
213
 
                          (= (get-value (get-top-card 4)) king))
214
 
                     (= (get-value (get-top-card slot))
215
 
                        (+ 1 (get-value (get-top-card 4)))))
216
 
                 (begin
217
 
                   (deal-cards slot '(4))
218
 
                   (add-to-score! 1)
219
 
                   (fill-tableau-slot slot))
220
 
                 #f))
221
 
            ((and (not (empty-slot? 5))
222
 
                  (= (get-suit (get-top-card slot))
223
 
                     (get-suit (get-top-card 5))))
224
 
             (if (or (and (= (get-value (get-top-card slot)) ace)
225
 
                          (= (get-value (get-top-card 5)) king))
226
 
                     (= (get-value (get-top-card slot))
227
 
                        (+ 1 (get-value (get-top-card 5)))))
228
 
                 (begin
229
 
                   (deal-cards slot '(5))
230
 
                   (add-to-score! 1)
231
 
                   (fill-tableau-slot slot))
232
 
                 #f))
233
 
            (#t #f))
234
 
      #f))
235
 
 
236
 
(define (game-over)
237
 
  (give-status-message)
238
 
  (and (not (game-won))
239
 
       (get-hint)))
240
 
 
241
 
(define (game-won)
242
 
  (and (empty-slot? 0)
243
 
       (empty-slot? 1)
244
 
       (empty-slot? 6)
245
 
       (empty-slot? 7)
246
 
       (empty-slot? 8)
247
 
       (empty-slot? 9)
248
 
       (empty-slot? 10)
249
 
       (empty-slot? 11)
250
 
       (empty-slot? 12)
251
 
       (empty-slot? 13)
252
 
       (empty-slot? 14)))
253
 
 
254
 
(define (check-a-foundation slot1 slot2)
255
 
  (and (not (empty-slot? slot2))
256
 
       (= (get-suit (get-top-card slot1))
257
 
          (get-suit (get-top-card slot2)))
258
 
       (or (= (get-value (get-top-card slot1))
259
 
              (+ 1 (get-value (get-top-card slot2))))
260
 
           (and (= (get-value (get-top-card slot1)) ace)
261
 
                (= (get-value (get-top-card slot2)) king)))))
262
 
 
263
 
(define (check-to-foundation slot)
264
 
  (if (and (not (empty-slot? slot))
265
 
           (is-visible? (get-top-card slot)))
266
 
      (cond ((= (get-value (get-top-card slot)) BASE-VAL)
267
 
             (list 0 (format #f (_"Move ~a to an empty foundation") (get-name (get-top-card slot)))))
268
 
            ((check-a-foundation slot 2)
269
 
             (list 1 
270
 
                   (get-name (get-top-card slot)) 
271
 
                   (get-name (get-top-card 2))))
272
 
            ((check-a-foundation slot 3)
273
 
             (list 1 
274
 
                   (get-name (get-top-card slot)) 
275
 
                   (get-name (get-top-card 3))))
276
 
            ((check-a-foundation slot 4)
277
 
             (list 1 
278
 
                   (get-name (get-top-card slot)) 
279
 
                   (get-name (get-top-card 4))))
280
 
            ((check-a-foundation slot 5)
281
 
             (list 1 
282
 
                   (get-name (get-top-card slot)) 
283
 
                   (get-name (get-top-card 5))))
284
 
            ((= slot 1)
285
 
             (check-to-foundation 6))
286
 
            ((< slot 14)
287
 
             (check-to-foundation (+ 1 slot)))
288
 
            (#t #f))
289
 
      (if (= slot 1)
290
 
          (check-to-foundation 6)
291
 
          (if (< slot 14)
292
 
              (check-to-foundation (+ 1 slot))
293
 
              #f))))
294
 
 
295
 
(define (check-empty-slot slot)
296
 
  (if (and (empty-slot? slot)
297
 
           (not (= slot 10)))
298
 
      (if (empty-slot? 1)
299
 
          #f
300
 
          (list 2 (get-name (get-top-card 1)) (_"an empty slot on tableau")))
301
 
      (if (< slot 14)
302
 
          (check-empty-slot (+ 1 slot))
303
 
          #f)))
304
 
 
305
 
(define (check-to-tableau slot card check-slot)
306
 
  (if (and (not (= slot check-slot))
307
 
           (not (= check-slot 10))
308
 
           (not (empty-slot? check-slot))
309
 
           (< (length (get-cards check-slot)) 3)
310
 
           (= (get-suit card)
311
 
              (get-suit (get-top-card check-slot)))
312
 
           (or (= (+ 1 (get-value card))
313
 
                  (get-value (get-top-card check-slot)))
314
 
               (and (= (get-value card) king)
315
 
                    (= (get-value (get-top-card check-slot)) ace))))
316
 
      (list 1 (get-name card) (get-name (get-top-card check-slot)))
317
 
      (if (< check-slot 14)
318
 
          (check-to-tableau slot card (+ 1 check-slot))
319
 
          #f)))
320
 
 
321
 
(define (check-tableau slot)
322
 
  (if (and (not (empty-slot? slot))
323
 
           (or (= slot 1)
324
 
               (and (> slot 5)
325
 
                    (is-visible? (get-top-card slot))
326
 
                    (= 1 (length (get-cards slot))))))
327
 
      (check-to-tableau slot (get-top-card slot) 6)
328
 
      #f))
329
 
 
330
 
(define (dealable?)
331
 
  (if (not (empty-slot? 0))
332
 
      (list 0 (_"Deal a card"))
333
 
      (if (and (not (empty-slot? 1))
334
 
               (< FLIP-COUNTER 2))
335
 
          (list 0 (_"Move waste back to stock"))
336
 
          #f)))
337
 
 
338
 
(define (get-hint)
339
 
  (or (check-to-foundation 1)
340
 
      (check-empty-slot 6)
341
 
      (check-tableau 1)
342
 
      (check-tableau 6)
343
 
      (check-tableau 7)
344
 
      (check-tableau 8)
345
 
      (check-tableau 9)
346
 
      (check-tableau 10)
347
 
      (check-tableau 11)
348
 
      (check-tableau 12)
349
 
      (check-tableau 13)
350
 
      (check-tableau 14)
351
 
      (dealable?)))
352
 
 
353
 
(define (get-options) #f)
354
 
 
355
 
(define (apply-options options) #f)
356
 
 
357
 
(define (timeout) #f)
358
 
 
359
 
(set-features droppable-feature dealable-feature)
360
 
 
361
 
(set-lambda new-game button-pressed button-released button-clicked button-double-clicked game-over game-won get-hint get-options apply-options timeout droppable? dealable?)