%! % From colossal!woods@sun.com Wed Jan 17 11:18:48 1990 % Date: Wed, 17 Jan 90 10:19:07 -0500 % To: NeWS-makers@brillig.umd.edu % Subject: Spider solitaire for X11/NeWS (part 1 of 2) % From: colossal!woods@sun.com (Don Woods) % % 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. % % 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 [] {} 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 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 {} } 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 {} } 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 {} } 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 {} } 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 {} } 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 /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 % /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