← Back to branch summary

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

« back to all changes in this revision

Viewing changes to aisleriot/scuffle.scm

  • Committer: Package Import Robot
  • Author(s): Jose Carlos Garcia Sogo
  • Date: 2002-02-15 20:12:21 UTC
  • Revision ID: package-import@ubuntu.com-20020215201221-pntf81dxhsatz4qy
Tags: upstream-1.4.0.3
Import upstream version 1.4.0.3

Show diffs side-by-side

added added

removed removed

Lines of Context:
aisleriot/scuffle.scm
 
1
; AisleRiot - scuffle.scm
 
2
; Copyright (C) 2001 Rosanna Yuen <zana@webwynk.net>
 
3
;
 
4
; This game 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 2, or (at your option)
 
7
; 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, write to the Free Software
 
16
; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
 
17
; USA
 
18
 
 
19
(define (new-game)
 
20
  (initialize-playing-area)
 
21
  (set-ace-low)
 
22
  (set! DECK (make-deck-list-ace-low 2 2 club))
 
23
  (shuffle-deck)
 
24
 
 
25
  (add-normal-slot DECK)
 
26
  (add-blank-slot)
 
27
  (add-normal-slot '())
 
28
  (add-normal-slot '())
 
29
  (add-normal-slot '())
 
30
  (add-normal-slot '())
 
31
  (add-carriage-return-slot)
 
32
  (add-blank-slot)
 
33
  (add-blank-slot)
 
34
  (add-normal-slot '())
 
35
  (add-normal-slot '())
 
36
  (add-normal-slot '())
 
37
  (add-normal-slot '())
 
38
  
 
39
  (add-card! 1 (make-visible (make-card ace club)))
 
40
  (add-card! 2 (make-visible (make-card ace diamond)))
 
41
  (add-card! 3 (make-visible (make-card ace heart)))
 
42
  (add-card! 4 (make-visible (make-card ace spade)))
 
43
 
 
44
  (give-status-message)
 
45
 
 
46
  (list 6 2)
 
47
)
 
48
 
 
49
(define (give-status-message)
 
50
  (set-statusbar-message (string-append (get-stock-no-string)
 
51
                                        "   "
 
52
                                        (get-redeals-string))))
 
53
 
 
54
(define (get-redeals-string)
 
55
  (string-append "Redeals left:  "
 
56
                 (number->string (- 2 FLIP-COUNTER))))
 
57
 
 
58
(define (get-stock-no-string)
 
59
  (string-append "Stock left:  " 
 
60
                 (number->string (length (get-cards 0)))))
 
61
 
 
62
(define (button-pressed slot-id card-list)
 
63
  (and (not (empty-slot? slot-id))
 
64
       (> slot-id 4)))
 
65
 
 
66
(define (button-released start-slot card-list end-slot)
 
67
  (and (< end-slot 5)
 
68
       (> end-slot 0)
 
69
       (= (get-value (car card-list))
 
70
          (+ 1 (get-value (get-top-card end-slot))))
 
71
       (move-n-cards! start-slot end-slot card-list)
 
72
       (add-to-score! 1)))
 
73
 
 
74
(define (deal-cards-out slot)
 
75
  (if (and (< slot 9)
 
76
           (not (empty-slot? 0)))
 
77
      (and (deal-cards-face-up 0 (list slot))
 
78
           (deal-cards-out (+ 1 slot)))
 
79
      #t))
 
80
 
 
81
(define (button-clicked slot-id)
 
82
  (and (= slot-id 0)
 
83
       (or (and (not (empty-slot? 0))
 
84
                (deal-cards-out 5))
 
85
           (and (< FLIP-COUNTER 2)
 
86
                (set! FLIP-COUNTER (+ 1 FLIP-COUNTER))
 
87
                (flip-deck 0 5)
 
88
                (flip-deck 0 6)
 
89
                (flip-deck 0 7)
 
90
                (flip-deck 0 8)
 
91
                (shuffle-deck)))))
 
92
 
 
93
(define (check-end-slot? slot1 slot2)
 
94
  (if (and (not (empty-slot? slot1))
 
95
           (= (get-value (get-top-card slot1))
 
96
              (+ 1 (get-value (get-top-card slot2)))))
 
97
      (begin
 
98
        (deal-cards slot1 (list slot2))
 
99
        (add-to-score! 1))
 
100
      (if (< slot2 4)
 
101
          (check-end-slot? slot1 (+ 1 slot2))
 
102
          #f)))
 
103
 
 
104
(define (button-double-clicked slot-id)
 
105
  (and (> slot-id 4)
 
106
       (check-end-slot? slot-id 1)))
 
107
 
 
108
(define (game-continuable)
 
109
  (give-status-message)
 
110
  (and (not (game-won))
 
111
       (get-hint)))
 
112
 
 
113
(define (game-won)
 
114
  (and (empty-slot? 0)
 
115
       (empty-slot? 5)
 
116
       (empty-slot? 6)
 
117
       (empty-slot? 7)
 
118
       (empty-slot? 8)))
 
119
 
 
120
(define (movable? slot1 slot2)
 
121
  (if (= slot1 9)
 
122
      #f
 
123
      (if (or (= slot2 5)
 
124
              (empty-slot? slot1))
 
125
          (movable? (+ 1 slot1) 1)
 
126
          (if (= (get-value (get-top-card slot1))
 
127
                 (+ 1 (get-value (get-top-card slot2))))
 
128
              (list 1
 
129
                    (get-name (get-top-card slot1)) 
 
130
                    (get-name (get-top-card slot2)))
 
131
              (movable? slot1 (+ 1 slot2))))))
 
132
 
 
133
(define (dealable?)
 
134
  (or (and (not (empty-slot? 0))
 
135
           (list 0 "Deal another round"))
 
136
      (and (< FLIP-COUNTER 2)
 
137
           (list 0 "Reshuffle cards"))))
 
138
 
 
139
(define (get-hint)
 
140
  (or (movable? 5 1)
 
141
      (dealable?)))
 
142
 
 
143
(define (get-options) 
 
144
  #f)
 
145
 
 
146
(define (apply-options options) 
 
147
  #f)
 
148
 
 
149
(define (timeout) 
 
150
  #f)
 
151
 
 
152
(set-lambda new-game button-pressed button-released button-clicked
 
153
button-double-clicked game-continuable game-won get-hint get-options
 
154
apply-options timeout)