← Back to branch summary

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

« back to all changes in this revision

Viewing changes to games/straight_up.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/straight_up.scm
1
 
; AisleRiot - straight_up.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
 
(define (new-game)
18
 
  (initialize-playing-area)
19
 
  (set-ace-high)
20
 
 
21
 
  (set! DECK (make-deck-list-ace-high 3 3 club))
22
 
  (shuffle-deck)
23
 
 
24
 
  (add-normal-slot DECK)
25
 
  (add-normal-slot '())
26
 
 
27
 
  (add-blank-slot)
28
 
 
29
 
  (add-normal-slot (list (make-visible (make-card 2 club))))
30
 
  (add-normal-slot (list (make-visible (make-card 2 diamond))))
31
 
  (add-normal-slot (list (make-visible (make-card 2 heart))))
32
 
  (add-normal-slot (list (make-visible (make-card 2 spade))))
33
 
 
34
 
  (add-carriage-return-slot)
35
 
 
36
 
  (add-normal-slot '())
37
 
 
38
 
  (add-blank-slot)
39
 
  (add-blank-slot)
40
 
 
41
 
  (add-extended-slot '() down)
42
 
  (add-extended-slot '() down)
43
 
  (add-extended-slot '() down)
44
 
  (add-extended-slot '() down)
45
 
 
46
 
  (deal-cards 0 '(6 6 6 6 6 6 6 6 6 6 6 6))
47
 
  (deal-cards-face-up 0 '(6 7 8 9 10))
48
 
 
49
 
  (give-status-message)
50
 
 
51
 
  (list 7 3)
52
 
)
53
 
 
54
 
(define (give-status-message)
55
 
  (set-statusbar-message (string-append (get-stock-no-string)
56
 
                                        "   "
57
 
                                        (get-reserve-no-string)
58
 
                                        "   "
59
 
                                        (get-redeals-string))))
60
 
 
61
 
(define (get-stock-no-string)
62
 
  (string-append (_"Stock left:") " "
63
 
                  (number->string (length (get-cards 0)))))
64
 
 
65
 
(define (get-reserve-no-string)
66
 
  (string-append (_"Reserve left:") " "
67
 
                 (number->string (length (get-cards 6)))))
68
 
 
69
 
(define (get-redeals-string)
70
 
  (string-append (_"Redeals left:") " "
71
 
                 (number->string (- 2 FLIP-COUNTER))))
72
 
 
73
 
(define (button-pressed slot-id card-list)
74
 
  (and (not (empty-slot? slot-id))
75
 
       (or (= slot-id 1)
76
 
           (> slot-id 5))))
77
 
 
78
 
(define (droppable? start-slot card-list end-slot)
79
 
  (cond ((= start-slot end-slot) #f)
80
 
        ((and (> end-slot 1)
81
 
              (< end-slot 6))
82
 
         (and (eq? (get-suit (get-top-card end-slot))
83
 
                   (get-suit (car card-list)))
84
 
              (= (+ 1 (get-value (get-top-card end-slot)))
85
 
                 (get-value (car card-list)))))
86
 
        ((> end-slot 6)
87
 
         (or (and (empty-slot? end-slot)
88
 
                  (empty-slot? 6)
89
 
                  (= start-slot 1))
90
 
             (and (not (empty-slot? end-slot))
91
 
                  (eq? (get-suit (get-top-card end-slot))
92
 
                       (get-suit (car card-list)))
93
 
                  (= (get-value (get-top-card end-slot))
94
 
                     (+ 1 (get-value (car (reverse card-list))))))))
95
 
        (else #f)))
96
 
 
97
 
(define (button-released start-slot card-list end-slot)
98
 
  (cond ((= start-slot end-slot) #f)
99
 
        ((and (> end-slot 1)
100
 
              (< end-slot 6))
101
 
         (and (eq? (get-suit (get-top-card end-slot))
102
 
                   (get-suit (car card-list)))
103
 
              (= (+ 1 (get-value (get-top-card end-slot)))
104
 
                 (get-value (car card-list)))
105
 
              (add-to-score! (length card-list))
106
 
              (move-n-cards! start-slot end-slot (reverse card-list))
107
 
              (check-reserve start-slot)))
108
 
        ((> end-slot 6)
109
 
         (or (and (empty-slot? end-slot)
110
 
                  (empty-slot? 6)
111
 
                  (= start-slot 1)
112
 
                  (move-n-cards! start-slot end-slot card-list))
113
 
             (and (not (empty-slot? end-slot))
114
 
                  (eq? (get-suit (get-top-card end-slot))
115
 
                       (get-suit (car card-list)))
116
 
                  (= (get-value (get-top-card end-slot))
117
 
                     (+ 1 (get-value (car (reverse card-list)))))
118
 
                  (move-n-cards! start-slot end-slot card-list)
119
 
                  (check-reserve start-slot))))
120
 
        (else #f)))
121
 
 
122
 
(define (check-reserve start-slot)
123
 
  (begin 
124
 
    (or (< start-slot 6)
125
 
        (empty-slot? 6)
126
 
        (and (= 6 start-slot)
127
 
             (make-visible-top-card 6))
128
 
        (not (empty-slot? start-slot))
129
 
        (and (deal-cards 6 (list start-slot))
130
 
             (or (empty-slot? 6)
131
 
                 (make-visible-top-card 6))))
132
 
    (give-status-message)))
133
 
 
134
 
(define (button-clicked slot-id)
135
 
  (and (= slot-id 0)
136
 
       (flip-stock 0 1 2)
137
 
       (give-status-message)))
138
 
 
139
 
(define (check-up slot-id foundation-id)
140
 
  (if (eq? (get-suit (get-top-card slot-id))
141
 
           (get-suit (get-top-card foundation-id)))
142
 
      (and (= (get-value (get-top-card slot-id))
143
 
              (+ 1 (get-value (get-top-card foundation-id))))
144
 
           (move-n-cards! slot-id 
145
 
                          foundation-id 
146
 
                          (list (get-top-card slot-id)))
147
 
           (add-to-score! 1)
148
 
           (remove-card slot-id)
149
 
           (check-reserve slot-id))
150
 
      (check-up slot-id (+ 1 foundation-id))))
151
 
 
152
 
(define (button-double-clicked slot-id)
153
 
  (and (not (empty-slot? slot-id))
154
 
       (is-visible? (get-top-card slot-id))
155
 
       (check-up slot-id 2)))
156
 
 
157
 
(define (dealable?)
158
 
  (flippable? 0 1 2))
159
 
  
160
 
(define (do-deal-next-cards)
161
 
  (and (flip-stock 0 1 2)
162
 
       (give-status-message)))
163
 
 
164
 
(define (game-continuable)
165
 
  (and (not (game-won))
166
 
       (get-hint)))
167
 
 
168
 
(define (game-won)
169
 
  (and (= (length (get-cards 2)) 13)
170
 
       (= (length (get-cards 3)) 13)
171
 
       (= (length (get-cards 4)) 13)
172
 
       (= (length (get-cards 5)) 13)))
173
 
 
174
 
(define (check-a-foundation slot-id foundation-id)
175
 
  (cond ((= foundation-id 6)
176
 
         #f)
177
 
        ((eq? (get-suit (get-top-card slot-id))
178
 
              (get-suit (get-top-card foundation-id)))
179
 
         (= (get-value (get-top-card slot-id))
180
 
            (+ 1 (get-value (get-top-card foundation-id)))))
181
 
        (#t (check-a-foundation slot-id (+ 1 foundation-id))))) 
182
 
 
183
 
(define (to-foundations slot-id)
184
 
  (cond ((= slot-id 11)
185
 
         #f)
186
 
        ((= slot-id 2)
187
 
         (to-foundations 6))
188
 
        ((and (not (empty-slot? slot-id))
189
 
              (check-a-foundation slot-id 2))
190
 
         (list 1 
191
 
               (get-name (get-top-card slot-id))
192
 
               (get-name (make-card (- (get-value (get-top-card slot-id))
193
 
                                       1)
194
 
                                    (get-suit (get-top-card slot-id))))))
195
 
        (#t
196
 
         (to-foundations (+ 1 slot-id)))))
197
 
 
198
 
(define (check-a-tableau slot-id t-slot)
199
 
  (cond ((= t-slot 11)
200
 
         #f)
201
 
        ((and (not (empty-slot? t-slot))
202
 
              (not (= slot-id t-slot))
203
 
              (eq? (get-suit (get-top-card slot-id))
204
 
                   (get-suit (get-top-card t-slot)))
205
 
              (or (and (< slot-id 7)
206
 
                       (= (get-value (get-top-card t-slot))
207
 
                          (+ 1 (get-value (get-top-card slot-id)))))
208
 
                  (and (> slot-id 6)
209
 
                       (= (get-value (get-top-card t-slot))
210
 
                          (+ 1 
211
 
                             (get-value 
212
 
                              (car (reverse (get-cards slot-id)))))))))
213
 
         #t)
214
 
        (#t (check-a-tableau slot-id (+ 1 t-slot)))))
215
 
 
216
 
(define (to-tableau slot-id)
217
 
  (cond ((= slot-id 11)
218
 
         #f)
219
 
        ((= slot-id 2)
220
 
         (to-tableau 6))
221
 
        ((and (not (empty-slot? slot-id))
222
 
              (check-a-tableau slot-id 7))
223
 
         (if (< slot-id 7)
224
 
             (list 1 
225
 
                   (get-name (get-top-card slot-id))
226
 
                   (get-name (make-card (+ (get-value 
227
 
                                            (get-top-card slot-id))
228
 
                                           1)
229
 
                                        (get-suit 
230
 
                                         (get-top-card slot-id)))))
231
 
             (list 1 
232
 
                   (get-name 
233
 
                    (car (reverse (get-cards slot-id))))
234
 
                   (get-name 
235
 
                    (make-card (+ (get-value 
236
 
                                   (car
237
 
                                    (reverse (get-cards slot-id))))
238
 
                                  1)
239
 
                               (get-suit 
240
 
                                (car 
241
 
                                 (reverse (get-cards slot-id)))))))))
242
 
        (#t (to-tableau (+ 1 slot-id)))))
243
 
 
244
 
(define (empty-tableau? slot-id)
245
 
  (cond ((or (empty-slot? 1)
246
 
             (> slot-id 10))
247
 
         #f)
248
 
        ((empty-slot? slot-id)
249
 
         (list 2 (get-name (get-top-card 1)) (_"an empty tableau slot")))
250
 
        (#t (empty-tableau? (+ 1 slot-id)))))
251
 
 
252
 
(define (get-hint)
253
 
  (or (to-foundations 1)
254
 
      (to-tableau 1)
255
 
      (empty-tableau? 7)
256
 
      (if (not (empty-slot? 0))
257
 
          (list 0 (_"Deal a new card from the deck"))
258
 
          (if (and (< FLIP-COUNTER 2)
259
 
                   (not (empty-slot? 1)))
260
 
              (list 0 (_"Move waste back to stock"))
261
 
              #f))))
262
 
 
263
 
(define (get-options) 
264
 
  #f)
265
 
 
266
 
(define (apply-options options) 
267
 
  #f)
268
 
 
269
 
(define (timeout) 
270
 
  #f)
271
 
 
272
 
(set-features droppable-feature dealable-feature)
273
 
 
274
 
(set-lambda new-game button-pressed button-released button-clicked
275
 
button-double-clicked game-continuable game-won get-hint get-options
276
 
apply-options timeout droppable? dealable?)