1; AisleRiot - yukon.scm 2; Copyright (C) 1998, 2003 Rosanna Yuen <rwsy@mit.edu> 3; This program is free software: you can redistribute it and/or modify 4; it under the terms of the GNU General Public License as published by 5; the Free Software Foundation, either version 3 of the License, or 6; (at your option) any later version. 7; 8; This program is distributed in the hope that it will be useful, 9; but WITHOUT ANY WARRANTY; without even the implied warranty of 10; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11; GNU General Public License for more details. 12; 13; You should have received a copy of the GNU General Public License 14; along with this program. If not, see <http://www.gnu.org/licenses/>. 15 16(use-modules (aisleriot interface) (aisleriot api)) 17 18(define foundation '(0 8 9 10)) 19(define tableau '(1 2 3 4 5 6 7)) 20 21(define (new-game) 22 (initialize-playing-area) 23 24 ;set up the cards 25 (make-standard-deck) 26 (shuffle-deck) 27 28 ;set up the board 29 (add-normal-slot DECK 'foundation) 30 (add-blank-slot) 31 (add-extended-slot '() down 'tableau) 32 (add-extended-slot '() down 'tableau) 33 (add-extended-slot '() down 'tableau) 34 (add-extended-slot '() down 'tableau) 35 (add-extended-slot '() down 'tableau) 36 (add-extended-slot '() down 'tableau) 37 (add-extended-slot '() down 'tableau) 38 (add-carriage-return-slot) 39 (add-normal-slot '() 'foundation) 40 (add-carriage-return-slot) 41 (add-normal-slot '() 'foundation) 42 (add-carriage-return-slot) 43 (add-normal-slot '() 'foundation) 44 45 46 (deal-cards 0 '(1 2 3 4 5 6 7 2 3 4 5 6 7 3 4 5 6 7 4 5 6 7 5 6 7 6 7 7)) 47 48 (flip-top-card 1) 49 (flip-top-card 2) 50 (flip-top-card 3) 51 (flip-top-card 4) 52 (flip-top-card 5) 53 (flip-top-card 6) 54 (flip-top-card 7) 55 56 (deal-cards 0 '(2 3 4 5 6 7)) 57 (flip-top-card 2) 58 (flip-top-card 3) 59 (flip-top-card 4) 60 (flip-top-card 5) 61 (flip-top-card 6) 62 (flip-top-card 7) 63 (deal-cards 0 '(2 3 4 5 6 7)) 64 (flip-top-card 2) 65 (flip-top-card 3) 66 (flip-top-card 4) 67 (flip-top-card 5) 68 (flip-top-card 6) 69 (flip-top-card 7) 70 (deal-cards 0 '(2 3 4 5 6 7)) 71 (flip-top-card 2) 72 (flip-top-card 3) 73 (flip-top-card 4) 74 (flip-top-card 5) 75 (flip-top-card 6) 76 (flip-top-card 7) 77 (deal-cards 0 '(2 3 4 5 6 7)) 78 (flip-top-card 2) 79 (flip-top-card 3) 80 (flip-top-card 4) 81 (flip-top-card 5) 82 (flip-top-card 6) 83 (flip-top-card 7) 84 85 (list 9 4)) 86 87(define (button-pressed slot-id card-list) 88 (if (and card-list 89 (> slot-id 0) 90 (< slot-id 8) 91 (is-visible? (car (reverse card-list)))) 92 #t 93 #f)) 94 95(define (complete-transaction start-slot card-list end-slot) 96 (move-n-cards! start-slot end-slot card-list) 97 (if (or (= end-slot 0) 98 (> end-slot 7)) 99 (add-to-score! 1)) 100 (if (not (empty-slot? start-slot)) 101 (make-visible-top-card start-slot))) 102 103(define (droppable? start-slot card-list end-slot) 104 (cond ((= start-slot end-slot) #f) 105 ((and (= (length card-list) 1) 106 (or (= end-slot 0) 107 (> end-slot 7))) 108 (cond ((and (= (get-value (car card-list)) ace) 109 (empty-slot? end-slot)) 110 #t) 111 ((and (not (empty-slot? end-slot)) 112 (= (get-suit (get-top-card end-slot)) 113 (get-suit (car card-list))) 114 (= (+ 1 (get-value (get-top-card end-slot))) 115 (get-value (car card-list)))) 116 #t) 117 (#t #f))) 118 ((and (> end-slot 0) 119 (< end-slot 8)) 120 (cond ((and (empty-slot? end-slot) 121 (= (get-value (car (reverse card-list))) king)) 122 #t) 123 ((empty-slot? end-slot) #f) 124 ((and (eq? (is-black? (car (reverse card-list))) 125 (is-red? (get-top-card end-slot))) 126 (= (get-value (get-top-card end-slot)) 127 (+ 1 (get-value (car (reverse card-list)))))) 128 #t) 129 (#t #f))) 130 (#t #f))) 131 132(define (button-released start-slot card-list end-slot) 133 (and (droppable? start-slot card-list end-slot) 134 (complete-transaction start-slot card-list end-slot))) 135 136(define (button-clicked slot-id) 137 #f) 138 139(define (button-double-clicked slot) 140 (cond ((or (empty-slot? slot) 141 (= slot 0) 142 (> slot 7)) 143 #f) 144 ((= (get-value (get-top-card slot)) ace) 145 (let ((top-card (get-top-card slot))) 146 (remove-card slot) 147 (cond ((empty-slot? 0) 148 (complete-transaction slot (list top-card) 0)) 149 ((empty-slot? 8) 150 (complete-transaction slot (list top-card) 8)) 151 ((empty-slot? 9) 152 (complete-transaction slot (list top-card) 9)) 153 (#t 154 (complete-transaction slot (list top-card) 10))))) 155 ((and (not (empty-slot? 0)) 156 (= (get-suit (get-top-card 0)) 157 (get-suit (get-top-card slot))) 158 (= (+ 1 (get-value (get-top-card 0))) 159 (get-value (get-top-card slot)))) 160 (let ((top-card (get-top-card slot))) 161 (remove-card slot) 162 (complete-transaction slot (list top-card) 0))) 163 ((and (not (empty-slot? 8)) 164 (= (get-suit (get-top-card 8)) 165 (get-suit (get-top-card slot))) 166 (= (+ 1 (get-value (get-top-card 8))) 167 (get-value (get-top-card slot)))) 168 (let ((top-card (get-top-card slot))) 169 (remove-card slot) 170 (complete-transaction slot (list top-card) 8))) 171 ((and (not (empty-slot? 9)) 172 (= (get-suit (get-top-card 9)) 173 (get-suit (get-top-card slot))) 174 (= (+ 1 (get-value (get-top-card 9))) 175 (get-value (get-top-card slot)))) 176 (let ((top-card (get-top-card slot))) 177 (remove-card slot) 178 (complete-transaction slot (list top-card) 9))) 179 ((and (not (empty-slot? 10)) 180 (= (get-suit (get-top-card 10)) 181 (get-suit (get-top-card slot))) 182 (= (+ 1 (get-value (get-top-card 10))) 183 (get-value (get-top-card slot)))) 184 (let ((top-card (get-top-card slot))) 185 (remove-card slot) 186 (complete-transaction slot (list top-card) 10))) 187 (#t #f))) 188 189(define (game-over) 190 (and (not (game-won)) 191 (get-hint))) 192 193(define (game-won) 194 (if (and (= 13 (length (get-cards 0))) 195 (= 13 (length (get-cards 8))) 196 (= 13 (length (get-cards 9))) 197 (= 13 (length (get-cards 10)))) 198 #t 199 #f)) 200 201(define (here-kingy-kingy slot num-cards card-list) 202 (cond ((or (= (length card-list) 0) 203 (= (length card-list) 1) 204 (not (is-visible? (car card-list)))) 205 #f) 206 ((= (get-value (car card-list)) king) 207 (hint-move slot num-cards (find-empty-slot tableau))) 208 (#t (here-kingy-kingy slot (+ num-cards 1) (cdr card-list))))) 209 210(define (king-avail? slot-id) 211 (cond ((= slot-id 8) 212 #f) 213 ((and (not (empty-slot? slot-id)) 214 (here-kingy-kingy slot-id 1 (get-cards slot-id))) 215 (here-kingy-kingy slot-id 1 (get-cards slot-id))) 216 (#t (king-avail? (+ 1 slot-id))))) 217 218(define (check-for-empty) 219 (and (find-empty-slot tableau) 220 (king-avail? 1))) 221 222(define (check-a-foundation card slot-id) 223 (cond ((= slot-id 11) 224 #f) 225 ((= slot-id 1) 226 (check-a-foundation card 8)) 227 ((and (not (empty-slot? slot-id)) 228 (eq? (get-suit card) 229 (get-suit (get-top-card slot-id))) 230 (= (get-value card) 231 (+ 1 (get-value (get-top-card slot-id))))) 232 #t) 233 (#t (check-a-foundation card (+ 1 slot-id))))) 234 235(define (find-suit suit slots) 236 (if (and (not (empty-slot? (car slots))) 237 (= (get-suit (get-top-card (car slots))) suit)) 238 (car slots) 239 (find-suit suit (cdr slots)))) 240 241(define (check-to-foundations? slot-id) 242 (cond ((= slot-id 8) 243 #f) 244 ((empty-slot? slot-id) 245 (check-to-foundations? (+ 1 slot-id))) 246 ((= (get-value (get-top-card slot-id)) ace) 247 (hint-move slot-id 1 (find-empty-slot foundation))) 248 ((check-a-foundation (get-top-card slot-id) 0) 249 (hint-move slot-id 1 (find-suit (get-suit (get-top-card slot-id)) foundation))) 250 (#t (check-to-foundations? (+ 1 slot-id))))) 251 252(define (stripped card-list card) 253 (if (<= (length card-list) 1) 254 '() 255 (if (eq? card (car card-list)) 256 (cdr card-list) 257 (if (= (length card-list) 2) 258 '() 259 (stripped (cdr card-list) card))))) 260 261(define (check-a-tableau card slot1 card-list slot2 num-cards) 262 (cond ((or (= (length card-list) 0) 263 (not (is-visible? (car card-list)))) 264 #f) 265 ((and (not (eq? (is-red? (car card-list)) 266 (is-red? card))) 267 (= (+ 1 (get-value (car card-list))) 268 (get-value card))) 269 (if (or (= (length card-list) 1) 270 (not (is-visible? (cadr card-list))) 271 (eq? (is-red? (car card-list)) 272 (is-red? (cadr card-list))) 273 (not (= (+ 1 (get-value (car card-list))) 274 (get-value (cadr card-list)))) 275 (check-a-foundation (cadr card-list) 0) 276 (check-a-tableau (get-top-card slot2) 277 slot1 278 (cdr card-list) 279 slot2 280 1) 281 (check-a-tableau (cadr card-list) 282 slot2 283 (get-cards slot1) 284 slot1 285 1) 286 (check-a-tableau (cadr card-list) 287 slot2 288 (stripped (get-cards slot2) 289 (car card-list)) 290 slot2 291 1)) 292 (hint-move slot2 num-cards slot1) 293 (check-a-tableau card 294 slot1 295 (cdr card-list) 296 slot2 297 (+ num-cards 1)))) 298 (#t (check-a-tableau card slot1 (cdr card-list) slot2 (+ num-cards 1))))) 299 300(define (check-to-tableau? slot1 slot2) 301 (cond ((= slot1 8) 302 #f) 303 ((or (= slot2 8) 304 (empty-slot? slot1)) 305 (check-to-tableau? (+ 1 slot1) 1)) 306 ((and (not (= slot1 slot2)) 307 (check-a-tableau (get-top-card slot1) 308 slot1 309 (get-cards slot2) 310 slot2 311 1)) 312 (check-a-tableau (get-top-card slot1) 313 slot1 314 (get-cards slot2) 315 slot2 316 1)) 317 (#t (check-to-tableau? slot1 (+ 1 slot2))))) 318 319(define (get-hint) 320 (or (check-to-foundations? 1) 321 (check-to-tableau? 1 2) 322 (check-for-empty))) 323 324(define (get-options) #f) 325 326(define (apply-options options) #f) 327 328(define (timeout) #f) 329 330(set-features droppable-feature) 331 332(set-lambda new-game button-pressed button-released button-clicked button-double-clicked game-over game-won get-hint get-options apply-options timeout droppable?) 333