Commit f9feeedf323047a3f2b3d6bb8a24b3364208aa05 - aisleriot

hamilton: Add new 'Hamilton' game Toby Goodwin authored 9 years ago Christian Persch committed 8 years ago

8 changed file(s) with 511 addition(s) and 8 deletion(s). Raw diff Collapse all Expand all

-0

games/Makefile.am less more

44	44	gold-mine.scm \
45	45	golf.scm \
46	46	gypsy.scm \
	47	hamilton.scm \
47	48	helsinki.scm \
48	49	hopscotch.scm \
49	50	isabel.scm \

+353

-0

games/hamilton.scm less more

	0	; AisleRiot - hamilton.scm
	1	; Copyright (C) 1999, 2011, 2014 Timothy Goodwin <toby@flare.email>
	2	; hamilton.scm is based on klondike.scm, which is
	3	; Copyright (C) 1998, 2003 Jonathan Blandford <jrb@mit.edu>
	4	;
	5	; This program is free software: you can redistribute it and/or modify
	6	; it under the terms of the GNU General Public License as published by
	7	; the Free Software Foundation, either version 3 of the License, or
	8	; (at your option) any later version.
	9	;
	10	; This program is distributed in the hope that it will be useful,
	11	; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	13	; GNU General Public License for more details.
	14	;
	15	; You should have received a copy of the GNU General Public License
	16	; along with this program. If not, see <http://www.gnu.org/licenses/>.
	17
	18	(use-modules (aisleriot interface) (aisleriot api))
	19
	20	;; For append-map, drop-right, every, find, last:
	21	(use-modules (srfi srfi-1))
	22
	23	;; Setup
	24
	25	(define stock 0)
	26	(define chooser 1)
	27	(define foundation '(2 3 4 5))
	28	(define tableau '(6 7 8 9 10 11 12))
	29
	30	(def-save-var choices 0)
	31	(def-save-var start-value 0)
	32
	33	(define (new-game)
	34	(initialize-playing-area)
	35	(set-ace-low)
	36
	37	(make-standard-deck)
	38	(shuffle-deck)
	39
	40	(add-normal-slot DECK 'stock)
	41	(add-normal-slot '() 'chooser)
	42	(add-blank-slot)
	43	(add-normal-slot '() 'foundation)
	44	(add-normal-slot '() 'foundation)
	45	(add-normal-slot '() 'foundation)
	46	(add-normal-slot '() 'foundation)
	47	(add-carriage-return-slot)
	48
	49	(add-extended-slot '() down 'tableau)
	50	(add-extended-slot '() down 'tableau)
	51	(add-extended-slot '() down 'tableau)
	52	(add-extended-slot '() down 'tableau)
	53	(add-extended-slot '() down 'tableau)
	54	(add-extended-slot '() down 'tableau)
	55	(add-extended-slot '() down 'tableau)
	56
	57	(deal-tableau tableau)
	58
	59	(set! choices 3)
	60	(set! start-value 0)
	61
	62	(give-status-message) ; this isn't actually displayed at the moment
	63
	64	(list 7 3.25) ; width and height of playing area
	65	)
	66
	67	(define (deal-tableau tableau)
	68	(if (not (null? tableau))
	69	(begin
	70	(deal-cards-face-up stock tableau)
	71	(deal-tableau (cdr tableau)))))
	72
	73	;; Status messages
	74
	75	(define (give-status-message)
	76	(set-statusbar-message (string-append (get-stock-no-string)
	77	" "
	78	(get-start-value-string))))
	79
	80	(define (get-value-name value)
	81	(cond ((eq? value ace) (_"ace"))
	82	((eq? value 2) (_"two"))
	83	((eq? value 3) (_"three"))
	84	((eq? value 4) (_"four"))
	85	((eq? value 5) (_"five"))
	86	((eq? value 6) (_"six"))
	87	((eq? value 7) (_"seven"))
	88	((eq? value 8) (_"eight"))
	89	((eq? value 9) (_"nine"))
	90	((eq? value 10) (_"ten"))
	91	((eq? value jack) (_"jack"))
	92	((eq? value queen) (_"queen"))
	93	((eq? value king) (_"king"))
	94	(#t (_"Unknown value"))))
	95
	96	(define (get-start-value-string)
	97	(if
	98	(> start-value 0)
	99	(string-append (_"Start card:") " " (get-value-name start-value))
	100	(string-append (_"Choices left:") " " (number->string choices))))
	101
	102	(define (get-stock-no-string)
	103	(string-append (_"Stock left:") " "
	104	(number->string (length (get-cards 0)))))
	105
	106	;; Interactions
	107
	108	(define (button-pressed start-slot card-list)
	109	(cond ((= start-slot stock) #f)
	110	((= 0 start-value) (= start-slot chooser))
	111	(else (valid-list? card-list))))
	112
	113	(define (button-released start-slot card-list end-slot)
	114	(if (droppable? start-slot card-list end-slot)
	115	(complete-transaction start-slot card-list end-slot)
	116	#f))
	117
	118	(define (button-clicked start-slot)
	119	(cond ((not (= start-slot stock)) #f)
	120	((> choices 0) (choose-next))
	121	((= 0 start-value) #f)
	122	((not (empty-slot? stock)) (do-deal-next-cards))
	123	(else #f)))
	124
	125	; find the longest prefix of xs which satisfies the predicate p (p is applied
	126	; to the entire list, not to individual elements); return a pair, first element
	127	; is the prefix, second element is the remainder of the list
	128	(define (split-with-list-pred p xs)
	129	(define (helper a b)
	130	(cond ((null? a) (cons a b))
	131	((p a) (cons a b))
	132	(else (helper (drop-right a 1) (append (take-right a 1) b)))))
	133	(helper xs '()))
	134
	135	(define (button-double-clicked start-slot)
	136	(cond
	137	((= start-slot stock) #f) ; cannot happen - actually deals twice
	138	((empty-slot? start-slot) #f)
	139	((member start-slot foundation) #f)
	140	((= start-slot chooser)
	141	(complete-transaction chooser
	142	(list (remove-card chooser))
	143	(car foundation)))
	144	((= 0 start-value) #f)
	145	((let ((end-slot (find-foundation-for (get-top-card start-slot))))
	146	(if end-slot
	147	(let ((split (split-with-list-pred valid-list?
	148	(get-cards start-slot))))
	149	(set-cards! start-slot (cdr split))
	150	(complete-transaction start-slot (car split) end-slot))
	151	#f)))
	152	(else #f)))
	153
	154	;; Rules
	155
	156	(define (choose-next)
	157	(set! choices (- choices 1))
	158	(if (not (empty-slot? chooser))
	159	(set-cards! stock (append (get-cards stock)
	160	(list (flip-card (remove-card chooser))))))
	161	(flip-stock stock chooser 2 1)
	162	#t)
	163
	164	(define (dealable?)
	165	(and
	166	(not (= 0 start-value))
	167	(> (length (get-cards stock)) 0)))
	168
	169	(define (do-deal-next-cards)
	170	(deal-cards-face-up stock
	171	(if (= (length (get-cards stock)) 2)
	172	(list-head tableau 2)
	173	tableau))
	174	#t)
	175
	176	(define (find-foundation-for card)
	177	(let ((value (get-value card))
	178	(suit (get-suit card)))
	179	(if (= start-value value)
	180	(find empty-slot? foundation)
	181	(let ((found (find (lambda (f)
	182	(and (not (empty-slot? f))
	183	(= suit (get-suit (get-top-card f)))))
	184	foundation)))
	185	(if (and found
	186	(value-ok? value (get-value (get-top-card found))))
	187	found
	188	#f)))))
	189
	190	(define (complete-transaction start-slot card-list end-slot)
	191	(add-cards! end-slot
	192	(if (member end-slot foundation)
	193	(reverse card-list) card-list))
	194	(if (member start-slot foundation)
	195	(add-to-score! -1)) ; can't move more than one off
	196	(if (member end-slot foundation)
	197	(begin
	198	(add-to-score! (length card-list))
	199	(if (= start-value 0)
	200	(begin
	201	(set! choices 0)
	202	(set! start-value (get-value (car card-list)))))))
	203	#t)
	204
	205	(define (value-ok? x y)
	206	(and
	207	(not (= start-value x))
	208	(or
	209	(= x (+ y 1))
	210	(and (= x ace) (= y king)))))
	211
	212	(define (in-sequence? l)
	213	(or
	214	(= (length l) 1)
	215	(and
	216	(value-ok? (cadr l) (car l))
	217	(in-sequence? (cdr l)))))
	218
	219	(define (valid-list? lyst)
	220	(let ((suit (get-suit (car lyst))))
	221	(and
	222	(every (lambda (c) (= suit (get-suit c))) lyst)
	223	(in-sequence? (map get-value lyst)))))
	224
	225	(define (colour-match? a b)
	226	(and (eq? (is-red? a) (is-red? b))
	227	(value-ok? (get-value a) (get-value b))))
	228
	229	(define (suit-match? a b)
	230	(and (eq? (get-suit a) (get-suit b))
	231	(value-ok? (get-value a) (get-value b))))
	232
	233	(define (droppable? start-slot card-list end-slot)
	234	(cond
	235	((member end-slot (list start-slot stock chooser)) #f)
	236	((member end-slot tableau)
	237	(and (> start-value 0)
	238	(or (empty-slot? end-slot)
	239	(colour-match? (get-top-card end-slot) (last card-list)))))
	240	; at this point, end-slot must be a member of foundation
	241	((= start-value 0) (= start-slot chooser))
	242	((empty-slot? end-slot) (= start-value (get-value (car card-list))))
	243	(else (suit-match? (car card-list) (get-top-card end-slot)))))
	244
	245	;; Hints
	246
	247	; These hints are simple-minded: they suggest possible moves, but don't
	248	; look ahead to find winning moves. They don't even attempt to find
	249	; suitable cards to fill empty slots. Having exhausted all suit matches,
	250	; they will recommend any possible colour match. Also, there are
	251	; occasions when a colour match is actually preferable to a suit match.
	252	; However, the "Deal another round" hint is only displayed when there
	253	; are no more moves.
	254
	255	(define (cartesian-product xs ys)
	256	(append-map (lambda (x) (map (lambda (y) (cons x y)) ys)) xs))
	257
	258	; all tableau-foundation pairs
	259	(define t-f-pairs (cartesian-product tableau foundation))
	260
	261	; all tableau-tableau pairs
	262	(define t-t-pairs
	263	(filter (lambda (x) (not (= (car x) (cdr x))))
	264	(cartesian-product tableau tableau)))
	265
	266	(define card #f)
	267	(define color 0)
	268	(define suit 0)
	269	(define value 0)
	270	(define slot-id1 0)
	271
	272	(define (not-chosen)
	273	(and
	274	(= start-value 0)
	275	(if (= choices 3)
	276	(hint-click chooser (_"Turn over the top card of the stock."))
	277	(hint-move chooser 1 (car foundation)))))
	278
	279	(define (valid-move? start end)
	280	(and
	281	(not (empty-slot? start))
	282	(droppable? start (list (get-top-card start)) end)))
	283
	284	; Given a slot, return the longest moveable sequence of cards in it
	285	(define (get-moveable slot)
	286	(car (split-with-list-pred valid-list? (get-cards slot))))
	287
	288	; Given a pair of slots, start and end, hint if there is a valid move from
	289	; start to end. If the end slot is a foundation, the hint is just the first
	290	; card. If in the tableau, the hint must be the longest moveable list of cards.
	291	(define (maybe-hint p)
	292	(letrec ((start (car p))
	293	(end (cdr p))
	294	(cards (if (member end foundation)
	295	(list (get-top-card start))
	296	(get-moveable start))))
	297	(and
	298	(not (empty-slot? start))
	299	(droppable? start cards end)
	300	(hint-move start (length cards) end))))
	301
	302	(define (hint-foundation)
	303	(or-map maybe-hint t-f-pairs))
	304
	305	(define (maybe-suit p)
	306	(and
	307	(not (empty-slot? (car p)))
	308	(not (empty-slot? (cdr p)))
	309	(= (get-suit (get-top-card (car p)))
	310	(get-suit (get-top-card (cdr p))))
	311	(maybe-hint p)))
	312
	313	(define (get-hint)
	314	(or
	315	(not-chosen)
	316	; Move to foundation?
	317	(or-map maybe-hint t-f-pairs)
	318	; Match within suit?
	319	(or-map maybe-suit t-t-pairs)
	320	; Empty slot?
	321	(and
	322	(or-map empty-slot? tableau)
	323	(list 0 (_"Fill an empty slot.")))
	324	; Colour matches are the last resort...
	325	(or-map maybe-hint t-t-pairs)
	326	; ... apart from dealing, of course.
	327	(and
	328	(not (empty-slot? stock))
	329	(hint-click stock (_"Deal a new round.")))
	330	; If all else fails.
	331	(list 0 (_"Try moving cards down from the foundations."))))
	332
	333	(define (game-won) (= (get-score) 52))
	334
	335	; We never say "game over".
	336	(define (game-over)
	337	(give-status-message)
	338	(not (game-won)))
	339
	340	(define (get-options) #f)
	341
	342	(define (apply-options options) #f)
	343
	344	(define (timeout) #f)
	345
	346	(set-features dealable-feature droppable-feature)
	347
	348	(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)
	349
	350	; This game is sometimes called Agnes, but I call it Hamilton after my
	351	; father, Geoffrey Hamilton Goodwin (b. 1937), who taught me the game
	352	; many many years ago. #t

+145

-0

help/C/hamilton.xml less more

	0	<?xml version="1.0" encoding="utf-8" ?>
	1	<!DOCTYPE refentry PUBLIC "-//OASIS//DTD DocBook XML V4.3//EN"
	2	"http://www.oasis-open.org/docbook/xml/4.3/docbookx.dtd" [
	3	]>
	4	<sect1 id="Hamilton"> <!--<sect1info>
	5	<copyright>
	6	<year>2014</year>
	7	<holder>Timothy Goodwin</holder>
	8	</copyright>
	9	<author>
	10	<firstname>Timothy</firstname>
	11	<surname>Goodwin</surname></author>
	12	<address><email>toby@flare.email</email></address>
	13	</sect1info>-->
	14
	15	<title>Hamilton</title>
	16
	17	<para>Written by Timothy Goodwin</para>
	18
	19	<sect2><title>Setup</title>
	20
	21	<informaltable>
	22	<tgroup cols="2">
	23	<tbody>
	24	<row>
	25	<entry>Type of Deck</entry>
	26	<entry>Standard Deck</entry>
	27	</row>
	28	<row>
	29	<entry>Stock</entry>
	30	<entry>
	31	Top left pile. The rest of the deck is placed here after
	32	dealing the Tableau. The first three cards may be turned
	33	over one at a time to Chooser. After choosing a Start card,
	34	clicking on Stock deals one card face up to each pile in the
	35	Tableau.
	36	</entry>
	37	</row>
	38	<row>
	39	<entry>Chooser</entry>
	40	<entry>
	41	Top left, next to Stock. While the Start card is being
	42	chosen, clicking Stock deals the top card face up to
	43	Chooser. The card in Chooser can be moved to a Foundation.
	44	Or if Stock is clicked again, it is returned face down to
	45	the bottom of Stock, and the next card moved to Chooser.
	46	</entry>
	47	</row>
	48	<row>
	49	<entry>Foundation</entry>
	50	<entry>
	51	Four piles top right. To be built up in suit from the
	52	chosen Start card to King, then Ace to the card with value
	53	one less than the Start Card.
	54	</entry>
	55	</row>
	56	<row>
	57	<entry>Tableau</entry>
	58	<entry>
	59	Seven piles. Deal one card face up to each pile. Start the
	60	second row on the second pile in the Tableau, and deal one
	61	card face up to each pile except the first. Repeat, till
	62	there are seven cards in the last pile. The Tableau can be
	63	built down by matching color. Groups of cards in order and
	64	in suit can be moved. Empty piles can be filled by any card
	65	or group of cards in order and in suit.
	66	</entry>
	67	</row>
	68	</tbody>
	69	</tgroup>
	70	</informaltable>
	71
	72	</sect2>
	73
	74	<sect2><title>Goal</title>
	75	<para>
	76	Move all cards to the Foundation piles.
	77	</para>
	78	</sect2>
	79
	80	<sect2><title>Rules</title>
	81	<para>
	82	To start the game, one card is flipped over from the Stock to the
	83	Chooser. This card can be moved to a Foundation, in which case it
	84	is the Start card for this game. Otherwise, the card in the Chooser
	85	is returned face down to the bottom of the stock, and the next card
	86	flipped over from Stock to Chooser. If none of the first three
	87	cards is chosen, the game is over. Double clicking on the Chooser
	88	will move the card there to a Foundation.
	89	</para>
	90	<para>
	91	Cards in the Tableau are built down by color. A King may be placed
	92	on an Ace (unless the Start card is Ace). Groups of cards that are
	93	in suit can be moved. An empty pile in the Tableau can be filled
	94	with any card, or with a group of cards that are in order and all
	95	the same suit.
	96	</para>
	97	<para>
	98	Foundations are built up in suit from the Start card to King, then
	99	Ace, Two, and so on to one less than the Start card. For example,
	100	if the Start card is Seven, the Foundations are built up from Seven
	101	to King, Ace to Six. Cards in Foundations are still in play.
	102	</para>
	103	<para>
	104	A group of cards that are in order and all the same suit can be
	105	moved to a Foundation in a single move. Double clicking on a pile
	106	in the Tableau will move all possible cards from that pile to the
	107	Foundation.
	108	</para>
	109	</sect2>
	110
	111	<sect2><title>Scoring</title>
	112	<para>
	113	Each card removed scores one point.
	114	</para>
	115	<para>
	116	Maximum possible score: 52
	117	</para>
	118	</sect2>
	119
	120	<sect2><title>Strategy</title>
	121	<para>
	122	Choose wisely. If you cannot move to the Foundation all visible
	123	cards of the Start value, you are unlikely to win. An empty slot in
	124	the Tableau is invaluable.
	125	</para>
	126	</sect2>
	127
	128	<sect2><title>Dedication</title>
	129	<para>
	130	This game is dedicated to, and named for, my father: Geoffrey
	131	Hamilton Goodwin (b. 1937). He taught me many patience (or
	132	solitaire) games; we both consider Hamilton the most interesting
	133	single-pack game.
	134	</para>
	135	</sect2>
	136
	137	<sect2><title>References</title>
	138	<para>
	139	This game is found under the name <emphasis>Agnes</emphasis> in the book
	140	<emphasis>Games of Patience</emphasis> by <emphasis>Basil
	141	Dalton</emphasis>, London 1924.
	142	</para>
	143	</sect2>
	144	</sect1>

-0

help/C/index.docbook less more

245	245	<xi:include href="gold_mine.xml" />
246	246	<xi:include href="golf.xml" />
247	247	<xi:include href="gypsy.xml" />
	248	<xi:include href="hamilton.xml" />
248	249	<xi:include href="helsinki.xml" />
249	250	<xi:include href="hopscotch.xml" />
250	251	<xi:include href="isabel.xml" />

-0

help/Makefile.am less more

48	48	glenwood.xml \
49	49	golf.xml \
50	50	gypsy.xml \
	51	hamilton.xml \
51	52	helsinki.xml \
52	53	hopscotch.xml \
53	54	isabel.xml \

-1

help/sol.6 less more

55	55	Cover, Elevator, Fortress, Giant, Spider, Gaps, Bakers Dozen, Whitehead,
56	56	Freecell, Helsinki, Spider Three Decks, Scuffle, Poker, Klondike Three Decks,
57	57	Valentine, Royal East, Thumb And Pouch, Klondike, Doublets, Template, Golf,
58		Westhaven, Beleaguered Castle, Hopscotch, Eliminator, Aunt Mary
	58	Westhaven, Beleaguered Castle, Hopscotch, Eliminator, Aunt Mary,
	59	Hamilton
59	60	.RE
60	61
61	62	.SH OPTIONS

-0

po/POTFILES.in less more

60	60	games/gold-mine.scm
61	61	games/golf.scm
62	62	games/gypsy.scm
	63	games/hamilton.scm
63	64	games/helsinki.scm
64	65	games/hopscotch.scm
65	66	games/isabel.scm

-7

src/game-names.h less more

283	283	locale, use that; otherwise you can translate this string
284	284	freely, literally, or not at all, at your option.
285	285	*/
	286	N_("Hamilton")
	287
	288	/* Translators: this string is the name of a game of patience.
	289	If there is an established standard name for this game in your
	290	locale, use that; otherwise you can translate this string
	291	freely, literally, or not at all, at your option.
	292	*/
286	293	N_("Helsinki")
287	294
288	295	/* Translators: this string is the name of a game of patience.

346	353	locale, use that; otherwise you can translate this string
347	354	freely, literally, or not at all, at your option.
348	355	*/
349		N_("Klondike Three Decks")
350
351		/* Translators: this string is the name of a game of patience.
352		If there is an established standard name for this game in your
353		locale, use that; otherwise you can translate this string
354		freely, literally, or not at all, at your option.
355		*/
356	356	N_("Labyrinth")
357	357
358	358	/* Translators: this string is the name of a game of patience.