Path: utzoo!utgpu!jarvis.csri.toronto.edu!cs.utexas.edu!tut.cis.ohio-state.edu!snorkelwacker!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 2 of 2) Keywords: card game solitaire spider Message-ID: <130346@sun.Eng.Sun.COM> Date: 17 Jan 90 01:18:28 GMT Sender: news@sun.Eng.Sun.COM Lines: 1360 Here's the second part of the source for Spider. See my previous posting for more info (and disclaimer / copyright notice). -------------------- cut here ---------------------------------- /SpiderCanvas [FlexBag CardUtils] [ /Deck % undealt cards /DeckCache % copy of deck for replay/restart /MoveCache % record of moves for replay /DownChild % child where mouse button went down /DownCard % CardImage over which button went down /DownTime % eventtime when button went down /LOCK % monitor to avoid damage-vs-update races /DealTimerEvent % event to trigger deal after single click plus timeout /PrevHash % value used for hashing output files /CharIndex % value used for hashing output files ] classbegin % Class Variables: /FillColor FELT def % overrides inherited method /ErrorAction /Both def % /Both, /Beep, /Flash, or other(none) /FlashDelay .03 def % delay to ensure flash gets to paint /ReplayDelay .02 def % delay between moves during replay /DoubleClick .25 def % timeout for double-click for dealing /SingleClick .25 def % timeout for single-click on a column /MovesIncomplete? false def % promoted true if partial file loaded /ColumnNames dictbegin 0 Ranks {1 index def 1 add} forall pop dictend def % Make canvas opaque so updating the frame title bar to reflect loss of % focus when a Notice pops up, doesn't invalidate the Notice's SaveBehind. % (Stupid server bug.) % /Transparent false def /Mapped true def % Methods: /newinit { /newinit super send /DeckCache 0 1 51 {} for 52 copy 104 array astore def /Deck 104 array def % force initial shuffle /LOCK createmonitor def % create client canvases; first, the control panel /Panel [ /nw {/nw self POSITION} ControlPanel ] /addclient self send % then the "hand" /Hand [ /nw {/sw /Panel POSITION} 4 1 /FaceDown StacksBag ] /addclient self send % the eight spots for completed suits /Removed [ /ne {/ne self POSITION /Panel HEIGHT sub} 0 8 /Blank StacksBag ] /addclient self send % the ten tableau columns; use Ranks[Queen..Three] (1-10) to name them /nw { /ne Previous POSITION self WIDTH Previous WIDTH 10 mul sub 18 sub 9 div cvi 0 max 0 XYADD } /setlayoutspec self send Ranks 1 get [ /nw {/sw /Hand POSITION 10 -5 XYADD} CardColumn ] /addclient self send Ranks 2 9 getinterval { [CardColumn] /addclient self send } forall % the big "congratulations" panel (usually unmapped) /Congrats [ /c {/c self POSITION} SpiderCongrats ] /addclient self send % store indices in children for fast lookup [/Panel /Hand /Removed /Congrats Ranks 1 10 getinterval {} forall] { /setindex 1 index /sendclient self send } forall % fork transaction handler so we don't have to tie up our main % event loop doing moves (which leads to dropped mouse-up events) /TransactionProcess [ /CallMethod dup null self MakeInterest ] /new ClassEventMgr send def (Spider Updates) /setname TransactionProcess send /clearsendcontext TransactionProcess send } def /activate { /activate super send (Spider Input) /setname EventMgr send (Click on deck to begin game. ) LeftFooter } def /destroy { /destroy super send TransactionProcess null ne { /destroy TransactionProcess send /TransactionProcess null def } if } def /minsize { % width: room for 10 columns plus 2 margins and minimal gaps % (4 between columns, 10 on either side = 4*9+2*10 = 56) % also room for the 2 StacksBags with some gap (25) between them % height: room for a modest column plus hand plus panel plus gaps % (5 between cols and hand, 4 below cols = 9) /minsize CardColumn send 9 add exch 10 mul 56 add % h1 w1 /minsize /Hand /sendclient self send /minsize /Removed /sendclient self send pop % h1 w1 w2 h2 w3 exch 4 1 roll add 25 add max % h1 h2 w 3 1 roll add % w h /minsize /Panel /sendclient self send exch pop add } def /Layout { /Layout super send /bbox /Panel /sendclient self send exch pop /size self send pop exch /reshape /Panel /sendclient self send 1 1 10 { GetColumn /bbox 1 index send 3 -1 roll add % col x w h+y BorderStroke 2 add dup 4 1 roll sub % col x y' w h' 1 max % h<0 does bad things later since /size yields abs(h) /reshape 6 -1 roll send } for } def % Override: Ensure we don't muck up the clipping during an update % just because the main eventmgr saw a damage event. % /HandleFix { LOCK {/HandleFix super send} monitor } def /shuffle { % - => - (Shuffling...) nullstring /setfooter Parent send % workaround for "constant" NeWS random number sequence: % use day of year (1-366) to skip some initial random numbers; % use seconds to decide how many times to repeat the shuffle % use minutes to skip some random numbers between repetitions % this yields 366*60*60 = 1.3M decks using about 10K calls to random (%pipe date "+{%M %S %j}") (r) file token {exec} {0 0 0} ifelse {random pop} repeat 0 1 51 {} for 52 copy % mins secs c1 c2 c3 .. c104 105 -1 roll 2 add { pause pause pause % e.g., to let initial window finish painting 104 -1 2 {dup random mul cvi roll} for 104 index {random pop} repeat } repeat 104 array astore % mins [deck] /Deck 1 index def /DeckCache exch def % mins pop /MoveCache growabledict def /MovesIncomplete? unpromote } def /reset { % - => - {/reset exch send} /foreachclient self send /paint self send nullstring nullstring /setfooter Parent send } def /deal { % - => - /busy? Parent send not dup {true /setbusy Parent send} if Deck 0 get null eq {/shuffle self send} if (Dealing...) nullstring /setfooter Parent send NoDealYet? not {0 0 0 true /record self send} if 1 1 10 { Deck length 50 gt { dup 3 mod 1 eq {6} {5} ifelse } { 1 } ifelse % !busy? col #cards Deck 0 2 index getinterval arrayreverse % for compat with old saved files /FaceDown IntsToCards dup dup length 1 sub get 2 /FaceUp put % !busy? col #cds [cds] /appendcards Ranks 5 -1 roll get /sendclient self send Deck exch 1 index length 1 index sub getinterval /Deck exch def } for /Remaining self send % !busy? {false /setbusy Parent send} if } def % Update thickness of deck and righthand footer text. % /Remaining { Deck length { 10 {2 0 /setdepth /Hand /sendclient self send false (1)} 0 { null null /Blank 0 0 /setall /Hand /sendclient self send true (No) } /Default {true Deck length 10 idiv 1 string cvs} } case % bool (n) ( deal) append exch {(s) append} if ( remaining.) append nullstring exch /setfooter Parent send } def % Add a move to the MoveCache. The arguments are the numbers of the % source and destination columns (1-10), number of cards moved, and a % bool that is true if the move revealed a previously facedown card. % Removing a completed suit is recorded as a move to column 0; dealing % more cards is recorded as a move from column 0. (The #cards and % exposed? arguments are irrelevant for these cases, as is the destcol % for dealing cards.) % /record { % fromcol destcol #cards exposed? => -- 1 0 ifelse 14 mul add 11 mul add 11 mul add MoveCache dup length 3 -1 roll put } def /unencode { % move => from dest #cards exposed? dup 11 mod exch 11 idiv dup 11 mod exch 11 idiv dup 14 mod exch 14 ge } def /undo { % -- => -- MoveCache dup length 1 sub 2 copy get 3 1 roll undef /unencode self send % from dest #cards exp? dup (Hmmph. ) nullstring ifelse LeftFooter % from dest #cards exp? 3 index 0 eq { pop pop pop pop /undo-deal self send } { 2 index 0 eq { 4 1 roll pop pop /undo-suit self send } { /undo-normal self send } ifelse } ifelse } def /undo-deal { % -- => -- 1 1 10 { GetColumn /TopCard 1 index send % col card /removecards 3 -1 roll send pop % [card] {/destroy exch send} forall } for DeckCache dup length Deck length sub 10 sub Deck length 10 add getinterval /Deck exch def /reset /Hand /sendclient self send /paint /Hand /sendclient self send Remaining } def /undo-suit { % exposed? fromcol => -- GetColumn exch {/unexpose 1 index send} if % col /restore /Removed /sendclient self send pop pop pop % col suit [ exch Ranks { % col [ ... suit rank /FaceUp 3 array astore dup 0 get % col [ ... [spec] suit } forall pop ] % col [cardspecs] /appendcards 3 -1 roll send } def /undo-normal { % from dest #cards exposed? => -- 4 2 roll GetColumn exch GetColumn % #cards exp? destcol fromcol 3 -1 roll {/unexpose 1 index send} if % #cards destcol fromcol /Cards 2 index send % #cards dcol fcol destcards dup length 5 -1 roll sub get % dcol fcol card /removecards 4 -1 roll send pop % fcol [cards] /appendcards 3 -1 roll send } def /replay { % - => - true /setbusy Parent send MoveCache /StartOverOK self send dup 0 1 2 index length 1 sub { % dict dict n ReplayDelay sleep get /unencode self send pop % dict from dest #cards 2 index 0 eq { pop pop pop /deal self send % dict } { 1 index 0 eq { pop pop GetColumn % dict fromcol /DownChild 1 index def /Cards exch send dup length 13 sub get /RemoveSuit? self send pop % dict } { exch GetColumn 3 -1 roll GetColumn % dict #cds dcol fcol /Cards 1 index send dup length 5 -1 roll sub get % dict dcol fcol card /MoveAndRecord self send % dict } ifelse } ifelse dup % dict dict } for pop pop false /setbusy Parent send } def /PointButton { UserProfile /ViewPoint get } def /AdjustButton { UserProfile /ViewAdjust get } def /MakeInterests { % - => interests /MakeInterests super send self soften dictbegin /DownTransition /StartMove BuildCanvasSend def dictend [PointButton AdjustButton] /new ClassNotifyInterest send % Nint null 2 copy % Nint any Nint can dictbegin /UpTransition /EndMove self soften buildsend def dictend null /new ClassDependentInterest send % Nint Dint /Synchronous true put % Nint } def /childindex { % child|null => any|null dup null eq {pop /Self} {/getindex exch send} ifelse } def /StartMove { % event => -- % ignore second mouse button going down while first is still down dup /Interest get /Triggered? 1 index send not { % event Nint null /finddependent 2 index send pop % event Nint Dint % watch for same button going up that went down /Name 3 index /Name get put % event Nint /NotifyIn 1 index send % event /DownChild /ChildUnderPoint self send def % event /DownTime lasteventtime def % event DownChild null ne { /CardAtPoint DownChild send } { pop null } ifelse /DownCard exch def } { pop pop } ifelse } def /EndMove { % event => -- dup /Name get PointButton eq % event point? /ChildUnderPoint self send % event point? upchild DownChild /childindex self send { /Self /Panel /Congrats {null} /Hand {/MousedHand} /Removed {/MousedTop} /Default {/MousedTableau} } case % ev pt? upchild /meth dup null ne { createevent begin /Action exch def 2 array astore /ClientData exch def /Name /CallMethod def /Canvas self def /TimeStamp lasteventtime def currentdict end sendevent } { pop pop pop } ifelse % event dup /Interest get /NotifyOut exch send } def % Put up a confirmation notice. The second button is always Cancel, and % does nothing except put a given string in the left footer. The first % button is always the default, and just sends an event (so that the % notice will go away before we start any painting). % /Confirm { % [(message)] (yes) /eventname (cancelled) => -- [4 -2 roll [exch /SendEvent] self soften buildsend (\r)] exch [(Cancel) [4 -1 roll /LeftFooter] self soften buildsend (\177)] 2 array astore % [(msg)] [buttonspecs] 2 array astore framebuffer /new NoticeFrame send null blockinputqueue { newprocessgroup 0 /setdefault 2 index send /place 1 index send /activate 1 index send /map 1 index send unblockinputqueue } fork pop pop } def /SendEvent { % /action => -- createevent begin /Action exch def /Name /CallMethod def /Canvas self def /TimeStamp lasteventtime def currentdict end sendevent } def % Method that gets called when /SendEvent or /SendParent sends a % /CallMethod event. It invokes the method given by the Action of the % event. If /ClientData in the event is arraytype, it is aloaded onto % the stack as arguments to the method. After the method returns, the % congrats canvas is mapped or unmapped as necessary. % /CallMethod { % event => -- dup /ClientData get dup type /arraytype eq { aload length 1 add -1 roll } { pop } ifelse % /method /Action get LOCK {self send} monitor /Mapped /Congrats /sendclient self send dup SuperWin? ne { % mapped? /unmap /map ifelse /Congrats /sendclient self send } { pop } ifelse } def % Moused down over hand. Use notice to confirm dealing new round; % there must be cards left to deal, and all spaces must be filled. % Doesn't matter which button was used or where it was released. % /MousedHand { % point? upchild => -- pop pop DealTimerEvent dup null ne { recallevent /DealTimerEvent null def /DoDeal self send } { pop createevent dup begin /Action /DoDeal def /Name /CallMethod def /Canvas self def /TimeStamp currenttime DoubleClick 65.536 div add def end dup sendevent /DealTimerEvent exch def } ifelse } def % Respond to either a double-click or single-click-plus-timeout. % /DoDeal { % - => - DealTimerEvent dup null ne { dup recallevent /DealTimerEvent null def } if % event|null NoDealYet? { /deal self send nullstring } { Deck length 0 gt { true 1 1 10 { Ranks exch get /Cards exch /sendclient self send length 0 ne and } for % event|null filled? { % event|null dup null eq { /deal self send } { [(Please confirm dealing more cards.)] (Deal) /deal nullstring Confirm } ifelse % event|null nullstring } { (Can't deal until all spaces are filled.) } ifelse } { (No cards left to deal.) } ifelse } ifelse % event|null str|null LeftFooter pop } def % Moused down on completed-suit region. Report suits that have all 13 % cards showing. Doesn't matter where mouse went up, nor which button. % /MousedTop { % point? upchild => -- pop pop dictbegin Suits {growabledict def} forall dictend % tempdict 1 1 10 { % dict n Ranks exch get /Cards exch /sendclient self send { % dict card /getcard exch send /FaceUp eq { % dict suit rank 3 copy pop get % d s r subdict exch dup put pop % dict } { pop pop } ifelse } forall } for % dict [ exch Suits { % [...dict suit 2 copy get length 13 eq { % [...dict suit exch } { pop } ifelse } forall pop ] % [readysuits] (Sufficient cards visible to form complete set of ) nullstring 3 -1 roll { % str pfx suit dup length string cvs append append (s, ) } forall % str pfx nullstring eq { pop (No suit has all 13 cards showing. ) } { (s. ) append } ifelse LeftFooter } def % Moused down in tableau. Interpretation depends on where mouse went up, % and which button was used. % /MousedTableau { % point? upchild => -- exch /CardToMove self send dup null eq {exch} if 1 index /childindex self send { % up nat /Self /Panel /Hand /Congrats {pop pop (\r)} % force flash /Removed {exch pop /RemoveSuit? self send} /Default {/ColToCol self send} } case % str LeftFooter } def % Method provided for testing; no UI hooked up to it in released version. % /Cheat { % point? upchild => -- DownCard null ne { dup /childindex self send { /Self /Panel /Hand /Removed /Congrats {pop (\r)} /Default { DownChild DownCard /MoveAndRecord self send (That's intended strictly for testing, you know. ) } } case LeftFooter } { pop } ifelse % point? pop } def /MoveAndRecord { % destcol sourcecol card => -- /removecards 2 index send % dest source [cards] exposed? 3 -1 roll ColNum 3 index ColNum % des [cd] ex? src# des# 3 index length 4 -1 roll % des [cd] src# des# #cd ex? /record self send % dest [cards] /appendcards 3 -1 roll send } def /CardToMove { % point? => card /natural DownChild send exch not 1 index null ne and { % nat /Y 1 index send /Y DownCard send gt { pop DownCard } if } if } def /RemoveSuit? { % card => str /Rank 1 index send /King eq /Canvas 2 index send /TopCard exch send /Rank exch send /Ace eq and { /Suit 1 index send exch % suit king /removecards DownChild send % suit [cards] exposed? DownChild ColNum 0 13 4 -1 roll /record self send {/destroy exch send} forall % suit /Ace /FaceUp 2 /replace /Removed /sendclient self send 7 eq {null (CONGRATULATIONS!!) /setfooter Parent send} if nullstring } { pop (Can only remove complete suit in sequence at bottom of column.) } ifelse } def /ColToCol { % destcol card => str 1 index DownChild eq { exch pop DownTime SingleClick 65.536 div add lasteventtime ge { /ObviousMove self send } { pop (Click faster if you want to make the \252obvious\272 move. ) } ifelse } { /TopCard 2 index send dup null ne { /Rank exch send % dest card destrank exch { dup null eq {exit} if Above /Rank 2 index send get % dest rank card rank' 2 index eq {exit} if /NextCard DownChild send } loop % dest rank card exch pop } { pop } ifelse % destcol card dup null ne { DownChild exch /MoveAndRecord self send nullstring } { pop /TopCard exch send (No legal move from column ) DownChild ColNum 2 string cvs append ( onto the ) append (.) /insertname 4 -1 roll send } ifelse } ifelse } def /ObviousMove { % card => str dup /RemoveSuit? self send dup nullstring eq { exch pop } { pop /getcard 1 index send pop Above exch get 999 10 -1 1 { % card suit r+1 best n /TopCard Ranks 2 index get /sendclient self send % card s r+1 best n top dup null eq { pop 200 add min } { /getcard exch send pop 4 index eq { % card s r+1 best n s' 4 index eq {0} {100} ifelse add min } { pop pop } ifelse } ifelse } for % card s r+1 best 3 1 roll pop pop dup 999 eq { pop (I can't figure out where to move the ) (.) /insertname 4 -1 roll send } { 100 mod GetColumn DownChild 3 -1 roll /MoveAndRecord self send nullstring } ifelse } ifelse } def % Determine which of our children, if any, was under the mouse for the % most recent event. % /ChildUnderPoint { % - => child|null null null canvasesunderpoint { % prev cv dup self eq {pop exit} {exch pop} ifelse } forall dup framebuffer eq {pop null} if } def % Register an invalid request. % /Flash { % - => - ErrorAction { /Both {beep true} /Beep {beep false} /Flash {true} /Default {false} } case { gsave 5 setrasteropcode 0 FlashDelay 65.536 div 2 { framebuffer setcanvas clippath fill /canvas self send setcanvas clippath fill dup 0 ne {sleep} {pop} ifelse } repeat grestore } if } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Methods for control panel buttons. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% /NewGame { % - => - NoDealYet? { /deal self send } { [(Do you really want to discard) (this game and start a new one?)] (Yes) /NewGameOK nullstring Confirm } ifelse } def /NewGameOK { % - => - /reset self send /Deck 104 array def /deal self send } def /StartOver { % - => - BadDeck? { (Sorry, original deck is not available.) LeftFooter } { NoDealYet? NoMovesYet? or { (You have to start before you can start over!) LeftFooter } { [(Do you really want to discard this) (position and back up to the beginning?)] (Yes) /StartOverOK nullstring Confirm } ifelse } ifelse } def /StartOverOK { % - => - /reset self send /Deck DeckCache def /MoveCache growabledict def /MovesIncomplete? unpromote /deal self send } def /BackUp { % - => - MoveCache length 0 eq { (No moves available to back up over.) LeftFooter } { MoveCache dup length 1 sub get 11 11 14 mul mul lt { /undo self send } { (Cheater alert!) LeftFooter [(CHEAT!! You've seen more cards now!) (Confirm backing up over that move!)] (Yes, dammit) /undo (That's more like it! ) Confirm } ifelse } ifelse } def /Replay { % - => - BadDeck? { (Sorry, original deck is not available.) } { NoDealYet? NoMovesYet? or MoveCache length 0 eq or { (No moves available to replay.) } { MovesIncomplete? { (Move record is incomplete; you could Start Over but you can't Replay.) } { [(This could take a while. Are you sure) (you want to replay all the moves?)] (Yes) /replay (Replay cancelled. ) Confirm nullstring } ifelse } ifelse } ifelse LeftFooter } def /Score { % - => - NoDealYet? { (Can't compute score until you start a game!) } { (Current position scores % out of 1000. ) [ComputeScore] sprintf } ifelse LeftFooter } def /Expand { % - => - (Click over the column whose contents you want to see. ) LeftFooter Cursor /xcurs /xcurs_m /setcursor self send { self createoverlay setcanvas createevent dup begin /Canvas currentcanvas def /Action /DownTransition def /Exclusivity true def end dup expressinterest awaitevent exch revokeinterest begin [XLocation YLocation] end } fork waitprocess % oldcurs [x y] Canvas /Cursor 4 -1 roll put ChildUnderPoint dup /childindex self send { /Self /Panel /Hand /Removed /Congrats {pop (That wasn't over a column!)} /Default {/textcontents exch send} } case LeftFooter } def /Locate { % - => - /value /Name /sendclient /Panel /sendclient self send /Unused null 3 -1 roll { % suit rank char dup 8#140 ge {8#40 xor} if % make it uppercase cvis (KQJT98765432ASHDC...0) exch search { % s r post char pre 3 1 roll pop pop length 17 mod % s r index dup 13 lt { Ranks exch get exch % suit newrank oldrank } { 13 sub Suits exch get exch 3 -1 roll % newsuit rank oldsuit } ifelse } if % suit rank junk % junk item might be string (K...C) if search failed pop } forall dup null eq { pop pop (Rank: KQJT98765432A (or 10); suit: SHDC. Omit suit to find unused card of named rank.) } { % suit rank [ 3 1 roll 1 1 10 { % [ ... suit rank n 3 copy /locatecard Ranks 3 -1 roll get /sendclient self send dup 0 ne { 2 array astore 3 1 roll % [ ... [n #found] suit rank } { pop pop } ifelse } for % [ [n #] [n #] ... suit rank counttomark 1 add 2 roll ] % s r [ [n #] [n #] ... ] dup length { 0 { pop (not visible) } 1 { 0 get aload pop dup { % s r col# #found 1 {pop (once)} 2 {pop (twice)} /Default {1 string cvs ( times) append} } case % s r col# (#times) exch 2 array astore (occurs % in column %) exch sprintf } /Default { dup length (occurs in columns) 3 -1 roll { % s r #left (str) [col# #found] aload pop dup { 1 {pop nullstring} 2 {pop ( (twice))} /Default {[exch] ( (% times)) exch sprintf} } case % s r #left (str) col# (#times) 4 -1 roll 1 sub dup 5 1 roll { 0 {nullstring} 1 {( and)} /Default {(,)} } case % s r #left (str) c# (#t) (sfx) 4 array astore (% %%%) exch sprintf % s r #left (str') } forall exch pop } } case % suit rank (where found) 3 array astore (% % %. ) exch sprintf } ifelse LeftFooter } def /SaveFile { % - => - NoDealYet? { (There's no game to save yet.) LeftFooter } { /value /Name /sendclient /Panel /sendclient self send {(r) file} stopped { pop pop /SaveFileOK self send } { closefile [(That file already exists. Replace it?)] (Yes) /SaveFileOK (Position NOT saved. ) Confirm nullstring LeftFooter } ifelse } ifelse } def /SaveFileOK { % - => - /value /Name /sendclient /Panel /sendclient self send {(w) file} stopped { pop pop (Unable to open output file.) } { true /setbusy Parent send (Writing file... ) LeftFooter dup WritePosition dup WriteMoves dup WriteTableau closefile (Position saved. ) false /setbusy Parent send } ifelse LeftFooter } def /Resume { % - => - NoDealYet? { /ResumeOK self send } { [(Do you really want to discard this) (game to read the filed position?)] (Yes) /ResumeOK nullstring Confirm } ifelse } def /ResumeOK { % - => - /value /Name /sendclient /Panel /sendclient self send {(r) file} stopped { pop pop (Unable to open input file.) } { () { % file string 1 index 500 string readstring % file string string' more? 3 1 roll append exch % file mergedstring more? not {exit} if } loop % file contents exch closefile /restorefromstring self send } ifelse LeftFooter } def /ReadSel { % - => - NoDealYet? { /ReadSelOK self send } { [(Do you really want to discard this) (game to set up the selected position?)] (Yes) /ReadSelOK nullstring Confirm } ifelse } def /ReadSelOK { % - => - (First select the text that encodes the position.) /PrimarySelection getselection dup null ne { /ContentsAscii /query 3 -1 roll send { exch pop /restorefromstring self send } if } { pop } ifelse LeftFooter } def /restorefromstring { % gamestring => footerstring true /setbusy Parent send (Restoring position...) nullstring /setfooter Parent send /MovesIncomplete? unpromote /MARK [ null null null 6 -1 roll { (.\n) search {exch pop} {nullstring exch} ifelse % rest posn RemoveNewlines ReadPosition % rest (.\n) search {3 1 roll pop pop} if % moves RemoveNewlines ReadMoves } stopped { /reset self send /DeckCache 0 1 51 {} for 52 copy 104 array astore def /Deck 104 array def {cleartomark /MARK eq {exit} if} loop (Invalid format in saved position.) } { cleartomark pop NoMovesYet? not MoveCache length 0 eq and /MovesIncomplete? exch ?promote (Position restored. ) } ifelse false /setbusy Parent send } def %%%%%%%%%%%%%%%% % File I/O % %%%%%%%%%%%%%%%% % File format: This is a bit obscure, since it was copied verbatim from % an earlier implementation of the program (so that the sample positions % in the documentation will still work) and thus is optimised for being % written in Mesa. Such is life... % % The first line has the original deck and current position, ending with a % period. In the original deck, the undealt cards come first, then a slash, % then the rest of the cards. (The deck is NOT simply reversed; the first % undealt card will be the next card dealt, not the last, and likewise the % first card after the slash was the first card dealt.) After the deck is a % space, then the ten tableau columns, separated by spaces. Each tableau % column has its cards from bottom (highest on the screen) to top. If any are % facedown, there's a slash after the last facedown card; else the slash is % omitted. % % In the above, each card is encoded as an int from 4-55 = (rank+1)*4+suit, % then xored with the previous card, and also xored with a value based on % the number of cards output so far. The resulting value from 0-63 is then % converted to a char from (0) to (o). % % The second line is optional and contains the moves, first to last, again % ending with a period. Each move is encoded as two chars in base 64 using % (0) to (o) as "digits". % % Next comes a blank line, followed by a human-readable form of the current % tableau. This part is ignored when reading the file. % Given a card encoded as 4*rank + suit, hash it. The hash is a simple % xor with the previous encoded card (stored in /PrevHash) and a char % index (stored in /CharIndex); the idea is not so much to make the file % hard to decipher, as to make it unlikely anyone will accidentally learn % anything from a casual glance. This routine also increments /CharIndex; % the caller is responsible for updating /PrevHash since we can't tell % whether it's the incoming or returned value that should be stored there. % /HashCard { % int => int /CharIndex CharIndex 5 add def PrevHash xor CharIndex dup 4 mod exch 4 mul add xor 8#77 and } def /ReadSequence { % string => [ints] [ exch { (0) 0 get sub HashCard /PrevHash 1 index def dup 4 idiv 13 exch sub exch 4 mod 3 exch sub 13 mul add 52 mod } forall ] } def /WriteSequence { % file [ints] => - [ exch { dup 13 idiv 3 exch sub exch 13 mod 13 exch sub 4 mul add dup HashCard /PrevHash 3 -1 roll def (0) 0 get add } forall ] cvas writestring } def % Remove newline chars, since some tools (notably xterm) include bogus % newlines if a long selection is wrapped onto multiple display lines. % /RemoveNewlines { % string => string { (\n) search not {exit} if exch pop exch append } loop } def /ReadPosition { % string => - % Assume any bad format will result in an error, caught via "stopped". NoDealYet? not {/reset self send} if /PrevHash 0 def /CharIndex 0 def ( ) search pop exch pop % rest deck (/) search pop exch pop % rest dealt hand dup length 3 1 roll % rest #hand dealt hand ReadSequence arrayreverse exch ReadSequence arrayreverse exch append % rest #hand [deck] /DeckCache exch def /Deck DeckCache dup length 3 index sub 4 -1 roll getinterval def 1 1 10 { % rest col# exch ( ) search {exch pop} {nullstring exch} ifelse % col# rest pile (/) search {exch pop} {nullstring} ifelse % col# rest up down ReadSequence /FaceDown IntsToCards exch ReadSequence /FaceUp IntsToCards append % col# rest [cardspecs] dup length 0 ne { /appendcards Ranks 5 -1 roll get /sendclient self send % rest } { pop exch pop % rest } ifelse } for ReadSequence /FaceUp IntsToCards { aload pop 2 /replace /Removed /sendclient self send pop } forall Remaining } def /IntsToCards { % [ints] type => [[suit rank type] ...] [ 3 1 roll exch { % [ ... type int Suits 1 index 13 idiv get % [ ... type int suit Ranks 3 -1 roll 13 mod get % [ ... type suit rank 2 index 3 array astore % [ ... type [card] exch } forall pop ] } def /CardsToInts { % [cards] /type => [othertypeints] [giventypeints] exch [ 3 1 roll { /getcard exch send % [ ... stoptype suit rank type 3 index eq { counttomark 1 add 2 roll % suit rank [ ... stoptype pop ] [ null 5 -2 roll % [...] [ newstoptype suit rank } if Ranks exch arrayindex not {0} if exch Suits exch arrayindex not {0} if 13 mul add exch % [ ... int stoptype } forall null ne {] [} if ] } def /ReadMoves { % string => - /MoveCache growabledict def true exch { % true char | tophalf false char (0) 0 get sub exch { 64 mul false } { add MoveCache dup length 3 -1 roll put true } ifelse } forall not {pop} if } def /WritePosition { % file => - /PrevHash 0 def /CharIndex 0 def dup Deck arrayreverse WriteSequence dup (/) writestring dup DeckCache 0 DeckCache length Deck length sub getinterval arrayreverse WriteSequence 1 1 10 { % file col# 1 index ( ) writestring Ranks exch get /Cards exch /sendclient self send /FaceUp CardsToInts % file [downints] [upints] exch dup length 0 ne { % file [upints] [downints] 2 index exch WriteSequence 1 index (/) writestring } { pop } ifelse % file [upints] 1 index exch WriteSequence % file } for /Cards /Removed /sendclient self send % file [removed] /Blank CardsToInts % file [removed] [blanks] pop dup length 0 ne { 1 index dup ( ) writestring % file [removed] file exch WriteSequence % file } { pop } ifelse (.\n) writestring } def /WriteMoves { % file => - 2 string MoveCache 2 copy % file str dict str dict 0 1 2 index length 1 sub { % file str dict str dict n get 2 copy % file str dic str move str move 64 idiv (0) 0 get add 0 exch put % file str dict str move 64 mod (0) 0 get add 1 exch put % file str dict 3 copy pop writestring 2 copy } for pop pop pop pop (.\n) writestring } def /WriteTableau { % file => - true 1 1 10 {GetColumnCards} for { % file topline? [cards1] [cards2] ... [cards10] (\n) 10 { % file top? [c] .. [c] line 11 -1 roll dup length 0 eq { % ... line [] exch 11 index {((sp)) append} if } { % ... line [cards] dup dup length 1 sub 1 exch getinterval 3 1 roll 0 get % ... [rest] line topcard /getcard exch send % ... line suit rank type /FaceDown eq { pop pop ( --) append } { CompactText dup length 3 eq {( ) exch append} if 0 3 getinterval append } ifelse } ifelse (\t) append } repeat % file top? [c1] .. [c10] line { % strip trailing tabs dup dup length 1 sub get (\t) 0 get ne {exit} if dup length 1 sub 0 exch getinterval } loop dup length 1 eq {exit} if 12 index exch writestring 11 -1 roll pop false 11 1 roll } loop % file top? [] .. [] (\n) 12 1 roll 11 {pop} repeat % file (\n) writestring } def %%%%%%%%%%%%%%%%%%%%%% % Utilities % %%%%%%%%%%%%%%%%%%%%%% % Test whether we have a valid deck to allow starting over. % /BadDeck? { % - => bool 52 {0} repeat 52 array astore dup % [tallies] [tallies] DeckCache {2 copy get 1 add put dup} forall pop % [tallies] false exch {2 ne or} forall } def % Test whether a game has already started. (If so, must confirm % [New Game] and [Resume]. If not, cannot [Save].) % /NoDealYet? { % - => bool Deck length 100 gt } def % Test whether the current position is the start of a game. % If so, cannot [Start Over], [Replay], or [Back Up]. Could % do this by testing /MoveCache, but prefer a test that will be % correct even for a restored position without /MoveCache. % /NoMovesYet? { % - => bool Deck length 50 eq dup { % bool 1 1 10 { dup GetColumnCards exch 3 mod 1 eq {6} {5} ifelse % bool [cards] initleng 1 index length ne {pop pop false exit} if % bool [cards] dup length 2 sub 2 getinterval { % bool card /Type exch send } forall % bool /type1 /type2 /FaceUp eq exch /FaceDown eq and and } for } if } def % Set the message in the left footer, and flash if it's an error message. % An error message is defined as a string that is not empty and does not % end with a space. % /LeftFooter { % string => - dup /footer Parent send pop ne { dup null /setfooter Parent send } if dup length 0 ne { dup length 1 sub get ( ) 0 get ne { /Flash self send } if } { pop } ifelse } def % Given a child that is presumed to be a tableau column, return the % index of that column as an integer from 1 to 10. % /ColNum { % child => int /getindex exch send ColumnNames exch get } def % Given a number from 1 to 10, obtain the corresponding CardColumn. % /GetColumn { % int => child Ranks exch get /getbyname self send pop } def % Given a number from 1 to 10, obtain the cards in that column. % /GetColumnCards { % int => [cards] /Cards Ranks 3 -1 roll get /sendclient self send } def % Check whether the big "congratulations" canvas should be mapped. % /SuperWin? { % - => bool 0 Deck length 0 eq { % n (# completed suits) 1 1 10 { % n col# GetColumnCards dup CompletedSuit? { pop 1 add } { length 0 ne {exit} if } ifelse } for } if % n 8 eq } def % See if an array of cards is King..Ace of a single suit. % /CompletedSuit? { % [cards] => bool dup length 13 ne { pop false } { dup 0 get /getcard exch send % [cds] suit rank type /FaceUp ne exch Ranks 0 get ne or { pop pop false } { % [cds] suit 0 3 -1 roll { % suit j card /getcard exch send pop % suit j suit' rank' Ranks 3 index get ne exch % suit j bool suit' 3 index ne or {exit} if 1 add % suit j+1 } forall % suit #seq exch pop 13 eq } ifelse } ifelse } def % Compute a somewhat arbitrary evaluation function for the position: % 2 point per card sitting atop next higher card in same suit % 10 per card turned face up % 15 extra for each column where all cards have been revealed % 50 per completed suit removed (note this costs 12*2 for cards in seq) % If all columns are either empty or contain completed suits, then those % suits also count 50 (including the 24 for the 12 cards that are atop % higher cards), plus an extra 2 for each suit after the first three. % Thus the only way to get 1000 points is to win with all eight suits % still in the tableau. % /ComputeScore { % - => int 44 10 mul 10 15 mul add % (score if cards NOT turned faceup) /Cards /Removed /sendclient self send { % score card /getcard exch send 3 1 roll pop pop % score type /FaceUp eq {50 add} if } forall % score 0 exch 1 1 10 { % #suits score col# GetColumn /evaluate 1 index send % #suits score col val /Cards 3 -1 roll send % #suits score val [cds] dup CompletedSuit? { pop 3 -1 roll 1 add 3 1 roll } { length 0 ne {3 -1 roll 99 sub 3 1 roll} if } ifelse % #suits score val add } for % #suits score exch 0 max dup 3 gt {28 mul 6 sub} {26 mul} ifelse add cvi } def classend def /SpiderFrame [/defaultclass ClassBaseFrame send] [] classbegin /FillColor 1 1 1 rgbcolor def % in case UserProfile overrides % default color in ClassFrame % Workaround for roundoff bogosity. % /BorderBottom {/BorderBottom super send round cvi} def % Install code copied from post-FCS tNt fork. % OpenLookFrame /FooterFraction known not { /FooterLayout { % - => - /Left /getbyname self send { BorderEdge 2 mul 1 add SelStroke FooterPad add Width FooterFraction mul 2 index sub 1 sub /preferredsize 4 index send exch pop /reshape 6 -1 roll send } if /Right /getbyname self send { Width dup FooterFraction mul SelStroke FooterPad add 3 -1 roll 1 FooterFraction sub mul BorderEdge 2 mul 1 add sub /preferredsize 4 index send exch pop /reshape 6 -1 roll send } if } /installmethod OpenLookFrame send OpenLookFrame /FooterFraction .5 put } if % Now override the fraction for this subclass. % /FooterFraction .8 def /newinit { /newinit super send (Spider) dup /setlabel self send /seticonlabel self send } def classend def /f SpiderCanvas [] framebuffer /new SpiderFrame send def 100 100 /minsize f send /reshape f send /activate f send /map f send newprocessgroup currentfile closefile -- -- Don Woods. [*** Generic Disclaimer ***] -- ...!sun!woods -or- Woods@Sun.com