Commit a30893b2 authored by Callum McKenzie's avatar Callum McKenzie

Aisleriot: the final huge batch of highlighting patches. Zebra documentation fix.

parent d798d47d
2005-07-14 Callum McKenzie <callum@physics.otago.ac.nz>
2005-07-15 Callum McKenzie <callum@physics.otago.ac.nz>
* rules/escalator.scm:
* rules/elevator.scm: Adapted to be sane in click-move-mode:
single clicks do nothing in that mode (as opposed to doing
something occasionally). Add hilight support.
* cscmi.c (scm_click_to_move_p): Export the click-to-move boolean
to scheme.
* rules/block_ten.scm: Leave a note about other things that
need to be fixed with this game.
* rules/template.scm: Document set-features and droppable?
* rules/agnes.scm:
* rules/osmosis.scm:
* rules/helsinki.scm:
* rules/bakers_dozen.scm:
* rules/bakers_game.scm:
* rules/isabel.scm:
* rules/beleaguered_castle.scm:
* rules/bristol.scm:
* rules/camelot.scm:
* rules/golf.scm:
* rules/jamestown.scm:
* rules/kansas.scm:
* rules/chessboard.scm:
* rules/eight_off.scm:
* rules/fortress.scm:
* rules/fourteen.scm:
* rules/gay_gordons.scm:
* rules/king_albert.scm:
* rules/labyrinth.scm:
* rules/neighbor.scm:
* rules/odessa.scm:
* rules/scorpion.scm:
* rules/streets_and_alleys.scm
* rules/thirteen.scm
* rules/zebra.scm: More highlighting patches from Vincet Povirk
(see bug #305609).
* TODO: Empty out now that we have finished the highlighting patches.
2005-07-14 Callum McKenzie <callum@physics.otago.ac.nz>
* rules/Makefile.am: Add carpet and backbone to the build.
......
For information about card highlighting, see::
http://bugs.gnome.org/show_bug.cgi?id=305609
This is now an empty file. It will occasionally be used to track which
games have, or have not, been adapted for particular features. The
droppable feature was the last such example (see bug #305609).
The following files do not yet support highlighting:
agnes.scm
bakers_dozen.scm
bakers_game.scm
beleaguered_castle.scm
block_ten.scm
bristol.scm
camelot.scm
chessboard.scm
eight_off.scm
elevator.scm
escalator.scm
fortress.scm
fortunes.scm
fourteen.scm
gay_gordons.scm
golf.scm
gypsy.scm
helsinki.scm
isabel.scm
jamestown.scm
kansas.scm
king_albert.scm
labyrinth.scm
neighbor.scm
odessa.scm
osmosis.scm
scorpion.scm
streets_and_alleys.scm
template.scm
thirteen.scm
union_square.scm
yield.scm
zebra.scm
The following games are supported:
Klondike, Freecell, Clock, Monte Carlo, Thieves, Spider (1, 2, & 4 suits),
Peek, Straight Up, Cover, Auld Lang Syne, Scuffle, Jumbo, Canfield,
Thumb and Pouch, Royal East, Valentine, Ten Across, Quatorze, Diamond
Mine, Doublets, Eagle Wing, Glenwood, Hopscotch, Lady Jane, Pileon,
Plait, Sir Tommy, Spiderette, Treize, Westhaven, Whitehead, Yukon,
Will O The Wisp, Triple Peaks
Games that don't even need it:
First Law, Maze, Poker
......@@ -285,7 +285,12 @@ static SCM scm_myrandom(SCM range)
return scm_long2num(g_random_int_range(0,SCM_INUM(range)));
}
static SCM scm_get_score()
static SCM scm_click_to_move_p (void)
{
return click_to_move ? SCM_BOOL_T : SCM_BOOL_F;
}
static SCM scm_get_score(void)
{
return scm_long2num(score);
}
......@@ -329,6 +334,7 @@ void cscm_init ()
scm_c_define_gsubr("set-slot-x-expansion!", 2, 0, 0, scm_set_slot_x_expansion);
scm_c_define_gsubr("set-lambda", 8, 0, 1, scm_set_lambda);
scm_c_define_gsubr("random", 1, 0, 0, scm_myrandom);
scm_c_define_gsubr("click-to-move?", 0, 0, 0, scm_click_to_move_p);
scm_c_define_gsubr("get-score", 0, 0, 0, scm_get_score);
scm_c_define_gsubr("set-score!", 1, 0, 0, scm_set_score);
scm_c_define_gsubr("get-timeout", 0, 0, 0, scm_get_timeout);
......
......@@ -40,9 +40,9 @@
<row>
<entry>Foundation</entry>
<entry>
Eight piles on top right. Place the eight two's on to these piles to
Eight piles on top right. Place the eight Aces on to these piles to
begin the Foundations. The Foundations are to be built up in alternate
color up to Ace's. Cards in Foundations are no longer in play.
color up to Kings. Cards in Foundations are no longer in play.
</entry>
</row>
<row>
......@@ -81,7 +81,7 @@
play. There is one redeal.
</para>
<para>
Foundations are built up by alternate color from two's to Ace's. Cards
Foundations are built up by alternate color from Aces to Kings. Cards
in Foundation piles are no longer in play.
</para>
......
2005-07-15 Callum McKenzie <callum@physics.otago.ac.nz>
* C/zebra.xml: Make the documentation match the game: s/two/ace/
and s/ace/king/.
2005-07-14 Callum McKenzie <callum@physics.otago.ac.nz>
* Makefile.am:
......
......@@ -99,7 +99,7 @@
(check-same-color-list card-list)
(check-straight-descending-list card-list)))
(define (button-released start-slot card-list end-slot)
(define (droppable? start-slot card-list end-slot)
(cond ((= start-slot end-slot)
#f)
((and (> end-slot 0)
......@@ -107,23 +107,14 @@
(and (= (length card-list) 1)
(or (and (empty-slot? end-slot)
(= (get-value (car card-list))
BASE-VAL)
(move-n-cards! start-slot end-slot card-list)
(or (< start-slot 5)
(and (add-to-score! 1)
(or (empty-slot? start-slot)
(make-visible-top-card start-slot)))))
BASE-VAL))
(and (not (empty-slot? end-slot))
(= (get-suit (car card-list))
(get-suit (get-top-card end-slot)))
(or (= (get-value (car card-list))
(+ 1 (get-value (get-top-card end-slot))))
(and (= (get-value (car card-list)) ace)
(= (get-value (get-top-card end-slot)) king)))
(move-n-cards! start-slot end-slot card-list)
(or (empty-slot? start-slot)
(make-visible-top-card start-slot))
(add-to-score! 1)))))
(= (get-value (get-top-card end-slot)) king)))))))
((> end-slot 4)
(and (not (empty-slot? end-slot))
(eq? (is-red? (car card-list))
......@@ -132,14 +123,19 @@
(or (= (get-value (car (reverse card-list)))
(- (get-value (get-top-card end-slot)) 1))
(and (= (get-value (car (reverse card-list))) king)
(= (get-value (get-top-card end-slot)) ace)))
(move-n-cards! start-slot end-slot card-list)
(or (empty-slot? start-slot)
(make-visible-top-card start-slot))
(or (> start-slot 4)
(add-to-score! -1))))
(= (get-value (get-top-card end-slot)) ace)))))
(#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)
(or (> start-slot 4)
(add-to-score! -1))
(or (> end-slot 4)
(add-to-score! 1))
(or (empty-slot? start-slot)
(make-visible-top-card start-slot))))
(define (check-slot-and-deal slot)
(if (and (not (empty-slot? 0))
(< slot 12))
......@@ -170,10 +166,22 @@
(#t
(check-dc slot (+ 1 f-slot) just-checking?))))
(define (autoplay-foundations)
(define (autoplay-foundations-tail)
(if (or-map button-double-clicked '(5 6 7 8 9 10 11))
(autoplay-foundations-tail)
#t))
(if (or-map button-double-clicked '(5 6 7 8 9 10 11))
(autoplay-foundations-tail)
#f))
(define (button-double-clicked slot-id)
(cond ((or (empty-slot? slot-id)
(< slot-id 5))
(cond ((or (and (empty-slot? slot-id)
(> slot-id 4))
(= slot-id 0))
#f)
((< slot-id 5)
(autoplay-foundations))
((= (get-value (get-top-card slot-id)) BASE-VAL)
(and (or (and (empty-slot? 1)
(deal-cards slot-id '(1)))
......@@ -263,6 +271,8 @@
(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)
apply-options timeout droppable?)
......@@ -74,32 +74,35 @@
(and (not (empty-slot? slot-id))
(= (length card-list) 1)))
(define (button-released start-slot card-list end-slot)
(define (droppable? start-slot card-list end-slot)
(cond ((= start-slot end-slot)
#f)
((< end-slot 4)
(cond ((and (= (get-value (car card-list))
ace)
(empty-slot? end-slot))
(and (move-n-cards! start-slot end-slot card-list)
(or (< start-slot 4)
(add-to-score! 1))))
#t)
((and (not (empty-slot? end-slot))
(= (get-suit (get-top-card end-slot))
(get-suit (car card-list)))
(= (+ 1 (get-value (get-top-card end-slot)))
(get-value (car card-list))))
(and (move-n-cards! start-slot end-slot card-list)
(add-to-score! 1)))
#t)
(#t #f)))
((and (not (empty-slot? end-slot))
(= (get-value (get-top-card end-slot))
(+ 1 (get-value (car card-list)))))
(and (move-n-cards! start-slot end-slot card-list)
(or (> start-slot 3)
(add-to-score! -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)
(or (> start-slot 3)
(add-to-score! -1))
(or (> end-slot 3)
(add-to-score! 1))))
(define (button-clicked slot-id)
#f)
......@@ -202,6 +205,8 @@
(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)
apply-options timeout droppable?)
......@@ -18,34 +18,23 @@
(def-save-var free-reserves 0)
(define reserve '(0 1 2 3))
(define foundation '(4 5 6 7))
(define tableau '(8 9 10 11 12 13 14 15))
(define (new-game)
(initialize-playing-area)
(set-ace-low)
(make-standard-deck)
(shuffle-deck)
; A lot of this is an awful hack because someone seems to have
; rearranged the cards at some point without renumbering them.
(add-blank-slot)
(add-blank-slot)
(add-blank-slot)
(add-blank-slot)
(add-blank-slot)
(add-normal-slot DECK)
(add-normal-slot '())
(set! HORIZPOS 0)
(add-normal-slot '())
(add-normal-slot '())
(add-blank-slot)
(add-normal-slot '())
(add-normal-slot '())
(add-blank-slot)
(add-blank-slot)
(add-blank-slot)
(add-normal-slot '())
(add-normal-slot '())
......@@ -74,132 +63,116 @@
(define (button-pressed slot-id card-list)
(and (not (empty-slot? slot-id))
(or (= (length card-list) 1)
(and (> slot-id 7)
(and (member slot-id tableau)
(< (length card-list) (+ 2 free-reserves))
(check-same-suit-list card-list)
(check-straight-descending-list card-list)))))
(define (button-released start-slot card-list end-slot)
(define (droppable? start-slot card-list end-slot)
(cond ((= start-slot end-slot)
#f)
((> end-slot 7)
((member end-slot tableau)
(and (or (and (empty-slot? end-slot)
(= (get-value (car (reverse card-list)))
king)
(move-n-cards! start-slot end-slot card-list))
king))
(and (not (empty-slot? end-slot))
(= (get-suit (get-top-card end-slot))
(get-suit (car card-list)))
(= (get-value (get-top-card end-slot))
(+ 1 (get-value (car (reverse card-list)))))
(move-n-cards! start-slot end-slot card-list)))
(or (> start-slot 7)
(and (> start-slot 1)
(< start-slot 6)
(set! free-reserves (+ 1 free-reserves)))
(add-to-score! -1))))
(+ 1 (get-value (car (reverse card-list)))))))))
((and (= (length card-list) 1)
(empty-slot? end-slot)
(> end-slot 1)
(< end-slot 6))
(and (move-n-cards! start-slot end-slot card-list)
(or (and (> start-slot 1)
(< start-slot 6))
(set! free-reserves (- free-reserves 1)))))
(member end-slot reserve))
#t)
((and (= (length card-list) 1)
(or (< end-slot 2)
(and (> end-slot 5)
(< end-slot 8))))
(member end-slot foundation))
(and (or (and (empty-slot? end-slot)
(= (get-value (car card-list)) ace))
(and (not (empty-slot? end-slot))
(= (get-suit (get-top-card end-slot))
(get-suit (car card-list)))
(= (+ 1 (get-value (get-top-card end-slot)))
(get-value (car card-list)))))
(move-n-cards! start-slot end-slot card-list)
(or (and (> start-slot 7)
(add-to-score! 1))
(and (> start-slot 1)
(< start-slot 6)
(set! free-reserves (+ free-reserves 1))
(add-to-score! 1))
#t)))
(get-value (car card-list)))))))
(#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)
(or (not (member start-slot reserve))
(set! free-reserves (+ free-reserves 1)))
(or (not (member end-slot reserve))
(set! free-reserves (- free-reserves 1)))
(or (not (member start-slot foundation))
(add-to-score! -1))
(or (not (member end-slot foundation))
(add-to-score! 1))))
(define (button-clicked slot-id)
#f)
(define (move-to-empty-foundation slot f-slot)
(cond ((= f-slot 2)
(move-to-empty-foundation slot 6))
((= f-slot 8)
(define (move-to-empty-foundation slot f-slots)
(cond ((eq? f-slots '())
#f)
((empty-slot? f-slot)
(deal-cards slot (list f-slot)))
(#t (move-to-empty-foundation slot (+ 1 f-slot)))))
((empty-slot? (car f-slots))
(deal-cards slot (list (car f-slots))))
(#t (move-to-empty-foundation slot (cdr f-slots)))))
(define (move-to-foundation slot f-slot)
(cond ((= f-slot 2)
(move-to-foundation slot 6))
((= f-slot 8)
(define (move-to-foundation slot f-slots)
(cond ((eq? f-slots '())
#f)
((and (not (empty-slot? f-slot))
((and (not (empty-slot? (car f-slots)))
(= (get-suit (get-top-card slot))
(get-suit (get-top-card f-slot))))
(get-suit (get-top-card (car f-slots)))))
(and (= (get-value (get-top-card slot))
(+ 1 (get-value (get-top-card f-slot))))
(deal-cards slot (list f-slot))))
(#t (move-to-foundation slot (+ 1 f-slot)))))
(+ 1 (get-value (get-top-card (car f-slots)))))
(deal-cards slot (list (car f-slots)))))
(#t (move-to-foundation slot (cdr f-slots)))))
(define (button-double-clicked slot-id)
(and (not (empty-slot? slot-id))
(> slot-id 1)
(or (< slot-id 6)
(> slot-id 7))
(or (member slot-id reserve)
(member slot-id tableau))
(or (and (= (get-value (get-top-card slot-id))
ace)
(move-to-empty-foundation slot-id 0))
(move-to-foundation slot-id 0))
(move-to-empty-foundation slot-id foundation))
(move-to-foundation slot-id foundation))
(add-to-score! 1)
(or (> slot-id 7)
(or (member slot-id tableau)
(set! free-reserves (+ 1 free-reserves)))))
(define (game-continuable)
(and (not (game-won))
(get-hint)))
(define (game-won)
(and (= (length (get-cards 0)) 13)
(= (length (get-cards 1)) 13)
(= (length (get-cards 6)) 13)
(= (length (get-cards 7)) 13)))
(define (check-full f-slots)
(or (eq? f-slots '())
(and (= (length (get-cards (car f-slots))) 13)
(check-full (cdr f-slots)))))
(define (check-to-foundations? slot f-slot)
(cond ((= slot 16)
#f)
((= slot 6)
(check-to-foundations? 8 0))
((= f-slot 2)
(check-to-foundations? slot 6))
((or (empty-slot? slot)
(= f-slot 8))
(check-to-foundations? (+ 1 slot) 0))
((= (get-value (get-top-card slot)) ace)
(list 2 (get-name (get-top-card slot)) (_"an empty Foundation")))
((and (not (empty-slot? f-slot))
(= (get-suit (get-top-card slot))
(get-suit (get-top-card f-slot)))
(= (get-value (get-top-card slot))
(+ 1 (get-value (get-top-card f-slot)))))
(list 1 (get-name (get-top-card slot)) (get-name (get-top-card f-slot))))
(#t (check-to-foundations? slot (+ 1 f-slot)))))
(define (game-won)
(check-full foundation))
(define (check-to-foundations? slots f-slots)
(cond ((eq? slots '())
#f)
((or (empty-slot? (car slots))
(eq? f-slots '()))
(check-to-foundations? (cdr slots) foundation))
((= (get-value (get-top-card (car slots))) ace)
(list 2 (get-name (get-top-card (car slots))) (_"an empty Foundation")))
((and (not (empty-slot? (car f-slots)))
(= (get-suit (get-top-card (car slots)))
(get-suit (get-top-card (car f-slots))))
(= (get-value (get-top-card (car slots)))
(+ 1 (get-value (get-top-card (car f-slots))))))
(list 1 (get-name (get-top-card (car slots))) (get-name (get-top-card (car f-slots)))))
(#t (check-to-foundations? slots (cdr f-slots)))))
(define (check-for-king card-list iter slot)
(cond ((= (length card-list) 0)
#f)
((and (= (length card-list) 1)
(> slot 7))
(member slot tableau))
#f)
((= (get-value (car card-list)) king)
(get-name (car card-list)))
......@@ -228,40 +201,38 @@
(check-for-spec-card (cdr card-list) (- iter 1) value))
(#t #f)))
(define (check-to-tableau? slot t-slot)
(cond ((= slot 16)
#f)
((= slot 6)
(check-to-tableau? 8 9))
((or (empty-slot? slot)
(= t-slot 16))
(check-to-tableau? (+ 1 slot) 8))
((and (not (= slot t-slot))
(empty-slot? t-slot)
(check-for-king (get-cards slot) free-reserves slot))
(define (check-to-tableau? slots t-slots)
(cond ((eq? slots '())
#f)
((or (empty-slot? (car slots))
(eq? t-slots '()))
(check-to-tableau? (cdr slots) tableau))
((= (car slots) (car t-slots))
(check-to-tableau? slots (cdr t-slots)))
((and (empty-slot? (car t-slots))
(check-for-king (get-cards (car slots)) free-reserves (car slots)))
(list 2
(check-for-king (get-cards slot) free-reserves slot)
(check-for-king (get-cards (car slots)) free-reserves (car slots))
(_"an empty Tableau")))
((and (not (= slot t-slot))
(not (empty-slot? t-slot))
(= (get-suit (get-top-card slot))
(get-suit (get-top-card t-slot)))
(check-for-spec-card (get-cards slot)
((and (not (empty-slot? (car t-slots)))
(= (get-suit (get-top-card (car slots)))
(get-suit (get-top-card (car t-slots))))
(check-for-spec-card (get-cards (car slots))
free-reserves
(- (get-value (get-top-card t-slot)) 1)))
(- (get-value (get-top-card (car t-slots))) 1)))
(list 1
(get-name (make-card (- (get-value (get-top-card t-slot)) 1)
(get-suit (get-top-card t-slot))))
(get-name (get-top-card t-slot))))
(#t (check-to-tableau? slot (+ 1 t-slot)))))
(get-name (make-card (- (get-value (get-top-card (car t-slots))) 1)
(get-suit (get-top-card (car t-slots)))))
(get-name (get-top-card (car t-slots)))))
(#t (check-to-tableau? slots (cdr t-slots)))))
(define (check-for-empty-reserve)
(and (> free-reserves 0)
(list 0 (_"Move something on to an empty reserve"))))
(define (get-hint)
(or (check-to-foundations? 2 0)
(check-to-tableau? 2 8)
(or (check-to-foundations? (append reserve tableau) foundation)
(check-to-tableau? (append reserve tableau) tableau)
(check-for-empty-reserve)))
(define (get-options)
......@@ -273,6 +244,8 @@
(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)
apply-options timeout droppable?)
......@@ -67,44 +67,26 @@
(and (= (length card-list) 1)
(not (= ace (get-value (car card-list))))))
(define (button-released start-slot card-list end-slot)
(define (droppable? start-slot card-list end-slot)
(cond ((= start-slot end-slot)
#f)
((or (= end-slot 1)
(= end-slot 4)
(= end-slot 7)
(= end-slot 10))
(cond ((empty-slot? end-slot)
(if (= (get-value (car card-list)) 1)
(move-n-cards! start-slot end-slot card-list)
#f))
((and (= (get-suit (get-top-card end-slot))
(get-suit (car card-list)))
(= (+ 1 (get-value (get-top-card end-slot)))
(get-value (car card-list))))
(begin
(move-n-cards! start-slot end-slot card-list)
(add-to-score! 1)))
(#t #f)))
((empty-slot? end-slot)
(begin
(move-n-cards! start-slot end-slot card-list)
(if (or (= start-slot 1)
(= start-slot 4)
(= start-slot 7)
(= start-slot 10))
(add-to-score! -1))))
((= (get-value (get-top-card end-slot))
(+ 1 (get-value (car card-list))))
(begin
(move-n-cards! start-slot end-slot card-list)
(if (or (= start-slot 1)
(= start-slot 4)
(= start-slot 7)
(= start-slot 10))
(add-to-score! -1))))
(#t #f)))
((member end-slot '(1 4 7 10))
(and (= (get-suit (get-top-card end-slot))
(get-suit (car card-list)))
(= (+ 1 (get-value (get-top-card end-slot)))
(get-value (car card-list)))))
(#t (or (empty-slot? end-slot)
(= (get-value (get-top-card end-slot))
(+ 1 (get-value (car card-list))))))))
(define (button-released start-slot card-list end-slot)
(and (droppable? start-slot card-list end-slot)
(or (not (member end-slot '(1 4 7 10)))
(add-to-score! 1))
(move-n-cards! start-slot end-slot card-list)
(or (not (member start-slot '(1 4 7 10)))
(add-to-score! -1))))
(define (button-clicked slot-id)
#f)
......@@ -197,6 +179,8 @@
(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)
apply-options timeout droppable?)
......@@ -16,6 +16,9 @@
; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
; USA
; FIXME: when the issues with this game get fixed, also add droppable?
; support at the same time.
(define (new-game)
(initialize-playing-area)
(make-standard-deck)
......
......@@ -108,27 +108,25 @@
(< slot-id 8)))
(= (length card-list) 1)))
(define (button-released start-slot card-list end-slot)
(define (droppable? start-slot card-list end-slot)
(cond ((and (> end-slot 3)
(< end-slot 8))
(cond ((not (empty-slot? end-slot))
(if (= (+ 1 (get-value (get-top-card end-slot)))
(get-value (car card-list)))
(begin
(add-to-score! 1)
(move-n-cards! start-slot end-slot card-list))
#f))
((= (get-value (car card-list)) ace)
(begin