scorpion.scm 6.21 KB
Newer Older
1 2 3
; AisleRiot - scorpion.scm
; Copyright (C) 1999 Rosanna Yuen <rwsy@mit.edu>
;
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 7
; the Free Software Foundation, either version 3 of the License, or
; (at your option) any later version.
8 9 10 11 12 13 14
;
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU General Public License for more details.
;
; 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
; winning game seed: 2036201447
19

20 21
(define tableau '(1 2 3 4 5 6 7))

22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50
(define (new-game)
  (initialize-playing-area)
  (set-ace-low)
  (make-standard-deck)
  (shuffle-deck)

  (add-normal-slot DECK)

  (add-blank-slot)

  (add-extended-slot '() down)
  (add-extended-slot '() down)
  (add-extended-slot '() down)
  (add-extended-slot '() down)
  (add-extended-slot '() down)
  (add-extended-slot '() down)
  (add-extended-slot '() down)

  (deal-cards 0 '(1 2 3 4))
  (deal-cards-face-up 0 '(5 6 7))
  (deal-cards 0 '(1 2 3 4))
  (deal-cards-face-up 0 '(5 6 7))
  (deal-cards 0 '(1 2 3 4))
  (deal-cards-face-up 0 '(5 6 7))
  (deal-cards-face-up 0 '(1 2 3 4 5 6 7))
  (deal-cards-face-up 0 '(1 2 3 4 5 6 7))
  (deal-cards-face-up 0 '(1 2 3 4 5 6 7))
  (deal-cards-face-up 0 '(1 2 3 4 5 6 7))

51
  (check-score)
52

53 54
  (list 9 4))

55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80
(define (check-score-cards acc cards unbroken count)
  (cond
      ((null? cards)
       (if (and unbroken (= count 13))
           (+ acc 4)
           acc))
      ((not (is-visible? (car cards)))
       (check-score-cards (- acc 3) (cdr cards) #f (+ count 1)))
      ((or (null? (cdr cards))
           (not (is-visible? (cadr cards))))
       (check-score-cards acc (cdr cards) unbroken (+ count 1)))
      ((and (= (get-suit (car cards))
               (get-suit (cadr cards)))
            (= (+ 1 (get-value (car cards)))
               (get-value (cadr cards))))
       (check-score-cards (+ acc 1) (cdr cards) unbroken (+ count 1)))
      (#t
       (check-score-cards acc (cdr cards) #f (+ count 1)))))

(define (check-score-slot acc slots)
  (if (null? slots)
      acc
      (check-score-slot (check-score-cards acc (get-cards (car slots)) #t 0) (cdr slots))))

(define (check-score)
  (set-score! (check-score-slot 36 tableau)))
81

82 83 84 85
(define (button-pressed slot-id card-list)
  (and (not (empty-slot? slot-id))
       (is-visible? (car (reverse card-list)))))

86 87
(define (correct-sequence card-list)
  (or (= (length card-list) 1)
88 89
      (and (is-visible? (cadr card-list))
	   (eq? (get-suit (car card-list))
90 91 92 93 94
		(get-suit (cadr card-list)))
	   (= (+ 1 (get-value (car card-list)))
	      (get-value (cadr card-list)))
	   (correct-sequence (cdr card-list)))))

95
(define (droppable? start-slot card-list end-slot)
96
  (and (not (= start-slot end-slot))
97
       (not (= end-slot 0))
98
       (or (and (empty-slot? end-slot)
99 100 101 102 103
		(= (get-value (car (reverse card-list))) king))
	   (and (not (empty-slot? end-slot))
		(eq? (get-suit (get-top-card end-slot))
		     (get-suit (car (reverse card-list))))
		(= (get-value (get-top-card end-slot))
104 105 106 107
		   (+ 1 (get-value (car (reverse card-list)))))))))

(define (button-released start-slot card-list end-slot)
  (and (droppable? start-slot card-list end-slot)
108 109
       (move-n-cards! start-slot end-slot card-list)
       (or (empty-slot? start-slot)
110 111
	   (make-visible-top-card start-slot))
       (check-score)))
112

113 114 115
(define (button-clicked slot-id)
  (and (= slot-id 0)
       (not (empty-slot? 0))
116
       (deal-cards-face-up 0 '(1 2 3))
117
       (check-score)))
118 119 120 121 122

(define (button-double-clicked slot-id)
  #f)

(define (game-continuable)
123
  (get-hint))
124

125 126 127 128 129 130 131 132 133 134 135 136
(define (slots-filled? slots)
  (cond
      ((null? slots)
       #t)
      ((empty-slot? (car slots))
       (slots-filled? (cdr slots)))
      ((and (= 13 (length (get-cards (car slots))))
            (correct-sequence (get-cards (car slots))))
       (slots-filled? (cdr slots)))
      (#t
       #f)))

137
(define (game-won)
138
  (slots-filled? tableau))
139 140 141

(define (dealable?)
  (and (not (empty-slot? 0))
142
       (list 0 (_"Deal the cards"))))
143

144
(define (check-slot-cards slot1 slot2 count card card-list)
145 146 147 148 149 150 151
  (cond ((or (= (length card-list) 0)
	     (not (is-visible? (car card-list))))
	 #f)
	((and (eq? (get-suit card)
		   (get-suit (car card-list)))
	      (= (get-value card)
		 (+ 1 (get-value (car card-list)))))
152 153
	 (hint-move slot2 count slot1))
	(#t (check-slot-cards slot1 slot2 (+ count 1) card (cdr card-list)))))
154 155 156 157 158 159

(define (check-a-slot slot1 slot2)
  (cond ((= slot2 8)
	 #f)
	((and (not (= slot1 slot2))
	      (not (empty-slot? slot2))
160 161
	      (check-slot-cards slot1 slot2 1 (get-top-card slot1) (get-cards slot2)))
	 (check-slot-cards slot1 slot2 1 (get-top-card slot1) (get-cards slot2)))
162 163 164 165 166 167 168
	(#t (check-a-slot slot1 (+ 1 slot2)))))

(define (check-slot slot-id)
  (cond ((= slot-id 8)
	 #f)
	((and (not (empty-slot? slot-id))
	      (check-a-slot slot-id 1))
169
	 (check-a-slot slot-id 1))
170 171
	(#t (check-slot (+ 1 slot-id)))))

172
(define (here-kingy-kingy slot-id count card-list)
173 174 175 176 177
  (cond ((or (= (length card-list) 0)
	     (= (length card-list) 1)
	     (not (is-visible? (car card-list))))
	 #f)
	((= (get-value (car card-list)) king)
178 179
	 (hint-move slot-id count (find-empty-slot tableau)))
	(#t (here-kingy-kingy slot-id (+ count 1) (cdr card-list)))))
180 181 182 183 184

(define (king-avail? slot-id)
  (cond ((= slot-id 8)
	 #f)
	((and (not (empty-slot? slot-id))
185 186
	      (here-kingy-kingy slot-id 1 (get-cards slot-id)))
	 (here-kingy-kingy slot-id 1 (get-cards slot-id)))
187 188 189 190 191 192 193 194 195 196 197
	(#t (king-avail? (+ 1 slot-id)))))

(define (check-for-empty)
  (and (or (empty-slot? 1)
	   (empty-slot? 2)
	   (empty-slot? 3)
	   (empty-slot? 4)
	   (empty-slot? 5)
	   (empty-slot? 6)
	   (empty-slot? 7))
       (king-avail? 1)))
198 199

(define (get-hint)
200 201 202
  (or (check-slot 1)
      (check-for-empty)
      (dealable?)))
203 204 205 206 207 208 209 210 211 212

(define (get-options) 
  #f)

(define (apply-options options) 
  #f)

(define (timeout) 
  #f)

213 214
(set-features droppable-feature)

215 216
(set-lambda new-game button-pressed button-released button-clicked
button-double-clicked game-continuable game-won get-hint get-options
217
apply-options timeout droppable?)