[aisleriot] hamilton: Add new 'Hamilton' game
- From: Christian Persch <chpe src gnome org>
- To: commits-list gnome org
- Cc:
- Subject: [aisleriot] hamilton: Add new 'Hamilton' game
- Date: Mon, 8 Jun 2015 20:37:08 +0000 (UTC)
commit f9feeedf323047a3f2b3d6bb8a24b3364208aa05
Author: Toby Goodwin <toby paccrat org>
Date: Thu Oct 23 21:59:47 2014 +0100
hamilton: Add new 'Hamilton' game
games/Makefile.am | 1 +
games/hamilton.scm | 353 ++++++++++++++++++++++++++++++++++++++++++++++++++
help/C/hamilton.xml | 145 +++++++++++++++++++++
help/C/index.docbook | 1 +
help/Makefile.am | 1 +
help/sol.6 | 3 +-
po/POTFILES.in | 1 +
src/game-names.h | 14 +-
8 files changed, 511 insertions(+), 8 deletions(-)
---
diff --git a/games/Makefile.am b/games/Makefile.am
index 4bba3ed..fddc91f 100644
--- a/games/Makefile.am
+++ b/games/Makefile.am
@@ -45,6 +45,7 @@ games_GUILE = \
gold-mine.scm \
golf.scm \
gypsy.scm \
+ hamilton.scm \
helsinki.scm \
hopscotch.scm \
isabel.scm \
diff --git a/games/hamilton.scm b/games/hamilton.scm
new file mode 100644
index 0000000..6ee557c
--- /dev/null
+++ b/games/hamilton.scm
@@ -0,0 +1,353 @@
+; AisleRiot - hamilton.scm
+; Copyright (C) 1999, 2011, 2014 Timothy Goodwin <toby flare email>
+; hamilton.scm is based on klondike.scm, which is
+; Copyright (C) 1998, 2003 Jonathan Blandford <jrb mit edu>
+;
+; This program 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 3 of the License, 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, see <http://www.gnu.org/licenses/>.
+
+(use-modules (aisleriot interface) (aisleriot api))
+
+;; For append-map, drop-right, every, find, last:
+(use-modules (srfi srfi-1))
+
+;; Setup
+
+(define stock 0)
+(define chooser 1)
+(define foundation '(2 3 4 5))
+(define tableau '(6 7 8 9 10 11 12))
+
+(def-save-var choices 0)
+(def-save-var start-value 0)
+
+(define (new-game)
+ (initialize-playing-area)
+ (set-ace-low)
+
+ (make-standard-deck)
+ (shuffle-deck)
+
+ (add-normal-slot DECK 'stock)
+ (add-normal-slot '() 'chooser)
+ (add-blank-slot)
+ (add-normal-slot '() 'foundation)
+ (add-normal-slot '() 'foundation)
+ (add-normal-slot '() 'foundation)
+ (add-normal-slot '() 'foundation)
+ (add-carriage-return-slot)
+
+ (add-extended-slot '() down 'tableau)
+ (add-extended-slot '() down 'tableau)
+ (add-extended-slot '() down 'tableau)
+ (add-extended-slot '() down 'tableau)
+ (add-extended-slot '() down 'tableau)
+ (add-extended-slot '() down 'tableau)
+ (add-extended-slot '() down 'tableau)
+
+ (deal-tableau tableau)
+
+ (set! choices 3)
+ (set! start-value 0)
+
+ (give-status-message) ; this isn't actually displayed at the moment
+
+ (list 7 3.25) ; width and height of playing area
+ )
+
+(define (deal-tableau tableau)
+ (if (not (null? tableau))
+ (begin
+ (deal-cards-face-up stock tableau)
+ (deal-tableau (cdr tableau)))))
+
+;; Status messages
+
+(define (give-status-message)
+ (set-statusbar-message (string-append (get-stock-no-string)
+ " "
+ (get-start-value-string))))
+
+(define (get-value-name value)
+ (cond ((eq? value ace) (_"ace"))
+ ((eq? value 2) (_"two"))
+ ((eq? value 3) (_"three"))
+ ((eq? value 4) (_"four"))
+ ((eq? value 5) (_"five"))
+ ((eq? value 6) (_"six"))
+ ((eq? value 7) (_"seven"))
+ ((eq? value 8) (_"eight"))
+ ((eq? value 9) (_"nine"))
+ ((eq? value 10) (_"ten"))
+ ((eq? value jack) (_"jack"))
+ ((eq? value queen) (_"queen"))
+ ((eq? value king) (_"king"))
+ (#t (_"Unknown value"))))
+
+(define (get-start-value-string)
+ (if
+ (> start-value 0)
+ (string-append (_"Start card:") " " (get-value-name start-value))
+ (string-append (_"Choices left:") " " (number->string choices))))
+
+(define (get-stock-no-string)
+ (string-append (_"Stock left:") " "
+ (number->string (length (get-cards 0)))))
+
+;; Interactions
+
+(define (button-pressed start-slot card-list)
+ (cond ((= start-slot stock) #f)
+ ((= 0 start-value) (= start-slot chooser))
+ (else (valid-list? card-list))))
+
+(define (button-released start-slot card-list end-slot)
+ (if (droppable? start-slot card-list end-slot)
+ (complete-transaction start-slot card-list end-slot)
+ #f))
+
+(define (button-clicked start-slot)
+ (cond ((not (= start-slot stock)) #f)
+ ((> choices 0) (choose-next))
+ ((= 0 start-value) #f)
+ ((not (empty-slot? stock)) (do-deal-next-cards))
+ (else #f)))
+
+; find the longest prefix of xs which satisfies the predicate p (p is applied
+; to the entire list, not to individual elements); return a pair, first element
+; is the prefix, second element is the remainder of the list
+(define (split-with-list-pred p xs)
+ (define (helper a b)
+ (cond ((null? a) (cons a b))
+ ((p a) (cons a b))
+ (else (helper (drop-right a 1) (append (take-right a 1) b)))))
+ (helper xs '()))
+
+(define (button-double-clicked start-slot)
+ (cond
+ ((= start-slot stock) #f) ; cannot happen - actually deals twice
+ ((empty-slot? start-slot) #f)
+ ((member start-slot foundation) #f)
+ ((= start-slot chooser)
+ (complete-transaction chooser
+ (list (remove-card chooser))
+ (car foundation)))
+ ((= 0 start-value) #f)
+ ((let ((end-slot (find-foundation-for (get-top-card start-slot))))
+ (if end-slot
+ (let ((split (split-with-list-pred valid-list?
+ (get-cards start-slot))))
+ (set-cards! start-slot (cdr split))
+ (complete-transaction start-slot (car split) end-slot))
+ #f)))
+ (else #f)))
+
+;; Rules
+
+(define (choose-next)
+ (set! choices (- choices 1))
+ (if (not (empty-slot? chooser))
+ (set-cards! stock (append (get-cards stock)
+ (list (flip-card (remove-card chooser))))))
+ (flip-stock stock chooser 2 1)
+ #t)
+
+(define (dealable?)
+ (and
+ (not (= 0 start-value))
+ (> (length (get-cards stock)) 0)))
+
+(define (do-deal-next-cards)
+ (deal-cards-face-up stock
+ (if (= (length (get-cards stock)) 2)
+ (list-head tableau 2)
+ tableau))
+ #t)
+
+(define (find-foundation-for card)
+ (let ((value (get-value card))
+ (suit (get-suit card)))
+ (if (= start-value value)
+ (find empty-slot? foundation)
+ (let ((found (find (lambda (f)
+ (and (not (empty-slot? f))
+ (= suit (get-suit (get-top-card f)))))
+ foundation)))
+ (if (and found
+ (value-ok? value (get-value (get-top-card found))))
+ found
+ #f)))))
+
+(define (complete-transaction start-slot card-list end-slot)
+ (add-cards! end-slot
+ (if (member end-slot foundation)
+ (reverse card-list) card-list))
+ (if (member start-slot foundation)
+ (add-to-score! -1)) ; can't move more than one off
+ (if (member end-slot foundation)
+ (begin
+ (add-to-score! (length card-list))
+ (if (= start-value 0)
+ (begin
+ (set! choices 0)
+ (set! start-value (get-value (car card-list)))))))
+ #t)
+
+(define (value-ok? x y)
+ (and
+ (not (= start-value x))
+ (or
+ (= x (+ y 1))
+ (and (= x ace) (= y king)))))
+
+(define (in-sequence? l)
+ (or
+ (= (length l) 1)
+ (and
+ (value-ok? (cadr l) (car l))
+ (in-sequence? (cdr l)))))
+
+(define (valid-list? lyst)
+ (let ((suit (get-suit (car lyst))))
+ (and
+ (every (lambda (c) (= suit (get-suit c))) lyst)
+ (in-sequence? (map get-value lyst)))))
+
+(define (colour-match? a b)
+ (and (eq? (is-red? a) (is-red? b))
+ (value-ok? (get-value a) (get-value b))))
+
+(define (suit-match? a b)
+ (and (eq? (get-suit a) (get-suit b))
+ (value-ok? (get-value a) (get-value b))))
+
+(define (droppable? start-slot card-list end-slot)
+ (cond
+ ((member end-slot (list start-slot stock chooser)) #f)
+ ((member end-slot tableau)
+ (and (> start-value 0)
+ (or (empty-slot? end-slot)
+ (colour-match? (get-top-card end-slot) (last card-list)))))
+ ; at this point, end-slot must be a member of foundation
+ ((= start-value 0) (= start-slot chooser))
+ ((empty-slot? end-slot) (= start-value (get-value (car card-list))))
+ (else (suit-match? (car card-list) (get-top-card end-slot)))))
+
+;; Hints
+
+; These hints are simple-minded: they suggest possible moves, but don't
+; look ahead to find winning moves. They don't even attempt to find
+; suitable cards to fill empty slots. Having exhausted all suit matches,
+; they will recommend any possible colour match. Also, there are
+; occasions when a colour match is actually preferable to a suit match.
+; However, the "Deal another round" hint is only displayed when there
+; are no more moves.
+
+(define (cartesian-product xs ys)
+ (append-map (lambda (x) (map (lambda (y) (cons x y)) ys)) xs))
+
+; all tableau-foundation pairs
+(define t-f-pairs (cartesian-product tableau foundation))
+
+; all tableau-tableau pairs
+(define t-t-pairs
+ (filter (lambda (x) (not (= (car x) (cdr x))))
+ (cartesian-product tableau tableau)))
+
+(define card #f)
+(define color 0)
+(define suit 0)
+(define value 0)
+(define slot-id1 0)
+
+(define (not-chosen)
+ (and
+ (= start-value 0)
+ (if (= choices 3)
+ (hint-click chooser (_"Turn over the top card of the stock."))
+ (hint-move chooser 1 (car foundation)))))
+
+(define (valid-move? start end)
+ (and
+ (not (empty-slot? start))
+ (droppable? start (list (get-top-card start)) end)))
+
+; Given a slot, return the longest moveable sequence of cards in it
+(define (get-moveable slot)
+ (car (split-with-list-pred valid-list? (get-cards slot))))
+
+; Given a pair of slots, start and end, hint if there is a valid move from
+; start to end. If the end slot is a foundation, the hint is just the first
+; card. If in the tableau, the hint must be the longest moveable list of cards.
+(define (maybe-hint p)
+ (letrec ((start (car p))
+ (end (cdr p))
+ (cards (if (member end foundation)
+ (list (get-top-card start))
+ (get-moveable start))))
+ (and
+ (not (empty-slot? start))
+ (droppable? start cards end)
+ (hint-move start (length cards) end))))
+
+(define (hint-foundation)
+ (or-map maybe-hint t-f-pairs))
+
+(define (maybe-suit p)
+ (and
+ (not (empty-slot? (car p)))
+ (not (empty-slot? (cdr p)))
+ (= (get-suit (get-top-card (car p)))
+ (get-suit (get-top-card (cdr p))))
+ (maybe-hint p)))
+
+(define (get-hint)
+ (or
+ (not-chosen)
+ ; Move to foundation?
+ (or-map maybe-hint t-f-pairs)
+ ; Match within suit?
+ (or-map maybe-suit t-t-pairs)
+ ; Empty slot?
+ (and
+ (or-map empty-slot? tableau)
+ (list 0 (_"Fill an empty slot.")))
+ ; Colour matches are the last resort...
+ (or-map maybe-hint t-t-pairs)
+ ; ... apart from dealing, of course.
+ (and
+ (not (empty-slot? stock))
+ (hint-click stock (_"Deal a new round.")))
+ ; If all else fails.
+ (list 0 (_"Try moving cards down from the foundations."))))
+
+(define (game-won) (= (get-score) 52))
+
+; We never say "game over".
+(define (game-over)
+ (give-status-message)
+ (not (game-won)))
+
+(define (get-options) #f)
+
+(define (apply-options options) #f)
+
+(define (timeout) #f)
+
+(set-features dealable-feature droppable-feature)
+
+(set-lambda new-game button-pressed button-released button-clicked button-double-clicked game-over game-won
get-hint get-options apply-options timeout droppable? dealable? do-deal-next-cards)
+
+; This game is sometimes called Agnes, but I call it Hamilton after my
+; father, Geoffrey Hamilton Goodwin (b. 1937), who taught me the game
+; many many years ago. #t
diff --git a/help/C/hamilton.xml b/help/C/hamilton.xml
new file mode 100644
index 0000000..e0eacdc
--- /dev/null
+++ b/help/C/hamilton.xml
@@ -0,0 +1,145 @@
+<?xml version="1.0" encoding="utf-8" ?>
+<!DOCTYPE refentry PUBLIC "-//OASIS//DTD DocBook XML V4.3//EN"
+"http://www.oasis-open.org/docbook/xml/4.3/docbookx.dtd"; [
+]>
+<sect1 id="Hamilton"> <!--<sect1info>
+ <copyright>
+ <year>2014</year>
+ <holder>Timothy Goodwin</holder>
+ </copyright>
+ <author>
+ <firstname>Timothy</firstname>
+ <surname>Goodwin</surname></author>
+ <address><email>toby flare email</email></address>
+ </sect1info>-->
+
+ <title>Hamilton</title>
+
+ <para>Written by Timothy Goodwin</para>
+
+ <sect2><title>Setup</title>
+
+ <informaltable>
+ <tgroup cols="2">
+ <tbody>
+ <row>
+ <entry>Type of Deck</entry>
+ <entry>Standard Deck</entry>
+ </row>
+ <row>
+ <entry>Stock</entry>
+ <entry>
+ Top left pile. The rest of the deck is placed here after
+ dealing the Tableau. The first three cards may be turned
+ over one at a time to Chooser. After choosing a Start card,
+ clicking on Stock deals one card face up to each pile in the
+ Tableau.
+ </entry>
+ </row>
+ <row>
+ <entry>Chooser</entry>
+ <entry>
+ Top left, next to Stock. While the Start card is being
+ chosen, clicking Stock deals the top card face up to
+ Chooser. The card in Chooser can be moved to a Foundation.
+ Or if Stock is clicked again, it is returned face down to
+ the bottom of Stock, and the next card moved to Chooser.
+ </entry>
+ </row>
+ <row>
+ <entry>Foundation</entry>
+ <entry>
+ Four piles top right. To be built up in suit from the
+ chosen Start card to King, then Ace to the card with value
+ one less than the Start Card.
+ </entry>
+ </row>
+ <row>
+ <entry>Tableau</entry>
+ <entry>
+ Seven piles. Deal one card face up to each pile. Start the
+ second row on the second pile in the Tableau, and deal one
+ card face up to each pile except the first. Repeat, till
+ there are seven cards in the last pile. The Tableau can be
+ built down by matching color. Groups of cards in order and
+ in suit can be moved. Empty piles can be filled by any card
+ or group of cards in order and in suit.
+ </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>
+ To start the game, one card is flipped over from the Stock to the
+ Chooser. This card can be moved to a Foundation, in which case it
+ is the Start card for this game. Otherwise, the card in the Chooser
+ is returned face down to the bottom of the stock, and the next card
+ flipped over from Stock to Chooser. If none of the first three
+ cards is chosen, the game is over. Double clicking on the Chooser
+ will move the card there to a Foundation.
+ </para>
+ <para>
+ Cards in the Tableau are built down by color. A King may be placed
+ on an Ace (unless the Start card is Ace). Groups of cards that are
+ in suit can be moved. An empty pile in the Tableau can be filled
+ with any card, or with a group of cards that are in order and all
+ the same suit.
+ </para>
+ <para>
+ Foundations are built up in suit from the Start card to King, then
+ Ace, Two, and so on to one less than the Start card. For example,
+ if the Start card is Seven, the Foundations are built up from Seven
+ to King, Ace to Six. Cards in Foundations are still in play.
+ </para>
+ <para>
+ A group of cards that are in order and all the same suit can be
+ moved to a Foundation in a single move. Double clicking on a pile
+ in the Tableau will move all possible cards from that pile to the
+ Foundation.
+ </para>
+ </sect2>
+
+ <sect2><title>Scoring</title>
+ <para>
+ Each card removed scores one point.
+ </para>
+ <para>
+ Maximum possible score: 52
+ </para>
+ </sect2>
+
+ <sect2><title>Strategy</title>
+ <para>
+ Choose wisely. If you cannot move to the Foundation all visible
+ cards of the Start value, you are unlikely to win. An empty slot in
+ the Tableau is invaluable.
+ </para>
+ </sect2>
+
+ <sect2><title>Dedication</title>
+ <para>
+ This game is dedicated to, and named for, my father: Geoffrey
+ Hamilton Goodwin (b. 1937). He taught me many patience (or
+ solitaire) games; we both consider Hamilton the most interesting
+ single-pack game.
+ </para>
+ </sect2>
+
+ <sect2><title>References</title>
+ <para>
+ This game is found under the name <emphasis>Agnes</emphasis> in the book
+ <emphasis>Games of Patience</emphasis> by <emphasis>Basil
+ Dalton</emphasis>, London 1924.
+ </para>
+ </sect2>
+</sect1>
diff --git a/help/C/index.docbook b/help/C/index.docbook
index 75b35c5..bbb6426 100644
--- a/help/C/index.docbook
+++ b/help/C/index.docbook
@@ -246,6 +246,7 @@ been coded for your pleasure in the GNOME scripting language (Scheme).
<xi:include href="gold_mine.xml" />
<xi:include href="golf.xml" />
<xi:include href="gypsy.xml" />
+ <xi:include href="hamilton.xml" />
<xi:include href="helsinki.xml" />
<xi:include href="hopscotch.xml" />
<xi:include href="isabel.xml" />
diff --git a/help/Makefile.am b/help/Makefile.am
index f1f02a5..50402b7 100644
--- a/help/Makefile.am
+++ b/help/Makefile.am
@@ -49,6 +49,7 @@ HELP_FILES = \
glenwood.xml \
golf.xml \
gypsy.xml \
+ hamilton.xml \
helsinki.xml \
hopscotch.xml \
isabel.xml \
diff --git a/help/sol.6 b/help/sol.6
index 84a9707..9030500 100644
--- a/help/sol.6
+++ b/help/sol.6
@@ -56,7 +56,8 @@ Saratoga, Cruel, Block Ten, Will O The Wisp, Odessa, Eagle Wing, Treize, Zebra,
Cover, Elevator, Fortress, Giant, Spider, Gaps, Bakers Dozen, Whitehead,
Freecell, Helsinki, Spider Three Decks, Scuffle, Poker, Klondike Three Decks,
Valentine, Royal East, Thumb And Pouch, Klondike, Doublets, Template, Golf,
-Westhaven, Beleaguered Castle, Hopscotch, Eliminator, Aunt Mary
+Westhaven, Beleaguered Castle, Hopscotch, Eliminator, Aunt Mary,
+Hamilton
.RE
.SH OPTIONS
diff --git a/po/POTFILES.in b/po/POTFILES.in
index c3a7bfb..5c99c72 100644
--- a/po/POTFILES.in
+++ b/po/POTFILES.in
@@ -61,6 +61,7 @@ games/glenwood.scm
games/gold-mine.scm
games/golf.scm
games/gypsy.scm
+games/hamilton.scm
games/helsinki.scm
games/hopscotch.scm
games/isabel.scm
diff --git a/src/game-names.h b/src/game-names.h
index 458fca7..1e61a58 100644
--- a/src/game-names.h
+++ b/src/game-names.h
@@ -284,6 +284,13 @@ N_("Gypsy")
locale, use that; otherwise you can translate this string
freely, literally, or not at all, at your option.
*/
+N_("Hamilton")
+
+/* Translators: this string is the name of a game of patience.
+ If there is an established standard name for this game in your
+ locale, use that; otherwise you can translate this string
+ freely, literally, or not at all, at your option.
+ */
N_("Helsinki")
/* Translators: this string is the name of a game of patience.
@@ -347,13 +354,6 @@ N_("Klondike")
locale, use that; otherwise you can translate this string
freely, literally, or not at all, at your option.
*/
-N_("Klondike Three Decks")
-
-/* Translators: this string is the name of a game of patience.
- If there is an established standard name for this game in your
- locale, use that; otherwise you can translate this string
- freely, literally, or not at all, at your option.
- */
N_("Labyrinth")
/* Translators: this string is the name of a game of patience.
[
Date Prev][
Date Next] [
Thread Prev][
Thread Next]
[
Thread Index]
[
Date Index]
[
Author Index]
