← Back to branch summary

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

« back to all changes in this revision

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