← Back to branch summary

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

« back to all changes in this revision

Viewing changes to aisleriot/rules/scorpion.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/scorpion.scm
1
 
; AisleRiot - scorpion.scm
2
 
; Copyright (C) 1999 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
 
; winning game seed: 2036201447
17
 
 
18
 
(define (new-game)
19
 
  (initialize-playing-area)
20
 
  (set-ace-low)
21
 
  (make-standard-deck)
22
 
  (shuffle-deck)
23
 
 
24
 
  (add-normal-slot DECK)
25
 
 
26
 
  (add-blank-slot)
27
 
 
28
 
  (add-extended-slot '() down)
29
 
  (add-extended-slot '() down)
30
 
  (add-extended-slot '() down)
31
 
  (add-extended-slot '() down)
32
 
  (add-extended-slot '() down)
33
 
  (add-extended-slot '() down)
34
 
  (add-extended-slot '() down)
35
 
 
36
 
  (deal-cards 0 '(1 2 3 4))
37
 
  (deal-cards-face-up 0 '(5 6 7))
38
 
  (deal-cards 0 '(1 2 3 4))
39
 
  (deal-cards-face-up 0 '(5 6 7))
40
 
  (deal-cards 0 '(1 2 3 4))
41
 
  (deal-cards-face-up 0 '(5 6 7))
42
 
  (deal-cards-face-up 0 '(1 2 3 4 5 6 7))
43
 
  (deal-cards-face-up 0 '(1 2 3 4 5 6 7))
44
 
  (deal-cards-face-up 0 '(1 2 3 4 5 6 7))
45
 
  (deal-cards-face-up 0 '(1 2 3 4 5 6 7))
46
 
 
47
 
  (begin-score (reverse (get-cards 1)))
48
 
  (begin-score (reverse (get-cards 2)))
49
 
  (begin-score (reverse (get-cards 3)))
50
 
  (begin-score (reverse (get-cards 4)))
51
 
  (begin-score (reverse (get-cards 5)))
52
 
  (begin-score (reverse (get-cards 6)))
53
 
  (begin-score (reverse (get-cards 7)))
54
 
 
55
 
  (list 9 4))
56
 
 
57
 
(define (begin-score card-list)
58
 
  (if (not (is-visible? (car card-list)))
59
 
      (begin-score (cdr card-list))
60
 
      (begin
61
 
        (if (and (= (get-suit (car card-list))
62
 
                    (get-suit (cadr card-list)))
63
 
                 (= (get-value (car card-list))
64
 
                    (+ (get-value (cadr card-list)) 1)))
65
 
            (add-to-score! 1))
66
 
        (if (> (length card-list) 2)
67
 
            (begin-score (cdr card-list))
68
 
            #f))))
69
 
 
70
 
(define (button-pressed slot-id card-list)
71
 
  (and (not (empty-slot? slot-id))
72
 
       (is-visible? (car (reverse card-list)))))
73
 
 
74
 
(define (correct-sequence card-list)
75
 
  (or (= (length card-list) 1)
76
 
      (and (is-visible? (cadr card-list))
77
 
           (eq? (get-suit (car card-list))
78
 
                (get-suit (cadr card-list)))
79
 
           (= (+ 1 (get-value (car card-list)))
80
 
              (get-value (cadr card-list)))
81
 
           (correct-sequence (cdr card-list)))))
82
 
 
83
 
(define (droppable? start-slot card-list end-slot)
84
 
  (and (not (= start-slot end-slot))
85
 
       (not (= end-slot 0))
86
 
       (or (and (empty-slot? end-slot)
87
 
                (= (get-value (car (reverse card-list))) king))
88
 
           (and (not (empty-slot? end-slot))
89
 
                (eq? (get-suit (get-top-card end-slot))
90
 
                     (get-suit (car (reverse card-list))))
91
 
                (= (get-value (get-top-card end-slot))
92
 
                   (+ 1 (get-value (car (reverse card-list)))))))))
93
 
 
94
 
(define (button-released start-slot card-list end-slot)
95
 
  (and (droppable? start-slot card-list end-slot)
96
 
       (or (empty-slot? end-slot)
97
 
           (add-to-score! 1))
98
 
       (move-n-cards! start-slot end-slot card-list)
99
 
       (or (empty-slot? start-slot)
100
 
           (is-visible? (get-top-card start-slot))
101
 
           (and (make-visible-top-card start-slot)
102
 
                (add-to-score! 3)))
103
 
       (or (not (= (length (get-cards end-slot)) 13))
104
 
           (not (correct-sequence (get-cards end-slot)))
105
 
           (and (= (length card-list) 13)
106
 
                (empty-slot? start-slot))
107
 
           (add-to-score! 4))
108
 
       (or (not (= (length (get-cards start-slot)) 13))
109
 
           (not (correct-sequence (get-cards start-slot)))
110
 
           (add-to-score! 4))))
111
 
 
112
 
(define (check-for-points slot-id)
113
 
  (if (> slot-id 3)
114
 
      (give-status-message)
115
 
      (begin
116
 
        (if (and (> (length (get-cards slot-id)) 1)
117
 
                 (eq? (get-suit (get-top-card slot-id))
118
 
                      (get-suit (cadr (get-cards slot-id))))
119
 
                 (= (+ 1 (get-value (get-top-card slot-id)))
120
 
                    (get-value  (cadr (get-cards slot-id)))))
121
 
            (add-to-score! 1)
122
 
            #t)
123
 
        (check-for-points (+ 1 slot-id)))))
124
 
 
125
 
(define (button-clicked slot-id)
126
 
  (and (= slot-id 0)
127
 
       (not (empty-slot? 0))
128
 
       (deal-cards-face-up 0 '(1 2 3))
129
 
       (check-for-points 1)))
130
 
 
131
 
(define (button-double-clicked slot-id)
132
 
  #f)
133
 
 
134
 
(define (game-continuable)
135
 
  (get-hint))
136
 
 
137
 
(define (game-won)
138
 
  (eq? (get-score) 100))
139
 
 
140
 
(define (dealable?)
141
 
  (and (not (empty-slot? 0))
142
 
       (list 0 (_"Deal the cards"))))
143
 
 
144
 
(define (check-slot-cards card card-list)
145
 
  (cond ((or (= (length card-list) 0)
146
 
             (not (is-visible? (car card-list))))
147
 
         #f)
148
 
        ((and (eq? (get-suit card)
149
 
                   (get-suit (car card-list)))
150
 
              (= (get-value card)
151
 
                 (+ 1 (get-value (car card-list)))))
152
 
         #t)
153
 
        (#t (check-slot-cards card (cdr card-list)))))
154
 
 
155
 
(define (check-a-slot slot1 slot2)
156
 
  (cond ((= slot2 8)
157
 
         #f)
158
 
        ((and (not (= slot1 slot2))
159
 
              (not (empty-slot? slot2))
160
 
              (check-slot-cards (get-top-card slot1) (get-cards slot2)))
161
 
         #t)
162
 
        (#t (check-a-slot slot1 (+ 1 slot2)))))
163
 
 
164
 
(define (check-slot slot-id)
165
 
  (cond ((= slot-id 8)
166
 
         #f)
167
 
        ((and (not (empty-slot? slot-id))
168
 
              (check-a-slot slot-id 1))
169
 
         (list 1 
170
 
               (get-name (make-card (- (get-value (get-top-card slot-id)) 1)
171
 
                                    (get-suit (get-top-card slot-id))))
172
 
               (get-name (get-top-card slot-id))))
173
 
        (#t (check-slot (+ 1 slot-id)))))
174
 
 
175
 
(define (here-kingy-kingy card-list)
176
 
  (cond ((or (= (length card-list) 0)
177
 
             (= (length card-list) 1)
178
 
             (not (is-visible? (car card-list))))
179
 
         #f)
180
 
        ((= (get-value (car card-list)) king)
181
 
         (list 2 (get-name (car card-list)) (_"an empty slot")))
182
 
        (#t (here-kingy-kingy (cdr card-list)))))
183
 
 
184
 
(define (king-avail? slot-id)
185
 
  (cond ((= slot-id 8)
186
 
         #f)
187
 
        ((and (not (empty-slot? slot-id))
188
 
              (here-kingy-kingy (get-cards slot-id)))
189
 
         (here-kingy-kingy (get-cards slot-id)))
190
 
        (#t (king-avail? (+ 1 slot-id)))))
191
 
 
192
 
(define (check-for-empty)
193
 
  (and (or (empty-slot? 1)
194
 
           (empty-slot? 2)
195
 
           (empty-slot? 3)
196
 
           (empty-slot? 4)
197
 
           (empty-slot? 5)
198
 
           (empty-slot? 6)
199
 
           (empty-slot? 7))
200
 
       (king-avail? 1)))
201
 
 
202
 
(define (get-hint)
203
 
  (or (check-slot 1)
204
 
      (check-for-empty)
205
 
      (dealable?)))
206
 
 
207
 
(define (get-options) 
208
 
  #f)
209
 
 
210
 
(define (apply-options options) 
211
 
  #f)
212
 
 
213
 
(define (timeout) 
214
 
  #f)
215
 
 
216
 
(set-features droppable-feature)
217
 
 
218
 
(set-lambda new-game button-pressed button-released button-clicked
219
 
button-double-clicked game-continuable game-won get-hint get-options
220
 
apply-options timeout droppable?)