1; AisleRiot - labyrinth.scm 2; Copyright (C) 2001 Rosanna Yuen <zana@webwynk.net> 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(def-save-var first-row #f) 20 21(define (new-game) 22 (initialize-playing-area) 23 (set-ace-low) 24 (set! DECK (make-deck-list-ace-low 2 2 club)) 25 (shuffle-deck) 26 27 (add-normal-slot DECK 'stock) 28 (add-blank-slot) 29 (add-normal-slot '() 'foundation) 30 (add-normal-slot '() 'foundation) 31 (add-normal-slot '() 'foundation) 32 (add-normal-slot '() 'foundation) 33 (add-carriage-return-slot) 34 35 (add-normal-slot '() 'tableau) 36 (add-normal-slot '() 'tableau) 37 (add-normal-slot '() 'tableau) 38 (add-normal-slot '() 'tableau) 39 (add-normal-slot '() 'tableau) 40 (add-normal-slot '() 'tableau) 41 (add-normal-slot '() 'tableau) 42 (add-normal-slot '() 'tableau) 43 44 (add-carriage-return-slot) 45 46 (set! VERTPOS (- VERTPOS (/ 2 3))) 47 48 (add-extended-slot '() down 'tableau) 49 (add-extended-slot '() down 'tableau) 50 (add-extended-slot '() down 'tableau) 51 (add-extended-slot '() down 'tableau) 52 (add-extended-slot '() down 'tableau) 53 (add-extended-slot '() down 'tableau) 54 (add-extended-slot '() down 'tableau) 55 (add-extended-slot '() down 'tableau) 56 57 58 (add-card! 1 (make-visible (make-card ace club))) 59 (add-card! 2 (make-visible (make-card ace diamond))) 60 (add-card! 3 (make-visible (make-card ace heart))) 61 (add-card! 4 (make-visible (make-card ace spade))) 62 63 (deal-cards-face-up 0 '(5 6 7 8 9 10 11 12)) 64 (set! first-row #t) 65 66 (give-status-message) 67 68 (list 8 4)) 69 70(define (give-status-message) 71 (set-statusbar-message (get-stock-no-string))) 72 73(define (get-stock-no-string) 74 (string-append (_"Stock left:") " " 75 (number->string (length (get-cards 0))))) 76 77(define (button-pressed slot-id card-list) 78 (and (not (empty-slot? slot-id)) 79 (> slot-id 4) 80 (= (length card-list) 1))) 81 82(define (droppable? start-slot card-list end-slot) 83 (and (< end-slot 5) 84 (> end-slot 0) 85 (= (get-suit (get-top-card end-slot)) 86 (get-suit (car card-list))) 87 (= (+ 1 (get-value (get-top-card end-slot))) 88 (get-value (car card-list))))) 89 90(define (button-released start-slot card-list end-slot) 91 (and (droppable? start-slot card-list end-slot) 92 (move-n-cards! start-slot end-slot card-list) 93 (or (and (not first-row) 94 (or (> start-slot 12) 95 (empty-slot? (+ start-slot 8)) 96 (and (set-cards! start-slot 97 (list (car (reverse (get-cards (+ start-slot 8)))))) 98 (set-cards! (+ start-slot 8) 99 (reverse (cdr (reverse (get-cards (+ start-slot 8))))))))) 100 (empty-slot? 0) 101 (deal-cards-face-up 0 (list start-slot))) 102 (add-to-score! 1))) 103 104(define (check-slot-and-deal slot) 105 (cond ((or (empty-slot? 0) 106 (= slot 21)) 107 #t) 108 ((empty-slot? (- slot 8)) 109 (and (deal-cards-face-up 0 (list (- slot 8))) 110 (check-slot-and-deal (+ 1 slot)))) 111 (#t (and (deal-cards-face-up 0 (list slot)) 112 (check-slot-and-deal (+ 1 slot)))))) 113 114(define (button-clicked slot-id) 115 (and (= slot-id 0) 116 (not (empty-slot? 0)) 117 (set! first-row #f) 118 (check-slot-and-deal 13))) 119 120(define (button-double-clicked slot-id) 121 (and (> slot-id 4) 122 (not (empty-slot? slot-id)) 123 (or (and (= (get-suit (get-top-card slot-id)) club) 124 (= (get-value (get-top-card slot-id)) 125 (+ 1 (get-value (get-top-card 1)))) 126 (deal-cards slot-id '(1)) 127 (add-to-score! 1)) 128 (and (= (get-suit (get-top-card slot-id)) diamond) 129 (= (get-value (get-top-card slot-id)) 130 (+ 1 (get-value (get-top-card 2)))) 131 (deal-cards slot-id '(2)) 132 (add-to-score! 1)) 133 (and (= (get-suit (get-top-card slot-id)) heart) 134 (= (get-value (get-top-card slot-id)) 135 (+ 1 (get-value (get-top-card 3)))) 136 (deal-cards slot-id '(3)) 137 (add-to-score! 1)) 138 (and (= (get-suit (get-top-card slot-id)) spade) 139 (= (get-value (get-top-card slot-id)) 140 (+ 1 (get-value (get-top-card 4)))) 141 (deal-cards slot-id '(4)) 142 (add-to-score! 1))) 143 (or (and first-row 144 (not (empty-slot? 0)) 145 (deal-cards-face-up 0 (list slot-id))) 146 (> slot-id 12) 147 (empty-slot? (+ 8 slot-id)) 148 (and (set-cards! slot-id 149 (list (car (reverse (get-cards (+ slot-id 8)))))) 150 (set-cards! (+ slot-id 8) 151 (reverse (cdr (reverse (get-cards (+ slot-id 8)))))))))) 152 153(define (game-continuable) 154 (give-status-message) 155 (and (not (game-won)) 156 (get-hint))) 157 158(define (game-won) 159 (and (= (length (get-cards 1)) 13) 160 (= (length (get-cards 2)) 13) 161 (= (length (get-cards 3)) 13) 162 (= (length (get-cards 4)) 13))) 163 164(define (check-slot slot) 165 (cond ((= slot 21) 166 #f) 167 ((empty-slot? slot) 168 (check-slot (+ 1 slot))) 169 ((and (= (get-suit (get-top-card slot)) club) 170 (= (get-value (get-top-card slot)) 171 (+ 1 (get-value (get-top-card 1))))) 172 (hint-move slot 1 1)) 173 ((and (= (get-suit (get-top-card slot)) diamond) 174 (= (get-value (get-top-card slot)) 175 (+ 1 (get-value (get-top-card 2))))) 176 (hint-move slot 1 2)) 177 ((and (= (get-suit (get-top-card slot)) heart) 178 (= (get-value (get-top-card slot)) 179 (+ 1 (get-value (get-top-card 3))))) 180 (hint-move slot 1 3)) 181 ((and (= (get-suit (get-top-card slot)) spade) 182 (= (get-value (get-top-card slot)) 183 (+ 1 (get-value (get-top-card 4))))) 184 (hint-move slot 1 4)) 185 (#t (check-slot (+ 1 slot))))) 186 187(define (dealable?) 188 (and (not (empty-slot? 0)) 189 (list 0 (_"Deal more cards")))) 190 191(define (get-hint) 192 (or (check-slot 5) 193 (dealable?))) 194 195(define (get-options) 196 #f) 197 198(define (apply-options options) 199 #f) 200 201(define (timeout) 202 #f) 203 204(set-features droppable-feature) 205 206(set-lambda new-game button-pressed button-released button-clicked 207button-double-clicked game-continuable game-won get-hint get-options 208apply-options timeout droppable?) 209 210