Solitaire

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
    ∇

    ∇ MDCHandler _                                              ⍝ handles MouseDblClick
      Turn NCARDS
    ∇

⍝ ---------------------------------------------------- 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