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