auld-lang-syne.scm 3.7 KB
Newer Older
1
; AisleRiot - auld_lang_syne.scm
2
; Copyright (C) 1999, 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 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 18
(use-modules (aisleriot interface) (aisleriot api))

19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43
(define (new-game)
  (initialize-playing-area)
  (set-ace-low)
  (set! DECK (make-deck-list-ace-low 2 2 club))
  (shuffle-deck)

  (add-normal-slot DECK)
  (add-blank-slot)
  (add-normal-slot '())
  (add-normal-slot '())
  (add-normal-slot '())
  (add-normal-slot '())
  (add-carriage-return-slot)
  (add-blank-slot)
  (add-blank-slot)
  (add-normal-slot '())
  (add-normal-slot '())
  (add-normal-slot '())
  (add-normal-slot '())
  
  (add-card! 1 (make-visible (make-card ace club)))
  (add-card! 2 (make-visible (make-card ace diamond)))
  (add-card! 3 (make-visible (make-card ace heart)))
  (add-card! 4 (make-visible (make-card ace spade)))

44
  (give-status-message)
45

46 47 48
  (list 6 2)
)

49 50 51
(define (give-status-message)
  (set-statusbar-message (get-stock-no-string)))

52
(define (get-stock-no-string)
53
  (string-append (_"Stock left:") " "
54 55
		 (number->string (length (get-cards 0)))))

56 57 58 59
(define (button-pressed slot-id card-list)
  (and (not (empty-slot? slot-id))
       (> slot-id 4)))

60
(define (droppable? start-slot card-list end-slot)
61 62 63
  (and (< end-slot 5)
       (> end-slot 0)
       (= (get-value (car card-list))
64 65 66 67
          (+ 1 (get-value (get-top-card end-slot))))))

(define (button-released start-slot card-list end-slot)
  (and (droppable? start-slot card-list end-slot)
68 69 70
       (move-n-cards! start-slot end-slot card-list)
       (add-to-score! 1)))

71 72 73 74 75 76
(define (dealable?)
  (not (empty-slot? 0)))

(define (do-deal-next-cards)
  (deal-cards-face-up 0 '(5 6 7 8)))

77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101
(define (button-clicked slot-id)
  (and (= slot-id 0)
       (not (empty-slot? 0))
       (deal-cards-face-up 0 '(5 6 7 8))))

(define (check-end-slot? slot1 slot2)
  (if (and (not (empty-slot? slot1))
	   (= (get-value (get-top-card slot1))
	      (+ 1 (get-value (get-top-card slot2)))))
      (begin
	(deal-cards slot1 (list slot2))
	(add-to-score! 1))
      (if (< slot2 4)
	  (check-end-slot? slot1 (+ 1 slot2))
	  #f)))

(define (button-double-clicked slot-id)
  (and (> slot-id 4)
       (check-end-slot? slot-id 1)))

(define (game-continuable)
  (and (not (game-won))
       (get-hint)))

(define (game-won)
102
  (give-status-message)
103 104 105 106 107 108 109 110 111 112 113 114 115 116
  (and (empty-slot? 0)
       (empty-slot? 5)
       (empty-slot? 6)
       (empty-slot? 7)
       (empty-slot? 8)))

(define (movable? slot1 slot2)
  (if (= slot1 9)
      #f
      (if (or (= slot2 5)
	      (empty-slot? slot1))
	  (movable? (+ 1 slot1) 1)
	  (if (= (get-value (get-top-card slot1))
		 (+ 1 (get-value (get-top-card slot2))))
117
	      (hint-move slot1 1 slot2)
118 119 120 121
	      (movable? slot1 (+ 1 slot2))))))

(define (dealable?)
  (and (not (empty-slot? 0))
122
       (list 0 (_"Deal another round"))))
123 124 125 126 127 128 129 130 131 132 133 134 135 136

(define (get-hint)
  (or (movable? 5 1)
      (dealable?)))

(define (get-options) 
  #f)

(define (apply-options options) 
  #f)

(define (timeout) 
  #f)

137
(set-features droppable-feature dealable-feature)
138

139 140
(set-lambda new-game button-pressed button-released button-clicked
button-double-clicked game-continuable game-won get-hint get-options
141
apply-options timeout droppable? dealable?)