← Back to branch summary

~ubuntu-branches/ubuntu/oneiric/gnome-games/oneiric

« back to all changes in this revision

Viewing changes to aisleriot/rules/giant.scm

  • Committer: Package Import Robot
  • Author(s): Jeremy Bicha
  • Date: 2011-07-21 04:22:50 UTC
  • mfrom: (1.1.93)
  • Revision ID: package-import@ubuntu.com-20110721042250-far722bxogjk1rhi
Tags: 1:3.1.3-0ubuntu1
https://launchpad.net/bugs/788514
* New upstream release
  - Aisleriot was split out of gnome-games into its own module.
  - Gnotravex was ported to GSettings.
  - Sudoku was ported to PyGObject/GTK3 by John Stowers.
* debian/aisleriot*: Dropped
* debian/control
  - Drop aisleriot package
  - Recommend aisleriot
  - Disable lightsoff & swell-foop as they're not ready yet
  - Re-enable gnome-sudoku
  - Use python-gobject instead of python-gtk2
  - Don't use python-launchpad-integration as it doesn't work with pygi yet
  - Switch to dh_python2 (LP: #788514)
  - Drop old pre-Lucid conflicts with gnome-cards-data & gnome-games-data
  - Drop obsolete build-depends: check, dpkg-dev, guile-1.8, lsb-release,
    rarian-compat, & scrollkeeper
  - Use ${gir:Depends}
* debian/copyright: Drop aisleriot & blackjack entries
* debian/glchess.install: Drop gnome-gnuchess
* debian/gnome-games-common.install: Drop aisleriot entries
* debian/gnome-sudoku.install: Install gconf schema
* debian/gnotravex.install: Install GSettings schema
* debian/rules
  - Clean up configure flags
  - Switch to dh_python2
* debian/watch: Watch for .bz2
* debian/patches/01_lpi.patch: Refreshed
* debian/patches/02_desktop-path.patch: Removed aisleriot references
* debian/patches/03_add-appinstall-keywords.patch
  - Add keywords to make searching for the games easier in Software Center

Show diffs side-by-side

added added

removed removed

Lines of Context:
aisleriot/rules/giant.scm
1
 
; AisleRiot - giant.scm
2
 
; Copyright (C) 2009 Ed Sirett <ed@makewrite.demon.co.uk>
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
 
 
18
 
;set up the deck
19
 
(set-ace-low)
20
 
 
21
 
(define stock-slot 0)
22
 
(define foundation '(1 2 3 4 5 6 7 8))
23
 
(define tableau '(9 10 11 12 13 14 15 16 ))
24
 
(define reserve-slot 17)
25
 
(define (make-deck)
26
 
  (make-standard-double-deck)
27
 
)
28
 
 
29
 
(define winning-score 104)
30
 
 
31
 
(define allow-empty-slots #t)
32
 
(define same-suit #f)
33
 
 
34
 
(define (new-game)
35
 
  (initialize-playing-area)
36
 
  (make-deck)
37
 
  (shuffle-deck)
38
 
 
39
 
  ;set up the board
40
 
  (add-normal-slot DECK)
41
 
  (add-blank-slot)
42
 
  (add-normal-slot '())
43
 
  (add-normal-slot '())
44
 
  (add-normal-slot '())
45
 
  (add-normal-slot '())
46
 
  (add-normal-slot '())
47
 
  (add-normal-slot '())
48
 
  (add-normal-slot '())
49
 
  (add-normal-slot '())
50
 
  (add-carriage-return-slot)
51
 
  (add-extended-slot '() down)
52
 
  (add-extended-slot '() down)
53
 
  (add-extended-slot '() down)
54
 
  (add-extended-slot '() down)
55
 
  (add-extended-slot '() down)
56
 
  (add-extended-slot '() down)
57
 
  (add-extended-slot '() down)
58
 
  (add-extended-slot '() down)
59
 
  (add-blank-slot)
60
 
  (add-normal-slot '())
61
 
 
62
 
  (deal-cards-face-up stock-slot tableau)
63
 
 
64
 
 
65
 
  (give-status-message)
66
 
  (list 10 4.5))
67
 
 
68
 
(define (give-status-message)
69
 
  (set-statusbar-message (get-stock-no-string))
70
 
)
71
 
 
72
 
(define (get-stock-no-string)
73
 
  (format (_"Deals left: ~a")
74
 
          (number->string (/ (length (get-cards stock-slot)) 8 ))
75
 
  )
76
 
)
77
 
 
78
 
;additional functions.
79
 
 
80
 
(define (complete-transaction start-slot card-list end-slot)
81
 
  (if (member end-slot foundation)
82
 
      (move-n-cards! start-slot end-slot (reverse card-list))
83
 
      (move-n-cards! start-slot end-slot card-list)
84
 
  )
85
 
)
86
 
 
87
 
(define (button-pressed slot card-list)
88
 
  (if (or (empty-slot? slot) (= slot stock-slot))
89
 
        #f   ; can't pick from stock or empty piles
90
 
        (and (or (and (not same-suit) (check-alternating-color-list card-list))
91
 
                 (and same-suit  (check-same-suit-list card-list)))
92
 
             (check-straight-descending-list card-list))))
93
 
 
94
 
 
95
 
 
96
 
(define (droppable? start-slot card-list end-slot)
97
 
  (and (not (= start-slot end-slot))
98
 
       ( or (and  (member end-slot foundation)
99
 
                  (check-straight-descending-list card-list)
100
 
                  (check-same-suit-list card-list)
101
 
                  (if (empty-slot? end-slot)
102
 
                      (= (get-value (car card-list)) ace)
103
 
                      (and (= (get-suit (car card-list)) (get-suit (get-top-card end-slot)))
104
 
                           (= (- (get-value (car card-list)) 1 ) (get-value (get-top-card end-slot)))
105
 
                      )
106
 
                  )
107
 
            )
108
 
            (and  (member end-slot tableau)
109
 
                  (check-straight-descending-list card-list)
110
 
                  (or (and (not same-suit) (check-alternating-color-list card-list))
111
 
                      (and  same-suit (check-same-suit-list card-list)))
112
 
                  (if (not (empty-slot? end-slot))
113
 
                      (and (= (+ (get-value (car (reverse card-list))) 1 ) (get-value (get-top-card end-slot)))
114
 
                           (or (and (not same-suit)
115
 
                                    (not ( eq? ( is-red? ( car (reverse card-list))) (is-red? (get-top-card end-slot)))))
116
 
                               (and same-suit
117
 
                                    (= (get-suit (car (reverse card-list))) (get-suit (get-top-card end-slot))))))
118
 
                      #t
119
 
                  )
120
 
            )
121
 
            (and  (=  end-slot reserve-slot)
122
 
                  (empty-slot? reserve-slot)
123
 
                  (= (length card-list) 1)
124
 
            )
125
 
       )
126
 
  )
127
 
)
128
 
 
129
 
(define (button-released start-slot card-list end-slot)
130
 
  (and (droppable? start-slot card-list end-slot)
131
 
       (complete-transaction start-slot card-list end-slot))
132
 
)
133
 
 
134
 
(define (do-deal-next-cards)
135
 
  (deal-cards-face-up stock-slot tableau))
136
 
 
137
 
(define (button-clicked slot)
138
 
  (if (= stock-slot slot)
139
 
      (if (dealable?) (do-deal-next-cards) #f)
140
 
      #f))
141
 
 
142
 
 
143
 
(define (find-any-to-foundation from-slots)
144
 
  (if (eq? from-slots '() )
145
 
      #f
146
 
      (let ((find-to-result (find-to foundation (car from-slots))))
147
 
        (if find-to-result
148
 
            (list (car from-slots) find-to-result)
149
 
            (find-any-to-foundation (cdr from-slots))))))
150
 
 
151
 
; remake a list of slots with/without empty members
152
 
(define (without-gaps slots with-empties)
153
 
    (cond ((eq? slots '()) '())
154
 
          (with-empties slots)
155
 
          ((empty-slot? (car slots)) (without-gaps (cdr slots) with-empties))
156
 
          ( else (cons (car slots) (without-gaps (cdr slots) with-empties)))))
157
 
 
158
 
 
159
 
(define (find-any-to-tableau from-slots with-empties)
160
 
  (if (eq? from-slots '() )
161
 
      #f
162
 
      (let ((find-to-result (find-to (without-gaps tableau with-empties) (car from-slots)))
163
 
            (cfs (car from-slots)))
164
 
        (if (and find-to-result
165
 
                  ; check we are not breaking an existing run
166
 
                 (or (= (length (get-cards cfs )) 1)
167
 
                     (not (check-straight-descending-list (list (get-top-card cfs) (cadr (get-cards cfs))))))
168
 
                  ; if suggesting a move to a gap make sure it is worthwhile
169
 
                 (or (not (empty-slot? find-to-result))
170
 
                     (> (length (get-cards cfs )) 1)))  ;can move a top card to a gap if it does not make a gap
171
 
            (list cfs find-to-result)
172
 
            (find-any-to-tableau (cdr from-slots) with-empties)))))
173
 
 
174
 
(define (move-any-to-foundation slots)
175
 
  (let (( find-any-result (find-any-to-foundation slots)))
176
 
    (if find-any-result
177
 
        (move-a-card (car find-any-result) (cadr find-any-result))
178
 
        #f)))
179
 
 
180
 
 
181
 
(define (auto-play)
182
 
    (if (move-any-to-foundation (append tableau (list reserve-slot)))
183
 
        (delayed-call auto-play)
184
 
        #f
185
 
    )
186
 
)
187
 
 
188
 
 
189
 
(define (find-to slots from-slot)
190
 
  (if (or (empty-slot? from-slot) (eq? slots '()))
191
 
        #f
192
 
       (if (droppable? from-slot (list (get-top-card from-slot)) (car slots) )
193
 
           (car slots)
194
 
           (find-to (cdr slots) from-slot)
195
 
       )
196
 
  )
197
 
)
198
 
 
199
 
(define (move-a-card from-slot to-slot)
200
 
   (if ( or (not to-slot) (empty-slot? from-slot))
201
 
        #f
202
 
       (add-card! to-slot (remove-card from-slot))
203
 
   )
204
 
)
205
 
 
206
 
(define (move-to-foundation from-slot)
207
 
   (move-a-card from-slot (find-to foundation from-slot ))
208
 
)
209
 
 
210
 
 
211
 
(define (button-double-clicked slot)
212
 
   (if (member slot foundation)
213
 
           (auto-play)
214
 
           (if (or (member slot tableau) (= slot reserve-slot) )
215
 
               (move-to-foundation slot)
216
 
               #f
217
 
           )
218
 
   )
219
 
)
220
 
 
221
 
 
222
 
(define (game-over)
223
 
  (give-status-message)
224
 
  (and (not (game-won))
225
 
       (get-hint)))
226
 
 
227
 
 
228
 
 
229
 
; score the game - 1 pt for every card in the foundations 104 to win.
230
 
(define (game-score slot-list)
231
 
  (if (and (null? slot-list))
232
 
      0
233
 
      (+ (length (get-cards (car slot-list))) (game-score (cdr slot-list)))
234
 
  )
235
 
)
236
 
 
237
 
; game is won when all cards are moved to foundations.
238
 
(define (game-won)
239
 
   (= (set-score! (game-score foundation)) winning-score)
240
 
)
241
 
 
242
 
 
243
 
 
244
 
(define (dealable?)
245
 
  (if (and
246
 
        (not (empty-slot? stock-slot ))
247
 
        (or allow-empty-slots
248
 
            (not (any-slot-empty? tableau))))
249
 
      (list 0 (_"Deal a row"))
250
 
      #f))
251
 
 
252
 
 
253
 
(define (my-get-card-name slot)
254
 
    (if (empty-slot? slot)
255
 
        (if  (member slot foundation)
256
 
             (_"an empty foundation place")
257
 
             (_"an empty tableau place"))
258
 
        (get-name (get-top-card slot))
259
 
    )
260
 
)
261
 
 
262
 
 
263
 
 
264
 
 
265
 
; This is the hint function
266
 
; 1) Suggest a move to a foundation.
267
 
; 2) Suggest moving a card from the (reserve  + tableau) to the tableau.
268
 
; 3) Suggest moviing a card to an empty tableau-slot
269
 
; 4) Suggest moving to the reserve if unoccupied
270
 
; 5) Suggest dealing a row if there are cards still in the stock.
271
 
; 6) Suggest moving cards around.
272
 
 
273
 
(define (get-hint)
274
 
  (let ((find-result (find-any-to-foundation (append tableau (list reserve-slot))))
275
 
        (t-result1   (find-any-to-tableau  (append tableau (list reserve-slot)) #f  ))
276
 
        (t-result2   (find-any-to-tableau  (append tableau (list reserve-slot)) #t )))
277
 
     (cond
278
 
           ( find-result
279
 
            (list 2 (my-get-card-name (car find-result)) (my-get-card-name (cadr find-result))))
280
 
           ( t-result1
281
 
            (list 2 (my-get-card-name (car t-result1)) (my-get-card-name (cadr t-result1))))
282
 
           ( t-result2
283
 
            (list 2 (my-get-card-name (car t-result2)) (my-get-card-name (cadr t-result2))))
284
 
           ( (empty-slot? reserve-slot) (list 0 (_"Try moving a card to the reserve")))
285
 
           ( (dealable?) (list 0 (_"Try dealing a row of cards")))
286
 
; this isn't great, but it will get around the premature end-of-game call
287
 
           (else (list 0 (_"Try moving card piles around")))
288
 
     )))
289
 
 
290
 
(define (get-options)
291
 
  (list 'begin-exclusive
292
 
        (list (_"Same suit") same-suit)
293
 
        (list (_"Alternating colors") (not same-suit))
294
 
        'end-exclusive))
295
 
 
296
 
(define (apply-options options)
297
 
  (set! same-suit (cadr (list-ref options 1))))
298
 
 
299
 
(define (timeout) #f)
300
 
 
301
 
(set-features droppable-feature dealable-feature)
302
 
 
303
 
(set-lambda new-game button-pressed button-released button-clicked button-double-clicked game-over game-won get-hint
304
 
get-options apply-options timeout droppable? dealable?)