1; AisleRiot - osmosis.scm 2; Copyright (C) 1998, 2003 Rosanna Yuen <rwsy@mit.edu> 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) (ice-9 format)) 18 19(define deal-three #f) 20 21(define (new-game) 22 (initialize-playing-area) 23 (set-ace-low) 24 (make-standard-deck) 25 (shuffle-deck) 26 27 (add-extended-slot '() right 'reserve) ;Slot 0 28 (add-blank-slot) 29 (add-extended-slot '() right 'foundation) ;Slot 1 30 (add-carriage-return-slot) 31 (add-extended-slot '() right 'reserve) ;Slot 2 32 (add-blank-slot) 33 (add-extended-slot '() right 'foundation) ;Slot 3 34 (add-carriage-return-slot) 35 (add-extended-slot '() right 'reserve) ;Slot 4 36 (add-blank-slot) 37 (add-extended-slot '() right 'foundation) ;Slot 5 38 (add-carriage-return-slot) 39 (add-extended-slot '() right 'reserve) ;Slot 6 40 (add-blank-slot) 41 (add-extended-slot '() right 'foundation) ;Slot 7 42 (add-carriage-return-slot) 43 (add-normal-slot DECK 'stock) ;Slot 8 44 45 (if deal-three 46 (add-partially-extended-slot '() right 3 'waste) 47 (add-normal-slot '() 'waste) 48 ) ;Slot 9 49 50 (initial-deal) 51 52 (give-status-message) 53 54 (add-to-score! 1) 55 (list 6 5)) 56 57(define (initial-deal) 58 (deal-cards 8 '(0 2 4 6 0 2 4 6 0 2 4 6)) 59 (deal-cards-face-up 8 '(0 2 4 6 1)) 60) 61 62(define (give-status-message) 63 (set-statusbar-message (string-append (get-stock-no-string) 64 " " 65 (get-redeals-string)))) 66 67(define (get-stock-no-string) 68 (format #f (_"Stock left: ~a") (number->string (length (get-cards 8)))) 69) 70 71(define (get-redeals-string) 72 (if deal-three 73 "" 74 (format #f (_"Redeals left: ~a") (number->string (- 2 FLIP-COUNTER))) 75 ) 76) 77 78(define (button-pressed slot-id card-list) 79 (and (not (empty-slot? slot-id)) 80 (= (length card-list) 1) 81 (or (= slot-id 0) 82 (= slot-id 2) 83 (= slot-id 4) 84 (= slot-id 6) 85 (= slot-id 9)))) 86 87(define (complete-transaction start-slot card-list end-slot) 88 (move-n-cards! start-slot end-slot card-list) 89 (add-to-score! 1) 90 (if (not (empty-slot? start-slot)) 91 (make-visible-top-card start-slot)) 92 #t) 93 94(define (find-card-val-in-list? cards value) 95 (and (not (null? cards)) 96 (or (= value (get-value (car cards))) 97 (find-card-val-in-list? (cdr cards) value)))) 98 99(define (droppable? start-slot card-list end-slot) 100 (and (not (= start-slot end-slot)) 101 (or (= end-slot 1) 102 (= end-slot 3) 103 (= end-slot 5) 104 (= end-slot 7)) 105 (if (empty-slot? end-slot) 106 (and (= (get-value (car (reverse (get-cards 1)))) 107 (get-value (car card-list))) 108 (while (empty-slot? (- end-slot 2)) 109 (set! end-slot (- end-slot 2)))) 110 (and (= (get-suit (get-top-card end-slot)) 111 (get-suit (car card-list))) 112 (or (= end-slot 1) 113 (find-card-val-in-list? (get-cards (- end-slot 2)) 114 (get-value (car card-list))) ))))) 115 116(define (button-released start-slot card-list end-slot) 117 (and (droppable? start-slot card-list end-slot) 118 (complete-transaction start-slot card-list end-slot))) 119 120(define (button-clicked slot-id) 121 (and (= slot-id 8) 122 (flip-stock 8 9 (if deal-three -1 2) (if deal-three 3 1)))) 123 124(define (check-to-move orig-slot end-slot above-list top-card) 125 (if (not (null? above-list)) 126 (if (eq? (get-value top-card) 127 (get-value (car above-list))) 128 (begin 129 (remove-card orig-slot) 130 (complete-transaction orig-slot (list top-card) end-slot)) 131 (check-to-move orig-slot end-slot (cdr above-list) top-card)) 132 #f)) 133 134 135(define (button-double-clicked slot) 136 (if (and (or (= slot 0) 137 (= slot 2) 138 (= slot 4) 139 (= slot 6) 140 (= slot 9)) 141 (not (empty-slot? slot))) 142 (begin 143 (let ((top-card (get-top-card slot))) 144 (if (eq? (get-suit top-card) 145 (get-suit (car (get-cards 1)))) 146 (begin 147 (remove-card slot) 148 (complete-transaction slot (list top-card) 1)) 149 (if (eq? (get-value top-card) 150 (get-value (car (reverse (get-cards 1))))) 151 (cond ((empty-slot? 3) 152 (begin 153 (remove-card slot) 154 (complete-transaction slot (list top-card) 3))) 155 ((empty-slot? 5) 156 (begin 157 (remove-card slot) 158 (complete-transaction slot (list top-card) 5))) 159 (#t 160 (begin 161 (remove-card slot) 162 (complete-transaction slot (list top-card) 7)))) 163 (cond ((and (not (empty-slot? 3)) 164 (eq? (get-suit top-card) 165 (get-suit (car (get-cards 3))))) 166 (check-to-move slot 3 (get-cards 1) top-card)) 167 ((and (not (empty-slot? 5)) 168 (eq? (get-suit top-card) 169 (get-suit (car (get-cards 5))))) 170 (check-to-move slot 5 (get-cards 3) top-card)) 171 ((and (not (empty-slot? 7)) 172 (eq? (get-suit top-card) 173 (get-suit (car (get-cards 7))))) 174 (check-to-move slot 7 (get-cards 5) top-card)) 175 (#t #f)))))) 176 #f)) 177 178(define (placeable? from-slot card slot-id) 179 (and (< slot-id 9) 180 (or (if (empty-slot? slot-id) 181 (and (= (get-value card) 182 (get-value (car (reverse (get-cards 1))))) 183 (hint-move from-slot 1 slot-id)) 184 (and (= (get-suit card) (get-suit (get-top-card slot-id))) 185 (or (= slot-id 1) 186 (find-card-val-in-list? (get-cards (- slot-id 2)) 187 (get-value card))) 188 (hint-move from-slot 1 slot-id))) 189 (placeable? from-slot card (+ slot-id 2))))) 190 191(define (get-valid-move id-list) 192 (and (not (null? id-list)) 193 (or (and (not (empty-slot? (car id-list))) 194 (placeable? (car id-list) (get-top-card (car id-list)) 1)) 195 (get-valid-move (cdr id-list))))) 196 197(define (game-continuable) 198 (give-status-message) 199 (or (and (or deal-three 200 (< FLIP-COUNTER 2)) 201 (not (empty-slot? 9))) 202 (not (empty-slot? 8)) 203 (get-valid-move '(0 2 4 6 9)))) 204 205(define (game-won) 206 (and (= 13 (length (get-cards 1))) 207 (= 13 (length (get-cards 3))) 208 (= 13 (length (get-cards 5))) 209 (= 13 (length (get-cards 7))))) 210 211(define (get-hint) 212 (or (get-valid-move '(0 2 4 6 9)) 213 (if deal-three 214 (list 0 (_"Deal new cards from the deck")) 215 (list 0 (_"Deal a new card from the deck")) 216 ) 217 ) 218) 219 220(define (get-options) 221 (list (list (_"Three card deals") deal-three))) 222 223(define (apply-options options) 224 (set! deal-three (cadar options)) 225) 226 227(define (timeout) #f) 228 229(set-features droppable-feature) 230 231(set-lambda new-game button-pressed button-released button-clicked button-double-clicked game-continuable game-won get-hint get-options apply-options timeout droppable?) 232