westhaven.scm 9.35 KB
Newer Older
Rosanna Yuen's avatar
Rosanna Yuen committed
1 2 3
; AisleRiot - westhaven.scm
; Copyright (C) 1999 Rosanna Yuen <rwsy@mit.edu>
;
4
; This program is free software: you can redistribute it and/or modify
Rosanna Yuen's avatar
Rosanna Yuen committed
5
; it under the terms of the GNU General Public License as published by
6 7
; the Free Software Foundation, either version 3 of the License, or
; (at your option) any later version.
Rosanna Yuen's avatar
Rosanna Yuen committed
8 9 10 11 12 13 14
;
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU General Public License for more details.
;
; 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/>.
Rosanna Yuen's avatar
Rosanna Yuen committed
16

17 18
(use-modules (aisleriot interface) (aisleriot api))

19 20 21 22 23
(define stock 0)
(define waste 1)
(define foundation '(2 3 4 5))
(define tableau '(6 7 8 9 10 11 12 13 14 15))

Rosanna Yuen's avatar
Rosanna Yuen committed
24 25 26 27 28 29
(define (new-game)
  (initialize-playing-area)
  (set-ace-low)
  (make-standard-deck)
  (shuffle-deck)

30 31
  (add-normal-slot DECK 'stock)
  (add-normal-slot '() 'waste)
Rosanna Yuen's avatar
Rosanna Yuen committed
32 33 34

  (add-blank-slot)

35 36 37 38
  (add-normal-slot '() 'foundation)
  (add-normal-slot '() 'foundation)
  (add-normal-slot '() 'foundation)
  (add-normal-slot '() 'foundation)
Rosanna Yuen's avatar
Rosanna Yuen committed
39 40 41

  (add-carriage-return-slot)

42 43 44 45 46 47 48 49 50 51
  (add-extended-slot '() down 'tableau)
  (add-extended-slot '() down 'tableau)
  (add-extended-slot '() down 'tableau)
  (add-extended-slot '() down 'tableau)
  (add-extended-slot '() down 'tableau)
  (add-extended-slot '() down 'tableau)
  (add-extended-slot '() down 'tableau)
  (add-extended-slot '() down 'tableau)
  (add-extended-slot '() down 'tableau)
  (add-extended-slot '() down 'tableau)
Rosanna Yuen's avatar
Rosanna Yuen committed
52 53 54 55 56

  (deal-cards 0 '(6 7 8 9 10 11 12 13 14 15))
  (deal-cards 0 '(6 7 8 9 10 11 12 13 14 15))
  (deal-cards-face-up 0 '(6 7 8 9 10 11 12 13 14 15))

57
  (give-status-message)
Rosanna Yuen's avatar
Rosanna Yuen committed
58 59 60 61

  (list 10 4)
)

62 63 64
(define (give-status-message)
  (set-statusbar-message (get-stock-no-string)))

Rosanna Yuen's avatar
Rosanna Yuen committed
65
(define (get-stock-no-string)
66
  (string-append (_"Stock left:") " " 
Rosanna Yuen's avatar
Rosanna Yuen committed
67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
		 (number->string (length (get-cards 0)))))

(define (next-card card-list number)
  (if (= number 0)
      (car card-list)
      (next-card (cdr card-list) (- number 1))))

(define (button-pressed slot-id card-list)
  (and (not (empty-slot? slot-id))
       (or (= slot-id 1)
	   (> slot-id 5))
       (is-visible? (car (reverse card-list)))
       (or (= (length card-list) 1)
	   (= (length card-list)
	      (length (get-cards slot-id)))
	   (not (is-visible? (next-card (get-cards slot-id)
					(length card-list)))))))

85
(define (droppable? start-slot card-list end-slot)
86 87
  (cond ((= start-slot end-slot) #f)
        ((> end-slot 5)
88
	 (or (empty-slot? end-slot)
Rosanna Yuen's avatar
Rosanna Yuen committed
89 90 91
	     (and (not (eq? (is-red? (get-top-card end-slot))
			    (is-red? (car (reverse card-list)))))
		  (= (get-value (get-top-card end-slot))
92
		     (+ 1 (get-value (car (reverse card-list))))))))
Rosanna Yuen's avatar
Rosanna Yuen committed
93 94 95
	((and (> end-slot 1)
	      (= 1 (length card-list)))
	 (if (= (get-value (car card-list)) ace)
96
	     (empty-slot? end-slot)
Rosanna Yuen's avatar
Rosanna Yuen committed
97 98 99 100
	     (and (not (empty-slot? end-slot))
		  (= (get-suit (car card-list))
		     (get-suit (get-top-card end-slot)))
		  (= (+ 1 (get-value (get-top-card end-slot)))
101
		     (get-value (car card-list))))))
Rosanna Yuen's avatar
Rosanna Yuen committed
102 103
	(#t #f)))

104 105 106 107 108 109 110 111 112 113
(define (button-released start-slot card-list end-slot)
  (and (droppable? start-slot card-list end-slot)
       (begin
	 (move-n-cards! start-slot end-slot card-list)
	 (and (< end-slot 6)
	      (> end-slot 1)
	      (add-to-score! 1))
	 (or (empty-slot? start-slot)
	     (make-visible-top-card start-slot)))))

Rosanna Yuen's avatar
Rosanna Yuen committed
114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178
(define (button-clicked slot-id)
  (and (= slot-id 0)
       (not (empty-slot? 0))
       (deal-cards-face-up 0 '(1))))

(define (double-clicked-move start-slot end-slot card-list)
  (move-n-cards! start-slot end-slot card-list)
  (remove-card start-slot)
  (add-to-score! 1)
  (if (not (empty-slot? start-slot))
      (make-visible-top-card start-slot)
      #t))

(define (button-double-clicked slot-id)
  (if (and (not (empty-slot? slot-id))
	   (or (= slot-id 1)
	       (> slot-id 5)))
      (if (= (get-value (get-top-card slot-id)) ace)
	  (cond ((empty-slot? 2)
		 (double-clicked-move slot-id 
				      2 
				      (list (get-top-card slot-id))))
		((empty-slot? 3)
		 (double-clicked-move slot-id 
				      3
				      (list (get-top-card slot-id))))
		((empty-slot? 4)
		 (double-clicked-move slot-id 
				      4 
				      (list (get-top-card slot-id))))
		(#t
		 (double-clicked-move slot-id 
				      5 
				      (list (get-top-card slot-id)))))
	  (cond ((and (not (empty-slot? 2))
		      (= (get-suit (get-top-card slot-id))
			 (get-suit (get-top-card 2)))
		      (= (get-value (get-top-card slot-id))
			 (+ 1 (get-value (get-top-card 2)))))
		 (double-clicked-move slot-id 
				      2 
				      (list (get-top-card slot-id))))
		((and (not (empty-slot? 3))
		      (= (get-suit (get-top-card slot-id))
			 (get-suit (get-top-card 3)))
		      (= (get-value (get-top-card slot-id))
			 (+ 1 (get-value (get-top-card 3)))))
		 (double-clicked-move slot-id 
				      3
				      (list (get-top-card slot-id))))
		((and (not (empty-slot? 4))
		      (= (get-suit (get-top-card slot-id))
			 (get-suit (get-top-card 4)))
		      (= (get-value (get-top-card slot-id))
			 (+ 1 (get-value (get-top-card 4)))))
		 (double-clicked-move slot-id 
				      4
				      (list (get-top-card slot-id))))
		((and (not (empty-slot? 5))
		      (= (get-suit (get-top-card slot-id))
			 (get-suit (get-top-card 5)))
		      (= (get-value (get-top-card slot-id))
			 (+ 1 (get-value (get-top-card 5)))))
		 (double-clicked-move slot-id 
				      5
179 180
				      (list (get-top-card slot-id))))
                (#t #f)))
Rosanna Yuen's avatar
Rosanna Yuen committed
181 182 183
      #f))

(define (game-continuable)
184
  (give-status-message)
Rosanna Yuen's avatar
Rosanna Yuen committed
185 186 187 188 189 190 191 192 193 194 195
  (and (not (game-won))
       (get-hint)))

(define (game-won)
  (and (= (length (get-cards 2)) 13)
       (= (length (get-cards 3)) 13)
       (= (length (get-cards 4)) 13)
       (= (length (get-cards 5)) 13)))

(define (dealable?)
  (if (not (empty-slot? 0))
196
      (list 0 (_"Deal a card"))
Rosanna Yuen's avatar
Rosanna Yuen committed
197 198 199 200 201 202 203 204 205 206
      #f))

(define (to-foundations? slot-id)
  (cond ((> slot-id 15)
	 #f)
	((= slot-id 2)
	 (to-foundations? 6))
	((empty-slot? slot-id)
	 (to-foundations? (+ 1 slot-id)))
	((= (get-value (get-top-card slot-id)) ace)
207
	 (hint-move slot-id 1 (find-empty-slot foundation)))
Rosanna Yuen's avatar
Rosanna Yuen committed
208 209 210 211 212
	((and (not (empty-slot? 2))
	      (eq? (get-suit (get-top-card 2))
		   (get-suit (get-top-card slot-id)))
	      (= (+ 1 (get-value (get-top-card 2)))
		 (get-value (get-top-card slot-id))))
213
	 (hint-move slot-id 1 2))
Rosanna Yuen's avatar
Rosanna Yuen committed
214 215 216 217 218
	((and (not (empty-slot? 5))
	      (eq? (get-suit (get-top-card 5))
		   (get-suit (get-top-card slot-id)))
	      (= (+ 1 (get-value (get-top-card 5)))
		 (get-value (get-top-card slot-id))))
219
	 (hint-move slot-id 1 5))
Rosanna Yuen's avatar
Rosanna Yuen committed
220 221 222 223 224
	((and (not (empty-slot? 3))
	      (eq? (get-suit (get-top-card 3))
		   (get-suit (get-top-card slot-id)))
	      (= (+ 1 (get-value (get-top-card 3)))
		 (get-value (get-top-card slot-id))))
225
	 (hint-move slot-id 1 3))
Rosanna Yuen's avatar
Rosanna Yuen committed
226 227 228 229 230
	((and (not (empty-slot? 4))
	      (eq? (get-suit (get-top-card 4))
		   (get-suit (get-top-card slot-id)))
	      (= (+ 1 (get-value (get-top-card 4)))
		 (get-value (get-top-card slot-id))))
231
	 (hint-move slot-id 1 4))
Rosanna Yuen's avatar
Rosanna Yuen committed
232 233 234 235 236 237 238 239 240 241 242 243
	(#t
	 (to-foundations? (+ 1 slot-id)))))

(define (waste-to-tableau? end-slot)
  (if (or (> end-slot 15)
	  (empty-slot? 1))
      #f
      (if (and (not (empty-slot? end-slot))
	       (not (eq? (is-red? (get-top-card 1))
			 (is-red? (get-top-card end-slot))))
	       (= (+ 1 (get-value (get-top-card 1)))
		  (get-value (get-top-card end-slot))))
244
	  (hint-move 1 1 end-slot)
Rosanna Yuen's avatar
Rosanna Yuen committed
245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270
	  (waste-to-tableau? (+ 1 end-slot)))))

(define (strip-invisible card-list)
  (if (is-visible? (car card-list))
      (car card-list)
      (strip-invisible (cdr card-list))))

(define (get-available-bottom slot-id)
  (strip-invisible (reverse (get-cards slot-id))))

(define (check-move card slot-id)
  (and (not (eq? (is-red? card)
		 (is-red? (get-top-card slot-id))))
       (= (+ 1 (get-value card))
	  (get-value (get-top-card slot-id)))))

(define (tableau-to-tableau? slot1 slot2)
  (cond ((= slot1 16)
	 #f)
	((or (empty-slot? slot1)
	     (= slot2 16))
	 (tableau-to-tableau? (+ 1 slot1) 6))
	((or (empty-slot? slot2)
	     (= slot1 slot2))
	 (tableau-to-tableau? slot1 (+ 1 slot2)))
	((check-move (get-available-bottom slot1) slot2)
271
	 (hint-move slot1 (find-card slot1 (get-available-bottom slot1)) slot2))
Rosanna Yuen's avatar
Rosanna Yuen committed
272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288
	(#t
	 (tableau-to-tableau? slot1 (+ 1 slot2)))))

(define (check-for-empty slot-id)
  (cond ((> slot-id 15)
	 #f)
	((empty-slot? slot-id)
	 slot-id)
	(#t
	 (check-for-empty (+ 1 slot-id)))))

(define (check-invisible slot-id)
  (cond ((> slot-id 15)
	 #f)

	((and (not (empty-slot? slot-id))
	      (not (is-visible? (car (reverse (get-cards slot-id))))))
289
	 slot-id)
Rosanna Yuen's avatar
Rosanna Yuen committed
290 291 292 293 294 295 296
	(#t
	 (check-invisible (+ 1 slot-id)))))

(define (check-empty-slot)
  (if (not (check-for-empty 6))
      #f
      (cond ((check-invisible 6)
297 298
             (let ((from-slot (check-invisible 6)))
              (hint-move from-slot (find-card from-slot (get-available-bottom from-slot)) (find-empty-slot tableau))))
Rosanna Yuen's avatar
Rosanna Yuen committed
299
	    ((not (empty-slot? 1))
300
	     (hint-move 1 1 (find-empty-slot tableau)))
Rosanna Yuen's avatar
Rosanna Yuen committed
301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318
	    (#t #f))))

(define (get-hint)
  (or (to-foundations? 1)
      (waste-to-tableau? 6)
      (tableau-to-tableau? 6 7)
      (check-empty-slot)
      (dealable?)))

(define (get-options) 
  #f)

(define (apply-options options) 
  #f)

(define (timeout) 
  #f)

319 320
(set-features droppable-feature)

Rosanna Yuen's avatar
Rosanna Yuen committed
321 322
(set-lambda new-game button-pressed button-released button-clicked
button-double-clicked game-continuable game-won get-hint get-options
323
apply-options timeout droppable?)