Path: utzoo!utgpu!jarvis.csri.toronto.edu!cs.utexas.edu!tut.cis.ohio-state.edu!zaphod.mps.ohio-state.edu!uakari.primate.wisc.edu!ames!apple!sun-barr!newstop!sun!colossal!woods From: woods%colossal@Sun.COM (Don Woods) Newsgroups: comp.windows.news Subject: Spider solitaire for X11/NeWS (part 1 of 2) Keywords: card game solitaire spider Message-ID: <130345@sun.Eng.Sun.COM> Date: 17 Jan 90 01:15:56 GMT Sender: news@sun.Eng.Sun.COM Lines: 1279 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 [] {} 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 -- -- Don Woods. [*** Generic Disclaimer ***] -- ...!sun!woods -or- Woods@Sun.com