← Back to branch summary

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

« back to all changes in this revision

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