= Solitaire = ||{{attachment:solitaire1.jpg}}|| This class is an application for the game of Solitaire. It requires Dyalog 12 Unicode to run, and ''nothing else'' – it includes no libraries or other classes; it is written using only the language primitives. == Download == [[attachment:solitaire.dyalog]] == Usage == {{{ Solitaire.Rules ⎕NEW Solitaire }}} The class exposes three methods for player moves. It also has a {{{Display}}} method that returns a character display of the game state. The game can thus also be played from the session: {{{ g←⎕NEW Solitaire ⋄ g.Visible←0 g.Turn 3 ⋄ g.Display J♥ ⌹ ⌹ ⌹ ⌹ ⌹ ⌹ 2♦ ⌹ ⌹ ⌹ ⌹ ⌹ 7♠ ⌹ ⌹ ⌹ ⌹ 2♣ ⌹ ⌹ ⌹ 9♠ ⌹ ⌹ J♣ ⌹ 6♣ ⌹ A♦ g.Promote 'AD' ⋄ g. Display Stacks: ⎕ ⎕ ⎕ A♦ J♥ ⌹ ⌹ ⌹ ⌹ ⌹ ⌹ 2♦ ⌹ ⌹ ⌹ ⌹ ⌹ 7♠ ⌹ ⌹ ⌹ ⌹ 2♣ ⌹ ⌹ ⌹ 9♠ ⌹ ⌹ J♣ ⌹ 6♣ ⌹ 8♣ g g.Promote '2♦' ⋄ g.Display ⍝ (alternative: '2D') Stacks: ⎕ ⎕ ⎕ 2♦ J♥ 8♦ ⌹ ⌹ ⌹ ⌹ ⌹ ⌹ ⌹ ⌹ ⌹ ⌹ 7♠ ⌹ ⌹ ⌹ ⌹ 2♣ ⌹ ⌹ ⌹ 9♠ ⌹ ⌹ J♣ ⌹ 6♣ ⌹ 8♣ g.Move '7♠' 2 ⋄ g.Display Stacks: ⎕ ⎕ ⎕ 2♦ J♥ 8♦ ⌹ ⌹ ⌹ ⌹ ⌹ 7♠ 5♥ ⌹ ⌹ ⌹ ⌹ ⌹ ⌹ ⌹ ⌹ 2♣ ⌹ ⌹ ⌹ 9♠ ⌹ ⌹ J♣ ⌹ 6♣ ⌹ 8♣ }}} == Notes == The class exemplifies * a complete GUI application within a single class * use of classes derived from native GUI classes * writing with high SemanticDensity * use of Unicode * use of a private class The script could easily be extended: * to compare playing strategies * to compare the effect of different shuffles * to provide Undo/Redo * to use different packs, eg a Tarot deck * use a different layout, eg 6 columns == Listing == {{{ :Class Solitaire: 'Form' :Field Public Started←0 :Field Public Won←0 :Field Public Shared Rules ∆←⊂'Object is to promote all the cards from the table and the pile onto the stacks' ∆,←⊂'top right. The first cards to promote are the Aces; the stacks are then filled' ∆,←⊂'by suit, in order, Ace to King.' ∆,←⊂'' ∆,←⊂'Right-click on an exposed card to promote it. Cards in the table cannot be' ∆,←⊂'promoted if they have cards below them.' ∆,←⊂'' ∆,←⊂'Left-click on exposed cards to move them to the table. Only a King may be moved' ∆,←⊂'to an empty column of the table.' ∆,←⊂'' ∆,←⊂'Left-click on the pile to turn over three cards onto the discards. When the pile' ∆,←⊂'is empty, left-click in its place to flip the discards over to make a new pile.' Rules←↑∆ ⍝ ---------------------------------------------------- construction ∇ makegame :Access Public :Implements Constructor :Base ('BCol'DKGREEN)('Coord' 'Pixel') :With MB←⎕NEW⊂'MenuBar' File Edit Help←{⎕NEW'Menu'(⊂'Caption'⍵)}¨'&File' '&Edit' '&Help' :With File New←⎕NEW'MenuItem'(⊂'Caption' 'New game') Ext←⎕NEW'MenuItem'(⊂'Caption' 'E&xit') :EndWith :With Edit Undo←⎕NEW'MenuItem'(('Caption' '&Undo')('Active' 0)) Redo←⎕NEW'MenuItem'(('Caption' '&Redo')('Active' 0)) :EndWith :With Help Hlp←⎕NEW'MenuItem'(⊂'Caption' '&Help…') Abt←⎕NEW'MenuItem'(⊂'Caption' '&About…') :EndWith :EndWith MB.File.(New Ext).onSelect←'NewGame' '⍎Close' MB.Help.(Abt Hlp).onSelect←'About' 'Help' ⎕RL←1000⊥¯2↑⎕TS ⍝ seed random link PACK←,{⎕NEW Card ⍵}¨SUITS∘.,VALUES ⍝ uses private class CARDSZ←(⊃PACK).Size ⍝ layout positions SEPN←CARDSZ+10 20 ⍝ horz & vert sepn TABL←,100 20∘+¨SEPN∘רi0 1,NCOLUMNS ⍝ posns for Table tops PILE DISC STAX←{(1⊃⍵)(2⊃⍵)(3↓⍵)}20,¨2⊃¨TABL ⍝ posns for stacks NewGame ∇ ⍝ ---------------------------------------------------- event handlers ∇ MUHandler(this _ Y X btn _);col;MOVE;PROMOTE ⍝ Handles MouseUp events ⍝ Left clicks to move cards to/within the Table ⍝ OR on Pile to turn cards ⍝ Right clicks to promote cards ⍝ Click L or R on Form in Pile space to turn cards :If this=⎕THIS Turn NCARDS×Y X inside PILE CARDSZ ⍝ DblClick on Form under Pile :Else MOVE PROMOTE←1 2 ⍝ left & right buttons :Select btn :Case MOVE :If this=⊃Pile Turn NCARDS :ElseIf (⍴Table)≥col←1⍳⍨(⊃∘⌽¨Table)canhold¨this Move this col :EndIf :Case PROMOTE :If this∊(⊃Discards),⊃∘⌽¨Table :AndIf this follows⊃Stacks⊃⍨SUITS⍳this.Suit Promote this :EndIf :EndSelect :EndIf ∇ ⍝ ---------------------------------------------------- public methods ∇ About;∆ :Access Public :With ⎕NEW'MsgBox'(('Caption' 'About Solitaire')('Style' 'Info')) ∆←⊂'This implementation of the game of Solitaire illustrates' ∆,←⊂'how to build an application in a Dyalog GUI class' ∆,←⊂'using arrays of objects.' ∆,←⊂'' ∆,←⊂'It is a stand-alone script, and requires neither' ∆,←⊂'other classes nor .Net assemblies.' ∆,←⊂'' ∆,←⊂'The code exemplifies the use of an informal DSL' ∆,←⊂'(domain-specific language) to expose the logic' ∆,←⊂'to a non-programming reader of the source code.' ∆,←⊂'' ∆,←⊂'Version 1.0 • 15Apr2008 • Stephen Taylor' ∆,←⊂'' ∆,←⊂'©2008 Dyalog Ltd' Text←∆ Wait :EndWith ∇ ∇ Arrange;qry;status ⍝ Reflect the game state :Access Public status←(⍕Started),' started, ',(⍕Won),' won' Caption←'Solitaire: ',{'New game'}if{Started=1}status (Pile Discards,Stacks)stackedat¨PILE DISC,STAX ⍝ arrange piles Table.Posn←TABL{⍺∘+¨0,⍨¨(⊃SEPN)×i0⍴⍵}¨Table ⍝ arrange Table Size←400,⍨200⌈20+(⊃CARDSZ)+⌈/⊃¨(⊃∘⌽¨Table).Posn ⍝ adjust form size PACK.(onMouseDblClick onMouseUp)←DISABLED ⍝ turn off handlers onMouseDblClick←DISABLED :If 0∊⍴Pile,Discards ⍝ are we there yet? :AndIf ∧/(⊃,/Table).FaceUp Won+←1 qry←'Congratulations, that’s a win!' 'New game?' :If confirm qry NewGame :Else Close ⍝ TERMINATE :EndIf :Else ⍝ reassign handlers (⊃¨Pile Discards).onMouseDblClick←⊂'⍎Turn NCARDS' (⊃¨Pile Discards,Stacks).onMouseUp←⊂'MUHandler' ({⍵/⍨⍵.FaceUp}⊃,/Table).onMouseUp←⊂'MUHandler' onMouseUp←{DISABLED}if{×⊃⍴Pile}'MUHandler' :EndIf ∇ ∇ z←Display;∆ ⍝ text display :Access Public ⍝ (devt tool) ∆←⊂'Stacks: ',⍕⊃¨Stacks ∆,←⊂⍕column¨Table ∆,←⊂⍕⊃¨Pile Discards z←column ∆ ∇ ∇ Help :Access Public :With ⎕NEW'MsgBox'(('Style' 'Info')('Text'Rules)) Caption←'Rules of Solitaire' Wait :EndWith ∇ ⍝ Move and Promote: ⍝ both take in their arguments either ⍝ - card refs (eg Move card 3 or Promote card) OR ⍝ - value/suit pairs (eg Move '3H' 3; or Promote 'K♠') ⍝ Card refs are for internal call; V/S pairs for external. ⍝ Calls are unvalidated: invalid calls will break. ∇ Move(this dst);src;leave;card ⍝ move to or within Table :Access Public card←identify if notref this :If card=⊃Discards ⍝ move from Discards to Table (dst⊃Table),←card Discards↓⍨←1 :ElseIf card∊⊃¨Stacks ⍝ move from Stacks to Table (dst⊃Table),←card src←SUITS⍳card.Suit (src⊃Stacks)↓⍨←1 :Else ⍝ move within Table src←1⍳⍨card∘∊¨Table ⍝ source column in Table leave←1-⍨(src⊃Table)⍳card ⍝ # of cards to leave (dst⊃Table),←leave↓src⊃Table ⍝ append to destn column (src⊃Table)↑⍨←leave ⍝ remove from source column (⊃⌽src⊃Table).FaceUp←1 ⍝ expose last card :EndIf Arrange ∇ ∇ NewGame :Access Public Discards←0/PACK Stacks←(⍴SUITS)/⊂0/PACK ⍝ a stack for each suit PACK.(FaceUp Visible)←⊂0 1 Pile Table←NCOLUMNS deal shuffle PACK (⊃∘⌽¨Table).FaceUp←1 ⍝ expose last cards Started+←1 Arrange ∇ ∇ Promote this;suit;col;card ⍝ promote to Stacks :Access Public card←identify if notref this suit←SUITS⍳card.Suit ⍝ index into Stacks :If card∊Discards (suit⊃Stacks),⍨←card Discards↓⍨←1 (⊃Discards).Visible←1 ⍝ expose new top card :ElseIf 7≥col←(⊃∘⌽¨Table)⍳card (suit⊃Stacks),⍨←card (col⊃Table)↓⍨←¯1 (⊃⌽col⊃Table).FaceUp←1 :EndIf Arrange ∇ ∇ Turn ncards :Access Public :If 0∊⍴Pile Pile Discards←{(⌽⍵)(0/⍵)}Discards Pile.FaceUp←0 :EndIf :If ncards>0 Discards,⍨←⌽ncards{⍵↑⍨⍺⌊⍴⍵}Pile Discards.FaceUp←1 Pile↓⍨←ncards :EndIf Arrange ∇ ⍝ ---------------------------------------------------- vocabulary if←{(⍺⍺⍣(⍵⍵ ⍵))⍵} ⍝ syntactic sugar canhold←{ ⍺.Value=0:⍵.Value='K' ⍝ empty column holds K (⍺ follows ⍵)∧⊃≢/(⍺ ⍵).Colour ⍝ prev card of opp. colour } column←{⍵⍴⍨⌽1,⍴⍵} confirm←{ MB←⎕NEW'MsgBox'(⊂'Style' 'Query') MB.(Caption Text)←⍵ MB.(onMsgBtn1 onMsgBtn2)←1 'MsgBtn1'≡2⊃MB.Wait } cnvrt←⍎if{∧/⍵∊⎕D} ∇ (pile table)←ncols deal cards;intbl ⍝ deal cards into table with ncols; return rest as pile intbl←+/⍳ncols ⍝ # of cards in table table←(⊃,/1↑⍨¨⍳ncols)⊂intbl↑cards ⍝ filled with cards pile←intbl↓cards ⍝ rest ∇ follows←{ 0∊v←(⍺ ⍵).Value:v≡'A' 0 ⍝ Ace follows (prototype Value) 1=-/VALUES⍳v } i0←{⎕IO←0 ⋄ ⍳⍵} identify←{PACK⊃⍨PACK.(Value Suit)⍳,/translate ⍵} ⍝ ref to card from (value suit) inside←{ ⍝ is point ⍺ within a rectangle TL SZ←⍵ ⍝ defined by ∧/⍺{1=+/⍺>⍵}¨TL+¨0,¨SZ ⍝ TL corner (yx coords) } notref←{9≠⊃⎕NC'⍵'} ⍝ not an obj reference shuffle←{⍵[?⍨⍴⍵]} stackedat←{⍺.Posn←⊂⍵ ⋄ ⍺.Visible←1↑⍨⍴⍺} ⍝ colocate; show top card translate←{(cnvrt¯1↓⍵)((,⍨SUITS)⊃⍨(SUITS,ACRONYMS)⍳⊃⌽⍵)} ⍝ regularise (value suit) ⍝ ---------------------------------------------------- constants :Field Public Shared ReadOnly COLOURS←4⍴'Black' 'Red' :Field Public Shared ReadOnly NCARDS←3 ⍝ # of cards to turn over :Field Public Shared ReadOnly SUITS←⎕UCS 9800+24 29 27 30 ⍝ spades hearts clubs diamonds :Field Private Shared ReadOnly ACRONYMS←'SHCD' ⍝ for suits :Field Private Shared ReadOnly DISABLED←¯1 ⍝ no callback :Field Private Shared ReadOnly DKGREEN←0 64 0 :Field Private Shared ReadOnly NCOLUMNS←7 ⍝ # of columns in table :Field Private Shared ReadOnly VALUES←'A',(1↓⍳10),'JQK' :Field Private CARDSZ ⍝ card size :Field Private DISC ⍝ coords of Discards :Field Private PACK :Field Private PILE ⍝ coords of Pile :Field Private SEPN ⍝ separation of Table cards :Field Private STAX ⍝ coords of Stacks ⎕IO ⎕ML←1 0 ⍝ ---------------------------------------------------- private properties :Field Private Discards ⍝ list of cards :Field Private Pile ⍝ list of cards :Field Private Stacks ⍝ 4 lists of cards :Field Private Table ⍝ ==================================================== private class :Class Card: 'SubForm' :Field Public Colour←'' :Field Public FaceUp←0 :Field Public Suit←' ' ⍝ null suit :Field Public Value←0 ⍝ null value :Field Private Shared ReadOnly BLACK←0 0 0 :Field Private Shared ReadOnly NAVY←0 0 128 :Field Private Shared ReadOnly RED←255 0 0 :Field Private Shared ReadOnly WHITE←255 255 255 ⍝ ------------------------------------------------ construction ∇ makecard0 :Access Public :Implements Constructor :Base ⎕DF'⎕' ⍝ null display ∇ ∇ makecard1(suit value) :Access Public :Implements Constructor :Base ('BCol'(0 0 128))('Size'(40 30)) Suit Value←suit value Colour←##.COLOURS⊃⍨##.SUITS⍳Suit ⎕DF'⌹' ∇ ⍝ ------------------------------------------------ trigger ∇ expose;tag;fcol :Implements Trigger FaceUp :If FaceUp BCol←WHITE tag←⊃,/⍕¨Value Suit ⎕DF Suit,⍨⍕Value :Else BCol←NAVY tag←'' ⎕DF'⌹' :EndIf fcol←⊃(Colour≡'Red')⌽BLACK RED Tag←⎕NEW'Text'(('FCol'fcol)('Points'(5 5))('Text'tag)) ∇ :EndClass ⍝ ==================================================== :EndClass }}} StephenTaylor