← Back to branch summary

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

« back to all changes in this revision

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