woods%colossal@Sun.COM (Don Woods) (01/17/90)
Here is the source for a NeWS implementation of Spider, a fairly complex
solitaire card game. See the front of the file for info on running it. (It
requires OPEN WINDOWS 1.0 or later, i.e., X11/NeWS instead of NeWS 1.1.) The
source is split into two postings; this is the first. The documentation will
be in a third posting. (It consists mainly of increasingly complex sample
positions to give you a feel for the game.)
I don't always have time to follow this newsgroup, so if you have questions
or comments please send mail to woods@sun.com.
-------------------- cut here ----------------------------------
% Copyright (c) 1989, Donald R. Woods and Sun Microsystems, Inc.
%
% Permission to use, copy, modify, distribute, and sell this software and its
% documentation for any purpose is hereby granted without fee, provided that
% the above copyright notice appear in all copies and that both that copyright
% notice and this permission notice appear in supporting documentation, and
% that the names of Donald Woods and Sun Microsystems not be used in
% advertising or publicity pertaining to distribution of the software without
% specific, written prior permission. Donald Woods and Sun Microsystems make
% no representations about the suitability of this software for any purpose.
% It is provided "as is" without express or implied warranty.
%
% THE ABOVE-NAMED DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
% INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT
% SHALL DONALD WOODS OR SUN MICROSYSTEMS BE LIABLE FOR ANY SPECIAL, INDIRECT OR
% CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE,
% DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
% TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
% OF THIS SOFTWARE.
%
% History: Spider is a solitaire card game that can be found in various books
% of same; the rules are presumed to be in the public domain. The author's
% first computer implementation was on the Stanford Artificial Intelligence Lab
% system (SAIL). It was later ported to the Xerox Development Environment.
% The card images are loosely based on scanned-in images but were largely
% redrawn by the author with help from Larry Rosenberg.
%
% This program is written entirely in NeWS and runs on OPEN WINDOWS 1.0.
% It could be made to run much faster if parts of it were written in C, using
% NeWS mainly for its display and input capabilities, but that is left as an
% exercise for the reader. Spider may also run with little or no modification
% on subsequent releases of OPEN WINDOWS, but no guarantee is made on this
% point (nor any other; see above!). To run Spider, feed this file to 'psh'.
%
% Author: Don Woods
% woods@sun.com
%
% Sun Microsystems, Inc.
% 2550 Garcia Avenue
% Mountain View, CA 94043
%
% CardUtils is a mix-in class, never intended to be instantiated. Mostly it
% defines colors and names.
%
/CardUtils nullarray nullarray classbegin
/grey {dup dup rgbcolor} def
/BLACK 0 grey def
/WHITE 1 grey def
/HALF .5 grey def
framebuffer /Color get {
/RED .8 0 0 rgbcolor def
/SUN 140 10 210 RGBcolor def
% for face-down cards; should replace with corporate color
/BACK .9 grey def
/FELT .2 .8 .6 rgbcolor def
/EDGE .7 grey def
/BLANK {FELT colorhsb exch 2 div exch hsbcolor} def
/PANEL BLANK def
} {
/RED .8 0 0 rgbcolor def
/SUN HALF def
/BACK WHITE def
/FELT HALF def
/EDGE HALF def
/BLANK .6 grey def
/PANEL WHITE def
} ifelse
/Suits [
/Spade /Heart /Diamond /Club
] def
/Ranks [
/King /Queen /Jack /Ten /Nine /Eight
/Seven /Six /Five /Four /Three /Deuce /Ace
] def
% Dict that maps a rank into the next higher rank.
%
/Above dictbegin
null Ranks { % r+1 r
dup 3 -1 roll def % r
} forall pop
dictend def
% Default for classes that don't actually care about specific mouse loc.
%
/CardAtPoint { % event => card
pop null
} def
% Method by which children can send an event to the SpiderCanvas.
%
/SendParent { % /meth => -
Parent dup null ne { % /meth parent
createevent begin
/Canvas exch def
/Action exch def
/Name /CallMethod def
/TimeStamp lasteventtime def
currentdict end sendevent
} {
pop pop
} ifelse
} def
% Utilities for accessing optional instance variable: index in parent.
/ParentIndex null def % promoted
/setindex { % any => -
/ParentIndex exch promote
} def
/getindex { % - => any
ParentIndex
} def
% Dict for translating Ranks and Suits into compact strings.
/Compact dictbegin
/King (K) def /Nine (9) def /Six (6) def /Three (3) def
/Queen (Q) def /Eight (8) def /Five (5) def /Deuce (2) def
/Jack (J) def /Seven (7) def /Four (4) def /Ace (A) def
/Ten (10) def
/Spade (s ) def /Heart (h ) def /Hyphen (-) def
/Diamond (d ) def /Club (c ) def
dictend def
% Convert /suit and /rank into a short string.
%
/CompactText { % suit rank => (Rs )
Compact exch get exch
Compact exch get append
} def
/CardWidth 79 def
/CardHeight 123 def
classend def
/CardImage [Object CardUtils]
[
/Canvas % parent canvas on which we paint
/X /Y % lower left corner where we paint
/Suit % name of suit class var (/Club, /Diamond, ...)
/SuitDict % dict obtained by looking up /Suit
/Rank % name of rank (/Ace, /Deuce, /Three, ...)
/RankProc % proc obtained by looking up /Rank
/Type % method name: /FaceUp, /FaceDown, /Joker, etc.
/AllVisible? % false if lower 2/3 or so is covered up
]
classbegin
% Class variables:
/Depth 0 def % promoted: extra card edges parent should show
% Methods:
/newinit { % suit rank type => --
/newinit super send
/setcard self send
/AllVisible? true def
} def
/destroy { % - => -
/Canvas null def
} def
/setdepth { % n => --
dup 0 ne {/Depth exch promote} {pop /Depth unpromote} ifelse
} def
/setcard { % suit rank type => --
/Type exch def
/Rank 1 index def
/RankProc exch dup type /nametype eq {load} if def
/Suit 1 index def
/SuitDict exch dup type /nametype eq {load} if def
} def
/setall { % suit rank type depth => --
/setdepth self send
/setcard self send
} def
% Erase old stack lines if about to make it shorter.
% Assumes current canvas is correct.
%
/shorter? { % depth => --
Depth lt {/FillColor Canvas send dup Stack} if
} def
/getcard { % -- => suit rank type
Suit Rank Type
} def
/getall { % -- => suit rank type depth
Suit Rank Type Depth
} def
/insertname { % (before...) (...after) => (before...Suit Rank...after)
Rank dup length string cvs exch append
Suit dup length string cvs ( ) append
exch append append
} def
% If argument is true, make the card be faceup; else make it facedown.
% Return true if state of card was changed.
%
/expose { % expose? => changed?
/FaceUp /FaceDown ifelse % want
dup Type ne /Type 3 -1 roll def
} def
/setvisible { % bool => -
/AllVisible? exch def
} def
/paint { % -- => --
Canvas null ne {
gsave
Canvas setcanvas
/PaintCard self send
grestore
} if
} def
% Given an array of instances (on the current canvas), paint them all.
% Avoids overhead of individual sends. Also avoids painting any cards
% outside the clip (includes 5-pixel slop to account for card borders).
%
/paintarray { % [cards] => --
clipcanvaspath pathbbox exch pop 5 add
3 1 roll exch pop 5 sub CardHeight sub % [cards] ymax ymin
3 -1 roll {
begin % put instance on dict stack as if sending to it
2 copy Y le exch Y ge and {PaintCard pause} if
end
} forall
pop pop
} def
% Paint card, assuming currentcanvas is correct.
%
/PaintCard { % -- => --
X Y moveto Type self send
Depth 0 ne {PaintStack} if
} def
/PaintStack { % -- => --
.4 grey .9 grey Stack
} def
/FaceUp { % -- => --
EDGE nullproc WHITE /Border self send
SuitDict dup /color get setcolor % suit
dup RankProc exec % suit rankbits
[ 9 14 4 -1 roll ] % suit rankpip
4 CardHeight 20 sub 3 copy pip did % suit
/small get dup 0 get % smallpip w
-2 idiv 8 add CardHeight 35 sub 3 copy pip did
} def
% Lazy evaluation of cached image for facedown card.
%
/FaceDownImage { % - => canvas
gsave
CardWidth CardHeight monochromecanvas 1 8 ifelse [] null buildimage
dup setcanvas
BACK setcolor clippath fill
SUN setcolor
CardWidth CardHeight true []
{<cce666733339999cccce 9e0ccf06678333c199e0 1b198d8cc6c6636331b0
19930cc98664c3326198 ccc6666333319998cccc 6664333219990ccc8666
33319998cccc66663332 9998cccc666633331998 ccc26661333099984ccc
6666333319998cccc666 330c99864cc326619330 1b198d8cc6c6636331b0
0f33079983ccc1e660f2 e666733339999cccce66 f0ccf8667c333e199f0c
319998cccc6666333318 61f330f9987ccc3e661e>}
imagemask
grestore
/FaceDownImage 1 index store
} def
/FaceDown { % -- => --
/path self send
gsave
clip % seems to be necessary even though this is the same
% path as the boundary of the FaceDownImage canvas
X Y translate CardWidth CardHeight scale
FaceDownImage imagecanvas
grestore
2 setlinewidth HALF setcolor stroke
} def
/Joker { % -- => --
EDGE nullproc WHITE /Border self send
[35 88 {<0000e00000 0001e00000 0001c00000 0001ef0000 0003f18000
0033f3c000 007ffc4000 00d7fcc000 01838cc000 03bf060000
03c56f0000 03840b0000 03821a0000 0181460000 00813a0000
0181820000 0183c70000 0007ffc000 001ffff800 003ffffc00
007ffffe00 03fbffef80 0373ffe1c0 0079efd0e0 00d1c7f040
00f0c3e840 01b081a560 01d000c7a0 0130018620 0110798d20
0211831820 03200d3060 0420f3e180 0450044300 0490046e00
048e063000 049fdd1000 089ffcf000 0d9ffe2000 1f1fffc000
3f3fff8000 3fbfff8000 3fbfffc000 1fbfffc000 17bfffe000
237fffe000 227ffff000 2a5fbff800 2ecf9fc800 2acf8f8000
3e0f890000 180f998000 080f998000 080f820000 080f820000
080f820000 0a0fc20000 0f27c20000 2dc7c40000 3a87c40000
2f87c40000 3f07c40000 7a03ca0000 8903ca0000 0b83d20000
0c81c20000 0f81ca0000 0f01c20000 0601c20000 0001c20000
0001c20000 0001c40000 0001c40000 0001c40000 0001cc0000
0000cc0000 0006cc0000 0007ce0000 0001fc0000 00037c0000
0006f80000 000cfc0000 0019fc0000 03633e0000 03fe1e0000
00000f0000 000007d800 000001f800>}] centerpip
[4 38 {<10 10 10 10 90 60 00 00 60 90 90 90 90 60 00 00 90 a0 c0 c0 a0
90 00 00 f0 80 e0 80 80 f0 00 00 e0 90 90 e0 90 90>}]
4 CardHeight 44 sub 3 copy pip did
} def
/Blank { % -- => --
EDGE nullproc BLANK /Border self send
} def
/Border { % edgecolor <args> proc fillcolor => --
gsave
/path self send setcolor fill
/path self send
exec
setcolor 2 setlinewidth stroke
grestore
} def
/path { % -- => --
5 X Y CardWidth CardHeight rrectpath
} def
/size { % -- => w h
CardWidth CardHeight
} def
/location { % -- => x y
X Y
} def
/relocate { % x y canvas => --
/Canvas exch def
/Y exch def
/X exch def
} def
/Stack { % darkcolor lightcolor => --
% assumes parent is current canvas
gsave
X 0.7 sub Y 0.7 add moveto % dark light
Depth dup -2 mul dup neg 0 6 -1 roll % ... depth dx dy width dark
Depth currentpoint 2.5 10 -1 roll % ... depth dx dy width light
2 {
setcolor setlinewidth translate {
2 -2 translate
3 0 moveto CardWidth 5 sub 5 5 270 0 arc
CardWidth CardHeight 3 sub lineto
stroke
} repeat
} repeat
grestore
} def
% Utilities:
/pip { % [w h bitsproc] dx dy => --; shows pip at currentpoint
gsave
rmoveto
aload pop true exch % w h true bits
[ 4 index 0 0 6 index dup neg 0 3 -1 roll ] % w h true bits [matrix]
exch currentpoint translate
5 -2 roll 2 copy 7 2 roll scale
imagemask
grestore
} def
/did { % same as pip but upside down
AllVisible? {
gsave
exch CardWidth exch sub exch CardHeight exch sub rmoveto
aload pop true exch
[ 4 index neg 0 0 6 index dup 0 exch ]
exch currentpoint translate
5 -2 roll 2 copy 7 2 roll scale
imagemask
grestore
} {
pop pop pop
} ifelse
} def
/qiq { % same as pip but reflected across vertical axis
gsave
exch CardWidth exch sub exch rmoveto
aload pop true exch
[ 4 index neg 0 0 6 index dup neg 0 3 -1 roll ]
exch currentpoint translate
5 -2 roll 2 copy 7 2 roll scale
imagemask
grestore
} def
/bib { % same as pip but reflected across horizontal axis
AllVisible? {
gsave
CardHeight exch sub rmoveto
aload pop true exch
[ 4 index 0 0 6 index dup 0 exch ]
exch currentpoint translate
5 -2 roll 2 copy 7 2 roll scale
imagemask
grestore
} {
pop pop pop
} ifelse
} def
/centerpip { % pip => --
AllVisible? {
dup aload pop pop % pip w h
CardHeight sub -2 idiv exch
CardWidth sub -2 idiv exch
pip
} {
pop
} ifelse
} def
/twopips { % pip => --
dup aload pop pop
CardHeight 1.6 mul sub -2 div round exch
CardWidth sub -2 idiv exch
3 copy pip
did
} def
/fourpips { % pip => --
dup aload pop pop % pip w h
CardHeight 1.6 mul sub -2 div round exch
CardWidth .6 mul sub -2 div round exch
3 copy pip
3 copy did
3 copy qiq
bib
} def
/sixpips { % pip => --
dup fourpips
AllVisible? {
dup aload pop pop % pip w h
CardHeight sub -2 idiv exch
CardWidth .6 mul sub -2 div round exch
3 copy pip
qiq
} {
pop
} ifelse
} def
/eightpips { % pip => --
dup fourpips
AllVisible? {
dup aload pop pop % pip w h
CardHeight 1.2 mul sub -2 div round exch
CardWidth .6 mul sub -2 div round exch
3 copy pip
3 copy did
3 copy qiq
bib
} {
pop
} ifelse
} def
/facecard { % bits => --
[ 47 46 4 -1 roll ]
CardWidth 47 sub 2 idiv CardHeight 2 idiv
3 copy pip
did
gsave
CardWidth 48 sub 2 idiv CardHeight 91 sub 2 idiv rmoveto 48 92 rect
% BLACK setcolor
0 setlinewidth stroke
grestore
} def
% Image definitions:
/Club dictbegin
/color BLACK def
/small [9 11 {<1c00 3e00 3e00 1c00 6b00 ff80 ff80 ff80 6b00 0800 1c00>}]
def
/normal [15 16 {<0380 07c0 0fe0 0fe0 0fe0 07c0 3bb8 7ffc fffe fffe fffe
7d7c 3938 0380 0380 07c0>}] def
/big normal def
/jack {<06d556d6c000 036b6aad8700 01b556db0f80 81db6ab61fc0
c16f7eec1fc0 627000181fc0 b2bffff00f80 d9bffff07770
ed2002b0fff8 062002a9fffc ff38faa9fffc 202502a9fffc
2078f2a8fff8 203262a87270 203a72a80200 202402a80700
202702ae0700 202202ba0f80 202042ea0000 201782aa0000
f01306ac0000 48180e3e0000 e4ec3bff8000 2797e07be000
e738f9eb7800 2f985f975e02 f73b46235786 2b98606b7eec
3d3879c36f78 3eab7fd77ea8 37585f835748 2bb847ab5698
3df362037f88 36f0bb5f6f08 2f50dc0b7e68 3db6aaf35e08
2de0d82b6418 3da1b5cb85a8 39ad50a62828 3b41b7298858
3b4352903658 335abcacd0b8 3683524160b8 3686abb6ad78
36b55d4d6178 3d06b6dac178>} def
/queen {<033749400000 07f794c00700 87f522400f80 c36549401fc0
406f94c01fc0 666df3c01fc0 2feb04400f80 2feaf7c07770
26ce6740fff8 20da75e1fffc 2dda0251fffc 7fd21649fffc
5f9e0ce4fff8 4fb404f27270 f3b404b90200 1b24209c8700
0f7e3dce4700 076f0de64f80 0e4f83f72000 0edac23b2000
1cf0fe8f2000 1d942a272000 393f00bb2080 3321edc3c140
77f13e46c360 645bb6ec6490 ccceebb8f36c ddfc5d1fd954
97dfebf58ca4 36aaf72f9fa8 6f779c35985c 7aaa883b9fa2
dddd47358fcc aaaac71fc6f2 77775ad6ed74 aaaadddc7a9a
dddddad4f5ec aaaac21cda16 777747180dca afeaa0180e26
f81de1181794 c003a3999bd6 80c0e55995d4 d8c0aee80aea
780c54540734 b00c793c601a>} def
/king {<000d04104160 01c7041041c0 03e3db6db780 07f184104300
07f0fffffe00 07f06aaaac00 03e035555800 1ddc3ffff000
3ffe3ffff000 7fff20055010 7fff3c755038 7fff2e65507c
3ffe3e7d505c 1c9c24055054 00802405505c 01c027855054
01c02205505c 03e02d855c54 0000e205745c 0001271dd454
000160e55c5c 000707357854 001f8f844c5c 007ff9ffd654
01fffc44475c 07fffd111fd4 1ffbfe447ddc 7ffd7f11f3d4
ffefafc7c65c fe6cd7ff8cd4 7c6c6f7c1e5c 7def570038d6
7bc7ab1c73de 7f39f71c79d6 7efeeb6b63de 7dd77577cfd6
7bbbab6bc7de ff55d508efd6 deeeeb1ccfde be54d7e19fd6
3f93b9319fde 1fff6109dff0 3fe66d6d9f1e 7feb4c65bf70
f3f341059f7e 1bf77bbddfb0>} def
dictend def
/Diamond dictbegin
/color RED def
/small [7 12 {<10 10 38 38 7c fe 7c 38 38 10 10 00>}] def
/normal [13 19 {<0200 0200 0700 0700 0f80 1fc0 1fc0 3fe0 7ff0 fff8
7ff0 3fe0 1fc0 1fc0 0f80 0700 0700 0200 0200>}] def
/big normal def
/jack {<0073b76e7000 0039b76ce100 001c3061c100 800fffff8380
c00fffff0380 e00d400307c0 601542030fe0 a0157c3f0fe0
601541431ff0 a0557e5f3ff8 60d55c5d7ffc a19544453ff8
629540451ff0 a51540250fe0 791540e50fe0 e215400507c0
447544050380 089543ebc382 b0f5c1892106 e0866014a10e
a1783822300c 23260fe3ec08 6699c01ccb0a ef663fe33bce
73b1c01c7bba 35dc3fe1fdb8 e8ebc01f7ddc 2d777ff76eee
ea3bdddd6e7c 2d5d77776f38 e896dddd6f9a 2d5b77776bce
f237bddd6fea 355bd77768f8 b8976ddd6ffc f55b7777681e
aa37dbdd6ffc 3d5bdd776808 689736dd6ffa f55eeb77681e
6e3ed5bd6fea 3559bad76a38 acb7456d6fec f7779ab76dde
adcedb5b7aec 34bd628d7a58>} def
/queen {<208f92800000 13ed29800100 109e44c00100 111a82a00380
17fd01900380 1137eed007c0 127a11e80fe0 1fe9f7e40fe0
12f0cef21ff0 24d8ebfa3ff8 3fe808f97ffc 25b804fd3ff8
43e835be9ff0 ff70095e4fe0 039001bf4fe0 02d8f95f47c0
071c33afa380 05460357a390 0f1307af9138 0bc584d7d154
1ff9793bd0ee 15ff45ffc854 3bbffffbe818 2f57ffd5e834
7feefeeff854 57f5555fdcaa faffbbfebf4a bf5ffff5fac4
fbabffab757a 73f5555fe9ac f64fabffeb46 e54ffe7ceaaa
ec4ff260ed10 cff4f27676aa da8c3b367c44 92aad931faaa
b98ad97f5510 3d721fd572aa 749df55fae44 7aa357f031aa
f6abf80f5510 faa307f951aa f69d7c028ec4 fab941fab92a
d6c55f5ac572 acd55bb5566a>} def
/king {<003444444580 011aaaaaab00 010c44444710 038711111220
0383aaaaae60 07c1911114a2 0fe0fff84ca6 0fe07fffa924
1ff0403fc956 3ff84f0ffa6e 7ffc508bfbb8 3ff85e0afbb8
1ff04d0aaa6e 0fe09e0aad56 0fe080055524 07c1440554a6
0381b202aaa6 03808c3aaa64 01004066aa26 010070daaa16
300060aaab04 6b0282a55506 5505555ffffe 6abaaafc6312
56fd5556b5a6 2b5effe318ce 1d2c7ffffffe 39a47bc000fe
4db235ffff82 ccf33b8c63da 671bbfdad7ea 6c7bbeb19d72
31e9b9bfaefa 27b49d35555e 4f141b6ad3be 9ab499d7f356
3474deace5ee 6ab5f554a4d4 d17adaac2e7a aafa55555554
44fa1ffb552e abda555fd394 179adffb594a a9dbf6ca594c
54fad938bce6 e47abffabc4e>} def
dictend def
/Heart dictbegin
/color RED def
/small [9 11 {<6300 f780 ff80 ff80 7f00 7f00 3e00 1c00 1c00
0800 0800>}] def
/normal [15 17 {<3838 7c7c fefe fefe fffe fffe 7ffc 7ffc 3ff8 1ff0
0fe0 0fe0 07c0 0380 0380 0100 0100>}] def
/big normal def
/jack {<065326530000 032b56a60000 8193264ce0e0 c0cb5699f1f0
e8630633fbf8 ec3ffff3fbf8 ea1ffff3fff8 e90aa013fff8
ec8aa7a1fff0 fc8aa321fff0 568aa520ffe0 558aa3907fc0
569540103f80 fc954c083f80 e91548d81f00 ea6a87200e00
ec9a80200e90 e96a81e004f0 e15ae0702460 e0e5581090b0
e37fae286fd0 effffffc1160 fce000032180 1cf122898240
e778fffe6570 7bfc01003958 6dce7ffe7ee8 9bcf2244cf50
b7779189cee0 6e3fca53bb60 dc9ce997fef8 b93cf5ae6b5e
7277742e76d6 e4effa5deb56 c9f59a5fdeda 93ab9db9bb4c
275fedb9d6d6 4ef8fe77eb5a 9f64667ffeec 3acfe6663b76
f59076664dba 6fbffe6fe6dc b75ffefff36e 5b5224489bb4
b751292915ea 5b56f29ed5b4>} def
/queen {<002aa0040000 003573047070 006ab388f8f8 00755b89fdfc
0068a809fdfc 00705cc9fffc 00ae7ce9fffc 00a20ee4fff8
00be7604fff8 00ae33347ff0 017e79ba3fe0 016201ba1fc0
016100c11fc0 017140ec8f80 02f181ff8700 02f081b00700
02f023fc0200 02e9c35e0210 05c8c7ff006c 05dc86afc054
05f40ffff0ba 05ea1ab3fc54 0bb5f573f86c 0bbaaadff012
0b4f578ff07e 0a89fcdfacec 1471246d0f04 193e278d2bd4
1267f81ce66e 2447c0185e4a 244fe6daba54 4ccbf57fe64a
948af2b5dc46 049cb937a4ce 2a9779735c9e 1a9bdc7354bc
489d9c6eacfa 399ddee6b4f4 2916eed6acea 213ee6fd54d4
71269fed6ca8 a936e7ad54d0 252eb99abca4 1125ee7af4c8
933d3b9ecc88 7a3bcee7b8bc>} def
/king {<001000000100 000db6db6e00 0006aaaaaa00 0003145144c0
000108208520 1c1c88208f40 3e3e7ffff97c 7f7f55555356
7f7f3ffff454 7fff20055354 7fff58f55154 3ffe65055f6a
3ffe7cf2aa40 1ffc5c32a9a2 0ff87c72ac7e 07f045015440
07f0460154fe 03e04202aa80 01c0c002abfe 01c34d84ab3c
0084c20b2a78 0089470a54f2 000f2015f9e4 001ad55593cc
0062aaae5796 03f4d056ff34 1e6a671f6658 75af3df6afd2
a99bcfc7b8e6 525ab01ab63e a52fafebe18e 4d9ababae262
924dabaf651c e9aafabea8b2 5cb76fede522 2e4d210caa6a
9f34aaaab54a 4ff5e54f69da 2e9a228ae99a 8d5cf10a67ba
1cb80a9d6922 ad58f91ba34e 4e380a99423c 1d58f81546f0
af74091e4fc6 71e7f39fcf1c>} def
dictend def
/Spade dictbegin
/color BLACK def
/small [9 12 {<0800 0800 1c00 1c00 3e00 7f00 ff80 ff80 ff80 6b00
0800 1c00>}] def
/normal [15 19 {<0100 0100 0380 0380 07c0 0fe0 0fe0 1ff0 3ff8 7ffc 7ffc
fffe fffe fffe fffe 7d7c 3938 0380 07c0>}] def
/big [39 52 {<0000100000 0000100000 0000100000 0000380000 0000380000
0000380000 00007c0000 00007c0000 0000fe0000 0000fe0000
0001ff0000 0003ff8000 0003ff8000 0007ffc000 000fffe000
000fffe000 001ffff000 003ffff800 007ffffc00 00fffffe00
01ffffff00 03ffffff80 07ffffffc0 0fffffffe0 1ffffffff0
1ffffffff0 3ffffffff8 3ffffffff8 7ffffffffc 7ffffffffc
7ffffffffc fffffffffe fffffffffe fffffffffe fffffffffe
fffffffffe 7ffffffffc 7ffffffffc 3fff7dfff8 3ffe38fff8
1ffc387ff0 0ff8383fe0 03e0380f80 0000380000 00007c0000
00007c0000 0000fe0000 0000fe0000 0001ff0000 0003ff8000
0007ffc000 000fffe000>}] def
/jack {<1d5d77570200 0eaeebae0700 275d775c0700 53aeebb80f80
71fffff00f80 70fffff01fc0 508015503fe0 508f15507ff0
7090d550fff8 709e1550fff8 508d1551fffc 709e1551fffc
51001551fffc a9c01551fffc 50991550faf8 708495507270
50fb15500700 707015500f80 704017700000 50403ddc0000
5060d7740000 703ffddc0000 79c0001f8000 8db6db60e000
7e40002e9800 9bffffeeb700 732ddde4e680 aa9f7760cce0
4c0ddfee9990 9c7ffdeeb33c b2641524e666 67524e608cfc
cd8f35aebbc8 198d8e2eed34 f74bdb249184 056f2020e4cc
3e7c9fff91b4 64725aab4484 49c9755711cc d325dbba44b4
e69317751984 0e4c5aac4d4e fd311559393c 1ca45ff4258c
325b9930ea5c 39f296d29f38>} def
/queen {<00692d080000 007298100000 00644dd00000 20a82cd00400
20b01d500400 50ae3e100e00 50a246f00e00 50be7e701f00
88ba33b01f00 515e3b083f80 715201f87fc0 215183b8ffe0
215103f9fff0 315005c3fff8 6159c683fff8 32b98b83fff8
62b40cc3fff8 32b41543fff8 62aa2221f5f0 32f5d550e4e0
67c888880e00 37d555741f00 666222640000 3e7555820000
683889290000 3d1556318020 6cd224514070 3ecd780140a8
6f27e286e1dc 3f85430df6a8 67892d3bbe72 33c9206f3ba4
69f110b66d9c 3cf1134cd6fe 66739dbda3d4 333ffb7da50c
61b396e5aa8c 38b119c5adb2 6cd11794d4c8 3459273668ac
62fd2e73306a 31c57c010ce8 61fffffffe0c 35a222222108
65fffffffffc 31d555555718>} def
/king {<000508208240 00439c71c680 0041befbef00 00e0befbe600
00e048208400 01f03ffffc00 01f03ffffc00 03f82a800404
07fc2a9e7c0e 0ffe2aa0841a 1fff2a9df430 1fff2ab96420
3fffaa9df424 3fffaa808424 3fffaa808428 3fffaa818428
1f5f2aad6c28 0e4e2ab83c24 00e02a86c424 01f02a810424
00006a838724 0000aac006a8 0000aab55aa8 0001d5cba528
0007fffffe2c 003d000023ac 00cdffffe2ac 03e0aaaaf566
1ce6ffffb566 6e7680008566 c7328c1d4aa2 e3b85c216aa2
f1cb4fe16aa2 394b47f214a2 1eb95bf29562 8d44422ad562
cee4244ad566 e9f5a0022966 7d7dbffd2ae6 3a3cbffdaafe
3e1e3555aa88 fa3e15547afe 177adaaa4650 fdf2dc6b457e
16e25eeb7ad0 fd421390857e>} def
dictend def
/Ace { % suit => rankbits
/big get centerpip
{<1c00 1c00 1c00 3600 3600 3600 3600
6300 7f00 7f00 6300 c180 c180 c180>}
} def
/Deuce {
/normal get twopips
{<3e00 7f00 e380 c180 0180 0380 0700
0e00 1c00 3800 7000 e180 ff80 ff80>}
} def
/Three {
/normal get dup twopips centerpip
{<ff80 ff80 c380 0700 0e00 1e00 3f00
1380 0180 0180 4180 e380 7f00 3e00>}
} def
/Four {
/normal get fourpips
{<0700 0f00 0f00 1b00 1b00 3300 3300
6300 6300 ff80 ff80 0300 0780 0780>}
} def
/Five {
/normal get dup fourpips centerpip
{<ff00 ff00 c000 c000 de00 ff00 e380
4180 0180 0180 4180 e380 7f00 3e00>}
} def
/Six {
/normal get sixpips
{<3e00 7f00 e380 c100 c000 de00 ff00
e380 c180 c180 c180 e380 7f00 3e00>}
} def
/Seven {
/normal get dup sixpips
dup aload pop pop
CardHeight 1.3 mul sub -2 div round exch
CardWidth sub -2 idiv exch
pip
{<ff80 ff80 c180 0300 0300 0600 0600
0c00 0c00 0c00 1800 1800 1800 1800>}
} def
/Eight {
/normal get dup sixpips
dup aload pop pop
CardHeight 1.3 mul sub -2 div round exch
CardWidth sub -2 idiv exch
3 copy pip
did
{<3e00 7f00 e380 c180 e380 7f00 3e00
7f00 e380 c180 c180 e380 7f00 3e00>}
} def
/Nine {
/normal get dup eightpips centerpip
{<3e00 7f00 e380 c180 c180 c180 e380
7f80 3d80 0180 4180 e380 7f00 3e00>}
} def
/Ten {
/normal get dup eightpips
dup aload pop pop
CardHeight 1.4 mul sub -2 div round exch
CardWidth sub -2 idiv exch
3 copy pip
did
{<cf00 df80 d980 d980 d980 d980 d980
d980 d980 d980 d980 d980 df80 cf00>}
} def
/Jack {
/jack get facecard
{<0780 0780 0300 0300 0300 0300 0300
0300 0300 c300 c300 e700 7e00 3c00>}
} def
/Queen {
/queen get facecard
{<1c00 3e00 7700 6300 6300 6300 6300
6300 fb00 ff00 6f00 7700 3f80 1d00>}
} def
/King {
/king get facecard
{<f780 f780 6700 6e00 7c00 7800 7800
7c00 6c00 6e00 6600 6700 f780 f780>}
} def
% Debugging aid (used by trace.ps)
%
/printstring { % -- => string
/printstring super send
self isinstance? {
(%(% % %@%,%)) [3 -1 roll Suit Rank Type X Y] sprintf
} if
} def
classend def % CardImage
/CardColumn [ClassCanvas CardUtils]
dictbegin
/Crunched? false def % cards are closer than dY apart?
/Cards [] def % CardImage instances (top to bottom)
dictend
classbegin
/dY 29 def % desired delta-Y when overlapping cards
/destroy { % - => -
/Cards nullarray def
} def
/minsize {
CardWidth 2 add
CardHeight dY 10 mul add
} def
/spread { % - => dy
/size self send exch pop CardHeight sub
Cards length 1 sub 1 max div
dY min
} def
/validate {
/spread self send /Crunched? 1 index dY ne def
/size self send exch CardWidth sub 2 div cvi exch CardHeight sub
Cards { % spread x y card
2 index 2 index round
self /relocate 5 -1 roll send % spread x y
2 index sub
} forall
pop pop pop
/validate super send
} def
/reshape {
/invalidate self send
/reshape super send
} def
/PaintCanvas { % -- => --
Cards /paintarray CardImage send
} def
% Append cards to the bottom of the column. Each cardspec is either a
% CardImage or an array of args to be used in creating a new CardImage.
%
/appendcards { % [cardspecs] => --
TopCard dup null ne {false /setvisible 3 -1 roll send} {pop} ifelse
[ exch {
dup isarray? {
aload pop /new CardImage send
false /setvisible 2 index send
} if
} forall ]
/Cards Cards 2 index append def
TopCard dup null ne {true /setvisible 3 -1 roll send} {pop} ifelse
/validate self send
gsave
Canvas setcanvas
Crunched? {
pop FillColor FillCanvas PaintCanvas
} {
/paintarray CardImage send
} ifelse
grestore
} def
% Remove a card and all subsequent cards. Turn exposed card (if any)
% face up. Return array of cards removed, and bool true if new card
% was exposed.
%
/removecards { % firstcard => [cards] exposed?
Cards exch arrayindex { % index
Cards 1 index Cards length 1 index sub getinterval % index [cards]
/Cards Cards 0 5 -1 roll getinterval def
dup { 0 0 null /relocate 5 -1 roll send } forall
gsave
Canvas setcanvas
Crunched? { % [cards]
/validate self send
TopCard dup null ne {
true /setvisible 2 index send
true /expose 3 -1 roll send
} {
pop false
} ifelse
FillColor FillCanvas % [cards] exp?
PaintCanvas
} { % [cards]
TopCard dup null ne { % [cards] newtop
true /setvisible 2 index send
true /expose 2 index send % [cards] newtop exp?
/location 2 index send % [] top exp? x y
5 add exch CardWidth add 2 add exch % [] top exp? x y
4 index dup length 1 sub get % [] top e? x y oldtp
/location exch send exch 2 sub exch % [] t e? x y x2 y2
points2rect rectpath FillColor setcolor fill
/PaintCard 3 -1 roll send % [cards] exposed?
} {
pop false
FillColor FillCanvas
} ifelse
} ifelse
grestore
} {
nullarray false
} ifelse
} def
% Turn the top card face down again.
%
/unexpose { % -- => --
TopCard false /expose 2 index send pop
gsave
Canvas setcanvas
/PaintCard exch send
grestore
} def
% Remove all cards, but don't paint.
%
/reset { % -- => --
Cards {/destroy exch send} forall
/Cards nullarray def
/invalidate self send
} def
% Return the highest (kingmost) sequential card. Top card is assumed to
% be faceup.
%
/natural { % - => card
TopCard dup null ne {
/getcard 1 index send pop % top suit rank
Cards length 2 sub -1 0 { % nat suit rank n
Cards exch get % nat suit rank card
/getcard 1 index send % nat s r card s' r' t'
/FaceUp eq
Above 6 -1 roll get 2 index eq and % nat s card s' r' bool
5 -1 roll 3 index eq and { % nat card s' r'
4 -1 roll pop
} {
3 -1 roll pop exit
} ifelse
} for pop pop % nat
} if
} def
% Report how many times the specified card occurs, face-up only, in this
% column. The suit can be /Unused to find "free" cards of given rank.
%
/locatecard { % suit rank => #found
0 1 Cards { % s r #f card# card
/getcard exch send % s r #f c# su rk type
/FaceUp ne exch 5 index ne or {
% either not faceup or wrong rank
pop % s r #f c#
} { % s r #f c# su
4 index eq {
exch 1 add exch
} {
3 index /Unused eq {
dup Cards length ge {
exch 1 add exch
} {
Cards 1 index get /Rank exch send
Above exch get 3 index ne {
exch 1 add exch
} if
} ifelse
} if
} ifelse
} ifelse % s r #f c#
1 add
} forall
pop 3 1 roll pop pop
} def
% Break cards into chunks that are in suit-and-sequence, and invoke
% callbacks for each facedown card and for each sequential chunk.
% Used by /textcontents and /evaluate. A single client-defined value
% is expected to be on the stack, and is provided to the callbacks:
% clientval /facedownproc => clientval'
% clientval n suit rank /sequenceproc => clientval'
%
/Sequences { % facedownproc sequenceproc clientval => clientval'
0 null null Cards { % fdp sqp val n pvsuit pvrank cd
/getcard exch send /FaceUp ne { % fdp sqp val n pvs pvr suit rnk
pop pop pop pop pop % fdp sqp val
2 index exec
0 null null % fdp sqp val' n pvsuit pvrank
} { % fdp sqp val n pvs pvr suit rnk
Above 1 index get 3 index eq
2 index 5 index eq and { % fdp sqp val n pvs pvr suit rnk
5 2 roll pop pop 1 add
3 1 roll % fdp sqp val n+1 suit rank
} {
6 2 roll % fdp sqp suit rnk val n pvs pvr
6 index exec % fdp sqp suit rank val'
1 4 2 roll % fdp sqp val' n suit rank
} ifelse
} ifelse
} forall % fdp sqp val n suit rank
5 -1 roll exec % fdp val'
exch pop
} def
% Return a string describing the cards in the column.
%
/textcontents { % - => string
{(? ) append} {AppendSequence} nullstring /Sequences self send
dup length 0 eq {pop (Empty column. )} if
} def
% Append a string that describes n sequential cards ending in the
% specified suit and rank.
%
/AppendSequence { % str n suit rank => str'
3 -1 roll dup {
0 {pop pop pop}
1 {pop CompactText append}
/Default { % str suit rank n
2 copy 1 sub {Above exch get} repeat
/Hyphen exch CompactText
4 1 roll pop % str (top-) suit rank
CompactText append append
}
} case
} def
% Compute an evaluation function; see SpiderCanvas' /ComputeScore.
%
/evaluate { % - => int
{dup 0 eq {15 sub} if 10 sub} % lose points for cards still facedown
{pop pop 1 sub 0 max 2 mul add} % 2 pt per all but first card in seq
0 /Sequences self send
} def
/CardAtPoint { % event => card
gsave
Canvas setcanvas
/YLocation get
grestore
/size self send exch pop exch sub % distanceFromTop
Crunched? {/spread self send} {dY} ifelse
div cvi dup Cards length ge {pop TopCard} {Cards exch get} ifelse
} def
/TopCard { % - => card
Cards length 0 ne {Cards dup length 1 sub get} {null} ifelse
} def
/NextCard { % card => card'
Cards exch arrayindex not {Cards length} if
1 add dup Cards length ge {pop null} {Cards exch get} ifelse
} def
classend def
/StacksBag [ClassCanvas CardUtils] [/InitDepth /InitType /Cards]
classbegin
/Gap 10 def % border and inter-stack gap
/newinit { % depth #cards cardtype => --
/newinit super send
/InitType exch def
[ exch {null null InitType /new CardImage send} repeat ]
/Cards exch def
/InitDepth exch def
Cards { InitDepth /setdepth 3 -1 roll send } forall
} def
/destroy { % - => -
/Cards nullarray def
} def
/minsize {
CardWidth Gap add Cards length mul Gap add
CardHeight Gap 2 mul add
2 {InitDepth 2 mul add exch} repeat
} def
/validate {
Gap % x
/size self send exch pop CardHeight sub Gap sub % x y
Cards { % x y card
2 index 2 index self
/relocate 5 -1 roll send % x y
exch CardWidth add Gap add exch
} forall
pop pop
} def
/reshape {
/invalidate self send
/reshape super send
} def
/reset {
Cards {
null null InitType InitDepth /setall 6 -1 roll send
} forall
} def
/setdepth { % depth n => -
Cards exch get
gsave
Canvas setcanvas
2 copy /shorter? exch send
2 copy /setdepth exch send
exch 0 ne {/PaintStack exch send} {pop} ifelse
grestore
} def
/setall { % suit rank type depth n => -
Cards exch get
gsave
Canvas setcanvas
2 copy /shorter? exch send
dup 6 1 roll
/setall exch send
/PaintCard exch send
grestore
} def
/replace { % suit rank type depth => n
0 Cards { % ... n card
/Type exch send InitType eq {
dup 6 1 roll /setall self send
exit
} if
1 add
} forall
} def
% Find LAST card that is NOT of InitType, and reset it.
% Return a /getall of the old value.
%
/restore { % -- => oldsuit oldrank oldtype olddepth
Cards length 1 sub -1 0 {
Cards 1 index get /getall exch send % n suit rank type depth
1 index InitType eq {
pop pop pop pop pop
} {
null null InitType InitDepth
9 -1 roll /setall self send
exit
} ifelse
} for
} def
/PaintCanvas {
Cards /paintarray CardImage send
} def
classend def
/ControlPanel [FlexBag CardUtils] nullarray
classbegin
% Make control panel opaque so deactivating the text item's caret
% doesn't invalidate the SaveBehind when a notice is over the tableau.
% (Stupid server bug.)
%
/Transparent false def
/Mapped true def
/FillColor PANEL def
/newinit {
/newinit super send
/sw {/se Previous POSITION 10 0 XYADD} /setlayoutspec self send
/NewGame [
/w {/w self POSITION 10 0 XYADD}
(New Game) /NewGame MakeProc
ClassButton
] /addclient self send
/BackUp [
(Back Up) [
(One Move) null /BackUp MakeProc
(Start Over) null /StartOver MakeProc
(Replay) null /Replay MakeProc
] null OpenLookButtonStack
] /addclient self send
/Score [
(Score) /Score MakeProc
ClassButton
] /addclient self send
/Expand [
(Expand) /Expand MakeProc
ClassButton
] /addclient self send
/Locate [
(Locate) /Locate MakeProc
ClassButton
] /addclient self send
/File [
(File) [
(Save in File) null /SaveFile MakeProc
(Resume from File) null /Resume MakeProc
(Resume from Selection) null /ReadSel MakeProc
] null OpenLookButtonStack
] /addclient self send
(Name:) /new OpenLookLabelGraphic send
/Label [/w {/e Previous POSITION 10 0 XYADD} 5 -1 roll]
/addclient self send
/Name [
/sw {/se Previous POSITION pop 5 add /se /File POSITION exch pop}
nullnotify ClassTextControl
] /addclient self send
10 10 /setpadding self send
} def
/Layout {
/Layout super send
/bbox /Name /sendclient self send exch pop % x y h
/size self send pop % x y h W
10 sub 3 index sub 1 max exch % x y w' h
% "1 max" is because w<0 screws up /size on next /Layout
/reshape /Name /sendclient self send
} def
/MakeProc { % /meth => proc
[exch /SendParent] {pop} exch append self soften buildsend
} def
/reset nullproc def % needed for parent's /reset
classend def
/SpiderCongrats [ClassCanvas CardUtils] nullarray
classbegin
/Transparent false def % also causes it to be initially unmapped
/TextFamily /Palatino-BoldItalic def
/TextSize 48 def
/TextColor RED def
FontDirectory TextFamily known not {
/TextFamily /Times-Italic def
} if
/String (Congratulations!!) def
/Pad 20 def
/minsize { % - => w h
gsave
TextFont setfont
String stringwidth pop Pad add TextFont fontheight Pad add
grestore
} def
/PaintCanvas { % - => -
BLACK BorderStroke WHITE /StrokeAndFillCanvas self send
Pad 2 div dup moveto
0 TextFont fontdescent rmoveto
TextFont setfont TextColor setcolor String show
} def
/reset nullproc def % needed for parent's /reset
classend def
-- -- Don Woods. [*** Generic Disclaimer ***]
-- ...!sun!woods -or- Woods@Sun.comwoods%colossal@Sun.COM (Don Woods) (01/17/90)
Here's the second part of the source for Spider. See my previous posting
for more info (and disclaimer / copyright notice).
-------------------- cut here ----------------------------------
/SpiderCanvas [FlexBag CardUtils]
[
/Deck % undealt cards
/DeckCache % copy of deck for replay/restart
/MoveCache % record of moves for replay
/DownChild % child where mouse button went down
/DownCard % CardImage over which button went down
/DownTime % eventtime when button went down
/LOCK % monitor to avoid damage-vs-update races
/DealTimerEvent % event to trigger deal after single click plus timeout
/PrevHash % value used for hashing output files
/CharIndex % value used for hashing output files
]
classbegin
% Class Variables:
/FillColor FELT def % overrides inherited method
/ErrorAction /Both def % /Both, /Beep, /Flash, or other(none)
/FlashDelay .03 def % delay to ensure flash gets to paint
/ReplayDelay .02 def % delay between moves during replay
/DoubleClick .25 def % timeout for double-click for dealing
/SingleClick .25 def % timeout for single-click on a column
/MovesIncomplete? false def % promoted true if partial file loaded
/ColumnNames dictbegin
0 Ranks {1 index def 1 add} forall pop
dictend def
% Make canvas opaque so updating the frame title bar to reflect loss of
% focus when a Notice pops up, doesn't invalidate the Notice's SaveBehind.
% (Stupid server bug.)
%
/Transparent false def
/Mapped true def
% Methods:
/newinit {
/newinit super send
/DeckCache 0 1 51 {} for 52 copy 104 array astore def
/Deck 104 array def % force initial shuffle
/LOCK createmonitor def
% create client canvases; first, the control panel
/Panel [
/nw {/nw self POSITION}
ControlPanel
] /addclient self send
% then the "hand"
/Hand [
/nw {/sw /Panel POSITION}
4 1 /FaceDown StacksBag
] /addclient self send
% the eight spots for completed suits
/Removed [
/ne {/ne self POSITION /Panel HEIGHT sub}
0 8 /Blank StacksBag
] /addclient self send
% the ten tableau columns; use Ranks[Queen..Three] (1-10) to name them
/nw {
/ne Previous POSITION
self WIDTH Previous WIDTH 10 mul sub 18 sub 9 div cvi 0 max 0 XYADD
} /setlayoutspec self send
Ranks 1 get [
/nw {/sw /Hand POSITION 10 -5 XYADD}
CardColumn
] /addclient self send
Ranks 2 9 getinterval { [CardColumn] /addclient self send } forall
% the big "congratulations" panel (usually unmapped)
/Congrats [
/c {/c self POSITION}
SpiderCongrats
] /addclient self send
% store indices in children for fast lookup
[/Panel /Hand /Removed /Congrats Ranks 1 10 getinterval {} forall] {
/setindex 1 index /sendclient self send
} forall
% fork transaction handler so we don't have to tie up our main
% event loop doing moves (which leads to dropped mouse-up events)
/TransactionProcess [
/CallMethod dup null self MakeInterest
] /new ClassEventMgr send def
(Spider Updates) /setname TransactionProcess send
/clearsendcontext TransactionProcess send
} def
/activate {
/activate super send
(Spider Input) /setname EventMgr send
(Click on deck to begin game. ) LeftFooter
} def
/destroy {
/destroy super send
TransactionProcess null ne {
/destroy TransactionProcess send
/TransactionProcess null def
} if
} def
/minsize {
% width: room for 10 columns plus 2 margins and minimal gaps
% (4 between columns, 10 on either side = 4*9+2*10 = 56)
% also room for the 2 StacksBags with some gap (25) between them
% height: room for a modest column plus hand plus panel plus gaps
% (5 between cols and hand, 4 below cols = 9)
/minsize CardColumn send 9 add
exch 10 mul 56 add % h1 w1
/minsize /Hand /sendclient self send
/minsize /Removed /sendclient self send pop % h1 w1 w2 h2 w3
exch 4 1 roll add 25 add max % h1 h2 w
3 1 roll add % w h
/minsize /Panel /sendclient self send exch pop add
} def
/Layout {
/Layout super send
/bbox /Panel /sendclient self send exch pop
/size self send pop exch
/reshape /Panel /sendclient self send
1 1 10 {
GetColumn /bbox 1 index send 3 -1 roll add % col x w h+y
BorderStroke 2 add dup 4 1 roll sub % col x y' w h'
1 max % h<0 does bad things later since /size yields abs(h)
/reshape 6 -1 roll send
} for
} def
% Override: Ensure we don't muck up the clipping during an update
% just because the main eventmgr saw a damage event.
%
/HandleFix {
LOCK {/HandleFix super send} monitor
} def
/shuffle { % - => -
(Shuffling...) nullstring /setfooter Parent send
% workaround for "constant" NeWS random number sequence:
% use day of year (1-366) to skip some initial random numbers;
% use seconds to decide how many times to repeat the shuffle
% use minutes to skip some random numbers between repetitions
% this yields 366*60*60 = 1.3M decks using about 10K calls to random
(%pipe date "+{%M %S %j}") (r) file token {exec} {0 0 0} ifelse
{random pop} repeat
0 1 51 {} for 52 copy % mins secs c1 c2 c3 .. c104
105 -1 roll 2 add {
pause pause pause % e.g., to let initial window finish painting
104 -1 2 {dup random mul cvi roll} for
104 index {random pop} repeat
} repeat
104 array astore % mins [deck]
/Deck 1 index def
/DeckCache exch def % mins
pop
/MoveCache growabledict def
/MovesIncomplete? unpromote
} def
/reset { % - => -
{/reset exch send} /foreachclient self send
/paint self send
nullstring nullstring /setfooter Parent send
} def
/deal { % - => -
/busy? Parent send not
dup {true /setbusy Parent send} if
Deck 0 get null eq {/shuffle self send} if
(Dealing...) nullstring /setfooter Parent send
NoDealYet? not {0 0 0 true /record self send} if
1 1 10 {
Deck length 50 gt {
dup 3 mod 1 eq {6} {5} ifelse
} {
1
} ifelse % !busy? col #cards
Deck 0 2 index getinterval
arrayreverse % for compat with old saved files
/FaceDown IntsToCards
dup dup length 1 sub get 2 /FaceUp put % !busy? col #cds [cds]
/appendcards Ranks 5 -1 roll get /sendclient self send
Deck exch 1 index length 1 index sub getinterval
/Deck exch def
} for
/Remaining self send % !busy?
{false /setbusy Parent send} if
} def
% Update thickness of deck and righthand footer text.
%
/Remaining {
Deck length {
10 {2 0 /setdepth /Hand /sendclient self send false (1)}
0 {
null null /Blank 0 0 /setall /Hand /sendclient self send
true (No)
}
/Default {true Deck length 10 idiv 1 string cvs}
} case % bool (n)
( deal) append exch {(s) append} if ( remaining.) append
nullstring exch /setfooter Parent send
} def
% Add a move to the MoveCache. The arguments are the numbers of the
% source and destination columns (1-10), number of cards moved, and a
% bool that is true if the move revealed a previously facedown card.
% Removing a completed suit is recorded as a move to column 0; dealing
% more cards is recorded as a move from column 0. (The #cards and
% exposed? arguments are irrelevant for these cases, as is the destcol
% for dealing cards.)
%
/record { % fromcol destcol #cards exposed? => --
1 0 ifelse
14 mul add
11 mul add
11 mul add
MoveCache dup length 3 -1 roll put
} def
/unencode { % move => from dest #cards exposed?
dup 11 mod exch 11 idiv
dup 11 mod exch 11 idiv
dup 14 mod exch
14 ge
} def
/undo { % -- => --
MoveCache dup length 1 sub 2 copy get 3 1 roll undef
/unencode self send % from dest #cards exp?
dup (Hmmph. ) nullstring ifelse LeftFooter % from dest #cards exp?
3 index 0 eq {
pop pop pop pop /undo-deal self send
} {
2 index 0 eq {
4 1 roll pop pop /undo-suit self send
} {
/undo-normal self send
} ifelse
} ifelse
} def
/undo-deal { % -- => --
1 1 10 {
GetColumn /TopCard 1 index send % col card
/removecards 3 -1 roll send pop % [card]
{/destroy exch send} forall
} for
DeckCache dup length Deck length sub 10 sub
Deck length 10 add getinterval /Deck exch def
/reset /Hand /sendclient self send
/paint /Hand /sendclient self send
Remaining
} def
/undo-suit { % exposed? fromcol => --
GetColumn exch {/unexpose 1 index send} if % col
/restore /Removed /sendclient self send pop pop pop % col suit
[ exch Ranks { % col [ ... suit rank
/FaceUp 3 array astore dup 0 get % col [ ... [spec] suit
} forall pop ] % col [cardspecs]
/appendcards 3 -1 roll send
} def
/undo-normal { % from dest #cards exposed? => --
4 2 roll GetColumn exch GetColumn % #cards exp? destcol fromcol
3 -1 roll {/unexpose 1 index send} if % #cards destcol fromcol
/Cards 2 index send % #cards dcol fcol destcards
dup length 5 -1 roll sub get % dcol fcol card
/removecards 4 -1 roll send pop % fcol [cards]
/appendcards 3 -1 roll send
} def
/replay { % - => -
true /setbusy Parent send
MoveCache
/StartOverOK self send
dup 0 1 2 index length 1 sub { % dict dict n
ReplayDelay sleep
get /unencode self send pop % dict from dest #cards
2 index 0 eq {
pop pop pop
/deal self send % dict
} {
1 index 0 eq {
pop pop GetColumn % dict fromcol
/DownChild 1 index def
/Cards exch send
dup length 13 sub get
/RemoveSuit? self send pop % dict
} {
exch GetColumn 3 -1 roll GetColumn % dict #cds dcol fcol
/Cards 1 index send
dup length 5 -1 roll sub get % dict dcol fcol card
/MoveAndRecord self send % dict
} ifelse
} ifelse
dup % dict dict
} for
pop pop
false /setbusy Parent send
} def
/PointButton { UserProfile /ViewPoint get } def
/AdjustButton { UserProfile /ViewAdjust get } def
/MakeInterests { % - => interests
/MakeInterests super send
self soften
dictbegin /DownTransition /StartMove BuildCanvasSend def dictend
[PointButton AdjustButton]
/new ClassNotifyInterest send % Nint
null 2 copy % Nint any Nint can
dictbegin /UpTransition /EndMove self soften buildsend def dictend
null /new ClassDependentInterest send % Nint Dint
/Synchronous true put % Nint
} def
/childindex { % child|null => any|null
dup null eq {pop /Self} {/getindex exch send} ifelse
} def
/StartMove { % event => --
% ignore second mouse button going down while first is still down
dup /Interest get /Triggered? 1 index send not { % event Nint
null /finddependent 2 index send pop % event Nint Dint
% watch for same button going up that went down
/Name 3 index /Name get put % event Nint
/NotifyIn 1 index send % event
/DownChild /ChildUnderPoint self send def % event
/DownTime lasteventtime def % event
DownChild null ne {
/CardAtPoint DownChild send
} {
pop null
} ifelse
/DownCard exch def
} {
pop pop
} ifelse
} def
/EndMove { % event => --
dup /Name get PointButton eq % event point?
/ChildUnderPoint self send % event point? upchild
DownChild /childindex self send {
/Self /Panel /Congrats
{null}
/Hand {/MousedHand}
/Removed {/MousedTop}
/Default {/MousedTableau}
} case % ev pt? upchild /meth
dup null ne {
createevent begin
/Action exch def
2 array astore /ClientData exch def
/Name /CallMethod def
/Canvas self def
/TimeStamp lasteventtime def
currentdict end sendevent
} {
pop pop pop
} ifelse % event
dup /Interest get /NotifyOut exch send
} def
% Put up a confirmation notice. The second button is always Cancel, and
% does nothing except put a given string in the left footer. The first
% button is always the default, and just sends an event (so that the
% notice will go away before we start any painting).
%
/Confirm { % [(message)] (yes) /eventname (cancelled) => --
[4 -2 roll [exch /SendEvent] self soften buildsend (\r)] exch
[(Cancel) [4 -1 roll /LeftFooter] self soften buildsend (\177)]
2 array astore % [(msg)] [buttonspecs]
2 array astore framebuffer /new NoticeFrame send
null blockinputqueue
{ newprocessgroup
0 /setdefault 2 index send
/place 1 index send
/activate 1 index send
/map 1 index send
unblockinputqueue
} fork pop pop
} def
/SendEvent { % /action => --
createevent begin
/Action exch def
/Name /CallMethod def
/Canvas self def
/TimeStamp lasteventtime def
currentdict end sendevent
} def
% Method that gets called when /SendEvent or /SendParent sends a
% /CallMethod event. It invokes the method given by the Action of the
% event. If /ClientData in the event is arraytype, it is aloaded onto
% the stack as arguments to the method. After the method returns, the
% congrats canvas is mapped or unmapped as necessary.
%
/CallMethod { % event => --
dup /ClientData get dup type /arraytype eq {
aload length 1 add -1 roll
} {
pop
} ifelse % <args> /method
/Action get
LOCK {self send} monitor
/Mapped /Congrats /sendclient self send dup
SuperWin? ne { % mapped?
/unmap /map ifelse
/Congrats /sendclient self send
} {
pop
} ifelse
} def
% Moused down over hand. Use notice to confirm dealing new round;
% there must be cards left to deal, and all spaces must be filled.
% Doesn't matter which button was used or where it was released.
%
/MousedHand { % point? upchild => --
pop pop
DealTimerEvent dup null ne {
recallevent
/DealTimerEvent null def
/DoDeal self send
} {
pop
createevent dup begin
/Action /DoDeal def
/Name /CallMethod def
/Canvas self def
/TimeStamp currenttime DoubleClick 65.536 div add def
end dup sendevent
/DealTimerEvent exch def
} ifelse
} def
% Respond to either a double-click or single-click-plus-timeout.
%
/DoDeal { % - => -
DealTimerEvent dup null ne {
dup recallevent
/DealTimerEvent null def
} if % event|null
NoDealYet? {
/deal self send
nullstring
} {
Deck length 0 gt {
true 1 1 10 {
Ranks exch get
/Cards exch /sendclient self send
length 0 ne and
} for % event|null filled?
{ % event|null
dup null eq {
/deal self send
} {
[(Please confirm dealing more cards.)]
(Deal) /deal nullstring Confirm
} ifelse % event|null
nullstring
} {
(Can't deal until all spaces are filled.)
} ifelse
} {
(No cards left to deal.)
} ifelse
} ifelse % event|null str|null
LeftFooter pop
} def
% Moused down on completed-suit region. Report suits that have all 13
% cards showing. Doesn't matter where mouse went up, nor which button.
%
/MousedTop { % point? upchild => --
pop pop
dictbegin Suits {growabledict def} forall dictend % tempdict
1 1 10 { % dict n
Ranks exch get
/Cards exch /sendclient self send { % dict card
/getcard exch send /FaceUp eq { % dict suit rank
3 copy pop get % d s r subdict
exch dup put pop % dict
} {
pop pop
} ifelse
} forall
} for % dict
[ exch Suits { % [...dict suit
2 copy get length 13 eq { % [...dict suit
exch
} {
pop
} ifelse
} forall pop ] % [readysuits]
(Sufficient cards visible to form complete set of )
nullstring 3 -1 roll { % str pfx suit
dup length string cvs append append (s, )
} forall % str pfx
nullstring eq {
pop (No suit has all 13 cards showing. )
} {
(s. ) append
} ifelse
LeftFooter
} def
% Moused down in tableau. Interpretation depends on where mouse went up,
% and which button was used.
%
/MousedTableau { % point? upchild => --
exch /CardToMove self send dup null eq {exch} if
1 index /childindex self send { % up nat
/Self /Panel /Hand /Congrats {pop pop (\r)} % force flash
/Removed {exch pop /RemoveSuit? self send}
/Default {/ColToCol self send}
} case % str
LeftFooter
} def
% Method provided for testing; no UI hooked up to it in released version.
%
/Cheat { % point? upchild => --
DownCard null ne {
dup /childindex self send {
/Self /Panel /Hand /Removed /Congrats {pop (\r)}
/Default {
DownChild DownCard /MoveAndRecord self send
(That's intended strictly for testing, you know. )
}
} case
LeftFooter
} {
pop
} ifelse % point?
pop
} def
/MoveAndRecord { % destcol sourcecol card => --
/removecards 2 index send % dest source [cards] exposed?
3 -1 roll ColNum 3 index ColNum % des [cd] ex? src# des#
3 index length 4 -1 roll % des [cd] src# des# #cd ex?
/record self send % dest [cards]
/appendcards 3 -1 roll send
} def
/CardToMove { % point? => card
/natural DownChild send exch not
1 index null ne and { % nat
/Y 1 index send /Y DownCard send gt {
pop DownCard
} if
} if
} def
/RemoveSuit? { % card => str
/Rank 1 index send /King eq
/Canvas 2 index send /TopCard exch send /Rank exch send /Ace eq and {
/Suit 1 index send exch % suit king
/removecards DownChild send % suit [cards] exposed?
DownChild ColNum 0 13 4 -1 roll /record self send
{/destroy exch send} forall % suit
/Ace /FaceUp 2 /replace /Removed /sendclient self send
7 eq {null (CONGRATULATIONS!!) /setfooter Parent send} if
nullstring
} {
pop (Can only remove complete suit in sequence at bottom of column.)
} ifelse
} def
/ColToCol { % destcol card => str
1 index DownChild eq {
exch pop
DownTime SingleClick 65.536 div add lasteventtime ge {
/ObviousMove self send
} {
pop
(Click faster if you want to make the \252obvious\272 move. )
} ifelse
} {
/TopCard 2 index send dup null ne {
/Rank exch send % dest card destrank
exch {
dup null eq {exit} if
Above /Rank 2 index send get % dest rank card rank'
2 index eq {exit} if
/NextCard DownChild send
} loop % dest rank card
exch pop
} {
pop
} ifelse % destcol card
dup null ne {
DownChild exch /MoveAndRecord self send
nullstring
} {
pop /TopCard exch send
(No legal move from column )
DownChild ColNum 2 string cvs append ( onto the ) append
(.) /insertname 4 -1 roll send
} ifelse
} ifelse
} def
/ObviousMove { % card => str
dup /RemoveSuit? self send dup nullstring eq {
exch pop
} {
pop
/getcard 1 index send pop Above exch get
999 10 -1 1 { % card suit r+1 best n
/TopCard Ranks 2 index get
/sendclient self send % card s r+1 best n top
dup null eq {
pop 200 add min
} {
/getcard exch send pop 4 index eq { % card s r+1 best n s'
4 index eq {0} {100} ifelse add min
} {
pop pop
} ifelse
} ifelse
} for % card s r+1 best
3 1 roll pop pop dup 999 eq {
pop (I can't figure out where to move the ) (.)
/insertname 4 -1 roll send
} {
100 mod GetColumn
DownChild 3 -1 roll /MoveAndRecord self send
nullstring
} ifelse
} ifelse
} def
% Determine which of our children, if any, was under the mouse for the
% most recent event.
%
/ChildUnderPoint { % - => child|null
null null canvasesunderpoint { % prev cv
dup self eq {pop exit} {exch pop} ifelse
} forall
dup framebuffer eq {pop null} if
} def
% Register an invalid request.
%
/Flash { % - => -
ErrorAction {
/Both {beep true}
/Beep {beep false}
/Flash {true}
/Default {false}
} case {
gsave
5 setrasteropcode
0 FlashDelay 65.536 div
2 {
framebuffer setcanvas clippath fill
/canvas self send setcanvas clippath fill
dup 0 ne {sleep} {pop} ifelse
} repeat
grestore
} if
} def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Methods for control panel buttons. %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/NewGame { % - => -
NoDealYet? {
/deal self send
} {
[(Do you really want to discard) (this game and start a new one?)]
(Yes) /NewGameOK nullstring Confirm
} ifelse
} def
/NewGameOK { % - => -
/reset self send
/Deck 104 array def
/deal self send
} def
/StartOver { % - => -
BadDeck? {
(Sorry, original deck is not available.) LeftFooter
} {
NoDealYet? NoMovesYet? or {
(You have to start before you can start over!) LeftFooter
} {
[(Do you really want to discard this)
(position and back up to the beginning?)]
(Yes) /StartOverOK nullstring Confirm
} ifelse
} ifelse
} def
/StartOverOK { % - => -
/reset self send
/Deck DeckCache def
/MoveCache growabledict def
/MovesIncomplete? unpromote
/deal self send
} def
/BackUp { % - => -
MoveCache length 0 eq {
(No moves available to back up over.) LeftFooter
} {
MoveCache dup length 1 sub get
11 11 14 mul mul lt {
/undo self send
} {
(Cheater alert!) LeftFooter
[(CHEAT!! You've seen more cards now!)
(Confirm backing up over that move!)]
(Yes, dammit) /undo (That's more like it! ) Confirm
} ifelse
} ifelse
} def
/Replay { % - => -
BadDeck? {
(Sorry, original deck is not available.)
} {
NoDealYet? NoMovesYet? or MoveCache length 0 eq or {
(No moves available to replay.)
} {
MovesIncomplete? {
(Move record is incomplete; you could Start Over but you can't Replay.)
} {
[(This could take a while. Are you sure)
(you want to replay all the moves?)]
(Yes) /replay (Replay cancelled. ) Confirm
nullstring
} ifelse
} ifelse
} ifelse
LeftFooter
} def
/Score { % - => -
NoDealYet? {
(Can't compute score until you start a game!)
} {
(Current position scores % out of 1000. ) [ComputeScore] sprintf
} ifelse
LeftFooter
} def
/Expand { % - => -
(Click over the column whose contents you want to see. ) LeftFooter
Cursor /xcurs /xcurs_m /setcursor self send
{
self createoverlay setcanvas
createevent dup begin
/Canvas currentcanvas def
/Action /DownTransition def
/Exclusivity true def
end dup expressinterest
awaitevent
exch revokeinterest
begin [XLocation YLocation] end
} fork waitprocess % oldcurs [x y]
Canvas /Cursor 4 -1 roll put
ChildUnderPoint dup /childindex self send {
/Self /Panel /Hand /Removed /Congrats
{pop (That wasn't over a column!)}
/Default
{/textcontents exch send}
} case
LeftFooter
} def
/Locate { % - => -
/value /Name /sendclient /Panel /sendclient self send
/Unused null 3 -1 roll { % suit rank char
dup 8#140 ge {8#40 xor} if % make it uppercase
cvis (KQJT98765432ASHDC...0) exch search { % s r post char pre
3 1 roll pop pop length 17 mod % s r index
dup 13 lt {
Ranks exch get exch % suit newrank oldrank
} {
13 sub Suits exch get exch 3 -1 roll % newsuit rank oldsuit
} ifelse
} if % suit rank junk
% junk item might be string (K...C) if search failed
pop
} forall
dup null eq {
pop pop
(Rank: KQJT98765432A (or 10); suit: SHDC. Omit suit to find unused card of named rank.)
} { % suit rank
[ 3 1 roll 1 1 10 { % [ ... suit rank n
3 copy /locatecard Ranks 3 -1 roll get /sendclient self send
dup 0 ne {
2 array astore 3 1 roll % [ ... [n #found] suit rank
} {
pop pop
} ifelse
} for % [ [n #] [n #] ... suit rank
counttomark 1 add 2 roll ] % s r [ [n #] [n #] ... ]
dup length {
0 {
pop (not visible)
}
1 {
0 get aload pop dup { % s r col# #found
1 {pop (once)}
2 {pop (twice)}
/Default {1 string cvs ( times) append}
} case % s r col# (#times)
exch 2 array astore
(occurs % in column %) exch sprintf
}
/Default {
dup length (occurs in columns)
3 -1 roll { % s r #left (str) [col# #found]
aload pop dup {
1 {pop nullstring}
2 {pop ( (twice))}
/Default {[exch] ( (% times)) exch sprintf}
} case % s r #left (str) col# (#times)
4 -1 roll 1 sub dup 5 1 roll {
0 {nullstring}
1 {( and)}
/Default {(,)}
} case % s r #left (str) c# (#t) (sfx)
4 array astore
(% %%%) exch sprintf % s r #left (str')
} forall exch pop
}
} case % suit rank (where found)
3 array astore (% % %. ) exch sprintf
} ifelse
LeftFooter
} def
/SaveFile { % - => -
NoDealYet? {
(There's no game to save yet.) LeftFooter
} {
/value /Name /sendclient /Panel /sendclient self send
{(r) file} stopped {
pop pop
/SaveFileOK self send
} {
closefile
[(That file already exists. Replace it?)]
(Yes) /SaveFileOK (Position NOT saved. ) Confirm
nullstring LeftFooter
} ifelse
} ifelse
} def
/SaveFileOK { % - => -
/value /Name /sendclient /Panel /sendclient self send
{(w) file} stopped {
pop pop (Unable to open output file.)
} {
true /setbusy Parent send
(Writing file... ) LeftFooter
dup WritePosition
dup WriteMoves
dup WriteTableau
closefile
(Position saved. )
false /setbusy Parent send
} ifelse
LeftFooter
} def
/Resume { % - => -
NoDealYet? {
/ResumeOK self send
} {
[(Do you really want to discard this)
(game to read the filed position?)]
(Yes) /ResumeOK nullstring Confirm
} ifelse
} def
/ResumeOK { % - => -
/value /Name /sendclient /Panel /sendclient self send
{(r) file} stopped {
pop pop (Unable to open input file.)
} {
() { % file string
1 index 500 string readstring % file string string' more?
3 1 roll append exch % file mergedstring more?
not {exit} if
} loop % file contents
exch closefile
/restorefromstring self send
} ifelse
LeftFooter
} def
/ReadSel { % - => -
NoDealYet? {
/ReadSelOK self send
} {
[(Do you really want to discard this)
(game to set up the selected position?)]
(Yes) /ReadSelOK nullstring Confirm
} ifelse
} def
/ReadSelOK { % - => -
(First select the text that encodes the position.)
/PrimarySelection getselection dup null ne {
/ContentsAscii /query 3 -1 roll send {
exch pop /restorefromstring self send
} if
} {
pop
} ifelse
LeftFooter
} def
/restorefromstring { % gamestring => footerstring
true /setbusy Parent send
(Restoring position...) nullstring /setfooter Parent send
/MovesIncomplete? unpromote
/MARK [ null null null 6 -1 roll {
(.\n) search {exch pop} {nullstring exch} ifelse % rest posn
RemoveNewlines ReadPosition % rest
(.\n) search {3 1 roll pop pop} if % moves
RemoveNewlines ReadMoves
} stopped {
/reset self send
/DeckCache 0 1 51 {} for 52 copy 104 array astore def
/Deck 104 array def
{cleartomark /MARK eq {exit} if} loop
(Invalid format in saved position.)
} {
cleartomark pop
NoMovesYet? not MoveCache length 0 eq and
/MovesIncomplete? exch ?promote
(Position restored. )
} ifelse
false /setbusy Parent send
} def
%%%%%%%%%%%%%%%%
% File I/O %
%%%%%%%%%%%%%%%%
% File format: This is a bit obscure, since it was copied verbatim from
% an earlier implementation of the program (so that the sample positions
% in the documentation will still work) and thus is optimised for being
% written in Mesa. Such is life...
%
% The first line has the original deck and current position, ending with a
% period. In the original deck, the undealt cards come first, then a slash,
% then the rest of the cards. (The deck is NOT simply reversed; the first
% undealt card will be the next card dealt, not the last, and likewise the
% first card after the slash was the first card dealt.) After the deck is a
% space, then the ten tableau columns, separated by spaces. Each tableau
% column has its cards from bottom (highest on the screen) to top. If any are
% facedown, there's a slash after the last facedown card; else the slash is
% omitted.
%
% In the above, each card is encoded as an int from 4-55 = (rank+1)*4+suit,
% then xored with the previous card, and also xored with a value based on
% the number of cards output so far. The resulting value from 0-63 is then
% converted to a char from (0) to (o).
%
% The second line is optional and contains the moves, first to last, again
% ending with a period. Each move is encoded as two chars in base 64 using
% (0) to (o) as "digits".
%
% Next comes a blank line, followed by a human-readable form of the current
% tableau. This part is ignored when reading the file.
% Given a card encoded as 4*rank + suit, hash it. The hash is a simple
% xor with the previous encoded card (stored in /PrevHash) and a char
% index (stored in /CharIndex); the idea is not so much to make the file
% hard to decipher, as to make it unlikely anyone will accidentally learn
% anything from a casual glance. This routine also increments /CharIndex;
% the caller is responsible for updating /PrevHash since we can't tell
% whether it's the incoming or returned value that should be stored there.
%
/HashCard { % int => int
/CharIndex CharIndex 5 add def
PrevHash xor CharIndex dup 4 mod exch 4 mul add xor 8#77 and
} def
/ReadSequence { % string => [ints]
[ exch {
(0) 0 get sub HashCard /PrevHash 1 index def
dup 4 idiv 13 exch sub exch
4 mod 3 exch sub 13 mul add 52 mod
} forall ]
} def
/WriteSequence { % file [ints] => -
[ exch {
dup 13 idiv 3 exch sub exch
13 mod 13 exch sub 4 mul add
dup HashCard /PrevHash 3 -1 roll def
(0) 0 get add
} forall ]
cvas writestring
} def
% Remove newline chars, since some tools (notably xterm) include bogus
% newlines if a long selection is wrapped onto multiple display lines.
%
/RemoveNewlines { % string => string
{ (\n) search not {exit} if
exch pop exch append
} loop
} def
/ReadPosition { % string => -
% Assume any bad format will result in an error, caught via "stopped".
NoDealYet? not {/reset self send} if
/PrevHash 0 def
/CharIndex 0 def
( ) search pop exch pop % rest deck
(/) search pop exch pop % rest dealt hand
dup length 3 1 roll % rest #hand dealt hand
ReadSequence arrayreverse exch
ReadSequence arrayreverse exch append % rest #hand [deck]
/DeckCache exch def
/Deck DeckCache dup length 3 index sub 4 -1 roll getinterval def
1 1 10 { % rest col#
exch ( ) search {exch pop} {nullstring exch} ifelse % col# rest pile
(/) search {exch pop} {nullstring} ifelse % col# rest up down
ReadSequence /FaceDown IntsToCards exch
ReadSequence /FaceUp IntsToCards append % col# rest [cardspecs]
dup length 0 ne {
/appendcards Ranks 5 -1 roll get
/sendclient self send % rest
} {
pop exch pop % rest
} ifelse
} for
ReadSequence /FaceUp IntsToCards {
aload pop 2 /replace /Removed /sendclient self send pop
} forall
Remaining
} def
/IntsToCards { % [ints] type => [[suit rank type] ...]
[ 3 1 roll exch { % [ ... type int
Suits 1 index 13 idiv get % [ ... type int suit
Ranks 3 -1 roll 13 mod get % [ ... type suit rank
2 index 3 array astore % [ ... type [card]
exch
} forall pop ]
} def
/CardsToInts { % [cards] /type => [othertypeints] [giventypeints]
exch [ 3 1 roll {
/getcard exch send % [ ... stoptype suit rank type
3 index eq {
counttomark 1 add 2 roll % suit rank [ ... stoptype
pop ] [ null 5 -2 roll % [...] [ newstoptype suit rank
} if
Ranks exch arrayindex not {0} if exch
Suits exch arrayindex not {0} if 13 mul add
exch % [ ... int stoptype
} forall
null ne {] [} if ]
} def
/ReadMoves { % string => -
/MoveCache growabledict def
true exch { % true char | tophalf false char
(0) 0 get sub exch {
64 mul false
} {
add MoveCache dup length 3 -1 roll put
true
} ifelse
} forall
not {pop} if
} def
/WritePosition { % file => -
/PrevHash 0 def
/CharIndex 0 def
dup Deck arrayreverse WriteSequence dup (/) writestring
dup DeckCache 0 DeckCache length Deck length sub
getinterval arrayreverse WriteSequence
1 1 10 { % file col#
1 index ( ) writestring
Ranks exch get /Cards exch /sendclient self send
/FaceUp CardsToInts % file [downints] [upints]
exch dup length 0 ne { % file [upints] [downints]
2 index exch WriteSequence
1 index (/) writestring
} {
pop
} ifelse % file [upints]
1 index exch WriteSequence % file
} for
/Cards /Removed /sendclient self send % file [removed]
/Blank CardsToInts % file [removed] [blanks]
pop dup length 0 ne {
1 index dup ( ) writestring % file [removed] file
exch WriteSequence % file
} {
pop
} ifelse
(.\n) writestring
} def
/WriteMoves { % file => -
2 string MoveCache 2 copy % file str dict str dict
0 1 2 index length 1 sub { % file str dict str dict n
get 2 copy % file str dic str move str move
64 idiv (0) 0 get add 0 exch put % file str dict str move
64 mod (0) 0 get add 1 exch put % file str dict
3 copy pop writestring
2 copy
} for pop pop pop pop
(.\n) writestring
} def
/WriteTableau { % file => -
true 1 1 10 {GetColumnCards} for
{ % file topline? [cards1] [cards2] ... [cards10]
(\n) 10 { % file top? [c] .. [c] line
11 -1 roll dup length 0 eq { % ... line []
exch 11 index {((sp)) append} if
} { % ... line [cards]
dup dup length 1 sub 1 exch getinterval
3 1 roll 0 get % ... [rest] line topcard
/getcard exch send % ... line suit rank type
/FaceDown eq {
pop pop ( --) append
} {
CompactText
dup length 3 eq {( ) exch append} if
0 3 getinterval append
} ifelse
} ifelse
(\t) append
} repeat % file top? [c1] .. [c10] line
{ % strip trailing tabs
dup dup length 1 sub get (\t) 0 get ne {exit} if
dup length 1 sub 0 exch getinterval
} loop
dup length 1 eq {exit} if
12 index exch writestring
11 -1 roll pop false 11 1 roll
} loop % file top? [] .. [] (\n)
12 1 roll 11 {pop} repeat % file (\n)
writestring
} def
%%%%%%%%%%%%%%%%%%%%%%
% Utilities %
%%%%%%%%%%%%%%%%%%%%%%
% Test whether we have a valid deck to allow starting over.
%
/BadDeck? { % - => bool
52 {0} repeat 52 array astore dup % [tallies] [tallies]
DeckCache {2 copy get 1 add put dup} forall pop % [tallies]
false exch {2 ne or} forall
} def
% Test whether a game has already started. (If so, must confirm
% [New Game] and [Resume]. If not, cannot [Save].)
%
/NoDealYet? { % - => bool
Deck length 100 gt
} def
% Test whether the current position is the start of a game.
% If so, cannot [Start Over], [Replay], or [Back Up]. Could
% do this by testing /MoveCache, but prefer a test that will be
% correct even for a restored position without /MoveCache.
%
/NoMovesYet? { % - => bool
Deck length 50 eq dup { % bool
1 1 10 {
dup GetColumnCards
exch 3 mod 1 eq {6} {5} ifelse % bool [cards] initleng
1 index length ne {pop pop false exit} if % bool [cards]
dup length 2 sub 2 getinterval { % bool card
/Type exch send
} forall % bool /type1 /type2
/FaceUp eq exch /FaceDown eq and and
} for
} if
} def
% Set the message in the left footer, and flash if it's an error message.
% An error message is defined as a string that is not empty and does not
% end with a space.
%
/LeftFooter { % string => -
dup /footer Parent send pop ne {
dup null /setfooter Parent send
} if
dup length 0 ne {
dup length 1 sub get ( ) 0 get ne {
/Flash self send
} if
} {
pop
} ifelse
} def
% Given a child that is presumed to be a tableau column, return the
% index of that column as an integer from 1 to 10.
%
/ColNum { % child => int
/getindex exch send ColumnNames exch get
} def
% Given a number from 1 to 10, obtain the corresponding CardColumn.
%
/GetColumn { % int => child
Ranks exch get /getbyname self send pop
} def
% Given a number from 1 to 10, obtain the cards in that column.
%
/GetColumnCards { % int => [cards]
/Cards Ranks 3 -1 roll get /sendclient self send
} def
% Check whether the big "congratulations" canvas should be mapped.
%
/SuperWin? { % - => bool
0 Deck length 0 eq { % n (# completed suits)
1 1 10 { % n col#
GetColumnCards dup CompletedSuit? {
pop 1 add
} {
length 0 ne {exit} if
} ifelse
} for
} if % n
8 eq
} def
% See if an array of cards is King..Ace of a single suit.
%
/CompletedSuit? { % [cards] => bool
dup length 13 ne {
pop false
} {
dup 0 get /getcard exch send % [cds] suit rank type
/FaceUp ne exch Ranks 0 get ne or {
pop pop false
} { % [cds] suit
0 3 -1 roll { % suit j card
/getcard exch send pop % suit j suit' rank'
Ranks 3 index get ne exch % suit j bool suit'
3 index ne or {exit} if
1 add % suit j+1
} forall % suit #seq
exch pop 13 eq
} ifelse
} ifelse
} def
% Compute a somewhat arbitrary evaluation function for the position:
% 2 point per card sitting atop next higher card in same suit
% 10 per card turned face up
% 15 extra for each column where all cards have been revealed
% 50 per completed suit removed (note this costs 12*2 for cards in seq)
% If all columns are either empty or contain completed suits, then those
% suits also count 50 (including the 24 for the 12 cards that are atop
% higher cards), plus an extra 2 for each suit after the first three.
% Thus the only way to get 1000 points is to win with all eight suits
% still in the tableau.
%
/ComputeScore { % - => int
44 10 mul 10 15 mul add % (score if cards NOT turned faceup)
/Cards /Removed /sendclient self send { % score card
/getcard exch send 3 1 roll pop pop % score type
/FaceUp eq {50 add} if
} forall % score
0 exch 1 1 10 { % #suits score col#
GetColumn /evaluate 1 index send % #suits score col val
/Cards 3 -1 roll send % #suits score val [cds]
dup CompletedSuit? {
pop 3 -1 roll 1 add 3 1 roll
} {
length 0 ne {3 -1 roll 99 sub 3 1 roll} if
} ifelse % #suits score val
add
} for % #suits score
exch 0 max dup 3 gt {28 mul 6 sub} {26 mul} ifelse add
cvi
} def
classend def
/SpiderFrame [/defaultclass ClassBaseFrame send] []
classbegin
/FillColor 1 1 1 rgbcolor def % in case UserProfile overrides
% default color in ClassFrame
% Workaround for roundoff bogosity.
%
/BorderBottom {/BorderBottom super send round cvi} def
% Install code copied from post-FCS tNt fork.
%
OpenLookFrame /FooterFraction known not {
/FooterLayout { % - => -
/Left /getbyname self send {
BorderEdge 2 mul 1 add
SelStroke FooterPad add
Width FooterFraction mul 2 index sub 1 sub
/preferredsize 4 index send exch pop
/reshape 6 -1 roll send
} if
/Right /getbyname self send {
Width dup FooterFraction mul
SelStroke FooterPad add
3 -1 roll 1 FooterFraction sub mul BorderEdge 2 mul 1 add sub
/preferredsize 4 index send exch pop
/reshape 6 -1 roll send
} if
} /installmethod OpenLookFrame send
OpenLookFrame /FooterFraction .5 put
} if
% Now override the fraction for this subclass.
%
/FooterFraction .8 def
/newinit {
/newinit super send
(Spider) dup /setlabel self send /seticonlabel self send
} def
classend def
/f SpiderCanvas [] framebuffer /new SpiderFrame send def
100 100 /minsize f send /reshape f send
/activate f send
/map f send
newprocessgroup
currentfile closefile
-- -- Don Woods. [*** Generic Disclaimer ***]
-- ...!sun!woods -or- Woods@Sun.com