A new patience game for Aisleriot: «Forty Thieves»
Submitted by Ed Sirett
Assigned to gno..@..e.bugs
Link to original bug (#519900)
Description
The scheme and xml files are for a two pack patience game called Forty Thieves. This game is a good balance between luck and skill.
I can't see how (even if it's possible) to attach files so this is the code.
forty_thieves.scm
; AisleRiot - forty_thieves.scm ; Copyright (C) 2008 Ed Sirett ed@makewrite.demon.co.uk ; ; This game is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 2, or (at your option) ; any later version. ; ; 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 ; along with this program; if not, write to the Free Software ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ; USA
(define (new-game) (initialize-playing-area) (set-ace-low) (make-standard-double-deck) (shuffle-deck)
(add-normal-slot DECK)
(add-blank-slot)
(add-normal-slot '()) (add-normal-slot '()) (add-normal-slot '()) (add-normal-slot '()) (add-normal-slot '()) (add-normal-slot '()) (add-normal-slot '()) (add-normal-slot '())
(add-carriage-return-slot) (add-extended-slot '() right) (add-carriage-return-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) (add-extended-slot '() down) (add-extended-slot '() down) (add-extended-slot '() down)
(deal-cards-face-up 0 '(10 11 12 13 14 15 16 17 18 19)) (deal-cards-face-up 0 '(10 11 12 13 14 15 16 17 18 19)) (deal-cards-face-up 0 '(10 11 12 13 14 15 16 17 18 19)) (deal-cards-face-up 0 '(10 11 12 13 14 15 16 17 18 19))
(give-status-message)
(list 10 5))
(define (give-status-message) (set-statusbar-message (get-stock-no-string)))
(define (get-stock-no-string) (string-append (_"Stock left:") " " (number->string (length (get-cards 0)))))
(define (button-pressed slot-id card-list) (and (not (empty-slot? slot-id)) (> slot-id 0) (not (eq? '() card-list)) (is-visible? (car (reverse card-list))) (< (length card-list) 3) ( or (= (length card-list) 1) ( and (= (get-suit (car card-list)) (get-suit (car (reverse card-list))) ) ( = (+ 1 (get-value (car card-list))) (get-value (car (reverse card-list))))
)
)
) )
(define (check-visibility slot) (or (empty-slot? slot) (is-visible? (get-top-card slot)) (make-visible-top-card slot)))
(define (foundation-score slot-id prev-total) (define (current-total) (+ prev-total (* (length (get-cards slot-id)) 5) (if (= (length (get-cards slot-id)) 13) 60 0))) (if (= slot-id 8) (current-total) (foundation-score (+ slot-id 1) (current-total))))
(define (recalculate-score) (set-score! (foundation-score 1 0)))
(define (space-score slot-id prev) (define (curtot previous) (+ previous (if (empty-slot? slot-id) 1 0))) (if (= slot-id 19) (curtot prev) (space-score (+ slot-id 1) (curtot prev))) )
(define (tableau-spaces start-slot) (space-score start-slot 0))
(define (tableau-space) (cond ((or (empty-slot? 10) (empty-slot? 11) (empty-slot? 12) (empty-slot? 13) (empty-slot? 14) (empty-slot? 15) (empty-slot? 16) (empty-slot? 17) (empty-slot? 18) (empty-slot? 19)) #t) (#t #f) ) )
(define (droppable? start-slot card-list end-slot)
(cond ((= end-slot start-slot)
#f)
((and (> start-slot 0) (< start-slot 9))
#f)
((and (> end-slot 0)
(< end-slot 9))
(if (= (length card-list) 1)
(cond ((empty-slot? end-slot)
(= (get-value (car card-list)) ace))
(#t
(and (= (get-suit (get-top-card end-slot))
(get-suit (car card-list))
)
(= (get-value (car card-list))
(+ 1 (get-value (get-top-card end-slot)))
)
)
)
)
)
)
((and (> end-slot 9)
(empty-slot? end-slot)
( or (= (length card-list) 1)
(and (= (length card-list) 2)
(or ( and ( > (tableau-spaces 10) 1) (not (empty-slot? start-slot)))
( > (tableau-spaces 10) 2)
)
)
)
)
#t)
((and (> end-slot 9)
(= (length card-list) 1)
(= (get-suit (get-top-card end-slot))
(get-suit (car card-list)))
(= (get-value (get-top-card end-slot))
(+ 1 (get-value (car card-list))))
)
#t)
((and (> end-slot 9)
(= (length card-list) 2)
(not (empty-slot? end-slot))
(= (get-suit (get-top-card end-slot))
(get-suit (car (reverse card-list))))
(= (get-value (get-top-card end-slot))
(+ 1 (get-value (car (reverse card-list)))))
(or ( and (tableau-space) (not (empty-slot? start-slot)))
( > (tableau-spaces 10) 1)
)
)
#t )
(#t #f)
) )
(define (button-released start-slot card-list end-slot) (and (droppable? start-slot card-list end-slot) (move-n-cards! start-slot end-slot card-list) (recalculate-score) (check-visibility start-slot)))
(define (button-clicked slot-id) (and (= slot-id 0) (not (empty-slot? slot-id)) (deal-cards-face-up 0 '(9)) (recalculate-score)))
(define (find-empty-foundation a-slot f-slot) (cond ((> f-slot 8) #f) ((empty-slot? f-slot) (deal-cards a-slot (list f-slot))) (#t (find-empty-foundation a-slot (+ 1 f-slot)))))
(define (find-foundation a-slot f-slot) (cond ((> f-slot 8) #f) ((and (not (empty-slot? f-slot)) (= (get-suit (get-top-card a-slot)) (get-suit (get-top-card f-slot))) (= (get-value (get-top-card a-slot)) (+ 1 (get-value (get-top-card f-slot))))) (deal-cards a-slot (list f-slot))) (#t (find-foundation a-slot (+ 1 f-slot)))))
(define (check-from-tableau slot-id) (cond ((= slot-id 20) #f) ((empty-slot? slot-id) (check-from-tableau (+ 1 slot-id))) ((= (get-value (get-top-card slot-id)) ace) (find-empty-foundation slot-id 1) ) ( (find-foundation slot-id 1) #t ) ( #t (check-from-tableau (+ 1 slot-id)) ) ) )
(define (autoplay-foundations) (if (check-from-tableau 9) (autoplay-foundations) (recalculate-score)) )
(define (button-double-clicked slot-id) (cond ((and (> slot-id 0) (< slot-id 9)) (autoplay-foundations)) ((> slot-id 8) (and (not (empty-slot? slot-id)) (or (and (= (get-value (get-top-card slot-id)) ace) (find-empty-foundation slot-id 1) (check-visibility slot-id) (recalculate-score)) (and (find-foundation slot-id 1) (check-visibility slot-id) (recalculate-score)) (and (check-to-tableau? slot-id 10) (recalculate-score)) ) ) ) (else #f) ) )
(define (check-to-tableau? from-slot slot-id)
(cond ( (= slot-id 20)
#f)
( (empty-slot? from-slot)
#f)
( (= from-slot slot-id)
(check-to-tableau? from-slot (+ slot-id 1) )
)
( (and (not (empty-slot? slot-id))
(= (get-suit (get-top-card slot-id)) (get-suit(get-top-card from-slot)) )
(= (- (get-value (get-top-card slot-id)) 1)
( get-value (get-top-card from-slot))
)
)
(not (deal-cards from-slot (list slot-id) ) )
)
; ( (empty-slot? slot-id)
; (deal-cards from-slot (list slot-id))
; )
(#t (check-to-tableau? from-slot (+ 1 slot-id)))
)
)
(define (game-continuable) (give-status-message) (and (not (game-won)) (get-hint)))
(define (game-won) (and (= (length (get-cards 1)) 13) (= (length (get-cards 2)) 13) (= (length (get-cards 3)) 13) (= (length (get-cards 4)) 13) (= (length (get-cards 5)) 13) (= (length (get-cards 6)) 13) (= (length (get-cards 7)) 13) (= (length (get-cards 8)) 13)))
(define (check-for-empty) (if (or (empty-slot? 10) (empty-slot? 11) (empty-slot? 12) (empty-slot? 13) (empty-slot? 14) (empty-slot? 15) (empty-slot? 16) (empty-slot? 17) (empty-slot? 18) (empty-slot? 19) ) (list 0 (_"Move a card to the empty slot")) #f))
(define (check-a-foundation card slot-id) (cond ((= slot-id 9) #f) ((and (not (empty-slot? slot-id)) (eq? (get-suit card) (get-suit (get-top-card slot-id))) (= (get-value card) (+ 1 (get-value (get-top-card slot-id))))) #t) (#t (check-a-foundation card (+ 1 slot-id)))))
(define (check-to-foundations? slot-id) (cond ((= slot-id 20) #f) ((empty-slot? slot-id) (check-to-foundations? (+ 1 slot-id))) ((= (get-value (get-top-card slot-id)) ace) (list 2 (get-name (get-top-card slot-id)) (_"an empty foundation"))) ((check-a-foundation (get-top-card slot-id) 1) (list 1 (get-name (get-top-card slot-id)) (get-name (make-card (- (get-value (get-top-card slot-id)) 1) (get-suit (get-top-card slot-id)))))) (#t (check-to-foundations? (+ 1 slot-id)))))
(define (check-for-deal) (if (not (empty-slot? 0)) (list 0 (_"Deal a card")) #f))
(define (get-hint) (or (check-to-foundations? 9) (check-for-empty) (check-for-deal) (cond (#t (list 0 (_"Move a card")) )) ) )
(define (get-options) #f)
(define (apply-options options) #f)
(define (timeout) #f)
(set-features droppable-feature)
(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?)
=============================== Now the help file. forty_thieves.xml
<sect1 id="Forty_Thieves">
`<title>`Forty Thieves`</title>`
<para>
Written by Ed Sirett</para>
`<sect2>``<title>`Setup`</title>`
<informaltable>
<tgroup cols="2">
<tbody>
<row>
<entry>
Type of Deck</entry>
<entry>
Double Deck</entry>
</row>
<row>
<entry>
Stock</entry>
<entry>
Top left pile. The rest of the deck is placed here after
dealing the Tableau. Cards are dealt singly to the waste,
The top card of the waste is available for play.
</entry>
</row>
<row>
<entry>
Foundation</entry>
<entry>
Eight piles top right. To be built in suit from Ace to
King.
</entry>
</row>
<row>
<entry>
Tableau</entry>
<entry>
Ten piles. Deal four rows face up to start. Tableau can
be built down in suit. Cards are moved singly. Empty
piles can be filled with any card.
</entry>
</row>
</tbody>
</tgroup>
</informaltable>
`</sect2>`
`<sect2>``<title>`Goal`</title>`
<para>
Move all cards to the Foundation piles.
</para>
`</sect2>`
`<sect2>``<title>`Rules`</title>`
<para>
Cards in Tableau are built down in the same suit. Card can only
be moved singly, but a pair can be moved if there is an empty
space. An empty pile in the Tableau can be filled
with any card.
</para>
<para>
Cards are played singly from the Stock to the waste pile, whose
top card is available for play. There are no redeals.
</para>
<para>
Foundations are built up in suit from Ace to King. Double clicking
on a foundation will autoplay cards. Double clicking on a card in
the Tableau or waste will move it to the appropriate Foundation pile
if such a move is possible, or to the tableau if possible.
</para>
`</sect2>`
`<sect2>``<title>`Scoring`</title>`
<para>
Each card in the Foundation scores 5 points. When a Foundation pile
is complete (from Ace to King), 60 more points are scored.
</para>
<para>
Maximum possible score: 1000
</para>
`</sect2>`
`<sect2>``<title>`Strategy`</title>`
<para>
Refrain from bringing cards to the tableau in order to obtain an empty
space as soon as possible. Then balance the requirements to maintain
empty spaces against the need to save low cards from being buried in
the waste.
</para>
</sect2>
</sect1>
Resolution: RESOLVED FIXED