← Back to branch summary

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

« back to all changes in this revision

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