1; AisleRiot - pileon.scm 2; Copyright (C) 1998 Nick Lamb <njl195@zepler.org.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(use-modules (aisleriot interface) (aisleriot api)) 18 19(define (new-game) 20 (initialize-playing-area) 21 (set-ace-low) 22 (make-standard-deck) 23 (shuffle-deck) 24 25 (add-partially-extended-slot '() right 4) 26 (set! HORIZPOS (+ HORIZPOS 1)) 27 (add-partially-extended-slot '() right 4) 28 (set! HORIZPOS (+ HORIZPOS 1)) 29 (add-partially-extended-slot '() right 4) 30 (set! HORIZPOS (+ HORIZPOS 1)) 31 (add-partially-extended-slot '() right 4) 32 (add-carriage-return-slot) 33 34 (add-partially-extended-slot '() right 4) 35 (set! HORIZPOS (+ HORIZPOS 1)) 36 (add-partially-extended-slot '() right 4) 37 (set! HORIZPOS (+ HORIZPOS 1)) 38 (add-partially-extended-slot '() right 4) 39 (set! HORIZPOS (+ HORIZPOS 1)) 40 (add-partially-extended-slot '() right 4) 41 (add-carriage-return-slot) 42 43 (add-partially-extended-slot '() right 4) 44 (set! HORIZPOS (+ HORIZPOS 1)) 45 (add-partially-extended-slot '() right 4) 46 (set! HORIZPOS (+ HORIZPOS 1)) 47 (add-partially-extended-slot '() right 4) 48 (set! HORIZPOS (+ HORIZPOS 1)) 49 (add-partially-extended-slot '() right 4) 50 (add-carriage-return-slot) 51 52 (add-partially-extended-slot '() right 4) 53 (set! HORIZPOS (+ HORIZPOS 1)) 54 (add-partially-extended-slot '() right 4) 55 (set! HORIZPOS (+ HORIZPOS 1)) 56 (add-partially-extended-slot '() right 4) 57 (add-carriage-return-slot) 58 59 (deal-cards-face-up-from-deck DECK 60 '(0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 6 6 6 6 7 7 7 7 8 8 8 8 9 9 9 9 10 10 10 10 11 11 11 11 12 12 12 12)) 61 62 (freeze-slots-if-complete '(0 1 2 3 4 5 6 7 8 9 10 11 12)) 63 64 (list 8 4)) 65 66(define (check-same-value-list card-list) 67 (if (< (length card-list) 2) 68 #t 69 (if (= (get-value (car card-list)) (get-value (cadr card-list))) 70 (check-same-value-list (cdr card-list)) 71 #f))) 72 73(define (freeze-slot slot-id) 74 (flip-top-card slot-id) 75 (add-to-score! 4)) 76 77(define (button-pressed slot-id card-list) 78 (and (check-same-value-list card-list) 79 (is-visible? (car card-list)))) 80 81(define (freeze-if-complete slot-id) 82 (and (= (length (get-cards slot-id)) 4) 83 (check-same-value-list (get-cards slot-id)) 84 (freeze-slot slot-id)) 85 #t) 86 87(define (freeze-slots-if-complete slots) 88 (and (not (null? slots)) 89 (freeze-if-complete (car slots)) 90 (freeze-slots-if-complete (cdr slots)))) 91 92(define (complete-transaction start-slot card-list end-slot) 93 (move-n-cards! start-slot end-slot card-list) 94 (freeze-if-complete end-slot)) 95 96(define (droppable? start-slot card-list end-slot) 97 (and (not (= start-slot end-slot)) 98 (or (empty-slot? end-slot) 99 (eq? (get-value (car (get-cards end-slot))) 100 (get-value (car card-list)))) 101 (< (+ (length (get-cards end-slot)) (length card-list)) 5))) 102 103(define (button-released start-slot card-list end-slot) 104 (and (droppable? start-slot card-list end-slot) 105 (complete-transaction start-slot card-list end-slot))) 106 107(define (button-clicked slot-id) #f) 108 109(define (button-double-clicked slot) #f) 110 111(define (game-over) 112 (and (not (game-won)) 113 (get-hint))) 114 115(define (done-or-empty slot-id) 116 (or (empty-slot? slot-id) 117 (not (is-visible? (car (get-cards slot-id)))))) 118 119(define (game-won) 120 (and (done-or-empty 0) 121 (done-or-empty 1) 122 (done-or-empty 2) 123 (done-or-empty 3) 124 (done-or-empty 4) 125 (done-or-empty 5) 126 (done-or-empty 6) 127 (done-or-empty 7) 128 (done-or-empty 8) 129 (done-or-empty 9) 130 (done-or-empty 10) 131 (done-or-empty 11) 132 (done-or-empty 12) 133 (done-or-empty 13) 134 (done-or-empty 14)) 135) 136 137(define (check-number slot-id) 138 (cond ((and (> (length (get-cards slot-id)) 1) 139 (not (= (get-value (get-top-card slot-id)) 140 (get-value (cadr (get-cards slot-id)))))) 141 1) 142 ((and (> (length (get-cards slot-id)) 2) 143 (not (= (get-value (get-top-card slot-id)) 144 (get-value (caddr (get-cards slot-id)))))) 145 2) 146 ((and (> (length (get-cards slot-id)) 3) 147 (not (= (get-value (get-top-card slot-id)) 148 (get-value (cadddr (get-cards slot-id)))))) 149 3) 150 (#t 1))) 151 152(define (check-a-slot slot-id number-to-move to-slot) 153 (if (> to-slot 14) 154 #f 155 (if (= slot-id to-slot) 156 (check-a-slot slot-id number-to-move (+ 1 to-slot)) 157 (cond ((empty-slot? slot-id) 158 (list 2 (_"something") (_"an empty slot"))) 159 ((empty-slot? to-slot) 160 (list 2 (_"something") (_"an empty slot"))) 161 ((= 4 (length (get-cards to-slot))) 162 (check-a-slot slot-id number-to-move (+ 1 to-slot))) 163 ((= (get-value (get-top-card to-slot)) 164 (get-value (get-top-card slot-id))) 165 (if (> number-to-move (- 4 (length (get-cards to-slot)))) 166 (check-a-slot slot-id 167 (- number-to-move 168 (- 4 (length (get-cards to-slot)))) 169 (+ 1 to-slot)) 170 (hint-move slot-id 1 to-slot))) 171 (#t (check-a-slot slot-id number-to-move (+ 1 to-slot))))))) 172 173(define (check-slots slot-id to-slot) 174 (if (> slot-id 14) 175 #f 176 (or (check-a-slot slot-id (check-number slot-id) to-slot) 177 (check-slots (+ 1 slot-id) 0)))) 178 179(define (get-hint) 180 (check-slots 0 1)) 181 182(define (get-options) #f) 183 184(define (apply-options options) #f) 185 186(define (timeout) #f) 187 188(set-features droppable-feature) 189 190(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?) 191