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